[project @ 2002-08-01 14:13:10 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 0044d67..fbd8b46 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -14,33 +14,39 @@ import CmdLineOpts  ( DynFlags, DynFlag(..), dopt )
 import HsSyn           ( TyClDecl(..),  
                          ConDecl(..),   Sig(..), HsPred(..), 
                          tyClDeclName, hsTyVarNames, tyClDeclTyVars,
 import HsSyn           ( TyClDecl(..),  
                          ConDecl(..),   Sig(..), HsPred(..), 
                          tyClDeclName, hsTyVarNames, tyClDeclTyVars,

-                         isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
+                         isTypeOrClassDecl, isClassDecl, isSynDecl, isClassOpSig

                        )
 import RnHsSyn         ( RenamedTyClDecl, tyClDeclFVs )
                        )
 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 TcMonad

-import TcEnv           ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
-                         tcExtendKindEnv, tcLookup, tcExtendGlobalEnv, tcExtendGlobalValEnv )
-import TcTyDecls       ( tcTyDecl1, kcConDetails, mkNewTyConRep )
+import TcEnv           ( TcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
+                         tcExtendKindEnv, tcLookup, tcExtendGlobalEnv,
+                         isLocalThing )
+import TcTyDecls       ( tcTyDecl, kcConDetails )

 import TcClassDcl      ( tcClassDecl1 )
 import TcClassDcl      ( tcClassDecl1 )

+import TcInstDcls      ( tcAddDeclCtxt )

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

-import TcType          ( TcKind, newKindVar, zonkKindEnv )
-
+import TcMType         ( newKindVar, zonkKindEnv, checkValidTyCon, checkValidClass )

 import TcUnify         ( unifyKind )
 import TcUnify         ( unifyKind )

-import TcInstDcls      ( tcAddDeclCtxt )
-import Type            ( Kind, mkArrowKind, liftedTypeKind, zipFunTys )
+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, tyConKind, ArgVrcs, AlgTyConFlavour(..), 
-                         mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon )
-import DataCon         ( isNullaryDataCon )
+import TyCon           ( TyCon, ArgVrcs, AlgTyConFlavour(..), DataConDetails(..), visibleDataCons,
+                         tyConKind, tyConTyVars, tyConDataCons, isNewTyCon,
+                         mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon, 
+                       )
+import TysWiredIn      ( unitTy )
+import Subst           ( substTyWith )
+import DataCon         ( dataConOrigArgTys )

 import Var             ( varName )
 import FiniteMap
 import Digraph         ( stronglyConnComp, SCC(..) )
 import Name            ( Name, getSrcLoc, isTyVarName )
 import Var             ( varName )
 import FiniteMap
 import Digraph         ( stronglyConnComp, SCC(..) )
 import Name            ( Name, getSrcLoc, isTyVarName )

-import NameEnv         ( NameEnv, mkNameEnv, lookupNameEnv_NF )
+import NameEnv

 import NameSet
 import Outputable
 import Maybes          ( mapMaybe )
 import NameSet
 import Outputable
 import Maybes          ( mapMaybe )

@@ -59,22 +65,23 @@ import Generics         ( mkTyConGenInfo )
 The main function
 ~~~~~~~~~~~~~~~~~
 \begin{code}
 The main function
 ~~~~~~~~~~~~~~~~~
 \begin{code}

-tcTyAndClassDecls :: RecTcEnv          -- Knot tying stuff
+tcTyAndClassDecls :: Module            -- Current module

                  -> [RenamedTyClDecl]
                  -> [RenamedTyClDecl]

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

 
 

-tcTyAndClassDecls unf_env decls
+tcTyAndClassDecls this_mod decls

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

-    tcGroups unf_env groups
+    tcGroups this_mod groups

 
 

-tcGroups unf_env []
-  = tcGetEnv   `thenNF_Tc` \ env ->
-    returnTc env
+tcGroups this_mod []
+  = returnTc []

 
 

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

     tcSetEnv env               $
     tcSetEnv env               $

-    tcGroups unf_env groups
+    tcGroups 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 +114,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 :: Module -> SCC RenamedTyClDecl 
+       -> TcM (TcEnv,          -- Input env extended by types and classes only
+               [TyThing])      -- Things defined by this group
+                                       
+tcGroup 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 +153,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

-       tcExtendGlobalEnv all_tyclss                    $
-       mapTc (tcTyClDecl1 is_rec unf_env) decls        `thenTc` \ tycls_details ->
+               -- Extend the environment with the final 
+               -- TyCons/Classes and check the decls
+       tcExtendGlobalEnv all_tyclss            $
+       mapTc tcTyClDecl1 decls                 `thenTc` \ tycls_details ->

 
                -- Return results
 
                -- 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_`
-
-       -- 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 ()
+       tcGetEnv                                `thenNF_Tc` \ env ->
+       returnTc (tycls_details, env, all_tyclss)
+    )                                          `thenTc` \ (_, env, all_tyclss) ->
+
+       -- 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 +197,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 decl
+  | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 decl)
+  | otherwise       = tcAddDeclCtxt decl (tcTyDecl     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 +265,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 +299,7 @@ kcTyClDeclBody decl thing_inside
 \end{code}
 
 
 \end{code}
 
 

+

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

@@ -306,13 +325,16 @@ 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
                           flavour is_rec gen_info

+       -- It's not strictly necesary to mark newtypes as
+       -- recursive if the loop is broken via a data type.
+       -- But I'm not sure it's worth the hassle of discovering that.

 
        gen_info | not (dopt Opt_Generics dflags) = Nothing
                 | otherwise = mkTyConGenInfo tycon sys_names
 
        gen_info | not (dopt Opt_Generics dflags) = Nothing
                 | otherwise = mkTyConGenInfo tycon sys_names

@@ -323,10 +345,20 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
        tyvars     = mkTyClTyVars tycon_kind tyvar_names
         argvrcs           = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 
        tyvars     = mkTyClTyVars tycon_kind tyvar_names
         argvrcs           = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 

+       -- Watch out!  mkTyConApp asks whether the tycon is a NewType,
+       -- so flavour has to be able to answer this question without consulting rec_details

        flavour = case data_or_new of
        flavour = case data_or_new of

-                       NewType -> NewTyCon (mkNewTyConRep tycon)
-                       DataType | all isNullaryDataCon data_cons -> EnumTyCon
-                                | otherwise                      -> DataTyCon
+                   NewType  -> NewTyCon (mkNewTyConRep tycon)
+                   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 
+                       -- depends on whether it's a data type or a newtype --- so
+                       -- in the recursive case we can get a loop.  This version is simple!

 
 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
                   (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
 
 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
                   (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})

@@ -346,16 +378,25 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
                              argvrcs dict_con
                             clas               -- Yes!  It's a dictionary 
                             flavour
                              argvrcs dict_con
                             clas               -- Yes!  It's a dictionary 
                             flavour

+                            is_rec
+               -- A class can be recursive, and in the case of newtypes 
+               -- this matters.  For example
+               --      class C a where { op :: C b => a -> b -> Int }
+               -- Because C has only one operation, it is represented by
+               -- a newtype, and it should be a *recursive* newtype.
+               -- [If we don't make it a recursive newtype, we'll expand the
+               -- newtype like a synonym, but that will lead toan inifinite type

 
        ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
 
        class_kind = lookupNameEnv_NF kenv class_name
        tyvars     = mkTyClTyVars class_kind tyvar_names
         argvrcs           = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 
        ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
 
        class_kind = lookupNameEnv_NF kenv class_name
        tyvars     = mkTyClTyVars class_kind tyvar_names
         argvrcs           = lookupWithDefaultFM rec_vrcs bogusVrcs tycon

-       n_fields   = length sc_sel_ids + length op_items

 
 

-       flavour | n_fields == 1 = NewTyCon (mkNewTyConRep tycon)
-               | otherwise     = DataTyCon
+       flavour = case dataConOrigArgTys dict_con of
+                       -- The tyvars in the datacon are the same as in the class
+                   [rep_ty] -> NewTyCon rep_ty
+                   other    -> DataTyCon 

 
        -- We can find the functional dependencies right away, 
        -- and it is vital to do so. Why?  Because in the next pass
 
        -- We can find the functional dependencies right away, 
        -- and it is vital to do so. Why?  Because in the next pass

@@ -368,6 +409,38 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
 bogusVrcs = panic "Bogus tycon arg variances"
 \end{code}
 
 bogusVrcs = panic "Bogus tycon arg variances"
 \end{code}
 

+\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
+-- 
+-- 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
+  = 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}

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

@@ -399,7 +472,7 @@ sortByDependency decls
     in
     returnTc decl_sccs
   where
     in
     returnTc decl_sccs
   where

-    tycl_decls = filter (not . isIfaceSigDecl) decls
+    tycl_decls = filter isTypeOrClassDecl decls

     edges      = map mkEdges tycl_decls
     
     is_syn_decl (d, _, _) = isSynDecl d
     edges      = map mkEdges tycl_decls
     
     is_syn_decl (d, _, _) = isSynDecl d