isTypeOrClassDecl, isClassDecl, isSynDecl, isClassOpSig
)
import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs )
-import BasicTypes ( RecFlag(..), isNonRec, NewOrData(..) )
-import HscTypes ( implicitTyThingIds )
+import RnEnv ( lookupSysName )
+import BasicTypes ( RecFlag(..), NewOrData(..) )
+import HscTypes ( implicitTyThings )
import TcRnMonad
import TcEnv ( TcTyThing(..), TyThing(..), TyThingDetails(..),
import Subst ( substTyWith )
import DataCon ( dataConOrigArgTys )
import Var ( varName )
+import OccName ( mkClassTyConOcc )
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 )
+import Maybes ( mapMaybe, orElse, catMaybes )
\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)
+ = do { edge_map <- mkEdgeMap tc_decls ;
+ let { edges = mkEdges edge_map tc_decls } ;
+ tcGroups edge_map (stronglyConnComp edges) }
where
- edges = map mkEdges (filter isTypeOrClassDecl decls)
+ tc_decls = filter isTypeOrClassDecl decls
-tcGroups []
- = returnM []
+tcGroups edge_map [] = getGblEnv
-tcGroups (group:groups)
- = tcGroup group `thenM` \ (env, new_things1) ->
- setGblEnv env $
- tcGroups groups `thenM` \ new_things2 ->
- returnM (new_things1 ++ new_things2)
+tcGroups edge_map (group:groups)
+ = tcGroup edge_map group `thenM` \ env ->
+ setGblEnv env $
+ tcGroups edge_map groups
\end{code}
Dealing with a group
@TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
\begin{code}
-tcGroup :: SCC RenamedTyClDecl
- -> TcM (TcGblEnv, -- Input env extended by types and classes only
- [TyThing]) -- Things defined by this group
+tcGroup :: EdgeMap -> SCC RenamedTyClDecl
+ -> TcM TcGblEnv -- Input env extended by types and classes
+ -- and their implicit Ids,DataCons
-tcGroup scc
+tcGroup edge_map 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 edge_map scc) `thenM` \ is_rec_tycon ->
-- Tie the knot
traceTc (text "starting" <+> ppr final_kinds) `thenM_`
- fixM ( \ ~(rec_details_list, _, rec_all_tyclss) ->
+ fixM ( \ ~(rec_details_list, _, _) ->
-- Step 4
let
kind_env = mkNameEnv final_kinds
rec_details = mkNameEnv rec_details_list
-- Calculate variances, and feed into buildTyConOrClass
- rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- rec_all_tyclss]
+ rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- tyclss]
build_one = buildTyConOrClass is_rec_tycon kind_env
rec_vrcs rec_details
) `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 :: EdgeMap -> SCC RenamedTyClDecl
-> TcM (Name -> AlgTyConFlavour -> RecFlag)
--- Check for illegal loops,
+-- Check for illegal loops in a single strongly-connected component
-- a) type synonyms
-- b) superclass hierarchy
--
-- Also return a function that says which tycons are recursive.
-- Remember:
-- a newtype is recursive if it is part of a recursive
--- group consisting only of newtype and synonyms
+-- group consisting only of newtype and synonyms
-checkLoops is_rec decls
- | isNonRec is_rec
+checkLoops edge_map (AcyclicSCC _)
= returnM (\ _ _ -> NonRecursive)
- | otherwise -- Recursive group
+checkLoops edge_map (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_edges = mkEdges edge_map (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)
+ newtype_edges = mkEdges edge_map (filter is_nt_cycle_decl decls)
newtype_cycles = findCycles newtype_edges
rec_newtypes = mkNameSet [tcdName d | ds <- newtype_cycles, d <- ds]
findCycles edges = [ ds | CyclicSCC ds <- stronglyConnComp edges]
----------------------------------------------------
-mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
-mkEdges decl = (decl, tyClDeclName decl, nameSetToList (tyClDeclFVs decl))
+-- Building edges for SCC analysis
+--
+-- When building the edges, we treat the 'main name' of the declaration as the
+-- key for the node, but when dealing with External Core we may come across
+-- references to one of the implicit names for the declaration. For example:
+-- class Eq a where ....
+-- data :TSig a = :TSig (:TEq a) ....
+-- The first decl is sucked in from an interface file; the second
+-- is in an External Core file, generated from a class decl for Sig.
+-- We have to recognise that the reference to :TEq represents a
+-- dependency on the class Eq declaration, else the SCC stuff won't work right.
+--
+-- This complication can only happen when consuming an External Core file
+--
+-- Solution: keep an "EdgeMap" (bad name) that maps :TEq -> Eq.
+-- Don't worry about data constructors, because we're only building
+-- SCCs for type and class declarations here. So the tiresome mapping
+-- is need only to map [class tycon -> class]
+
+type EdgeMap = NameEnv Name
+
+mkEdgeMap :: [RenamedTyClDecl] -> TcM EdgeMap
+mkEdgeMap decls = do { mb_pairs <- mapM mk_mb_pair decls ;
+ return (mkNameEnv (catMaybes mb_pairs)) }
+ where
+ mk_mb_pair (ClassDecl { tcdName = cls_name })
+ = do { tc_name <- lookupSysName cls_name mkClassTyConOcc ;
+ return (Just (tc_name, cls_name)) }
+ mk_mb_pair other = return Nothing
+
+mkEdges :: EdgeMap -> [RenamedTyClDecl] -> [(RenamedTyClDecl, Name, [Name])]
+-- We use the EdgeMap to map any implicit names to
+-- the 'main name' for the declaration
+mkEdges edge_map decls
+ = [ (decl, tyClDeclName decl, get_refs decl) | decl <- decls ]
+ where
+ get_refs decl = [ lookupNameEnv edge_map n `orElse` n
+ | n <- nameSetToList (tyClDeclFVs decl) ]
----------------------------------------------------
-- mk_cls_edges looks only at the context of class 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