isTypeOrClassDecl, isClassDecl, isSynDecl, isClassOpSig
)
import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs )
-import BasicTypes ( RecFlag(..), isNonRec, NewOrData(..) )
-import HscTypes ( implicitTyThingIds )
+import BasicTypes ( RecFlag(..), NewOrData(..) )
+import HscTypes ( implicitTyThings )
import TcRnMonad
import TcEnv ( TcTyThing(..), TyThing(..), TyThingDetails(..),
import Var ( varName )
import FiniteMap
import Digraph ( stronglyConnComp, SCC(..) )
-import Name ( Name, getSrcLoc )
+import Name ( Name )
import NameEnv
import NameSet
import Outputable
import Maybes ( mapMaybe )
-import ErrUtils ( Message )
\end{code}
~~~~~~~~~~~~~~~~~
\begin{code}
tcTyAndClassDecls :: [RenamedTyClDecl]
- -> TcM [TyThing] -- Returns newly defined things:
- -- types, classes and implicit Ids
+ -> TcM TcGblEnv -- Returns extended environment
tcTyAndClassDecls decls
= tcGroups (stronglyConnComp edges)
where
edges = map mkEdges (filter isTypeOrClassDecl decls)
-tcGroups []
- = returnM []
+tcGroups [] = getGblEnv
tcGroups (group:groups)
- = tcGroup group `thenM` \ (env, new_things1) ->
+ = tcGroup group `thenM` \ env ->
setGblEnv env $
- tcGroups groups `thenM` \ new_things2 ->
- returnM (new_things1 ++ new_things2)
+ tcGroups groups
\end{code}
Dealing with a group
\begin{code}
tcGroup :: SCC RenamedTyClDecl
- -> TcM (TcGblEnv, -- Input env extended by types and classes only
- [TyThing]) -- Things defined by this group
+ -> TcM TcGblEnv -- Input env extended by types and classes
+ -- and their implicit Ids,DataCons
tcGroup scc
= -- Step 1
- mappM getInitialKind decls `thenM` \ initial_kinds ->
+ mappM getInitialKind decls `thenM` \ initial_kinds ->
-- Step 2
tcExtendKindEnv initial_kinds (mappM kcTyClDecl decls) `thenM_`
-- Step 3
- zonkKindEnv initial_kinds `thenM` \ final_kinds ->
+ zonkKindEnv initial_kinds `thenM` \ final_kinds ->
- -- Check for loops
- checkLoops is_rec decls `thenM` \ is_rec_tycon ->
+ -- Check for loops; if any are found, bale out now
+ -- because the compiler itself will loop otherwise!
+ checkNoErrs (checkLoops scc) `thenM` \ is_rec_tycon ->
-- Tie the knot
traceTc (text "starting" <+> ppr final_kinds) `thenM_`
) `thenM` \ (_, env, tyclss) ->
-- Step 7: Check validity
+ setGblEnv env $
+
traceTc (text "ready for validity check") `thenM_`
getModule `thenM` \ mod ->
- setGblEnv env (
- mappM_ (checkValidTyCl mod) decls
- ) `thenM_`
+ mappM_ (checkValidTyCl mod) decls `thenM_`
traceTc (text "done") `thenM_`
let -- Add the tycons that come from the classes
-- We want them in the environment because
-- they are mentioned in interface files
- implicit_tycons, implicit_ids, all_tyclss :: [TyThing]
- implicit_tycons = [ATyCon (classTyCon clas) | AClass clas <- tyclss]
- all_tyclss = implicit_tycons ++ tyclss
- implicit_ids = [AnId id | id <- implicitTyThingIds all_tyclss]
- new_things = implicit_ids ++ all_tyclss
+ implicit_things = implicitTyThings tyclss
in
- returnM (env, new_things)
+ traceTc ((text "Adding" <+> ppr tyclss) $$ (text "and" <+> ppr implicit_things)) `thenM_`
+ tcExtendGlobalEnv implicit_things getGblEnv
where
- is_rec = case scc of
- AcyclicSCC _ -> NonRecursive
- CyclicSCC _ -> Recursive
-
decls = case scc of
AcyclicSCC decl -> [decl]
CyclicSCC decls -> decls
-- (guaranteed not to be another newtype)
-- Find the representation type for this newtype TyCon
+-- Remember that the representation type is the ultimate representation
+-- type, looking through other newtypes.
--
-- The non-recursive newtypes are easy, because they look transparent
-- to splitTyConApp_maybe, but recursive ones really are represented as
Dependency analysis
~~~~~~~~~~~~~~~~~~~
\begin{code}
-checkLoops :: RecFlag -> [RenamedTyClDecl]
+checkLoops :: SCC RenamedTyClDecl
-> TcM (Name -> AlgTyConFlavour -> RecFlag)
-- Check for illegal loops,
-- a) type synonyms
-- a newtype is recursive if it is part of a recursive
-- group consisting only of newtype and synonyms
-checkLoops is_rec decls
- | isNonRec is_rec
+checkLoops (AcyclicSCC _)
= returnM (\ _ _ -> NonRecursive)
- | otherwise -- Recursive group
+checkLoops (CyclicSCC decls)
= let -- CHECK FOR CLASS CYCLES
cls_edges = mapMaybe mkClassEdges decls
cls_cycles = findCycles cls_edges
in
- checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenM_`
+ mapM_ (cycleErr "class") cls_cycles `thenM_`
let -- CHECK FOR SYNONYM CYCLES
syn_edges = map mkEdges (filter isSynDecl decls)
syn_cycles = findCycles syn_edges
in
- checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenM_`
+ mapM_ (cycleErr "type synonym") syn_cycles `thenM_`
let -- CHECK FOR NEWTYPE CYCLES
newtype_edges = map mkEdges (filter is_nt_cycle_decl decls)
%************************************************************************
\begin{code}
-typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
-
-typeCycleErr syn_cycles
- = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
+cycleErr :: String -> [RenamedTyClDecl] -> TcM ()
-classCycleErr cls_cycles
- = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
+cycleErr kind_of_decl decls
+ = addErrAt loc (ppr_cycle kind_of_decl decls)
+ where
+ loc = tcdLoc (head decls)
-pp_cycle str decls
- = hang (text str)
+ppr_cycle kind_of_decl decls
+ = hang (ptext SLIT("Cycle in") <+> text kind_of_decl <+> ptext SLIT("declarations:"))
4 (vcat (map pp_decl decls))
where
- pp_decl decl
- = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
- where
- name = tyClDeclName decl
-
+ pp_decl decl = hsep [quotes (ppr (tcdName decl)),
+ ptext SLIT("at"), ppr (tcdLoc decl)]
\end{code}
projects / ghc-hetmet.git / blobdiff