[project @ 2002-03-04 17:01:26 by simonmar]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcTyClsDecls.lhs

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 382ce38..5101ab3 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -17,24 +17,30 @@ import HsSyn                ( TyClDecl(..),
                          isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
                        )
 import RnHsSyn         ( RenamedTyClDecl, tyClDeclFVs )
                          isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
                        )
 import RnHsSyn         ( RenamedTyClDecl, tyClDeclFVs )

-import BasicTypes      ( RecFlag(..), NewOrData(..), isRec )
+import BasicTypes      ( RecFlag(..), NewOrData(..) )

 import HscTypes                ( implicitTyThingIds )
 import HscTypes                ( implicitTyThingIds )

+import Module          ( Module )

 
 import TcMonad
 import TcEnv           ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
 
 import TcMonad
 import TcEnv           ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),

-                         tcExtendKindEnv, tcLookup, tcExtendGlobalEnv, tcExtendGlobalValEnv )
-import TcTyDecls       ( tcTyDecl1, kcConDetails )
-import TcClassDcl      ( tcClassDecl1 )
+                         tcExtendKindEnv, tcLookup, tcExtendGlobalEnv,
+                         isLocalThing )
+import TcTyDecls       ( tcTyDecl, kcConDetails, checkValidTyCon )
+import TcClassDcl      ( tcClassDecl1, checkValidClass )

 import TcInstDcls      ( tcAddDeclCtxt )
 import TcMonoType      ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
 import TcInstDcls      ( tcAddDeclCtxt )
 import TcMonoType      ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )

-import TcMType         ( unifyKind, newKindVar, zonkKindEnv )
-import TcType          ( Type, Kind, mkArrowKind, liftedTypeKind, zipFunTys )
+import TcMType         ( newKindVar, zonkKindEnv )
+import TcUnify         ( unifyKind )
+import TcType          ( Type, Kind, TcKind, mkArrowKind, liftedTypeKind, zipFunTys )
+import Type            ( splitTyConApp_maybe )

 import Variance         ( calcTyConArgVrcs )
 import Class           ( Class, mkClass, classTyCon )
 import Variance         ( calcTyConArgVrcs )
 import Class           ( Class, mkClass, classTyCon )

-import TyCon           ( TyCon, ArgVrcs, AlgTyConFlavour(..), 
-                         tyConKind, tyConDataCons,
+import TyCon           ( TyCon, ArgVrcs, AlgTyConFlavour(..), DataConDetails(..), visibleDataCons,
+                         tyConKind, tyConTyVars, tyConDataCons, isNewTyCon,

                          mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon, 
                          mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon, 

-                         isRecursiveTyCon )
+                       )
+import TysWiredIn      ( unitTy )
+import Subst           ( substTyWith )

 import DataCon         ( dataConOrigArgTys )
 import Var             ( varName )
 import FiniteMap
 import DataCon         ( dataConOrigArgTys )
 import Var             ( varName )
 import FiniteMap

@@ -60,21 +66,24 @@ The main function
 ~~~~~~~~~~~~~~~~~
 \begin{code}
 tcTyAndClassDecls :: RecTcEnv          -- Knot tying stuff
 ~~~~~~~~~~~~~~~~~
 \begin{code}
 tcTyAndClassDecls :: RecTcEnv          -- Knot tying stuff

+                 -> Module             -- Current module

                  -> [RenamedTyClDecl]
                  -> [RenamedTyClDecl]

-                 -> TcM TcEnv
+                 -> TcM [TyThing]      -- Returns newly defined things:
+                                       -- types, classes and implicit Ids

 
 

-tcTyAndClassDecls unf_env decls
+tcTyAndClassDecls unf_env this_mod decls

   = sortByDependency decls             `thenTc` \ groups ->
   = sortByDependency decls             `thenTc` \ groups ->

-    tcGroups unf_env groups
+    tcGroups unf_env this_mod groups

 
 

-tcGroups unf_env []
+tcGroups unf_env this_mod []

   = tcGetEnv   `thenNF_Tc` \ env ->
   = tcGetEnv   `thenNF_Tc` \ env ->

-    returnTc env
+    returnTc []

 
 

-tcGroups unf_env (group:groups)
-  = tcGroup unf_env group      `thenTc` \ env ->
-    tcSetEnv env               $
-    tcGroups unf_env groups
+tcGroups unf_env this_mod (group:groups)
+  = tcGroup unf_env this_mod group     `thenTc` \ (env, new_things1) ->
+    tcSetEnv env                       $
+    tcGroups unf_env this_mod groups   `thenTc` \ new_things2 ->
+    returnTc (new_things1 ++ new_things2)

 \end{code}
 
 Dealing with a group
 \end{code}
 
 Dealing with a group

@@ -107,23 +116,26 @@ Step 5:   tcTyClDecl1
        to tcTyClDecl1.
        
 
        to tcTyClDecl1.
        
 

-Step 6:                tcTyClDecl1 again
-       For a recursive group only, check all the decls again, just
-       but this time with the wimp flag off.  Now we can check things
-       like whether a function argument is an unlifted tuple, looking
-       through type synonyms properly.  We can't do that in Step 5.
-
-Step 7:                Extend environment
+Step 6:                Extend environment

        We extend the type environment with bindings not only for the TyCons and Classes,
        but also for their "implicit Ids" like data constructors and class selectors
 
        We extend the type environment with bindings not only for the TyCons and Classes,
        but also for their "implicit Ids" like data constructors and class selectors
 

+Step 7:                checkValidTyCl
+       For a recursive group only, check all the decls again, just
+       to check all the side conditions on validity.  We could not
+       do this before because we were in a mutually recursive knot.
+
+

 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
 @TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
 
 \begin{code}
 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
 @TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
 
 \begin{code}

-tcGroup :: RecTcEnv -> SCC RenamedTyClDecl -> TcM TcEnv
-tcGroup unf_env scc
-  = getDOptsTc                                                 `thenTc` \ dflags ->
+tcGroup :: RecTcEnv -> Module -> SCC RenamedTyClDecl 
+       -> TcM (TcEnv,          -- Input env extended by types and classes only
+               [TyThing])      -- Things defined by this group
+                                       
+tcGroup unf_env this_mod scc
+  = getDOptsTc                                                 `thenNF_Tc` \ dflags ->

        -- Step 1
     mapNF_Tc getInitialKind decls                              `thenNF_Tc` \ initial_kinds ->
 
        -- Step 1
     mapNF_Tc getInitialKind decls                              `thenNF_Tc` \ initial_kinds ->
 

@@ -143,45 +155,40 @@ tcGroup unf_env scc
 
            tyclss, all_tyclss :: [TyThing]
            tyclss = map (buildTyConOrClass dflags is_rec kind_env 
 
            tyclss, all_tyclss :: [TyThing]
            tyclss = map (buildTyConOrClass dflags is_rec kind_env 

-                                                  rec_vrcs rec_details) decls
+                                           rec_vrcs rec_details) decls

 
                -- Add the tycons that come from the classes
                -- We want them in the environment because 
                -- they are mentioned in interface files
 
                -- Add the tycons that come from the classes
                -- We want them in the environment because 
                -- they are mentioned in interface files

-           all_tyclss  = [ ATyCon (classTyCon clas) | AClass clas <- tyclss]
+           all_tyclss  = [ATyCon (classTyCon clas) | AClass clas <- tyclss]

                          ++ tyclss
 
                -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
             rec_vrcs    = calcTyConArgVrcs [tc | ATyCon tc <- all_tyclss]
        in
                -- Step 5
                          ++ tyclss
 
                -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
             rec_vrcs    = calcTyConArgVrcs [tc | ATyCon tc <- all_tyclss]
        in
                -- Step 5

+               -- Extend the environment with the final 
+               -- TyCons/Classes and check the decls

        tcExtendGlobalEnv all_tyclss                    $
        tcExtendGlobalEnv all_tyclss                    $

-       mapTc (tcTyClDecl1 is_rec unf_env) decls        `thenTc` \ tycls_details ->
+       mapTc (tcTyClDecl1 unf_env) decls               `thenTc` \ tycls_details ->

 
                -- Return results
        tcGetEnv                                        `thenNF_Tc` \ env ->
 
                -- Return results
        tcGetEnv                                        `thenNF_Tc` \ env ->

-       returnTc (tycls_details, all_tyclss, env)
-    )                                          `thenTc` \ (_, all_tyclss, env) ->
-
-    tcSetEnv env                               $
-
-    traceTc (text "ready for pass 2" <+> ppr (isRec is_rec))                   `thenTc_`
+       returnTc (tycls_details, env, all_tyclss)
+    )                                          `thenTc` \ (_, env, all_tyclss) ->

 
 

-       -- Step 6
-       -- For a recursive group, check all the types again,
-       -- this time with the wimp flag off
-    (if isRec is_rec then
-       mapTc_ (tcTyClDecl1 NonRecursive unf_env) decls
-     else
-       returnTc ()
+       -- Step 7: Check validity
+    traceTc (text "ready for validity check")  `thenTc_`
+    tcSetEnv env (
+       mapTc_ (checkValidTyCl this_mod) decls

     )                                          `thenTc_`
     )                                          `thenTc_`

-

     traceTc (text "done")                      `thenTc_`
     traceTc (text "done")                      `thenTc_`

-
-       -- Step 7
-       -- Extend the environment with the final TyCons/Classes 
-       -- and their implicit Ids
-    tcExtendGlobalValEnv (implicitTyThingIds all_tyclss) tcGetEnv
+   
+    let
+       implicit_things = [AnId id | id <- implicitTyThingIds all_tyclss]
+       new_things      = all_tyclss ++ implicit_things
+    in
+    returnTc (env, new_things)

 
   where
     is_rec = case scc of
 
   where
     is_rec = case scc of

@@ -192,9 +199,22 @@ tcGroup unf_env scc
                AcyclicSCC decl -> [decl]
                CyclicSCC decls -> decls
 
                AcyclicSCC decl -> [decl]
                CyclicSCC decls -> decls
 

-tcTyClDecl1 is_rec unf_env decl
-  | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 is_rec unf_env decl)
-  | otherwise       = tcAddDeclCtxt decl (tcTyDecl1    is_rec unf_env decl)
+tcTyClDecl1 unf_env decl
+  | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 decl)
+  | otherwise       = tcAddDeclCtxt decl (tcTyDecl     unf_env decl)
+
+-- We do the validity check over declarations, rather than TyThings
+-- only so that we can add a nice context with tcAddDeclCtxt
+checkValidTyCl this_mod decl
+  = tcLookup (tcdName decl)    `thenNF_Tc` \ (AGlobal thing) ->
+    if not (isLocalThing this_mod thing) then
+       -- Don't bother to check validity for non-local things
+       returnTc ()
+    else
+    tcAddDeclCtxt decl $
+    case thing of
+       ATyCon tc -> checkValidTyCon tc
+       AClass cl -> checkValidClass cl

 \end{code}
 
 
 \end{code}
 
 

@@ -247,7 +267,7 @@ kcTyClDecl (ForeignType {}) = returnTc ()
 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
   = kcTyClDeclBody decl                        $ \ result_kind ->
     kcHsContext context                        `thenTc_` 
 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
   = kcTyClDeclBody decl                        $ \ result_kind ->
     kcHsContext context                        `thenTc_` 

-    mapTc_ kc_con_decl con_decls
+    mapTc_ kc_con_decl (visibleDataCons con_decls)

   where
     kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
       = kcHsTyVars ex_tvs              `thenNF_Tc` \ kind_env ->
   where
     kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
       = kcHsTyVars ex_tvs              `thenNF_Tc` \ kind_env ->

@@ -281,6 +301,7 @@ kcTyClDeclBody decl thing_inside
 \end{code}
 
 
 \end{code}
 
 

+

 %************************************************************************
 %*                                                                     *
 \subsection{Step 4: Building the tycon/class}
 %************************************************************************
 %*                                                                     *
 \subsection{Step 4: Building the tycon/class}

@@ -306,12 +327,12 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
         argvrcs                    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 
 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
         argvrcs                    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 
 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details

-                 (TyData {tcdND = data_or_new, tcdName = tycon_name, tcdTyVars = tyvar_names,
-                          tcdNCons = nconstrs, tcdSysNames = sys_names})
+                 (TyData {tcdND = data_or_new, tcdName = tycon_name, 
+                          tcdTyVars = tyvar_names, tcdSysNames = sys_names})

   = ATyCon tycon
   where
        tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
   = ATyCon tycon
   where
        tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs

-                          data_cons nconstrs sel_ids
+                          data_cons sel_ids

                           flavour is_rec gen_info
 
        gen_info | not (dopt Opt_Generics dflags) = Nothing
                           flavour is_rec gen_info
 
        gen_info | not (dopt Opt_Generics dflags) = Nothing

@@ -327,8 +348,11 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
        -- so flavour has to be able to answer this question without consulting rec_details
        flavour = case data_or_new of
                    NewType  -> NewTyCon (mkNewTyConRep tycon)
        -- so flavour has to be able to answer this question without consulting rec_details
        flavour = case data_or_new of
                    NewType  -> NewTyCon (mkNewTyConRep tycon)

-                   DataType | all (null . dataConOrigArgTys) data_cons -> EnumTyCon
-                            | otherwise                                -> DataTyCon
+                   DataType | all_nullary data_cons -> EnumTyCon
+                            | otherwise             -> DataTyCon
+
+       all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
+       all_nullary other           = False     -- Safe choice for unknown data types

                        -- NB (null . dataConOrigArgTys).  It used to say isNullaryDataCon
                        -- but that looks at the *representation* arity, and that in turn
                        -- depends on deciding whether to unpack the args, and that 
                        -- NB (null . dataConOrigArgTys).  It used to say isNullaryDataCon
                        -- but that looks at the *representation* arity, and that in turn
                        -- depends on deciding whether to unpack the args, and that 

@@ -387,17 +411,36 @@ bogusVrcs = panic "Bogus tycon arg variances"
 \begin{code}
 mkNewTyConRep :: TyCon         -- The original type constructor
              -> Type           -- Chosen representation type
 \begin{code}
 mkNewTyConRep :: TyCon         -- The original type constructor
              -> Type           -- Chosen representation type

+                               -- (guaranteed not to be another newtype)
+

 -- Find the representation type for this newtype TyCon
 -- Find the representation type for this newtype TyCon

--- For a recursive type constructor we give an error thunk,
--- because we never look at the rep in that case
--- (see notes on newypes in types/TypeRep
+-- 
+-- The non-recursive newtypes are easy, because they look transparent
+-- to splitTyConApp_maybe, but recursive ones really are represented as
+-- TyConApps (see TypeRep).
+-- 
+-- The trick is to to deal correctly with recursive newtypes
+-- such as     newtype T = MkT T

 
 mkNewTyConRep tc
 
 mkNewTyConRep tc

-  | isRecursiveTyCon tc = pprPanic "Attempt to get the rep of newtype" (ppr tc)
-  | otherwise          = head (dataConOrigArgTys (head (tyConDataCons tc)))
+  = go [] tc
+  where
+       -- Invariant: tc is a NewTyCon
+       --            tcs have been seen before
+    go tcs tc 
+       | tc `elem` tcs = unitTy
+       | otherwise
+       = let
+             rep_ty = head (dataConOrigArgTys (head (tyConDataCons tc)))
+         in
+         case splitTyConApp_maybe rep_ty of
+                       Nothing -> rep_ty 
+                       Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
+                                       | otherwise            -> go1 (tc:tcs) tc' tys
+
+    go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)

 \end{code}
 
 \end{code}
 

-

 %************************************************************************
 %*                                                                     *
 \subsection{Dependency analysis}
 %************************************************************************
 %*                                                                     *
 \subsection{Dependency analysis}