Generate Typeable info at definition sites
authorBen Gamari <ben@smart-cactus.org>
Wed, 26 Aug 2015 16:24:34 +0000 (18:24 +0200)
committerBen Gamari <ben@smart-cactus.org>
Thu, 29 Oct 2015 15:14:51 +0000 (16:14 +0100)
This patch implements the idea floated in Trac #9858, namely that we
should generate type-representation information at the data type
declaration site, rather than when solving a Typeable constraint.

However, this turned out quite a bit harder than I expected. I still
think it's the right thing to do, and it's done now, but it was quite
a struggle.

See particularly

 * Note [Grand plan for Typeable] in TcTypeable (which is a new module)
 * Note [The overall promotion story] in DataCon (clarifies existing stuff)

The most painful bit was that to generate Typeable instances (ie
TyConRepName bindings) for every TyCon is tricky for types in ghc-prim
etc:

 * We need to have enough data types around to *define* a TyCon
 * Many of these types are wired-in

Also, to minimise the code generated for each data type, I wanted to
generate pure data, not CAFs with unpackCString# stuff floating about.

Performance
~~~~~~~~~~~
Three perf/compiler tests start to allocate quite a bit more. This isn't
surprising, because they all allocate zillions of data types, with
practically no other code, esp. T1969

 * T3294:   GHC allocates 110% more (filed #11030 to track this)
 * T1969:   GHC allocates 30% more
 * T4801:   GHC allocates 14% more
 * T5321FD: GHC allocates 13% more
 * T783:    GHC allocates 12% more
 * T9675:   GHC allocates 12% more
 * T5642:   GHC allocates 10% more
 * T9961:   GHC allocates 6% more

 * T9203:   Program allocates 54% less

I'm treating this as acceptable. The payoff comes in Typeable-heavy
code.

Remaining to do
~~~~~~~~~~~~~~~

 * I think that "TyCon" and "Module" are over-generic names to use for
   the runtime type representations used in GHC.Typeable. Better might be
   "TrTyCon" and "TrModule". But I have not yet done this

 * Add more info the the "TyCon" e.g. source location where it was
   defined

 * Use the new "Module" type to help with Trac Trac #10068

 * It would be possible to generate TyConRepName (ie Typeable
   instances) selectively rather than all the time. We'd need to persist
   the information in interface files. Lacking a motivating reason I have
   not done this, but it would not be difficult.

Refactoring
~~~~~~~~~~~
As is so often the case, I ended up refactoring more than I intended.
In particular

 * In TyCon, a type *family* (whether type or data) is repesented by a
   FamilyTyCon
     * a algebraic data type (including data/newtype instances) is
       represented by AlgTyCon This wasn't true before; a data family
       was represented as an AlgTyCon. There are some corresponding
       changes in IfaceSyn.

     * Also get rid of the (unhelpfully named) tyConParent.

 * In TyCon define 'Promoted', isomorphic to Maybe, used when things are
   optionally promoted; and use it elsewhere in GHC.

 * Cleanup handling of knownKeyNames

 * Each TyCon, including promoted TyCons, contains its TyConRepName, if
   it has one. This is, in effect, the name of its Typeable instance.

Requires update of the haddock submodule.

Differential Revision: https://phabricator.haskell.org/D757

109 files changed:
compiler/basicTypes/DataCon.hs
compiler/basicTypes/OccName.hs
compiler/basicTypes/Unique.hs
compiler/coreSyn/MkCore.hs
compiler/deSugar/DsBinds.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsUtils.hs
compiler/ghc.cabal.in
compiler/hsSyn/HsUtils.hs
compiler/iface/BuildTyCl.hs
compiler/iface/IfaceSyn.hs
compiler/iface/MkIface.hs
compiler/iface/TcIface.hs
compiler/main/HscMain.hs
compiler/main/HscTypes.hs
compiler/prelude/PrelInfo.hs
compiler/prelude/PrelNames.hs
compiler/prelude/THNames.hs
compiler/prelude/TysPrim.hs
compiler/prelude/TysWiredIn.hs
compiler/simplCore/FloatIn.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcEnv.hs
compiler/typecheck/TcEvidence.hs
compiler/typecheck/TcGenGenerics.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcInteract.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcTyDecls.hs
compiler/typecheck/TcTypeNats.hs
compiler/typecheck/TcTypeable.hs [new file with mode: 0644]
compiler/types/TyCon.hs
compiler/types/Type.hs
compiler/utils/Binary.hs
compiler/vectorise/Vectorise/Generic/PData.hs
compiler/vectorise/Vectorise/Type/Env.hs
compiler/vectorise/Vectorise/Type/TyConDecl.hs
ghc/InteractiveUI.hs
libraries/base/Data/Typeable.hs
libraries/base/Data/Typeable/Internal.hs
libraries/base/GHC/Show.hs
libraries/base/GHC/Stack/Types.hs
libraries/ghc-prim/GHC/Classes.hs
libraries/ghc-prim/GHC/Magic.hs
libraries/ghc-prim/GHC/Tuple.hs
libraries/ghc-prim/GHC/Types.hs
testsuite/tests/codeGen/should_run/cgrun057.stderr
testsuite/tests/deSugar/should_compile/T2431.stderr
testsuite/tests/deriving/should_fail/T9687.stderr
testsuite/tests/ghci.debugger/scripts/T2740.stdout
testsuite/tests/ghci.debugger/scripts/break006.stderr
testsuite/tests/ghci.debugger/scripts/break009.stdout
testsuite/tests/ghci.debugger/scripts/break010.stdout
testsuite/tests/ghci.debugger/scripts/break011.stdout
testsuite/tests/ghci.debugger/scripts/break012.stdout
testsuite/tests/ghci.debugger/scripts/break018.stdout
testsuite/tests/ghci.debugger/scripts/break022/break022.stdout
testsuite/tests/ghci.debugger/scripts/break028.stdout
testsuite/tests/ghci.debugger/scripts/print018.stdout
testsuite/tests/ghci.debugger/scripts/print019.stderr
testsuite/tests/ghci.debugger/scripts/print031.stdout
testsuite/tests/ghci/scripts/T4175.stdout
testsuite/tests/ghci/scripts/T5417.stdout
testsuite/tests/ghci/scripts/T8674.stdout
testsuite/tests/indexed-types/should_compile/T3017.stderr
testsuite/tests/numeric/should_compile/T7116.stdout
testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr
testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr
testsuite/tests/perf/compiler/all.T
testsuite/tests/perf/should_run/all.T
testsuite/tests/polykinds/T8132.stderr
testsuite/tests/quasiquotation/T7918.stdout
testsuite/tests/roles/should_compile/Roles1.stderr
testsuite/tests/roles/should_compile/Roles13.stderr
testsuite/tests/roles/should_compile/Roles14.stderr
testsuite/tests/roles/should_compile/Roles2.stderr
testsuite/tests/roles/should_compile/Roles3.stderr
testsuite/tests/roles/should_compile/Roles4.stderr
testsuite/tests/roles/should_compile/T8958.stderr
testsuite/tests/simplCore/should_compile/T3234.stderr
testsuite/tests/simplCore/should_compile/T3717.stderr
testsuite/tests/simplCore/should_compile/T3772.stdout
testsuite/tests/simplCore/should_compile/T4908.stderr
testsuite/tests/simplCore/should_compile/T4930.stderr
testsuite/tests/simplCore/should_compile/T7360.stderr
testsuite/tests/simplCore/should_compile/T8274.stdout
testsuite/tests/simplCore/should_compile/T9400.stderr
testsuite/tests/simplCore/should_compile/rule2.stderr
testsuite/tests/simplCore/should_compile/spec-inline.stderr
testsuite/tests/stranal/should_compile/T10694.stdout
testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
testsuite/tests/stranal/sigs/HyperStrUse.stderr
testsuite/tests/stranal/sigs/StrAnalExample.stderr
testsuite/tests/stranal/sigs/T8569.stderr
testsuite/tests/stranal/sigs/T8598.stderr
testsuite/tests/stranal/sigs/UnsatFun.stderr
testsuite/tests/th/TH_Roles2.stderr
testsuite/tests/typecheck/should_compile/holes2.stderr
testsuite/tests/typecheck/should_fail/T5095.stderr
testsuite/tests/typecheck/should_fail/tcfail072.stderr
testsuite/tests/typecheck/should_fail/tcfail133.stderr
utils/haddock

index 76bdaa0..9a827e0 100644 (file)
@@ -35,7 +35,8 @@ module DataCon (
         dataConSrcBangs,
         dataConSourceArity, dataConRepArity, dataConRepRepArity,
         dataConIsInfix,
         dataConSrcBangs,
         dataConSourceArity, dataConRepArity, dataConRepRepArity,
         dataConIsInfix,
-        dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
+        dataConWorkId, dataConWrapId, dataConWrapId_maybe,
+        dataConImplicitTyThings,
         dataConRepStrictness, dataConImplBangs, dataConBoxer,
 
         splitDataProductType_maybe,
         dataConRepStrictness, dataConImplBangs, dataConBoxer,
 
         splitDataProductType_maybe,
@@ -46,16 +47,18 @@ module DataCon (
         isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked,
 
         -- ** Promotion related functions
         isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked,
 
         -- ** Promotion related functions
-        promoteKind, promoteDataCon, promoteDataCon_maybe
+        promoteDataCon, promoteDataCon_maybe,
+        promoteType, promoteKind,
+        isPromotableType, computeTyConPromotability,
     ) where
 
 #include "HsVersions.h"
 
 import {-# SOURCE #-} MkId( DataConBoxer )
 import Type
     ) where
 
 #include "HsVersions.h"
 
 import {-# SOURCE #-} MkId( DataConBoxer )
 import Type
+import ForeignCall( CType )
 import TypeRep( Type(..) )  -- Used in promoteType
 import PrelNames( liftedTypeKindTyConKey )
 import TypeRep( Type(..) )  -- Used in promoteType
 import PrelNames( liftedTypeKindTyConKey )
-import ForeignCall( CType )
 import Coercion
 import Kind
 import Unify
 import Coercion
 import Kind
 import Unify
@@ -72,11 +75,11 @@ import BasicTypes
 import FastString
 import Module
 import VarEnv
 import FastString
 import Module
 import VarEnv
+import NameSet
 import Binary
 
 import qualified Data.Data as Data
 import qualified Data.Typeable
 import Binary
 
 import qualified Data.Data as Data
 import qualified Data.Typeable
-import Data.Maybe
 import Data.Char
 import Data.Word
 import Data.List( mapAccumL, find )
 import Data.Char
 import Data.Word
 import Data.List( mapAccumL, find )
@@ -399,8 +402,8 @@ data DataCon
                                 -- Used for Template Haskell and 'deriving' only
                                 -- The actual fixity is stored elsewhere
 
                                 -- Used for Template Haskell and 'deriving' only
                                 -- The actual fixity is stored elsewhere
 
-        dcPromoted :: Maybe TyCon    -- The promoted TyCon if this DataCon is promotable
-                                     -- See Note [Promoted data constructors] in TyCon
+        dcPromoted :: Promoted TyCon    -- The promoted TyCon if this DataCon is promotable
+                                        -- See Note [Promoted data constructors] in TyCon
   }
   deriving Data.Typeable.Typeable
 
   }
   deriving Data.Typeable.Typeable
 
@@ -671,7 +674,9 @@ isMarkedStrict _               = True   -- All others are strict
 -- | Build a new data constructor
 mkDataCon :: Name
           -> Bool           -- ^ Is the constructor declared infix?
 -- | Build a new data constructor
 mkDataCon :: Name
           -> Bool           -- ^ Is the constructor declared infix?
-          -> [HsSrcBang]       -- ^ Strictness/unpack annotations, from user
+          -> Promoted TyConRepName -- ^ Whether promoted, and if so the TyConRepName
+                                   --   for the promoted TyCon
+          -> [HsSrcBang]    -- ^ Strictness/unpack annotations, from user
           -> [FieldLabel]   -- ^ Field labels for the constructor,
                             -- if it is a record, otherwise empty
           -> [TyVar]        -- ^ Universally quantified type variables
           -> [FieldLabel]   -- ^ Field labels for the constructor,
                             -- if it is a record, otherwise empty
           -> [TyVar]        -- ^ Universally quantified type variables
@@ -688,7 +693,7 @@ mkDataCon :: Name
           -> DataCon
   -- Can get the tag from the TyCon
 
           -> DataCon
   -- Can get the tag from the TyCon
 
-mkDataCon name declared_infix
+mkDataCon name declared_infix prom_info
           arg_stricts   -- Must match orig_arg_tys 1-1
           fields
           univ_tvs ex_tvs
           arg_stricts   -- Must match orig_arg_tys 1-1
           fields
           univ_tvs ex_tvs
@@ -733,15 +738,12 @@ mkDataCon name declared_infix
              mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
 
     mb_promoted   -- See Note [Promoted data constructors] in TyCon
              mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
 
     mb_promoted   -- See Note [Promoted data constructors] in TyCon
-      | isJust (promotableTyCon_maybe rep_tycon)
-          -- The TyCon is promotable only if all its datacons
-          -- are, so the promoteType for prom_kind should succeed
-      = Just (mkPromotedDataCon con name (getUnique name) prom_kind roles)
-      | otherwise
-      = Nothing
-    prom_kind = promoteType (dataConUserType con)
-    roles = map (const Nominal)          (univ_tvs ++ ex_tvs) ++
-            map (const Representational) orig_arg_tys
+      = case prom_info of
+          NotPromoted     -> NotPromoted
+          Promoted rep_nm -> Promoted (mkPromotedDataCon con name rep_nm prom_kind prom_roles)
+    prom_kind  = promoteType (dataConUserType con)
+    prom_roles = map (const Nominal)          (univ_tvs ++ ex_tvs) ++
+                 map (const Representational) orig_arg_tys
 
 eqSpecPreds :: [(TyVar,Type)] -> ThetaType
 eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
 
 eqSpecPreds :: [(TyVar,Type)] -> ThetaType
 eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
@@ -824,11 +826,13 @@ dataConWrapId dc = case dcRep dc of
 
 -- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently,
 -- the union of the 'dataConWorkId' and the 'dataConWrapId'
 
 -- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently,
 -- the union of the 'dataConWorkId' and the 'dataConWrapId'
-dataConImplicitIds :: DataCon -> [Id]
-dataConImplicitIds (MkData { dcWorkId = work, dcRep = rep})
-  = case rep of
-       NoDataConRep               -> [work]
-       DCR { dcr_wrap_id = wrap } -> [wrap,work]
+dataConImplicitTyThings :: DataCon -> [TyThing]
+dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep })
+  = [AnId work] ++ wrap_ids
+  where
+    wrap_ids = case rep of
+                 NoDataConRep               -> []
+                 DCR { dcr_wrap_id = wrap } -> [AnId wrap]
 
 -- | The labels for the fields of this particular 'DataCon'
 dataConFieldLabels :: DataCon -> [FieldLabel]
 
 -- | The labels for the fields of this particular 'DataCon'
 dataConFieldLabels :: DataCon -> [FieldLabel]
@@ -1073,60 +1077,112 @@ dataConCannotMatch tys con
 {-
 ************************************************************************
 *                                                                      *
 {-
 ************************************************************************
 *                                                                      *
-              Building an algebraic data type
+                 Promotion
+
+   These functions are here becuase
+   - isPromotableTyCon calls dataConFullSig
+   - mkDataCon calls promoteType
+   - It's nice to keep the promotion stuff together
 *                                                                      *
 ************************************************************************
 
 *                                                                      *
 ************************************************************************
 
-buildAlgTyCon is here because it is called from TysWiredIn, which in turn
-depends on DataCon, but not on BuildTyCl.
--}
-
-buildAlgTyCon :: Name
-              -> [TyVar]               -- ^ Kind variables and type variables
-              -> [Role]
-              -> Maybe CType
-              -> ThetaType             -- ^ Stupid theta
-              -> AlgTyConRhs
-              -> RecFlag
-              -> Bool                  -- ^ True <=> this TyCon is promotable
-              -> Bool                  -- ^ True <=> was declared in GADT syntax
-              -> TyConParent
-              -> TyCon
-
-buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
-              is_rec is_promotable gadt_syn parent
-  = tc
-  where
-    kind = mkPiKinds ktvs liftedTypeKind
-
-    -- tc and mb_promoted_tc are mutually recursive
-    tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta
-                    rhs parent is_rec gadt_syn
-                    mb_promoted_tc
+Note [The overall promotion story]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is the overall plan.
+
+* Compared to a TyCon T, the promoted 'T has
+     same Name (and hence Unique)
+     same TyConRepName
+  In future the two will collapse into one anyhow.
+
+* Compared to a DataCon K, the promoted 'K (a type constructor) has
+      same Name (and hence Unique)
+  But it has a fresh TyConRepName; after all, the DataCon doesn't have
+  a TyConRepName at all.  (See Note [Grand plan for Typeable] in TcTypeable
+  for TyConRepName.)
+
+  Why does 'K have the same unique as K?  It's acceptable because we don't
+  mix types and terms, so we won't get them confused.  And it's helpful mainly
+  so that we know when to print 'K as a qualified name in error message. The
+  PrintUnqualified stuff depends on whether K is lexically in scope.. but 'K
+  never is!
+
+* It follows that the tick-mark (eg 'K) is not part of the Occ name of
+  either promoted data constructors or type constructors. Instead,
+  pretty-printing: the pretty-printer prints a tick in front of
+     - promoted DataCons (always)
+     - promoted TyCons (with -dppr-debug)
+  See TyCon.pprPromotionQuote
+
+* For a promoted data constructor K, the pipeline goes like this:
+    User writes (in a type):      K or 'K
+    Parser produces OccName:      K{tc} or K{d}, respectively
+    Renamer makes Name:           M.K{d}_r62   (i.e. same unique as DataCon K)
+                                     and K{tc} has been turned into K{d}
+                                     provided it was unambiguous
+    Typechecker makes TyCon:      PromotedDataCon MK{d}_r62
+
+
+Note [Checking whether a group is promotable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We only want to promote a TyCon if all its data constructors
+are promotable; it'd be very odd to promote some but not others.
 
 
-    mb_promoted_tc
-      | is_promotable = Just (mkPromotedTyCon tc (promoteKind kind))
-      | otherwise     = Nothing
+But the data constructors may mention this or other TyCons.
 
 
-{-
-************************************************************************
-*                                                                      *
-        Promoting of data types to the kind level
-*                                                                      *
-************************************************************************
+So we treat the recursive uses as all OK (ie promotable) and
+do one pass to check that each TyCon is promotable.
 
 
-These two 'promoted..' functions are here because
- * They belong together
- * 'promoteDataCon' depends on DataCon stuff
+Currently type synonyms are not promotable, though that
+could change.
 -}
 
 promoteDataCon :: DataCon -> TyCon
 -}
 
 promoteDataCon :: DataCon -> TyCon
-promoteDataCon (MkData { dcPromoted = Just tc }) = tc
+promoteDataCon (MkData { dcPromoted = Promoted tc }) = tc
 promoteDataCon dc = pprPanic "promoteDataCon" (ppr dc)
 
 promoteDataCon dc = pprPanic "promoteDataCon" (ppr dc)
 
-promoteDataCon_maybe :: DataCon -> Maybe TyCon
+promoteDataCon_maybe :: DataCon -> Promoted TyCon
 promoteDataCon_maybe (MkData { dcPromoted = mb_tc }) = mb_tc
 
 promoteDataCon_maybe (MkData { dcPromoted = mb_tc }) = mb_tc
 
+computeTyConPromotability :: NameSet -> TyCon -> Bool
+computeTyConPromotability rec_tycons tc
+  =  isAlgTyCon tc    -- Only algebraic; not even synonyms
+                     -- (we could reconsider the latter)
+  && ok_kind (tyConKind tc)
+  && case algTyConRhs tc of
+       DataTyCon { data_cons = cs } -> all ok_con cs
+       TupleTyCon { data_con = c }  -> ok_con c
+       NewTyCon { data_con = c }    -> ok_con c
+       AbstractTyCon {}             -> False
+  where
+    ok_kind kind = all isLiftedTypeKind args && isLiftedTypeKind res
+            where  -- Checks for * -> ... -> * -> *
+              (args, res) = splitKindFunTys kind
+
+    -- See Note [Promoted data constructors] in TyCon
+    ok_con con = all (isLiftedTypeKind . tyVarKind) ex_tvs
+              && null eq_spec   -- No constraints
+              && null theta
+              && all (isPromotableType rec_tycons) orig_arg_tys
+       where
+         (_, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig con
+
+
+isPromotableType :: NameSet -> Type -> Bool
+-- Must line up with promoteType
+-- But the function lives here because we must treat the
+-- *recursive* tycons as promotable
+isPromotableType rec_tcs con_arg_ty
+  = go con_arg_ty
+  where
+    go (TyConApp tc tys) =  tys `lengthIs` tyConArity tc
+                         && (tyConName tc `elemNameSet` rec_tcs
+                             || isPromotableTyCon tc)
+                         && all go tys
+    go (FunTy arg res)   = go arg && go res
+    go (TyVarTy {})      = True
+    go _                 = False
+
 {-
 Note [Promoting a Type to a Kind]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 {-
 Note [Promoting a Type to a Kind]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1156,7 +1212,7 @@ promoteType ty
     kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ]
     env = zipVarEnv tvs kvs
 
     kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ]
     env = zipVarEnv tvs kvs
 
-    go (TyConApp tc tys) | Just prom_tc <- promotableTyCon_maybe tc
+    go (TyConApp tc tys) | Promoted prom_tc <- promotableTyCon_maybe tc
                          = mkTyConApp prom_tc (map go tys)
     go (FunTy arg res)   = mkArrowKind (go arg) (go res)
     go (TyVarTy tv)      | Just kv <- lookupVarEnv env tv
                          = mkTyConApp prom_tc (map go tys)
     go (FunTy arg res)   = mkArrowKind (go arg) (go res)
     go (TyVarTy tv)      | Just kv <- lookupVarEnv env tv
@@ -1208,3 +1264,41 @@ splitDataProductType_maybe ty
   = Just (tycon, ty_args, con, dataConInstArgTys con ty_args)
   | otherwise
   = Nothing
   = Just (tycon, ty_args, con, dataConInstArgTys con ty_args)
   | otherwise
   = Nothing
+
+{-
+************************************************************************
+*                                                                      *
+              Building an algebraic data type
+*                                                                      *
+************************************************************************
+
+buildAlgTyCon is here because it is called from TysWiredIn, which can
+depend on this module, but not on BuildTyCl.
+-}
+
+buildAlgTyCon :: Name
+              -> [TyVar]               -- ^ Kind variables and type variables
+              -> [Role]
+              -> Maybe CType
+              -> ThetaType             -- ^ Stupid theta
+              -> AlgTyConRhs
+              -> RecFlag
+              -> Bool                  -- ^ True <=> this TyCon is promotable
+              -> Bool                  -- ^ True <=> was declared in GADT syntax
+              -> AlgTyConFlav
+              -> TyCon
+
+buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
+              is_rec is_promotable gadt_syn parent
+  = tc
+  where
+    kind = mkPiKinds ktvs liftedTypeKind
+
+    -- tc and mb_promoted_tc are mutually recursive
+    tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta
+                    rhs parent is_rec gadt_syn
+                    mb_promoted_tc
+
+    mb_promoted_tc
+      | is_promotable = Promoted (mkPromotedTyCon tc (promoteKind kind))
+      | otherwise     = NotPromoted
index 67942df..e299709 100644 (file)
@@ -72,6 +72,7 @@ module OccName (
         mkPReprTyConOcc,
         mkPADFunOcc,
         mkRecFldSelOcc,
         mkPReprTyConOcc,
         mkPADFunOcc,
         mkRecFldSelOcc,
+        mkTyConRepUserOcc, mkTyConRepSysOcc,
 
         -- ** Deconstruction
         occNameFS, occNameString, occNameSpace,
 
         -- ** Deconstruction
         occNameFS, occNameString, occNameSpace,
@@ -586,7 +587,8 @@ mkDataConWrapperOcc, mkWorkerOcc,
         mkGenR, mkGen1R, mkGenRCo,
         mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
         mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
         mkGenR, mkGen1R, mkGenRCo,
         mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
         mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
-        mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc
+        mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
+        mkTyConRepUserOcc, mkTyConRepSysOcc
    :: OccName -> OccName
 
 -- These derived variables have a prefix that no Haskell value could have
    :: OccName -> OccName
 
 -- These derived variables have a prefix that no Haskell value could have
@@ -609,11 +611,24 @@ mkNewTyCoOcc        = mk_simple_deriv tcName   "NTCo:"  -- Coercion for newtypes
 mkInstTyCoOcc       = mk_simple_deriv tcName   "TFCo:"   -- Coercion for type functions
 mkEqPredCoOcc       = mk_simple_deriv tcName   "$co"
 
 mkInstTyCoOcc       = mk_simple_deriv tcName   "TFCo:"   -- Coercion for type functions
 mkEqPredCoOcc       = mk_simple_deriv tcName   "$co"
 
--- used in derived instances
+-- Used in derived instances
 mkCon2TagOcc        = mk_simple_deriv varName  "$con2tag_"
 mkTag2ConOcc        = mk_simple_deriv varName  "$tag2con_"
 mkMaxTagOcc         = mk_simple_deriv varName  "$maxtag_"
 
 mkCon2TagOcc        = mk_simple_deriv varName  "$con2tag_"
 mkTag2ConOcc        = mk_simple_deriv varName  "$tag2con_"
 mkMaxTagOcc         = mk_simple_deriv varName  "$maxtag_"
 
+-- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable
+-- incluing the wrinkle about mkSpecialTyConRepName
+mkTyConRepSysOcc occ = mk_simple_deriv varName prefix occ
+  where
+    prefix | isDataOcc occ = "$tc'"
+           | otherwise     = "$tc"
+
+mkTyConRepUserOcc occ = mk_simple_deriv varName prefix occ
+  where
+    -- *User-writable* prefix, for types in gHC_TYPES
+    prefix | isDataOcc occ = "tc'"
+           | otherwise     = "tc"
+
 -- Generic deriving mechanism
 
 -- | Generate a module-unique name, to be used e.g. while generating new names
 -- Generic deriving mechanism
 
 -- | Generate a module-unique name, to be used e.g. while generating new names
index 12629ff..5705c6f 100644 (file)
@@ -48,10 +48,13 @@ module Unique (
         mkPreludeTyConUnique, mkPreludeClassUnique,
         mkPArrDataConUnique,
 
         mkPreludeTyConUnique, mkPreludeClassUnique,
         mkPArrDataConUnique,
 
-    mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
+        mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
         mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
         mkCostCentreUnique,
 
         mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
         mkCostCentreUnique,
 
+        tyConRepNameUnique,
+        dataConWorkerUnique, dataConRepNameUnique,
+
         mkBuiltinUnique,
         mkPseudoUniqueD,
         mkPseudoUniqueE,
         mkBuiltinUnique,
         mkPseudoUniqueD,
         mkPseudoUniqueE,
@@ -99,9 +102,10 @@ unpkUnique      :: Unique -> (Char, Int)        -- The reverse
 mkUniqueGrimily :: Int -> Unique                -- A trap-door for UniqSupply
 getKey          :: Unique -> Int                -- for Var
 
 mkUniqueGrimily :: Int -> Unique                -- A trap-door for UniqSupply
 getKey          :: Unique -> Int                -- for Var
 
-incrUnique      :: Unique -> Unique
-deriveUnique    :: Unique -> Int -> Unique
-newTagUnique    :: Unique -> Char -> Unique
+incrUnique   :: Unique -> Unique
+stepUnique   :: Unique -> Int -> Unique
+deriveUnique :: Unique -> Int -> Unique
+newTagUnique :: Unique -> Char -> Unique
 
 mkUniqueGrimily = MkUnique
 
 
 mkUniqueGrimily = MkUnique
 
@@ -109,9 +113,11 @@ mkUniqueGrimily = MkUnique
 getKey (MkUnique x) = x
 
 incrUnique (MkUnique i) = MkUnique (i + 1)
 getKey (MkUnique x) = x
 
 incrUnique (MkUnique i) = MkUnique (i + 1)
+stepUnique (MkUnique i) n = MkUnique (i + n)
 
 -- deriveUnique uses an 'X' tag so that it won't clash with
 -- any of the uniques produced any other way
 
 -- deriveUnique uses an 'X' tag so that it won't clash with
 -- any of the uniques produced any other way
+-- SPJ says: this looks terribly smelly to me!
 deriveUnique (MkUnique i) delta = mkUnique 'X' (i + delta)
 
 -- newTagUnique changes the "domain" of a unique to a different char
 deriveUnique (MkUnique i) delta = mkUnique 'X' (i + delta)
 
 -- newTagUnique changes the "domain" of a unique to a different char
@@ -305,14 +311,19 @@ mkPArrDataConUnique    :: Int -> Unique
 mkAlphaTyVarUnique   i = mkUnique '1' i
 mkPreludeClassUnique i = mkUnique '2' i
 
 mkAlphaTyVarUnique   i = mkUnique '1' i
 mkPreludeClassUnique i = mkUnique '2' i
 
--- Prelude type constructors occupy *three* slots.
--- The first is for the tycon itself; the latter two
--- are for the generic to/from Ids.  See TysWiredIn.mk_tc_gen_info.
+--------------------------------------------------
+-- Wired-in data constructor keys occupy *three* slots:
+--    * u: the DataCon itself
+--    * u+1: its worker Id
+--    * u+2: the TyConRepName of the promoted TyCon
+-- Prelude data constructors are too simple to need wrappers.
+mkPreludeTyConUnique i                = mkUnique '3' (3*i)
+mkTupleTyConUnique Boxed           a  = mkUnique '4' (3*a)
+mkTupleTyConUnique Unboxed         a  = mkUnique '5' (3*a)
+mkCTupleTyConUnique                a  = mkUnique 'k' (3*a)
 
 
-mkPreludeTyConUnique i       = mkUnique '3' (3*i)
-mkTupleTyConUnique Boxed   a = mkUnique '4' (3*a)
-mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a)
-mkCTupleTyConUnique        a = mkUnique 'k' (3*a)
+tyConRepNameUnique :: Unique -> Unique
+tyConRepNameUnique  u = incrUnique u
 
 -- Data constructor keys occupy *two* slots.  The first is used for the
 -- data constructor itself and its wrapper function (the function that
 
 -- Data constructor keys occupy *two* slots.  The first is used for the
 -- data constructor itself and its wrapper function (the function that
@@ -320,10 +331,22 @@ mkCTupleTyConUnique        a = mkUnique 'k' (3*a)
 -- used for the worker function (the function that builds the constructor
 -- representation).
 
 -- used for the worker function (the function that builds the constructor
 -- representation).
 
-mkPreludeDataConUnique i       = mkUnique '6' (2*i)    -- Must be alphabetic
-mkTupleDataConUnique Boxed   a = mkUnique '7' (2*a)        -- ditto (*may* be used in C labels)
-mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a)
+--------------------------------------------------
+-- Wired-in data constructor keys occupy *three* slots:
+--    * u: the DataCon itself
+--    * u+1: its worker Id
+--    * u+2: the TyConRepName of the promoted TyCon
+-- Prelude data constructors are too simple to need wrappers.
+
+mkPreludeDataConUnique i              = mkUnique '6' (3*i)    -- Must be alphabetic
+mkTupleDataConUnique Boxed          a = mkUnique '7' (3*a)    -- ditto (*may* be used in C labels)
+mkTupleDataConUnique Unboxed        a = mkUnique '8' (3*a)
+
+dataConRepNameUnique, dataConWorkerUnique :: Unique -> Unique
+dataConWorkerUnique  u = incrUnique u
+dataConRepNameUnique u = stepUnique u 2
 
 
+--------------------------------------------------
 mkPrimOpIdUnique op         = mkUnique '9' op
 mkPreludeMiscIdUnique  i    = mkUnique '0' i
 
 mkPrimOpIdUnique op         = mkUnique '9' op
 mkPreludeMiscIdUnique  i    = mkUnique '0' i
 
index fb797f1..8670e21 100644 (file)
@@ -126,12 +126,12 @@ mkCoreLets binds body = foldr mkCoreLet body binds
 
 -- | Construct an expression which represents the application of one expression
 -- to the other
 
 -- | Construct an expression which represents the application of one expression
 -- to the other
-mkCoreApp :: CoreExpr -> CoreExpr -> CoreExpr
+mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
 -- Respects the let/app invariant by building a case expression where necessary
 --   See CoreSyn Note [CoreSyn let/app invariant]
 -- Respects the let/app invariant by building a case expression where necessary
 --   See CoreSyn Note [CoreSyn let/app invariant]
-mkCoreApp fun (Type ty) = App fun (Type ty)
-mkCoreApp fun (Coercion co) = App fun (Coercion co)
-mkCoreApp fun arg       = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg )
+mkCoreApp fun (Type ty) = App fun (Type ty)
+mkCoreApp fun (Coercion co) = App fun (Coercion co)
+mkCoreApp d fun arg       = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )
                           mk_val_app fun arg arg_ty res_ty
                       where
                         fun_ty = exprType fun
                           mk_val_app fun arg arg_ty res_ty
                       where
                         fun_ty = exprType fun
index 4fa09cb..93b50df 100644 (file)
@@ -44,10 +44,11 @@ import TyCon
 import TcEvidence
 import TcType
 import Type
 import TcEvidence
 import TcType
 import Type
-import Kind (returnsConstraintKind)
+import Kind( isKind )
 import Coercion hiding (substCo)
 import TysWiredIn ( eqBoxDataCon, coercibleDataCon, mkListTy
 import Coercion hiding (substCo)
 import TysWiredIn ( eqBoxDataCon, coercibleDataCon, mkListTy
-                  , mkBoxedTupleTy, charTy, typeNatKind, typeSymbolKind )
+                  , mkBoxedTupleTy, charTy
+                  , typeNatKind, typeSymbolKind )
 import Id
 import MkId(proxyHashId)
 import Class
 import Id
 import MkId(proxyHashId)
 import Class
@@ -70,15 +71,12 @@ import FastString
 import Util
 import MonadUtils
 import Control.Monad(liftM,when)
 import Util
 import MonadUtils
 import Control.Monad(liftM,when)
-import Fingerprint(Fingerprint(..), fingerprintString)
 
 
-{-
-************************************************************************
+{-**********************************************************************
 *                                                                      *
 *                                                                      *
-\subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
+           Desugaring a MonoBinds
 *                                                                      *
 *                                                                      *
-************************************************************************
--}
+**********************************************************************-}
 
 dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
 dsTopLHsBinds binds = ds_lhs_binds binds
 
 dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
 dsTopLHsBinds binds = ds_lhs_binds binds
@@ -815,7 +813,7 @@ dsHsWrapper (WpCompose c1 c2) e = do { e1 <- dsHsWrapper c2 e
                                      ; dsHsWrapper c1 e1 }
 dsHsWrapper (WpFun c1 c2 t1 _) e = do { x <- newSysLocalDs t1
                                       ; e1 <- dsHsWrapper c1 (Var x)
                                      ; dsHsWrapper c1 e1 }
 dsHsWrapper (WpFun c1 c2 t1 _) e = do { x <- newSysLocalDs t1
                                       ; e1 <- dsHsWrapper c1 (Var x)
-                                      ; e2 <- dsHsWrapper c2 (e `mkCoreAppDs` e1)
+                                      ; e2 <- dsHsWrapper c2 (mkCoreAppDs (text "dsHsWrapper") e e1)
                                       ; return (Lam x e2) }
 dsHsWrapper (WpCast co)       e = ASSERT(tcCoercionRole co == Representational)
                                   dsTcCoercion co (mkCastDs e)
                                       ; return (Lam x e2) }
 dsHsWrapper (WpCast co)       e = ASSERT(tcCoercionRole co == Representational)
                                   dsTcCoercion co (mkCastDs e)
@@ -853,154 +851,145 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
        = (b, var, varSetElems (evVarsOfTerm term))
 
 
        = (b, var, varSetElems (evVarsOfTerm term))
 
 
----------------------------------------
+{-**********************************************************************
+*                                                                      *
+           Desugaring EvTerms
+*                                                                      *
+**********************************************************************-}
+
 dsEvTerm :: EvTerm -> DsM CoreExpr
 dsEvTerm :: EvTerm -> DsM CoreExpr
-dsEvTerm (EvId v) = return (Var v)
+dsEvTerm (EvId v)           = return (Var v)
+dsEvTerm (EvCallStack cs)   = dsEvCallStack cs
+dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev
+dsEvTerm (EvLit (EvNum n))  = mkIntegerExpr n
+dsEvTerm (EvLit (EvStr s))  = mkStringExprFS s
 
 dsEvTerm (EvCast tm co)
   = do { tm' <- dsEvTerm tm
        ; dsTcCoercion co $ mkCastDs tm' }
 
 dsEvTerm (EvCast tm co)
   = do { tm' <- dsEvTerm tm
        ; dsTcCoercion co $ mkCastDs tm' }
-                        -- 'v' is always a lifted evidence variable so it is
-                        -- unnecessary to call varToCoreExpr v here.
+         -- 'v' is always a lifted evidence variable so it is
+         -- unnecessary to call varToCoreExpr v here.
+
+dsEvTerm (EvDFunApp df tys tms)
+  = return (Var df `mkTyApps` tys `mkApps` (map Var tms))
 
 
-dsEvTerm (EvDFunApp df tys tms)     = return (Var df `mkTyApps` tys `mkApps` (map Var tms))
 dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v)  -- See Note [Simple coercions]
 dsEvTerm (EvCoercion co)            = dsTcCoercion co mkEqBox
 dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v)  -- See Note [Simple coercions]
 dsEvTerm (EvCoercion co)            = dsTcCoercion co mkEqBox
+
 dsEvTerm (EvSuperClass d n)
   = do { d' <- dsEvTerm d
        ; let (cls, tys) = getClassPredTys (exprType d')
              sc_sel_id  = classSCSelId cls n    -- Zero-indexed
        ; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
 
 dsEvTerm (EvSuperClass d n)
   = do { d' <- dsEvTerm d
        ; let (cls, tys) = getClassPredTys (exprType d')
              sc_sel_id  = classSCSelId cls n    -- Zero-indexed
        ; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
 
-dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
+dsEvTerm (EvDelayedError ty msg)
+  = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
   where
     errorId = tYPE_ERROR_ID
     litMsg  = Lit (MachStr (fastStringToByteString msg))
 
   where
     errorId = tYPE_ERROR_ID
     litMsg  = Lit (MachStr (fastStringToByteString msg))
 
-dsEvTerm (EvLit l) =
-  case l of
-    EvNum n -> mkIntegerExpr n
-    EvStr s -> mkStringExprFS s
-
-dsEvTerm (EvCallStack cs) = dsEvCallStack cs
-
-dsEvTerm (EvTypeable ev) = dsEvTypeable ev
-
-dsEvTypeable :: EvTypeable -> DsM CoreExpr
-dsEvTypeable ev =
-  do tyCl      <- dsLookupTyCon typeableClassName
-     typeRepTc <- dsLookupTyCon typeRepTyConName
-     let tyRepType = mkTyConApp typeRepTc []
-
-     (ty, rep) <-
-        case ev of
-
-          EvTypeableTyCon tc ks ->
-            do ctr       <- dsLookupGlobalId mkPolyTyConAppName
-               mkTyCon   <- dsLookupGlobalId mkTyConName
-               dflags    <- getDynFlags
-               let mkRep cRep kReps tReps =
-                     mkApps (Var ctr) [ cRep, mkListExpr tyRepType kReps
-                                            , mkListExpr tyRepType tReps ]
-
-               let kindRep k =
-                     case splitTyConApp_maybe k of
-                       Nothing -> panic "dsEvTypeable: not a kind constructor"
-                       Just (kc,ks) ->
-                         do kcRep <- tyConRep dflags mkTyCon kc
-                            reps  <- mapM kindRep ks
-                            return (mkRep kcRep [] reps)
-
-               tcRep     <- tyConRep dflags mkTyCon tc
-
-               kReps     <- mapM kindRep ks
-
-               return ( mkTyConApp tc ks
-                      , mkRep tcRep kReps []
-                      )
-
-          EvTypeableTyApp t1 t2 ->
-            do e1  <- getRep tyCl t1
-               e2  <- getRep tyCl t2
-               ctr <- dsLookupGlobalId mkAppTyName
-
-               return ( mkAppTy (snd t1) (snd t2)
-                      , mkApps (Var ctr) [ e1, e2 ]
-                      )
-
-          EvTypeableTyLit t ->
-            do e <- tyLitRep t
-               return (snd t, e)
-
-     -- TyRep -> Typeable t
-     -- see also: Note [Memoising typeOf]
-     repName <- newSysLocalDs tyRepType
-     let proxyT = mkProxyPrimTy (typeKind ty) ty
-         method = bindNonRec repName rep
-                $ mkLams [mkWildValBinder proxyT] (Var repName)
-
-     -- package up the method as `Typeable` dictionary
-     return $ mkCastDs method $ mkSymCo $ getTypeableCo tyCl ty
-
+{-**********************************************************************
+*                                                                      *
+           Desugaring Typeable dictionaries
+*                                                                      *
+**********************************************************************-}
+
+dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr
+-- Return a CoreExpr :: Typeable ty
+-- This code is tightly coupled to the representation
+-- of TypeRep, in base library Data.Typeable.Internals
+dsEvTypeable ty ev
+  = do { tyCl <- dsLookupTyCon typeableClassName   -- Typeable
+       ; let kind = typeKind ty
+             Just typeable_data_con
+                 = tyConSingleDataCon_maybe tyCl      -- "Data constructor"
+                                                      -- for Typeable
+
+       ; rep_expr <- ds_ev_typeable ty ev
+
+       -- Build Core for (let r::TypeRep = rep in \proxy. rep)
+       -- See Note [Memoising typeOf]
+       ; repName <- newSysLocalDs (exprType rep_expr)
+       ; let proxyT = mkProxyPrimTy kind ty
+             method = bindNonRec repName rep_expr
+                      $ mkLams [mkWildValBinder proxyT] (Var repName)
+
+       -- Package up the method as `Typeable` dictionary
+       ; return $ mkConApp typeable_data_con [Type kind, Type ty, method] }
+
+
+ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr
+-- Returns a CoreExpr :: TypeRep ty
+ds_ev_typeable ty EvTypeableTyCon
+  | Just (tc, ks) <- splitTyConApp_maybe ty
+  = ASSERT( all isKind ks )
+    do { ctr <- dsLookupGlobalId mkPolyTyConAppName
+                    -- mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep
+       ; tyRepTc <- dsLookupTyCon typeRepTyConName  -- TypeRep (the TyCon)
+       ; let tyRepType = mkTyConApp tyRepTc []      -- TypeRep (the Type)
+             mkRep cRep kReps tReps
+               = mkApps (Var ctr) [ cRep
+                                  , mkListExpr tyRepType kReps
+                                  , mkListExpr tyRepType tReps ]
+
+             kindRep k  -- Returns CoreExpr :: TypeRep for that kind k
+               = case splitTyConApp_maybe k of
+                   Nothing -> panic "dsEvTypeable: not a kind constructor"
+                   Just (kc,ks) -> do { kcRep <- tyConRep kc
+                                      ; reps  <- mapM kindRep ks
+                                      ; return (mkRep kcRep [] reps) }
+
+       ; tcRep <- tyConRep tc
+       ; kReps <- mapM kindRep ks
+       ; return (mkRep tcRep kReps []) }
+
+ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)
+  | Just (t1,t2) <- splitAppTy_maybe ty
+  = do { e1  <- getRep ev1 t1
+       ; e2  <- getRep ev2 t2
+       ; ctr <- dsLookupGlobalId mkAppTyName
+       ; return ( mkApps (Var ctr) [ e1, e2 ] ) }
+
+ds_ev_typeable ty (EvTypeableTyLit ev)
+  = do { fun  <- dsLookupGlobalId tr_fun
+       ; dict <- dsEvTerm ev       -- Of type KnownNat/KnownSym
+       ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty]
+       ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) }
   where
   where
-  -- co: method -> Typeable k t
-  getTypeableCo tc t =
-    case instNewTyCon_maybe tc [typeKind t, t] of
-      Just (_,co) -> co
-      _           -> panic "Class `Typeable` is not a `newtype`."
-
-  -- Typeable t -> TyRep
-  getRep tc (ev,t) =
-    do typeableExpr <- dsEvTerm ev
-       let co     = getTypeableCo tc t
-           method = mkCastDs typeableExpr co
-           proxy  = mkTyApps (Var proxyHashId) [typeKind t, t]
-       return (mkApps method [proxy])
-
-  -- KnownNat t -> TyRep      (also used for KnownSymbol)
-  tyLitRep (ev,t) =
-    do dict <- dsEvTerm ev
-       fun  <- dsLookupGlobalId $
-               case typeKind t of
-                 k | eqType k typeNatKind    -> typeNatTypeRepName
-                   | eqType k typeSymbolKind -> typeSymbolTypeRepName
-                   | otherwise -> panic "dsEvTypeable: unknown type lit kind"
-       let finst  = mkTyApps (Var fun) [t]
-           proxy  = mkTyApps (Var proxyHashId) [typeKind t, t]
-       return (mkApps finst [ dict, proxy ])
-
-  -- This part could be cached
-  tyConRep dflags mkTyCon tc =
-    do pkgStr  <- mkStringExprFS pkg_fs
-       modStr  <- mkStringExprFS modl_fs
-       nameStr <- mkStringExprFS name_fs
-       return (mkApps (Var mkTyCon) [ int64 high, int64 low
-                                    , pkgStr, modStr, nameStr
-                                    ])
-    where
-    tycon_name                = tyConName tc
-    modl                      = nameModule tycon_name
-    pkg                       = moduleUnitId modl
-
-    modl_fs                   = moduleNameFS (moduleName modl)
-    pkg_fs                    = unitIdFS pkg
-    name_fs                   = occNameFS (nameOccName tycon_name)
-    hash_name_fs
-      | isPromotedTyCon tc    = appendFS (mkFastString "$k") name_fs
-      | isPromotedDataCon tc  = appendFS (mkFastString "$c") name_fs
-      | isTupleTyCon tc &&
-        returnsConstraintKind (tyConKind tc)
-                              = appendFS (mkFastString "$p") name_fs
-      | otherwise             = name_fs
-
-    hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, hash_name_fs]
-    Fingerprint high low = fingerprintString hashThis
-
-    int64
-      | wORD_SIZE dflags == 4 = mkWord64LitWord64
-      | otherwise             = mkWordLit dflags . fromIntegral
-
-
+    ty_kind = typeKind ty
+
+    -- tr_fun is the Name of
+    --       typeNatTypeRep    :: KnownNat    a => Proxy# a -> TypeRep
+    -- of    typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep
+    tr_fun | ty_kind `eqType` typeNatKind    = typeNatTypeRepName
+           | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName
+           | otherwise = panic "dsEvTypeable: unknown type lit kind"
+
+
+ds_ev_typeable ty ev
+  = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev)
+
+getRep :: EvTerm -> Type  -- EvTerm for Typeable ty, and ty
+       -> DsM CoreExpr    -- Return CoreExpr :: TypeRep (of ty)
+                          -- namely (typeRep# dict proxy)
+-- Remember that
+--   typeRep# :: forall k (a::k). Typeable k a -> Proxy k a -> TypeRep
+getRep ev ty
+  = do { typeable_expr <- dsEvTerm ev
+       ; typeRepId     <- dsLookupGlobalId typeRepIdName
+       ; let ty_args = [typeKind ty, ty]
+       ; return (mkApps (mkTyApps (Var typeRepId) ty_args)
+                        [ typeable_expr
+                        , mkTyApps (Var proxyHashId) ty_args ]) }
+
+tyConRep :: TyCon -> DsM CoreExpr
+-- Returns CoreExpr :: TyCon
+tyConRep tc
+  | Just tc_rep_nm <- tyConRepName_maybe tc
+  = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm
+       ; return (Var tc_rep_id) }
+  | otherwise
+  = pprPanic "tyConRep" (ppr tc)
 
 {- Note [Memoising typeOf]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 {- Note [Memoising typeOf]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1012,8 +1001,11 @@ help GHC by manually keeping the 'rep' *outside* the lambda.
 -}
 
 
 -}
 
 
-
-
+{-**********************************************************************
+*                                                                      *
+           Desugaring EvCallStack evidence
+*                                                                      *
+**********************************************************************-}
 
 dsEvCallStack :: EvCallStack -> DsM CoreExpr
 -- See Note [Overview of implicit CallStacks] in TcEvidence.hs
 
 dsEvCallStack :: EvCallStack -> DsM CoreExpr
 -- See Note [Overview of implicit CallStacks] in TcEvidence.hs
@@ -1025,7 +1017,7 @@ dsEvCallStack cs = do
   let srcLocTy     = mkTyConTy srcLocTyCon
   let mkSrcLoc l =
         liftM (mkCoreConApps srcLocDataCon)
   let srcLocTy     = mkTyConTy srcLocTyCon
   let mkSrcLoc l =
         liftM (mkCoreConApps srcLocDataCon)
-              (sequence [ mkStringExpr (showPpr df $ moduleUnitId m)
+              (sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)
                         , mkStringExprFS (moduleNameFS $ moduleName m)
                         , mkStringExprFS (srcSpanFile l)
                         , return $ mkIntExprInt df (srcSpanStartLine l)
                         , mkStringExprFS (moduleNameFS $ moduleName m)
                         , mkStringExprFS (srcSpanFile l)
                         , return $ mkIntExprInt df (srcSpanStartLine l)
@@ -1071,7 +1063,12 @@ dsEvCallStack cs = do
     EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
     EvCsEmpty -> panic "Cannot have an empty CallStack"
 
     EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
     EvCsEmpty -> panic "Cannot have an empty CallStack"
 
----------------------------------------
+{-**********************************************************************
+*                                                                      *
+           Desugaring Coercions
+*                                                                      *
+**********************************************************************-}
+
 dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
 -- This is the crucial function that moves
 -- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
 dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
 -- This is the crucial function that moves
 -- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
index f47843a..6e415d7 100644 (file)
@@ -217,8 +217,8 @@ dsExpr (HsLamCase arg matches)
        ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
        ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
 
        ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
        ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
 
-dsExpr (HsApp fun arg)
-  = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
+dsExpr e@(HsApp fun arg)
+  = mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*>  dsLExpr arg
 
 
 {-
 
 
 {-
@@ -260,15 +260,15 @@ If \tr{expr} is actually just a variable, say, then the simplifier
 will sort it out.
 -}
 
 will sort it out.
 -}
 
-dsExpr (OpApp e1 op _ e2)
+dsExpr e@(OpApp e1 op _ e2)
   = -- for the type of y, we need the type of op's 2nd argument
   = -- for the type of y, we need the type of op's 2nd argument
-    mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
+    mkCoreAppsDs (text "opapp" <+> ppr e) <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
 
 dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
 
 dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
-  = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
+  = mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExpr expr
 
 -- dsLExpr (SectionR op expr)   -- \ x -> op x expr
 
 -- dsLExpr (SectionR op expr)   -- \ x -> op x expr
-dsExpr (SectionR op expr) = do
+dsExpr e@(SectionR op expr) = do
     core_op <- dsLExpr op
     -- for the type of x, we need the type of op's 2nd argument
     let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
     core_op <- dsLExpr op
     -- for the type of x, we need the type of op's 2nd argument
     let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
@@ -277,7 +277,7 @@ dsExpr (SectionR op expr) = do
     x_id <- newSysLocalDs x_ty
     y_id <- newSysLocalDs y_ty
     return (bindNonRec y_id y_core $
     x_id <- newSysLocalDs x_ty
     y_id <- newSysLocalDs y_ty
     return (bindNonRec y_id y_core $
-            Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
+            Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id]))
 
 dsExpr (ExplicitTuple tup_args boxity)
   = do { let go (lam_vars, args) (L _ (Missing ty))
 
 dsExpr (ExplicitTuple tup_args boxity)
   = do { let go (lam_vars, args) (L _ (Missing ty))
index bce5186..503e29d 100644 (file)
@@ -241,7 +241,7 @@ mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
 -- let var' = viewExpr var in mr
 mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
 mkViewMatchResult var' viewExpr var =
 -- let var' = viewExpr var in mr
 mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
 mkViewMatchResult var' viewExpr var =
-    adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs viewExpr (Var var))))
+    adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs (text "mkView" <+> ppr var') viewExpr (Var var))))
 
 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
 mkEvalMatchResult var ty
 
 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
 mkEvalMatchResult var ty
@@ -343,7 +343,7 @@ mkPatSynCase var ty alt fail = do
     matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [ty]
     let MatchResult _ mkCont = match_result
     cont <- mkCoreLams bndrs <$> mkCont fail
     matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [ty]
     let MatchResult _ mkCont = match_result
     cont <- mkCoreLams bndrs <$> mkCont fail
-    return $ mkCoreAppsDs matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
+    return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
   where
     MkCaseAlt{ alt_pat = psyn,
                alt_bndrs = bndrs,
   where
     MkCaseAlt{ alt_pat = psyn,
                alt_bndrs = bndrs,
@@ -536,8 +536,8 @@ into
 which stupidly tries to bind the datacon 'True'.
 -}
 
 which stupidly tries to bind the datacon 'True'.
 -}
 
-mkCoreAppDs  :: CoreExpr -> CoreExpr -> CoreExpr
-mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
+mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
+mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
   | f `hasKey` seqIdKey            -- Note [Desugaring seq (1), (2)]
   = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
   where
   | f `hasKey` seqIdKey            -- Note [Desugaring seq (1), (2)]
   = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
   where
@@ -545,10 +545,10 @@ mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
                    Var v1 | isLocalId v1 -> v1        -- Note [Desugaring seq (2) and (3)]
                    _                     -> mkWildValBinder ty1
 
                    Var v1 | isLocalId v1 -> v1        -- Note [Desugaring seq (2) and (3)]
                    _                     -> mkWildValBinder ty1
 
-mkCoreAppDs fun arg = mkCoreApp fun arg  -- The rest is done in MkCore
+mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in MkCore
 
 
-mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr
-mkCoreAppsDs fun args = foldl mkCoreAppDs fun args
+mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
+mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args
 
 mkCastDs :: CoreExpr -> Coercion -> CoreExpr
 -- We define a desugarer-specific verison of CoreUtils.mkCast,
 
 mkCastDs :: CoreExpr -> Coercion -> CoreExpr
 -- We define a desugarer-specific verison of CoreUtils.mkCast,
index e31d848..5506078 100644 (file)
@@ -414,6 +414,7 @@ Library
         TcErrors
         TcTyClsDecls
         TcTyDecls
         TcErrors
         TcTyClsDecls
         TcTyDecls
+        TcTypeable
         TcType
         TcEvidence
         TcUnify
         TcType
         TcEvidence
         TcUnify
index be01baa..a2ed948 100644 (file)
@@ -41,7 +41,7 @@ module HsUtils(
   mkPatSynBind,
 
   -- Literals
   mkPatSynBind,
 
   -- Literals
-  mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString,
+  mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
 
   -- Patterns
   mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
 
   -- Patterns
   mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
@@ -319,6 +319,10 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
 mkHsString :: String -> HsLit
 mkHsString s = HsString s (mkFastString s)
 
 mkHsString :: String -> HsLit
 mkHsString s = HsString s (mkFastString s)
 
+mkHsStringPrimLit :: FastString -> HsLit
+mkHsStringPrimLit fs
+  = HsStringPrim (unpackFS fs) (fastStringToByteString fs)
+
 -------------
 userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
 -- Caller sets location
 -------------
 userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
 -- Caller sets location
index 1187307..6085b0c 100644 (file)
@@ -14,7 +14,7 @@ module BuildTyCl (
         TcMethInfo, buildClass,
         distinctAbstractTyConRhs, totallyAbstractTyConRhs,
         mkNewTyConRhs, mkDataTyConRhs,
         TcMethInfo, buildClass,
         distinctAbstractTyConRhs, totallyAbstractTyConRhs,
         mkNewTyConRhs, mkDataTyConRhs,
-        newImplicitBinder
+        newImplicitBinder, newTyConRepName
     ) where
 
 #include "HsVersions.h"
     ) where
 
 #include "HsVersions.h"
@@ -22,6 +22,7 @@ module BuildTyCl (
 import IfaceEnv
 import FamInstEnv( FamInstEnvs )
 import TysWiredIn( isCTupleTyConName )
 import IfaceEnv
 import FamInstEnv( FamInstEnvs )
 import TysWiredIn( isCTupleTyConName )
+import PrelNames( tyConRepModOcc )
 import DataCon
 import PatSyn
 import Var
 import DataCon
 import PatSyn
 import Var
@@ -36,6 +37,7 @@ import Id
 import Coercion
 import TcType
 
 import Coercion
 import TcType
 
+import SrcLoc( noSrcSpan )
 import DynFlags
 import TcRnMonad
 import UniqSupply
 import DynFlags
 import TcRnMonad
 import UniqSupply
@@ -49,7 +51,8 @@ buildSynonymTyCon :: Name -> [TyVar] -> [Role]
                   -> TyCon
 buildSynonymTyCon tc_name tvs roles rhs rhs_kind
   = mkSynonymTyCon tc_name kind tvs roles rhs
                   -> TyCon
 buildSynonymTyCon tc_name tvs roles rhs rhs_kind
   = mkSynonymTyCon tc_name kind tvs roles rhs
-  where kind = mkPiKinds tvs rhs_kind
+  where
+    kind = mkPiKinds tvs rhs_kind
 
 
 buildFamilyTyCon :: Name         -- ^ Type family name
 
 
 buildFamilyTyCon :: Name         -- ^ Type family name
@@ -57,7 +60,7 @@ buildFamilyTyCon :: Name         -- ^ Type family name
                  -> Maybe Name   -- ^ Result variable name
                  -> FamTyConFlav -- ^ Open, closed or in a boot file?
                  -> Kind         -- ^ Kind of the RHS
                  -> Maybe Name   -- ^ Result variable name
                  -> FamTyConFlav -- ^ Open, closed or in a boot file?
                  -> Kind         -- ^ Kind of the RHS
-                 -> TyConParent  -- ^ Parent, if exists
+                 -> Maybe Class  -- ^ Parent, if exists
                  -> Injectivity  -- ^ Injectivity annotation
                                  -- See [Injectivity annotation] in HsDecls
                  -> TyCon
                  -> Injectivity  -- ^ Injectivity annotation
                                  -- See [Injectivity annotation] in HsDecls
                  -> TyCon
@@ -132,7 +135,9 @@ mkNewTyConRhs tycon_name tycon con
 
 ------------------------------------------------------
 buildDataCon :: FamInstEnvs
 
 ------------------------------------------------------
 buildDataCon :: FamInstEnvs
-            -> Name -> Bool
+            -> Name
+            -> Bool                     -- Declared infix
+            -> Promoted TyConRepName    -- Promotable
             -> [HsSrcBang]
             -> Maybe [HsImplBang]
                 -- See Note [Bangs on imported data constructors] in MkId
             -> [HsSrcBang]
             -> Maybe [HsImplBang]
                 -- See Note [Bangs on imported data constructors] in MkId
@@ -148,7 +153,7 @@ buildDataCon :: FamInstEnvs
 --   a) makes the worker Id
 --   b) makes the wrapper Id if necessary, including
 --      allocating its unique (hence monadic)
 --   a) makes the worker Id
 --   b) makes the wrapper Id if necessary, including
 --      allocating its unique (hence monadic)
-buildDataCon fam_envs src_name declared_infix src_bangs impl_bangs field_lbls
+buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls
              univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
   = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
         ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
              univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
   = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
         ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
@@ -156,11 +161,12 @@ buildDataCon fam_envs src_name declared_infix src_bangs impl_bangs field_lbls
         -- code, which (for Haskell source anyway) will be in the DataName name
         -- space, and puts it into the VarName name space
 
         -- code, which (for Haskell source anyway) will be in the DataName name
         -- space, and puts it into the VarName name space
 
+        ; traceIf (text "buildDataCon 1" <+> ppr src_name)
         ; us <- newUniqueSupply
         ; dflags <- getDynFlags
         ; let
                 stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
         ; us <- newUniqueSupply
         ; dflags <- getDynFlags
         ; let
                 stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
-                data_con = mkDataCon src_name declared_infix
+                data_con = mkDataCon src_name declared_infix prom_info
                                      src_bangs field_lbls
                                      univ_tvs ex_tvs eq_spec ctxt
                                      arg_tys res_ty rep_tycon
                                      src_bangs field_lbls
                                      univ_tvs ex_tvs eq_spec ctxt
                                      arg_tys res_ty rep_tycon
@@ -169,6 +175,7 @@ buildDataCon fam_envs src_name declared_infix src_bangs impl_bangs field_lbls
                 dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
                                                   impl_bangs data_con)
 
                 dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
                                                   impl_bangs data_con)
 
+        ; traceIf (text "buildDataCon 2" <+> ppr src_name)
         ; return data_con }
 
 
         ; return data_con }
 
 
@@ -227,7 +234,8 @@ type TcMethInfo = (Name, DefMethSpec, Type)
         -- A temporary intermediate, to communicate between
         -- tcClassSigs and buildClass.
 
         -- A temporary intermediate, to communicate between
         -- tcClassSigs and buildClass.
 
-buildClass :: Name -> [TyVar] -> [Role] -> ThetaType
+buildClass :: Name     -- Name of the class/tycon (they have the same Name)
+           -> [TyVar] -> [Role] -> ThetaType
            -> [FunDep TyVar]               -- Functional dependencies
            -> [ClassATItem]                -- Associated types
            -> [TcMethInfo]                 -- Method info
            -> [FunDep TyVar]               -- Functional dependencies
            -> [ClassATItem]                -- Associated types
            -> [TcMethInfo]                 -- Method info
@@ -240,10 +248,7 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
     do  { traceIf (text "buildClass")
 
         ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
     do  { traceIf (text "buildClass")
 
         ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
-                -- The class name is the 'parent' for this datacon, not its tycon,
-                -- because one should import the class to get the binding for
-                -- the datacon
-
+        ; tc_rep_name  <- newTyConRepName tycon_name
 
         ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
                         -- Build the selector id and default method id
 
         ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
                         -- Build the selector id and default method id
@@ -282,6 +287,7 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
         ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
                                    datacon_name
                                    False        -- Not declared infix
         ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
                                    datacon_name
                                    False        -- Not declared infix
+                                   NotPromoted  -- Class tycons are not promoted
                                    (map (const no_bang) args)
                                    (Just (map (const HsLazy) args))
                                    [{- No fields -}]
                                    (map (const no_bang) args)
                                    (Just (map (const HsLazy) args))
                                    [{- No fields -}]
@@ -300,9 +306,8 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
                  else return (mkDataTyConRhs [dict_con])
 
         ; let { clas_kind = mkPiKinds tvs constraintKind
                  else return (mkDataTyConRhs [dict_con])
 
         ; let { clas_kind = mkPiKinds tvs constraintKind
-
-              ; tycon = mkClassTyCon tycon_name clas_kind tvs roles
-                                     rhs rec_clas tc_isrec
+              ; tycon     = mkClassTyCon tycon_name clas_kind tvs roles
+                                         rhs rec_clas tc_isrec tc_rep_name
                 -- 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 }
                 -- 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 }
@@ -366,3 +371,12 @@ newImplicitBinder base_name mk_sys_occ
   where
     occ = mk_sys_occ (nameOccName base_name)
     loc = nameSrcSpan base_name
   where
     occ = mk_sys_occ (nameOccName base_name)
     loc = nameSrcSpan base_name
+
+-- | Make the 'TyConRepName' for this 'TyCon'
+newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
+newTyConRepName tc_name
+  | Just mod <- nameModule_maybe tc_name
+  , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
+  = newGlobalBinder mod occ noSrcSpan
+  | otherwise
+  = newImplicitBinder tc_name mkTyConRepUserOcc
index 8bf744f..3911786 100644 (file)
@@ -165,7 +165,8 @@ data IfaceTyConParent
                    IfaceTcArgs
 
 data IfaceFamTyConFlav
                    IfaceTcArgs
 
 data IfaceFamTyConFlav
-  = IfaceOpenSynFamilyTyCon
+  = IfaceDataFamilyTyCon                      -- Data family
+  | IfaceOpenSynFamilyTyCon
   | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch]))
     -- ^ Name of associated axiom and branches for pretty printing purposes,
     -- or 'Nothing' for an empty closed family without an axiom
   | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch]))
     -- ^ Name of associated axiom and branches for pretty printing purposes,
     -- or 'Nothing' for an empty closed family without an axiom
@@ -192,7 +193,6 @@ data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars  :: [IfaceTvBndr]
 
 data IfaceConDecls
   = IfAbstractTyCon Bool                          -- c.f TyCon.AbstractTyCon
 
 data IfaceConDecls
   = IfAbstractTyCon Bool                          -- c.f TyCon.AbstractTyCon
-  | IfDataFamTyCon                                -- Data family
   | IfDataTyCon [IfaceConDecl] Bool [FieldLabelString] -- Data type decls
   | IfNewTyCon  IfaceConDecl   Bool [FieldLabelString] -- Newtype decls
 
   | IfDataTyCon [IfaceConDecl] Bool [FieldLabelString] -- Data type decls
   | IfNewTyCon  IfaceConDecl   Bool [FieldLabelString] -- Newtype decls
 
@@ -343,14 +343,12 @@ See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoid
 
 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
 visibleIfConDecls (IfAbstractTyCon {}) = []
 
 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
 visibleIfConDecls (IfAbstractTyCon {}) = []
-visibleIfConDecls IfDataFamTyCon       = []
 visibleIfConDecls (IfDataTyCon cs _ _) = cs
 visibleIfConDecls (IfNewTyCon c   _ _) = [c]
 
 ifaceConDeclFields :: IfaceConDecls -> [FieldLbl OccName]
 ifaceConDeclFields x = case x of
     IfAbstractTyCon {}              -> []
 visibleIfConDecls (IfDataTyCon cs _ _) = cs
 visibleIfConDecls (IfNewTyCon c   _ _) = [c]
 
 ifaceConDeclFields :: IfaceConDecls -> [FieldLbl OccName]
 ifaceConDeclFields x = case x of
     IfAbstractTyCon {}              -> []
-    IfDataFamTyCon  {}              -> []
     IfDataTyCon cons is_over labels -> map (help cons  is_over) labels
     IfNewTyCon  con  is_over labels -> map (help [con] is_over) labels
   where
     IfDataTyCon cons is_over labels -> map (help cons  is_over) labels
     IfNewTyCon  con  is_over labels -> map (help [con] is_over) labels
   where
@@ -368,35 +366,15 @@ ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName]
 -- TyThing.getOccName should define a bijection between the two lists.
 -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
 -- The order of the list does not matter.
 -- TyThing.getOccName should define a bijection between the two lists.
 -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
 -- The order of the list does not matter.
-ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}}  = []
-
--- Newtype
-ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ,
-                              ifCons = IfNewTyCon (IfCon { ifConOcc = con_occ }) _ _})
-  =   -- implicit newtype coercion
-    (mkNewTyCoOcc tc_occ) : -- JPM: newtype coercions shouldn't be implicit
-      -- data constructor and worker (newtypes don't have a wrapper)
-    [con_occ, mkDataConWorkerOcc con_occ]
-
-
-ifaceDeclImplicitBndrs (IfaceData {ifName = _tc_occ,
-                              ifCons = IfDataTyCon cons _ _ })
-  = -- for each data constructor in order,
-    --    data constructor, worker, and (possibly) wrapper
-    concatMap dc_occs cons
-  where
-    dc_occs con_decl
-        | has_wrapper = [con_occ, work_occ, wrap_occ]
-        | otherwise   = [con_occ, work_occ]
-        where
-          con_occ  = ifConOcc con_decl            -- DataCon namespace
-          wrap_occ = mkDataConWrapperOcc con_occ  -- Id namespace
-          work_occ = mkDataConWorkerOcc con_occ   -- Id namespace
-          has_wrapper = ifConWrapper con_decl     -- This is the reason for
-                                                  -- having the ifConWrapper field!
-
-ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
-                               ifSigs = sigs, ifATs = ats })
+
+ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ, ifCons = cons })
+  = case cons of
+      IfAbstractTyCon {}  -> []
+      IfNewTyCon  cd  _ _ -> mkNewTyCoOcc tc_occ : ifaceConDeclImplicitBndrs cd
+      IfDataTyCon cds _ _ -> concatMap ifaceConDeclImplicitBndrs cds
+
+ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt, ifName = cls_tc_occ
+                                   , ifSigs = sigs, ifATs = ats })
   = --   (possibly) newtype coercion
     co_occs ++
     --    data constructor (DataCon namespace)
   = --   (possibly) newtype coercion
     co_occs ++
     --    data constructor (DataCon namespace)
@@ -420,6 +398,14 @@ ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
 
 ifaceDeclImplicitBndrs _ = []
 
 
 ifaceDeclImplicitBndrs _ = []
 
+ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName]
+ifaceConDeclImplicitBndrs (IfCon { ifConWrapper = has_wrapper, ifConOcc = con_occ })
+  = [con_occ, work_occ] ++ wrap_occs
+  where
+    work_occ  = mkDataConWorkerOcc con_occ                   -- Id namespace
+    wrap_occs | has_wrapper = [mkDataConWrapperOcc con_occ]  -- Id namespace
+              | otherwise   = []
+
 -- -----------------------------------------------------------------------------
 -- The fingerprints of an IfaceDecl
 
 -- -----------------------------------------------------------------------------
 -- The fingerprints of an IfaceDecl
 
@@ -685,7 +671,6 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
 
     pp_nd = case condecls of
               IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d))
 
     pp_nd = case condecls of
               IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d))
-              IfDataFamTyCon    -> ptext (sLit "data family")
               IfDataTyCon{}     -> ptext (sLit "data")
               IfNewTyCon{}      -> ptext (sLit "newtype")
 
               IfDataTyCon{}     -> ptext (sLit "data")
               IfNewTyCon{}      -> ptext (sLit "newtype")
 
@@ -694,6 +679,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
     pp_prom | is_prom   = ptext (sLit "Promotable")
             | otherwise = Outputable.empty
 
     pp_prom | is_prom   = ptext (sLit "Promotable")
             | otherwise = Outputable.empty
 
+
 pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
                             , ifCtxt   = context, ifName  = clas
                             , ifTyVars = tyvars,  ifRoles = roles
 pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
                             , ifCtxt   = context, ifName  = clas
                             , ifTyVars = tyvars,  ifRoles = roles
@@ -738,7 +724,12 @@ pprIfaceDecl ss (IfaceSynonym { ifName   = tc
 pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
                              , ifFamFlav = rhs, ifFamKind = kind
                              , ifResVar = res_var, ifFamInj = inj })
 pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
                              , ifFamFlav = rhs, ifFamKind = kind
                              , ifResVar = res_var, ifFamInj = inj })
-  = vcat [ hang (text "type family" <+> pprIfaceDeclHead [] ss tycon tyvars)
+  | IfaceDataFamilyTyCon <- rhs
+  = ptext (sLit "data family") <+> pprIfaceDeclHead [] ss tycon tyvars
+
+  | otherwise
+  = vcat [ hang (ptext (sLit "type family")
+                 <+> pprIfaceDeclHead [] ss tycon tyvars)
               2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs))
          , ppShowRhs ss (nest 2 (pp_branches rhs)) ]
   where
               2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs))
          , ppShowRhs ss (nest 2 (pp_branches rhs)) ]
   where
@@ -752,11 +743,13 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
        []  -> empty
        tvs -> hsep [text "|", ppr res, text "->", interppSP (map fst tvs)]
 
        []  -> empty
        tvs -> hsep [text "|", ppr res, text "->", interppSP (map fst tvs)]
 
+    pp_rhs IfaceDataFamilyTyCon
+      = ppShowIface ss (ptext (sLit "data"))
     pp_rhs IfaceOpenSynFamilyTyCon
       = ppShowIface ss (ptext (sLit "open"))
     pp_rhs IfaceAbstractClosedSynFamilyTyCon
       = ppShowIface ss (ptext (sLit "closed, abstract"))
     pp_rhs IfaceOpenSynFamilyTyCon
       = ppShowIface ss (ptext (sLit "open"))
     pp_rhs IfaceAbstractClosedSynFamilyTyCon
       = ppShowIface ss (ptext (sLit "closed, abstract"))
-    pp_rhs (IfaceClosedSynFamilyTyCon _)
+    pp_rhs (IfaceClosedSynFamilyTyCon {})
       = ptext (sLit "where")
     pp_rhs IfaceBuiltInSynFamTyCon
       = ppShowIface ss (ptext (sLit "built-in"))
       = ptext (sLit "where")
     pp_rhs IfaceBuiltInSynFamTyCon
       = ppShowIface ss (ptext (sLit "built-in"))
@@ -1170,12 +1163,13 @@ freeNamesIfIdDetails _                 = emptyNameSet
 
 -- All other changes are handled via the version info on the tycon
 freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet
 
 -- All other changes are handled via the version info on the tycon
 freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet
-freeNamesIfFamFlav IfaceOpenSynFamilyTyCon           = emptyNameSet
+freeNamesIfFamFlav IfaceOpenSynFamilyTyCon             = emptyNameSet
+freeNamesIfFamFlav IfaceDataFamilyTyCon                = emptyNameSet
 freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br)))
   = unitNameSet ax &&& fnList freeNamesIfAxBranch br
 freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet
 freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br)))
   = unitNameSet ax &&& fnList freeNamesIfAxBranch br
 freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet
-freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
-freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet
+freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon   = emptyNameSet
+freeNamesIfFamFlav IfaceBuiltInSynFamTyCon             = emptyNameSet
 
 freeNamesIfContext :: IfaceContext -> NameSet
 freeNamesIfContext = fnList freeNamesIfType
 
 freeNamesIfContext :: IfaceContext -> NameSet
 freeNamesIfContext = fnList freeNamesIfType
@@ -1526,18 +1520,22 @@ instance Binary IfaceDecl where
             _ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
 
 instance Binary IfaceFamTyConFlav where
             _ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
 
 instance Binary IfaceFamTyConFlav where
-    put_ bh IfaceOpenSynFamilyTyCon           = putByte bh 0
-    put_ bh (IfaceClosedSynFamilyTyCon mb)    = putByte bh 1 >> put_ bh mb
-    put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2
+    put_ bh IfaceDataFamilyTyCon              = putByte bh 0
+    put_ bh IfaceOpenSynFamilyTyCon           = putByte bh 1
+    put_ bh (IfaceClosedSynFamilyTyCon mb)    = putByte bh 2 >> put_ bh mb
+    put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3
     put_ _ IfaceBuiltInSynFamTyCon
         = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty
 
     get bh = do { h <- getByte bh
                 ; case h of
     put_ _ IfaceBuiltInSynFamTyCon
         = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty
 
     get bh = do { h <- getByte bh
                 ; case h of
-                    0 -> return IfaceOpenSynFamilyTyCon
-                    1 -> do { mb <- get bh
+                    0 -> return IfaceDataFamilyTyCon
+                    1 -> return IfaceOpenSynFamilyTyCon
+                    2 -> do { mb <- get bh
                             ; return (IfaceClosedSynFamilyTyCon mb) }
                             ; return (IfaceClosedSynFamilyTyCon mb) }
-                    _ -> return IfaceAbstractClosedSynFamilyTyCon }
+                    3 -> return IfaceAbstractClosedSynFamilyTyCon
+                    _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag"
+                                  (ppr (fromIntegral h :: Int)) }
 
 instance Binary IfaceClassOp where
     put_ bh (IfaceClassOp n def ty) = do
 
 instance Binary IfaceClassOp where
     put_ bh (IfaceClassOp n def ty) = do
@@ -1576,17 +1574,16 @@ instance Binary IfaceAxBranch where
         return (IfaceAxBranch a1 a2 a3 a4 a5)
 
 instance Binary IfaceConDecls where
         return (IfaceAxBranch a1 a2 a3 a4 a5)
 
 instance Binary IfaceConDecls where
-    put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
-    put_ bh IfDataFamTyCon      = putByte bh 1
-    put_ bh (IfDataTyCon cs b fs) = putByte bh 2 >> put_ bh cs >> put_ bh b >> put_ bh fs
-    put_ bh (IfNewTyCon c b fs)   = putByte bh 3 >> put_ bh c >> put_ bh b >> put_ bh fs
+    put_ bh (IfAbstractTyCon d)   = putByte bh 0 >> put_ bh d
+    put_ bh (IfDataTyCon cs b fs) = putByte bh 1 >> put_ bh cs >> put_ bh b >> put_ bh fs
+    put_ bh (IfNewTyCon c b fs)   = putByte bh 2 >> put_ bh c >> put_ bh b >> put_ bh fs
     get bh = do
         h <- getByte bh
         case h of
             0 -> liftM IfAbstractTyCon $ get bh
     get bh = do
         h <- getByte bh
         case h of
             0 -> liftM IfAbstractTyCon $ get bh
-            1 -> return IfDataFamTyCon
-            2 -> liftM3 IfDataTyCon (get bh) (get bh) (get bh)
-            _ -> liftM3 IfNewTyCon (get bh) (get bh) (get bh)
+            1 -> liftM3 IfDataTyCon (get bh) (get bh) (get bh)
+            2 -> liftM3 IfNewTyCon (get bh) (get bh) (get bh)
+            _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls"
 
 instance Binary IfaceConDecl where
     put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
 
 instance Binary IfaceConDecl where
     put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
index df96f6a..b7bdc38 100644 (file)
@@ -1611,7 +1611,7 @@ tyConToIfaceDecl env tycon
                   ifCons    = ifaceConDecls (algTyConRhs tycon) (algTcFields tycon),
                   ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
                   ifGadtSyntax = isGadtSyntaxTyCon tycon,
                   ifCons    = ifaceConDecls (algTyConRhs tycon) (algTcFields tycon),
                   ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
                   ifGadtSyntax = isGadtSyntaxTyCon tycon,
-                  ifPromotable = isJust (promotableTyCon_maybe tycon),
+                  ifPromotable = isPromotableTyCon tycon,
                   ifParent  = parent })
 
   | otherwise  -- FunTyCon, PrimTyCon, promoted TyCon/DataCon
                   ifParent  = parent })
 
   | otherwise  -- FunTyCon, PrimTyCon, promoted TyCon/DataCon
@@ -1649,16 +1649,14 @@ tyConToIfaceDecl env tycon
             axn  = coAxiomName ax
     to_if_fam_flav (ClosedSynFamilyTyCon Nothing)
       = IfaceClosedSynFamilyTyCon Nothing
             axn  = coAxiomName ax
     to_if_fam_flav (ClosedSynFamilyTyCon Nothing)
       = IfaceClosedSynFamilyTyCon Nothing
-    to_if_fam_flav AbstractClosedSynFamilyTyCon
-      = IfaceAbstractClosedSynFamilyTyCon
+    to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon
+    to_if_fam_flav (DataFamilyTyCon {})         = IfaceDataFamilyTyCon
+    to_if_fam_flav (BuiltInSynFamTyCon {})      = IfaceBuiltInSynFamTyCon
 
 
-    to_if_fam_flav (BuiltInSynFamTyCon {})
-      = IfaceBuiltInSynFamTyCon
 
 
     ifaceConDecls (NewTyCon { data_con = con })    flds = IfNewTyCon  (ifaceConDecl con) (ifaceOverloaded flds) (ifaceFields flds)
     ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (ifaceOverloaded flds) (ifaceFields flds)
 
 
     ifaceConDecls (NewTyCon { data_con = con })    flds = IfNewTyCon  (ifaceConDecl con) (ifaceOverloaded flds) (ifaceFields flds)
     ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (ifaceOverloaded flds) (ifaceFields flds)
-    ifaceConDecls (DataFamilyTyCon {})             _    = IfDataFamTyCon
     ifaceConDecls (TupleTyCon { data_con = con })  _    = IfDataTyCon [ifaceConDecl con] False []
     ifaceConDecls (AbstractTyCon distinct)         _    = IfAbstractTyCon distinct
         -- The AbstractTyCon case happens when a TyCon has been trimmed
     ifaceConDecls (TupleTyCon { data_con = con })  _    = IfDataTyCon [ifaceConDecl con] False []
     ifaceConDecls (AbstractTyCon distinct)         _    = IfAbstractTyCon distinct
         -- The AbstractTyCon case happens when a TyCon has been trimmed
index 1328b3c..80de36e 100644 (file)
@@ -297,13 +297,13 @@ What this means is that the implicitTyThings MUST NOT DEPEND on any of
 the forkM stuff.
 -}
 
 the forkM stuff.
 -}
 
-tcIfaceDecl :: Bool     -- True <=> discard IdInfo on IfaceId bindings
+tcIfaceDecl :: Bool     -- True <=> discard IdInfo on IfaceId bindings
             -> IfaceDecl
             -> IfL TyThing
             -> IfaceDecl
             -> IfL TyThing
-tcIfaceDecl = tc_iface_decl NoParentTyCon
+tcIfaceDecl = tc_iface_decl Nothing
 
 
-tc_iface_decl :: TyConParent    -- For nested declarations
-              -> Bool   -- True <=> discard IdInfo on IfaceId bindings
+tc_iface_decl :: Maybe Class  -- ^ For associated type/data family declarations
+              -> Bool         -- ^ True <=> discard IdInfo on IfaceId bindings
               -> IfaceDecl
               -> IfL TyThing
 tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
               -> IfaceDecl
               -> IfL TyThing
 tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
@@ -314,7 +314,7 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
         ; info <- tcIdInfo ignore_prags name ty info
         ; return (AnId (mkGlobalId details name ty info)) }
 
         ; info <- tcIdInfo ignore_prags name ty info
         ; return (AnId (mkGlobalId details name ty info)) }
 
-tc_iface_decl parent _ (IfaceData {ifName = occ_name,
+tc_iface_decl _ _ (IfaceData {ifName = occ_name,
                           ifCType = cType,
                           ifTyVars = tv_bndrs,
                           ifRoles = roles,
                           ifCType = cType,
                           ifTyVars = tv_bndrs,
                           ifRoles = roles,
@@ -326,22 +326,23 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
     { tc_name <- lookupIfaceTop occ_name
     ; tycon <- fixM $ \ tycon -> do
             { stupid_theta <- tcIfaceCtxt ctxt
     { tc_name <- lookupIfaceTop occ_name
     ; tycon <- fixM $ \ tycon -> do
             { stupid_theta <- tcIfaceCtxt ctxt
-            ; parent' <- tc_parent mb_parent
-            ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
+            ; parent' <- tc_parent tc_name mb_parent
+            ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons is_prom
             ; return (buildAlgTyCon tc_name tyvars roles cType stupid_theta
                                     cons is_rec is_prom gadt_syn parent') }
     ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
     ; return (ATyCon tycon) }
   where
             ; return (buildAlgTyCon tc_name tyvars roles cType stupid_theta
                                     cons is_rec is_prom gadt_syn parent') }
     ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
     ; return (ATyCon tycon) }
   where
-    tc_parent :: IfaceTyConParent -> IfL TyConParent
-    tc_parent IfNoParent = return parent
-    tc_parent (IfDataInstance ax_name _ arg_tys)
-      = ASSERT( isNoParent parent )
-        do { ax <- tcIfaceCoAxiom ax_name
+    tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav
+    tc_parent tc_name IfNoParent
+      = do { tc_rep_name <- newTyConRepName tc_name
+           ; return (VanillaAlgTyCon tc_rep_name) }
+    tc_parent _ (IfDataInstance ax_name _ arg_tys)
+      = do { ax <- tcIfaceCoAxiom ax_name
            ; let fam_tc  = coAxiomTyCon ax
                  ax_unbr = toUnbranchedAxiom ax
            ; lhs_tys <- tcIfaceTcArgs arg_tys
            ; let fam_tc  = coAxiomTyCon ax
                  ax_unbr = toUnbranchedAxiom ax
            ; lhs_tys <- tcIfaceTcArgs arg_tys
-           ; return (FamInstTyCon ax_unbr fam_tc lhs_tys) }
+           ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }
 
 tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, ifTyVars = tv_bndrs,
                                       ifRoles = roles,
 
 tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, ifTyVars = tv_bndrs,
                                       ifRoles = roles,
@@ -365,20 +366,25 @@ tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs,
      { tc_name  <- lookupIfaceTop occ_name
      ; rhs_kind <- tcIfaceKind kind     -- Note [Synonym kind loop]
      ; rhs      <- forkM (mk_doc tc_name) $
      { tc_name  <- lookupIfaceTop occ_name
      ; rhs_kind <- tcIfaceKind kind     -- Note [Synonym kind loop]
      ; rhs      <- forkM (mk_doc tc_name) $
-                   tc_fam_flav fam_flav
+                   tc_fam_flav tc_name fam_flav
      ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res
      ; let tycon = buildFamilyTyCon tc_name tyvars res_name rhs rhs_kind
                                     parent inj
      ; return (ATyCon tycon) }
    where
      mk_doc n = ptext (sLit "Type synonym") <+> ppr n
      ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res
      ; let tycon = buildFamilyTyCon tc_name tyvars res_name rhs rhs_kind
                                     parent inj
      ; return (ATyCon tycon) }
    where
      mk_doc n = ptext (sLit "Type synonym") <+> ppr n
-     tc_fam_flav IfaceOpenSynFamilyTyCon   = return OpenSynFamilyTyCon
-     tc_fam_flav (IfaceClosedSynFamilyTyCon mb_ax_name_branches)
+
+     tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav
+     tc_fam_flav tc_name IfaceDataFamilyTyCon
+       = do { tc_rep_name <- newTyConRepName tc_name
+            ; return (DataFamilyTyCon tc_rep_name) }
+     tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon
+     tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches)
        = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches
             ; return (ClosedSynFamilyTyCon ax) }
        = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches
             ; return (ClosedSynFamilyTyCon ax) }
-     tc_fam_flav IfaceAbstractClosedSynFamilyTyCon
+     tc_fam_flav IfaceAbstractClosedSynFamilyTyCon
          = return AbstractClosedSynFamilyTyCon
          = return AbstractClosedSynFamilyTyCon
-     tc_fam_flav IfaceBuiltInSynFamTyCon
+     tc_fam_flav IfaceBuiltInSynFamTyCon
          = pprPanic "tc_iface_decl"
                     (text "IfaceBuiltInSynFamTyCon in interface file")
 
          = pprPanic "tc_iface_decl"
                     (text "IfaceBuiltInSynFamTyCon in interface file")
 
@@ -422,7 +428,7 @@ tc_iface_decl _parent ignore_prags
           ; return (op_name, dm, op_ty) }
 
    tc_at cls (IfaceAT tc_decl if_def)
           ; return (op_name, dm, op_ty) }
 
    tc_at cls (IfaceAT tc_decl if_def)
-     = do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl
+     = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl
           mb_def <- case if_def of
                       Nothing  -> return Nothing
                       Just def -> forkM (mk_at_doc tc)                 $
           mb_def <- case if_def of
                       Nothing  -> return Nothing
                       Just def -> forkM (mk_at_doc tc)                 $
@@ -506,11 +512,10 @@ tc_ax_branch prev_branches
                           , cab_incomps = map (prev_branches !!) incomps }
     ; return (prev_branches ++ [br]) }
 
                           , cab_incomps = map (prev_branches !!) incomps }
     ; return (prev_branches ++ [br]) }
 
-tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
-tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
+tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> Bool -> IfL AlgTyConRhs
+tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom
   = case if_cons of
         IfAbstractTyCon dis -> return (AbstractTyCon dis)
   = case if_cons of
         IfAbstractTyCon dis -> return (AbstractTyCon dis)
-        IfDataFamTyCon  -> return DataFamilyTyCon
         IfDataTyCon cons _ _ -> do  { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
                                     ; data_cons  <- mapM (tc_con_decl field_lbls) cons
                                     ; return (mkDataTyConRhs data_cons) }
         IfDataTyCon cons _ _ -> do  { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
                                     ; data_cons  <- mapM (tc_con_decl field_lbls) cons
                                     ; return (mkDataTyConRhs data_cons) }
@@ -528,14 +533,14 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
        -- parent TyCon, and are alrady in scope
        bindIfaceTyVars ex_tvs    $ \ ex_tyvars -> do
         { traceIf (text "Start interface-file tc_con_decl" <+> ppr occ)
        -- parent TyCon, and are alrady in scope
        bindIfaceTyVars ex_tvs    $ \ ex_tyvars -> do
         { traceIf (text "Start interface-file tc_con_decl" <+> ppr occ)
-        ; name  <- lookupIfaceTop occ
+        ; dc_name  <- lookupIfaceTop occ
 
         -- Read the context and argument types, but lazily for two reasons
         -- (a) to avoid looking tugging on a recursive use of
         --     the type itself, which is knot-tied
         -- (b) to avoid faulting in the component types unless
         --     they are really needed
 
         -- Read the context and argument types, but lazily for two reasons
         -- (a) to avoid looking tugging on a recursive use of
         --     the type itself, which is knot-tied
         -- (b) to avoid faulting in the component types unless
         --     they are really needed
-        ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc name) $
+        ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $
              do { eq_spec <- tcIfaceEqSpec spec
                 ; theta   <- tcIfaceCtxt ctxt
                 ; arg_tys <- mapM tcIfaceType args
              do { eq_spec <- tcIfaceEqSpec spec
                 ; theta   <- tcIfaceCtxt ctxt
                 ; arg_tys <- mapM tcIfaceType args
@@ -555,20 +560,24 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
         ; let orig_res_ty = mkFamilyTyConApp tycon
                                 (substTyVars (mkTopTvSubst eq_spec) tc_tyvars)
 
         ; let orig_res_ty = mkFamilyTyConApp tycon
                                 (substTyVars (mkTopTvSubst eq_spec) tc_tyvars)
 
-        ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
-                   name is_infix
-                   (map src_strict if_src_stricts)
-                   (Just stricts)
-                     -- Pass the HsImplBangs (i.e. final
-                     -- decisions) to buildDataCon; it'll use
-                     -- these to guide the construction of a
-                     -- worker.
-                     -- See Note [Bangs on imported data constructors] in MkId
-                   lbl_names
-                   tc_tyvars ex_tyvars
-                   eq_spec theta
-                   arg_tys orig_res_ty tycon
-        ; traceIf (text "Done interface-file tc_con_decl" <+> ppr name)
+        ; prom_info <- if is_prom then do { n <- newTyConRepName dc_name
+                                          ; return (Promoted n) }
+                                  else return NotPromoted
+
+        ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))
+                       dc_name is_infix prom_info
+                       (map src_strict if_src_stricts)
+                       (Just stricts)
+                       -- Pass the HsImplBangs (i.e. final
+                       -- decisions) to buildDataCon; it'll use
+                       -- these to guide the construction of a
+                       -- worker.
+                       -- See Note [Bangs on imported data constructors] in MkId
+                       lbl_names
+                       tc_tyvars ex_tyvars
+                       eq_spec theta
+                       arg_tys orig_res_ty tycon
+        ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
         ; return con }
     mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
 
         ; return con }
     mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
 
@@ -889,7 +898,7 @@ tcIfaceTupleTy sort info args
             -> return (mkTyConApp base_tc args')
 
           IfacePromotedTyCon
             -> return (mkTyConApp base_tc args')
 
           IfacePromotedTyCon
-            | Just tc <- promotableTyCon_maybe base_tc
+            | Promoted tc <- promotableTyCon_maybe base_tc
             -> return (mkTyConApp tc args')
             | otherwise
             -> panic "tcIfaceTupleTy" (ppr base_tc)
             -> return (mkTyConApp tc args')
             | otherwise
             -> panic "tcIfaceTupleTy" (ppr base_tc)
@@ -1366,7 +1375,7 @@ tcIfaceTyCon (IfaceTyCon name info)
                                    -- Same Name as its underlying TyCon
   where
     promote_tc tc
                                    -- Same Name as its underlying TyCon
   where
     promote_tc tc
-      | Just prom_tc <- promotableTyCon_maybe tc = prom_tc
+      | Promoted prom_tc <- promotableTyCon_maybe tc = prom_tc
       | isSuperKind (tyConKind tc)               = tc
       | otherwise = pprPanic "tcIfaceTyCon" (ppr name $$ ppr tc)
 
       | isSuperKind (tyConKind tc)               = tc
       | otherwise = pprPanic "tcIfaceTyCon" (ppr name $$ ppr tc)
 
index 64143e0..95cb5f2 100644 (file)
@@ -94,9 +94,11 @@ import BasicTypes       ( HValue )
 import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
 import Linker
 import CoreTidy         ( tidyExpr )
 import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
 import Linker
 import CoreTidy         ( tidyExpr )
-import Type             ( Type, Kind )
+import Type             ( Type )
+import {- Kind parts of -} Type         ( Kind )
 import CoreLint         ( lintInteractiveExpr )
 import VarEnv           ( emptyTidyEnv )
 import CoreLint         ( lintInteractiveExpr )
 import VarEnv           ( emptyTidyEnv )
+import THNames          ( templateHaskellNames )
 import ConLike
 
 import GHC.Exts
 import ConLike
 
 import GHC.Exts
@@ -181,7 +183,7 @@ newHscEnv :: DynFlags -> IO HscEnv
 newHscEnv dflags = do
     eps_var <- newIORef initExternalPackageState
     us      <- mkSplitUniqSupply 'r'
 newHscEnv dflags = do
     eps_var <- newIORef initExternalPackageState
     us      <- mkSplitUniqSupply 'r'
-    nc_var  <- newIORef (initNameCache us knownKeyNames)
+    nc_var  <- newIORef (initNameCache us allKnownKeyNames)
     fc_var  <- newIORef emptyModuleEnv
     return HscEnv {  hsc_dflags       = dflags,
                      hsc_targets      = [],
     fc_var  <- newIORef emptyModuleEnv
     return HscEnv {  hsc_dflags       = dflags,
                      hsc_targets      = [],
@@ -194,6 +196,13 @@ newHscEnv dflags = do
                      hsc_type_env_var = Nothing }
 
 
                      hsc_type_env_var = Nothing }
 
 
+allKnownKeyNames :: [Name]      -- Put here to avoid loops involving DsMeta,
+allKnownKeyNames =              -- where templateHaskellNames are defined
+    knownKeyNames
+#ifdef GHCI
+        ++ templateHaskellNames
+#endif
+
 -- -----------------------------------------------------------------------------
 
 getWarnings :: Hsc WarningMessages
 -- -----------------------------------------------------------------------------
 
 getWarnings :: Hsc WarningMessages
index fb65a67..b711ffe 100644 (file)
@@ -1689,8 +1689,8 @@ implicitTyThings (AConLike cl)  = implicitConLikeThings cl
 
 implicitConLikeThings :: ConLike -> [TyThing]
 implicitConLikeThings (RealDataCon dc)
 
 implicitConLikeThings :: ConLike -> [TyThing]
 implicitConLikeThings (RealDataCon dc)
-  = map AnId (dataConImplicitIds dc)
-    -- For data cons add the worker and (possibly) wrapper
+  = dataConImplicitTyThings dc
+
 implicitConLikeThings (PatSynCon {})
   = []  -- Pattern synonyms have no implicit Ids; the wrapper and matcher
         -- are not "implicit"; they are simply new top-level bindings,
 implicitConLikeThings (PatSynCon {})
   = []  -- Pattern synonyms have no implicit Ids; the wrapper and matcher
         -- are not "implicit"; they are simply new top-level bindings,
@@ -1705,7 +1705,7 @@ implicitClassThings cl
   = -- Does not include default methods, because those Ids may have
     --    their own pragmas, unfoldings etc, not derived from the Class object
     -- associated types
   = -- Does not include default methods, because those Ids may have
     --    their own pragmas, unfoldings etc, not derived from the Class object
     -- associated types
-    --    No extras_plus (recursive call) for the classATs, because they
+    --    No recursive call for the classATs, because they
     --    are only the family decls; they have no implicit things
     map ATyCon (classATs cl) ++
     -- superclass and operation selectors
     --    are only the family decls; they have no implicit things
     map ATyCon (classATs cl) ++
     -- superclass and operation selectors
@@ -1721,7 +1721,8 @@ implicitTyConThings tc
 
       -- for each data constructor in order,
       --   the contructor, worker, and (possibly) wrapper
 
       -- for each data constructor in order,
       --   the contructor, worker, and (possibly) wrapper
-    concatMap (extras_plus . AConLike . RealDataCon) (tyConDataCons tc)
+    [ thing | dc    <- tyConDataCons tc
+            , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ]
       -- NB. record selectors are *not* implicit, they have fully-fledged
       -- bindings that pass through the compilation pipeline as normal.
   where
       -- NB. record selectors are *not* implicit, they have fully-fledged
       -- bindings that pass through the compilation pipeline as normal.
   where
@@ -1729,10 +1730,6 @@ implicitTyConThings tc
         Nothing -> []
         Just cl -> implicitClassThings cl
 
         Nothing -> []
         Just cl -> implicitClassThings cl
 
--- add a thing and recursive call
-extras_plus :: TyThing -> [TyThing]
-extras_plus thing = thing : implicitTyThings thing
-
 -- For newtypes and closed type families (only) add the implicit coercion tycon
 implicitCoTyCon :: TyCon -> [TyThing]
 implicitCoTyCon tc
 -- For newtypes and closed type families (only) add the implicit coercion tycon
 implicitCoTyCon :: TyCon -> [TyThing]
 implicitCoTyCon tc
index f79b6b1..f76b62e 100644 (file)
@@ -10,7 +10,7 @@ module PrelInfo (
         primOpRules, builtinRules,
 
         ghcPrimExports,
         primOpRules, builtinRules,
 
         ghcPrimExports,
-        wiredInThings, knownKeyNames,
+        knownKeyNames,
         primOpId,
 
         -- Random other things
         primOpId,
 
         -- Random other things
@@ -23,56 +23,31 @@ module PrelInfo (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 
+import Constants        ( mAX_TUPLE_SIZE )
+import BasicTypes       ( Boxity(..) )
+import ConLike          ( ConLike(..) )
 import PrelNames
 import PrelRules
 import Avail
 import PrimOp
 import DataCon
 import Id
 import PrelNames
 import PrelRules
 import Avail
 import PrimOp
 import DataCon
 import Id
+import Name
 import MkId
 import MkId
-import Name( Name, getName )
 import TysPrim
 import TysWiredIn
 import HscTypes
 import Class
 import TyCon
 import TysPrim
 import TysWiredIn
 import HscTypes
 import Class
 import TyCon
-import Outputable
-import UniqFM
 import Util
 import {-# SOURCE #-} TcTypeNats ( typeNatTyCons )
 
 import Util
 import {-# SOURCE #-} TcTypeNats ( typeNatTyCons )
 
-#ifdef GHCI
-import THNames
-#endif
-
 import Data.Array
 
 import Data.Array
 
-
-{- *********************************************************************
-*                                                                      *
-                Known key things
-*                                                                      *
-********************************************************************* -}
-
-knownKeyNames :: [Name]
-knownKeyNames =
-  ASSERT2( isNullUFM badNamesUFM, text "badknownKeyNames" <+> ppr badNamesUFM )
-  names
-  where
-  badNamesUFM = filterUFM (\ns -> length ns > 1) namesUFM
-  namesUFM = foldl (\m n -> addToUFM_Acc (:) singleton m n n) emptyUFM names
-  names = concat
-    [ map getName wiredInThings
-    , cTupleTyConNames
-    , basicKnownKeyNames
-#ifdef GHCI
-    , templateHaskellNames
-#endif
-    ]
-
-{- *********************************************************************
+{-
+************************************************************************
 *                                                                      *
 *                                                                      *
-                Wired in things
+\subsection[builtinNameInfo]{Lookup built-in names}
 *                                                                      *
 ************************************************************************
 
 *                                                                      *
 ************************************************************************
 
@@ -87,33 +62,61 @@ Notes about wired in things
 
 * The name cache is initialised with (the names of) all wired-in things
 
 
 * The name cache is initialised with (the names of) all wired-in things
 
-* The type checker sees if the Name is wired in before looking up
-  the name in the type environment.  So the type envt itself contains
-  no wired in things.
+* The type environment itself contains no wired in things. The type
+  checker sees if the Name is wired in before looking up the name in
+  the type environment.
 
 * MkIface prunes out wired-in things before putting them in an interface file.
   So interface files never contain wired-in things.
 -}
 
 
 * MkIface prunes out wired-in things before putting them in an interface file.
   So interface files never contain wired-in things.
 -}
 
-wiredInThings :: [TyThing]
--- This list is used only to initialise HscMain.knownKeyNames
--- to ensure that when you say "Prelude.map" in your source code, you
--- get a Name with the correct known key (See Note [Known-key names])
-wiredInThings
-  = concat
-    [           -- Wired in TyCons and their implicit Ids
-          tycon_things
-        , concatMap implicitTyThings tycon_things
-
-                -- Wired in Ids
-        , map AnId wiredInIds
-
-                -- PrimOps
-        , map (AnId . primOpId) allThePrimOps
-    ]
+
+knownKeyNames :: [Name]
+-- This list is used to ensure that when you say "Prelude.map"
+--  in your source code, or in an interface file,
+-- you get a Name with the correct known key
+-- (See Note [Known-key names] in PrelNames)
+knownKeyNames
+  = concat [ tycon_kk_names funTyCon
+           , concatMap tycon_kk_names primTyCons
+
+           , concatMap tycon_kk_names wiredInTyCons
+             -- Does not include tuples
+
+           , concatMap tycon_kk_names typeNatTyCons
+
+           , concatMap (rep_names . tupleTyCon Boxed) [2..mAX_TUPLE_SIZE]  -- Yuk
+
+           , cTupleTyConNames
+             -- Constraint tuples are known-key but not wired-in
+             -- They can't show up in source code, but can appear
+             -- in intreface files
+
+           , map idName wiredInIds
+           , map (idName . primOpId) allThePrimOps
+           , basicKnownKeyNames ]
   where
   where
-    tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons
-                                    ++ typeNatTyCons)
+    -- "kk" short for "known-key"
+    tycon_kk_names :: TyCon -> [Name]
+    tycon_kk_names tc = tyConName tc : (rep_names tc ++ concatMap thing_kk_names (implicitTyConThings tc))
+
+    datacon_kk_names dc
+      | Promoted tc <- promoteDataCon_maybe dc = dataConName dc : rep_names tc
+      | otherwise                              = [dataConName dc]
+
+    thing_kk_names :: TyThing -> [Name]
+    thing_kk_names (ATyCon tc)                 = tycon_kk_names tc
+    thing_kk_names (AConLike (RealDataCon dc)) = datacon_kk_names dc
+    thing_kk_names thing                       = [getName thing]
+
+    -- The TyConRepName for a known-key TyCon has a known key,
+    -- but isn't itself an implicit thing.  Yurgh.
+    -- NB: if any of the wired-in TyCons had record fields, the record
+    --     field names would be in a similar situation.  Ditto class ops.
+    --     But it happens that there aren't any
+    rep_names tc = case tyConRepName_maybe tc of
+                         Just n  -> [n]
+                         Nothing -> []
 
 {-
 We let a lot of "non-standard" values be visible, so that we can make
 
 {-
 We let a lot of "non-standard" values be visible, so that we can make
index 30d11fe..05a38ff 100644 (file)
@@ -206,11 +206,13 @@ basicKnownKeyNames
         -- Typeable
         typeableClassName,
         typeRepTyConName,
         -- Typeable
         typeableClassName,
         typeRepTyConName,
-        mkTyConName,
+        trTyConDataConName,
+        trModuleDataConName,
+        trNameSDataConName,
+        typeRepIdName,
         mkPolyTyConAppName,
         mkAppTyName,
         mkPolyTyConAppName,
         mkAppTyName,
-        typeNatTypeRepName,
-        typeSymbolTypeRepName,
+        typeSymbolTypeRepName, typeNatTypeRepName,
 
         -- Dynamic
         toDynName,
 
         -- Dynamic
         toDynName,
@@ -226,7 +228,6 @@ basicKnownKeyNames
         fromIntegralName, realToFracName,
 
         -- String stuff
         fromIntegralName, realToFracName,
 
         -- String stuff
-        stringTyConName,
         fromStringName,
 
         -- Enum stuff
         fromStringName,
 
         -- Enum stuff
@@ -607,7 +608,8 @@ toInteger_RDR           = nameRdrName toIntegerName
 toRational_RDR          = nameRdrName toRationalName
 fromIntegral_RDR        = nameRdrName fromIntegralName
 
 toRational_RDR          = nameRdrName toRationalName
 fromIntegral_RDR        = nameRdrName fromIntegralName
 
-fromString_RDR :: RdrName
+stringTy_RDR, fromString_RDR :: RdrName
+stringTy_RDR            = tcQual_RDR gHC_BASE (fsLit "String")
 fromString_RDR          = nameRdrName fromStringName
 
 fromList_RDR, fromListN_RDR, toList_RDR :: RdrName
 fromString_RDR          = nameRdrName fromStringName
 
 fromList_RDR, fromListN_RDR, toList_RDR :: RdrName
@@ -668,11 +670,6 @@ showString_RDR          = varQual_RDR gHC_SHOW (fsLit "showString")
 showSpace_RDR           = varQual_RDR gHC_SHOW (fsLit "showSpace")
 showParen_RDR           = varQual_RDR gHC_SHOW (fsLit "showParen")
 
 showSpace_RDR           = varQual_RDR gHC_SHOW (fsLit "showSpace")
 showParen_RDR           = varQual_RDR gHC_SHOW (fsLit "showParen")
 
-typeRep_RDR, mkTyCon_RDR, mkTyConApp_RDR :: RdrName
-typeRep_RDR       = varQual_RDR tYPEABLE_INTERNAL    (fsLit "typeRep#")
-mkTyCon_RDR       = varQual_RDR tYPEABLE_INTERNAL    (fsLit "mkTyCon")
-mkTyConApp_RDR    = varQual_RDR tYPEABLE_INTERNAL    (fsLit "mkTyConApp")
-
 undefined_RDR :: RdrName
 undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined")
 
 undefined_RDR :: RdrName
 undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined")
 
@@ -782,6 +779,39 @@ and it's convenient to write them all down in one place.
 -- guys as well (perhaps) e.g. see  trueDataConName     below
 -}
 
 -- guys as well (perhaps) e.g. see  trueDataConName     below
 -}
 
+-- | Build a 'Name' for the 'Typeable' representation of the given special 'TyCon'.
+-- Special 'TyCon's include @(->)@, @BOX@, @Constraint@, etc. See 'TysPrim'.
+mkSpecialTyConRepName :: FastString -> Name -> Name
+-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable.
+mkSpecialTyConRepName fs tc_name
+  = mkExternalName (tyConRepNameUnique (nameUnique tc_name))
+                   tYPEABLE_INTERNAL
+                   (mkVarOccFS fs)
+                   wiredInSrcSpan
+
+-- | Make a 'Name' for the 'Typeable' representation of the given wired-in type
+mkPrelTyConRepName :: Name -> Name
+-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable.
+mkPrelTyConRepName tc_name  -- Prelude tc_name is always External,
+                            -- so nameModule will work
+  = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name)
+  where
+    name_occ  = nameOccName tc_name
+    name_mod  = nameModule  tc_name
+    name_uniq = nameUnique  tc_name
+    rep_uniq | isTcOcc name_occ = tyConRepNameUnique   name_uniq
+             | otherwise        = dataConRepNameUnique name_uniq
+    (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ
+
+-- | TODO
+-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable.
+tyConRepModOcc :: Module -> OccName -> (Module, OccName)
+tyConRepModOcc tc_module tc_occ
+  | tc_module == gHC_TYPES
+  = (tYPEABLE_INTERNAL, mkTyConRepUserOcc tc_occ)
+  | otherwise
+  = (tc_module,         mkTyConRepSysOcc tc_occ)
+
 wildCardName :: Name
 wildCardName = mkSystemVarName wildCardKey (fsLit "wild")
 
 wildCardName :: Name
 wildCardName = mkSystemVarName wildCardKey (fsLit "wild")
 
@@ -849,12 +879,11 @@ uWordTyConName     = tcQual gHC_GENERICS (fsLit "UWord") uWordTyConKey
 
 -- Base strings Strings
 unpackCStringName, unpackCStringFoldrName,
 
 -- Base strings Strings
 unpackCStringName, unpackCStringFoldrName,
-    unpackCStringUtf8Name, eqStringName, stringTyConName :: Name
+    unpackCStringUtf8Name, eqStringName :: Name
 unpackCStringName       = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey
 unpackCStringFoldrName  = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey
 unpackCStringUtf8Name   = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey
 eqStringName            = varQual gHC_BASE (fsLit "eqString")  eqStringIdKey
 unpackCStringName       = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey
 unpackCStringFoldrName  = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey
 unpackCStringUtf8Name   = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey
 eqStringName            = varQual gHC_BASE (fsLit "eqString")  eqStringIdKey
-stringTyConName         = tcQual  gHC_BASE (fsLit "String") stringTyConKey
 
 -- The 'inline' function
 inlineIdName :: Name
 
 -- The 'inline' function
 inlineIdName :: Name
@@ -1053,15 +1082,21 @@ ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey
 -- Class Typeable, and functions for constructing `Typeable` dictionaries
 typeableClassName
   , typeRepTyConName
 -- Class Typeable, and functions for constructing `Typeable` dictionaries
 typeableClassName
   , typeRepTyConName
-  , mkTyConName
+  , trTyConDataConName
+  , trModuleDataConName
+  , trNameSDataConName
   , mkPolyTyConAppName
   , mkAppTyName
   , mkPolyTyConAppName
   , mkAppTyName
+  , typeRepIdName
   , typeNatTypeRepName
   , typeSymbolTypeRepName
   :: Name
 typeableClassName     = clsQual tYPEABLE_INTERNAL (fsLit "Typeable")       typeableClassKey
 typeRepTyConName      = tcQual  tYPEABLE_INTERNAL (fsLit "TypeRep")        typeRepTyConKey
   , typeNatTypeRepName
   , typeSymbolTypeRepName
   :: Name
 typeableClassName     = clsQual tYPEABLE_INTERNAL (fsLit "Typeable")       typeableClassKey
 typeRepTyConName      = tcQual  tYPEABLE_INTERNAL (fsLit "TypeRep")        typeRepTyConKey
-mkTyConName           = varQual tYPEABLE_INTERNAL (fsLit "mkTyCon")        mkTyConKey
+trTyConDataConName    = dcQual  gHC_TYPES         (fsLit "TyCon")          trTyConDataConKey
+trModuleDataConName   = dcQual  gHC_TYPES         (fsLit "Module")         trModuleDataConKey
+trNameSDataConName    = dcQual  gHC_TYPES         (fsLit "TrNameS")        trNameSDataConKey
+typeRepIdName         = varQual tYPEABLE_INTERNAL (fsLit "typeRep#")       typeRepIdKey
 mkPolyTyConAppName    = varQual tYPEABLE_INTERNAL (fsLit "mkPolyTyConApp") mkPolyTyConAppKey
 mkAppTyName           = varQual tYPEABLE_INTERNAL (fsLit "mkAppTy")        mkAppTyKey
 typeNatTypeRepName    = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey
 mkPolyTyConAppName    = varQual tYPEABLE_INTERNAL (fsLit "mkPolyTyConApp") mkPolyTyConAppKey
 mkAppTyName           = varQual tYPEABLE_INTERNAL (fsLit "mkAppTy")        mkAppTyKey
 typeNatTypeRepName    = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey
@@ -1342,7 +1377,7 @@ ghciIoClassKey :: Unique
 ghciIoClassKey = mkPreludeClassUnique 44
 
 ---------------- Template Haskell -------------------
 ghciIoClassKey = mkPreludeClassUnique 44
 
 ---------------- Template Haskell -------------------
---      USES ClassUniques 200-299
+--      THNames.hs: USES ClassUniques 200-299
 -----------------------------------------------------
 
 {-
 -----------------------------------------------------
 
 {-
@@ -1489,9 +1524,6 @@ unknown2TyConKey                        = mkPreludeTyConUnique 131
 unknown3TyConKey                        = mkPreludeTyConUnique 132
 opaqueTyConKey                          = mkPreludeTyConUnique 133
 
 unknown3TyConKey                        = mkPreludeTyConUnique 132
 opaqueTyConKey                          = mkPreludeTyConUnique 133
 
-stringTyConKey :: Unique
-stringTyConKey                          = mkPreludeTyConUnique 134
-
 -- Generics (Unique keys)
 v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
   k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,
 -- Generics (Unique keys)
 v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
   k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,
@@ -1589,7 +1621,7 @@ ipCoNameKey = mkPreludeTyConUnique 185
 
 
 ---------------- Template Haskell -------------------
 
 
 ---------------- Template Haskell -------------------
---      USES TyConUniques 200-299
+--      THNames.hs: USES TyConUniques 200-299
 -----------------------------------------------------
 
 ----------------------- SIMD ------------------------
 -----------------------------------------------------
 
 ----------------------- SIMD ------------------------
@@ -1668,6 +1700,16 @@ srcLocDataConKey                        = mkPreludeDataConUnique 37
 ipDataConKey :: Unique
 ipDataConKey                            = mkPreludeDataConUnique 38
 
 ipDataConKey :: Unique
 ipDataConKey                            = mkPreludeDataConUnique 38
 
+trTyConDataConKey, trModuleDataConKey, trNameSDataConKey :: Unique
+trTyConDataConKey                       = mkPreludeDataConUnique 40
+trModuleDataConKey                      = mkPreludeDataConUnique 41
+trNameSDataConKey                       = mkPreludeDataConUnique 42
+
+---------------- Template Haskell -------------------
+--      THNames.hs: USES DataUniques 100-150
+-----------------------------------------------------
+
+
 {-
 ************************************************************************
 *                                                                      *
 {-
 ************************************************************************
 *                                                                      *
@@ -1922,7 +1964,7 @@ proxyHashKey :: Unique
 proxyHashKey = mkPreludeMiscIdUnique 502
 
 ---------------- Template Haskell -------------------
 proxyHashKey = mkPreludeMiscIdUnique 502
 
 ---------------- Template Haskell -------------------
---      USES IdUniques 200-499
+--      THNames.hs: USES IdUniques 200-499
 -----------------------------------------------------
 
 -- Used to make `Typeable` dictionaries
 -----------------------------------------------------
 
 -- Used to make `Typeable` dictionaries
@@ -1931,19 +1973,21 @@ mkTyConKey
   , mkAppTyKey
   , typeNatTypeRepKey
   , typeSymbolTypeRepKey
   , mkAppTyKey
   , typeNatTypeRepKey
   , typeSymbolTypeRepKey
+  , typeRepIdKey
   :: Unique
 mkTyConKey            = mkPreludeMiscIdUnique 503
 mkPolyTyConAppKey     = mkPreludeMiscIdUnique 504
 mkAppTyKey            = mkPreludeMiscIdUnique 505
 typeNatTypeRepKey     = mkPreludeMiscIdUnique 506
 typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 507
   :: Unique
 mkTyConKey            = mkPreludeMiscIdUnique 503
 mkPolyTyConAppKey     = mkPreludeMiscIdUnique 504
 mkAppTyKey            = mkPreludeMiscIdUnique 505
 typeNatTypeRepKey     = mkPreludeMiscIdUnique 506
 typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 507
+typeRepIdKey          = mkPreludeMiscIdUnique 508
 
 -- Dynamic
 toDynIdKey :: Unique
 
 -- Dynamic
 toDynIdKey :: Unique
-toDynIdKey = mkPreludeMiscIdUnique 508
+toDynIdKey            = mkPreludeMiscIdUnique 509
 
 bitIntegerIdKey :: Unique
 
 bitIntegerIdKey :: Unique
-bitIntegerIdKey       = mkPreludeMiscIdUnique 509
+bitIntegerIdKey       = mkPreludeMiscIdUnique 510
 
 {-
 ************************************************************************
 
 {-
 ************************************************************************
index 062f957..571487a 100644 (file)
@@ -448,23 +448,6 @@ unsafeName     = libFun (fsLit "unsafe") unsafeIdKey
 safeName       = libFun (fsLit "safe") safeIdKey
 interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
 
 safeName       = libFun (fsLit "safe") safeIdKey
 interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
 
--- data Inline = ...
-noInlineDataConName, inlineDataConName, inlinableDataConName :: Name
-noInlineDataConName  = thCon (fsLit "NoInline")  noInlineDataConKey
-inlineDataConName    = thCon (fsLit "Inline")    inlineDataConKey
-inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey
-
--- data RuleMatch = ...
-conLikeDataConName, funLikeDataConName :: Name
-conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey
-funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey
-
--- data Phases = ...
-allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name
-allPhasesDataConName   = thCon (fsLit "AllPhases")   allPhasesDataConKey
-fromPhaseDataConName   = thCon (fsLit "FromPhase")   fromPhaseDataConKey
-beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey
-
 -- newtype TExp a = ...
 tExpDataConName :: Name
 tExpDataConName = thCon (fsLit "TExp") tExpDataConKey
 -- newtype TExp a = ...
 tExpDataConName :: Name
 tExpDataConName = thCon (fsLit "TExp") tExpDataConKey
@@ -523,12 +506,42 @@ quotePatName        = qqFun (fsLit "quotePat")  quotePatKey
 quoteDecName        = qqFun (fsLit "quoteDec")  quoteDecKey
 quoteTypeName       = qqFun (fsLit "quoteType") quoteTypeKey
 
 quoteDecName        = qqFun (fsLit "quoteDec")  quoteDecKey
 quoteTypeName       = qqFun (fsLit "quoteType") quoteTypeKey
 
+-- data Inline = ...
+noInlineDataConName, inlineDataConName, inlinableDataConName :: Name
+noInlineDataConName  = thCon (fsLit "NoInline")  noInlineDataConKey
+inlineDataConName    = thCon (fsLit "Inline")    inlineDataConKey
+inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey
+
+-- data RuleMatch = ...
+conLikeDataConName, funLikeDataConName :: Name
+conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey
+funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey
+
+-- data Phases = ...
+allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name
+allPhasesDataConName   = thCon (fsLit "AllPhases")   allPhasesDataConKey
+fromPhaseDataConName   = thCon (fsLit "FromPhase")   fromPhaseDataConKey
+beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey
+
+
+{- *********************************************************************
+*                                                                      *
+                     Class keys
+*                                                                      *
+********************************************************************* -}
+
 -- ClassUniques available: 200-299
 -- Check in PrelNames if you want to change this
 
 liftClassKey :: Unique
 liftClassKey = mkPreludeClassUnique 200
 
 -- ClassUniques available: 200-299
 -- Check in PrelNames if you want to change this
 
 liftClassKey :: Unique
 liftClassKey = mkPreludeClassUnique 200
 
+{- *********************************************************************
+*                                                                      *
+                     TyCon keys
+*                                                                      *
+********************************************************************* -}
+
 -- TyConUniques available: 200-299
 -- Check in PrelNames if you want to change this
 
 -- TyConUniques available: 200-299
 -- Check in PrelNames if you want to change this
 
@@ -574,6 +587,43 @@ tExpTyConKey            = mkPreludeTyConUnique 230
 injAnnTyConKey          = mkPreludeTyConUnique 231
 kindTyConKey            = mkPreludeTyConUnique 232
 
 injAnnTyConKey          = mkPreludeTyConUnique 231
 kindTyConKey            = mkPreludeTyConUnique 232
 
+{- *********************************************************************
+*                                                                      *
+                     DataCon keys
+*                                                                      *
+********************************************************************* -}
+
+-- DataConUniques available: 100-150
+-- If you want to change this, make sure you check in PrelNames
+
+-- data Inline = ...
+noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique
+noInlineDataConKey  = mkPreludeDataConUnique 100
+inlineDataConKey    = mkPreludeDataConUnique 101
+inlinableDataConKey = mkPreludeDataConUnique 102
+
+-- data RuleMatch = ...
+conLikeDataConKey, funLikeDataConKey :: Unique
+conLikeDataConKey = mkPreludeDataConUnique 103
+funLikeDataConKey = mkPreludeDataConUnique 104
+
+-- data Phases = ...
+allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique
+allPhasesDataConKey   = mkPreludeDataConUnique 105
+fromPhaseDataConKey   = mkPreludeDataConUnique 106
+beforePhaseDataConKey = mkPreludeDataConUnique 107
+
+-- newtype TExp a = ...
+tExpDataConKey :: Unique
+tExpDataConKey = mkPreludeDataConUnique 108
+
+
+{- *********************************************************************
+*                                                                      *
+                     Id keys
+*                                                                      *
+********************************************************************* -}
+
 -- IdUniques available: 200-499
 -- If you want to change this, make sure you check in PrelNames
 
 -- IdUniques available: 200-499
 -- If you want to change this, make sure you check in PrelNames
 
@@ -843,27 +893,6 @@ unsafeIdKey        = mkPreludeMiscIdUnique 430
 safeIdKey          = mkPreludeMiscIdUnique 431
 interruptibleIdKey = mkPreludeMiscIdUnique 432
 
 safeIdKey          = mkPreludeMiscIdUnique 431
 interruptibleIdKey = mkPreludeMiscIdUnique 432
 
--- data Inline = ...
-noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique
-noInlineDataConKey  = mkPreludeDataConUnique 40
-inlineDataConKey    = mkPreludeDataConUnique 41
-inlinableDataConKey = mkPreludeDataConUnique 42
-
--- data RuleMatch = ...
-conLikeDataConKey, funLikeDataConKey :: Unique
-conLikeDataConKey = mkPreludeDataConUnique 43
-funLikeDataConKey = mkPreludeDataConUnique 44
-
--- data Phases = ...
-allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique
-allPhasesDataConKey   = mkPreludeDataConUnique 45
-fromPhaseDataConKey   = mkPreludeDataConUnique 46
-beforePhaseDataConKey = mkPreludeDataConUnique 47
-
--- newtype TExp a = ...
-tExpDataConKey :: Unique
-tExpDataConKey = mkPreludeDataConUnique 48
-
 -- data FunDep = ...
 funDepIdKey :: Unique
 funDepIdKey = mkPreludeMiscIdUnique 440
 -- data FunDep = ...
 funDepIdKey :: Unique
 funDepIdKey = mkPreludeMiscIdUnique 440
index d66b48e..3a6dd03 100644 (file)
@@ -10,6 +10,8 @@
 -- | This module defines TyCons that can't be expressed in Haskell.
 --   They are all, therefore, wired-in TyCons.  C.f module TysWiredIn
 module TysPrim(
 -- | This module defines TyCons that can't be expressed in Haskell.
 --   They are all, therefore, wired-in TyCons.  C.f module TysWiredIn
 module TysPrim(
+        mkPrimTyConName, -- For implicit parameters in TysWiredIn only
+
         mkTemplateTyVars,
         alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
         alphaTy, betaTy, gammaTy, deltaTy,
         mkTemplateTyVars,
         alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
         alphaTy, betaTy, gammaTy, deltaTy,
@@ -81,12 +83,11 @@ module TysPrim(
 #include "HsVersions.h"
 
 import Var              ( TyVar, KindVar, mkTyVar )
 #include "HsVersions.h"
 
 import Var              ( TyVar, KindVar, mkTyVar )
-import Name             ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName )
-import OccName          ( mkTyVarOccFS, mkTcOccFS )
+import Name
 import TyCon
 import TypeRep
 import SrcLoc
 import TyCon
 import TypeRep
 import SrcLoc
-import Unique           ( mkAlphaTyVarUnique )
+import Unique
 import PrelNames
 import FastString
 
 import PrelNames
 import FastString
 
@@ -258,8 +259,9 @@ funTyConName :: Name
 funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
 
 funTyCon :: TyCon
 funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
 
 funTyCon :: TyCon
-funTyCon = mkFunTyCon funTyConName $
-           mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
+funTyCon = mkFunTyCon funTyConName kind tc_rep_nm
+  where
+    kind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
         -- You might think that (->) should have type (?? -> ? -> *), and you'd be right
         -- But if we do that we get kind errors when saying
         --      instance Control.Arrow (->)
         -- You might think that (->) should have type (?? -> ? -> *), and you'd be right
         -- But if we do that we get kind errors when saying
         --      instance Control.Arrow (->)
@@ -269,6 +271,8 @@ funTyCon = mkFunTyCon funTyConName $
         -- a prefix way, thus:  (->) Int# Int#.  And this is unusual.
         -- because they are never in scope in the source
 
         -- a prefix way, thus:  (->) Int# Int#.  And this is unusual.
         -- because they are never in scope in the source
 
+    tc_rep_nm = mkSpecialTyConRepName (fsLit "tcFun") funTyConName
+
 -- One step to remove subkinding.
 -- (->) :: * -> * -> *
 -- but we should have (and want) the following typing rule for fully applied arrows
 -- One step to remove subkinding.
 -- (->) :: * -> * -> *
 -- but we should have (and want) the following typing rule for fully applied arrows
@@ -318,14 +322,21 @@ superKindTyConName, anyKindTyConName, liftedTypeKindTyConName,
       constraintKindTyConName
    :: Name
 
       constraintKindTyConName
    :: Name
 
-superKindTyCon        = mkKindTyCon superKindTyConName        superKind
-   -- See Note [SuperKind (BOX)]
+mk_kind_tycon :: Name        -- ^ Name of the kind constructor, e.g. @*@
+              -> FastString  -- ^ Name of the 'TyConRepName' function,
+                             -- e.g. @tcLiftedKind :: TyCon@
+              -> TyCon       -- ^ The kind constructor
+mk_kind_tycon tc_name rep_fs
+  = mkKindTyCon tc_name superKind (mkSpecialTyConRepName rep_fs tc_name)
+
+superKindTyCon = mk_kind_tycon superKindTyConName (fsLit "tcBOX")
+    -- See Note [SuperKind (BOX)]
 
 
-anyKindTyCon          = mkKindTyCon anyKindTyConName          superKind
-liftedTypeKindTyCon   = mkKindTyCon liftedTypeKindTyConName   superKind
-openTypeKindTyCon     = mkKindTyCon openTypeKindTyConName     superKind
-unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName superKind
-constraintKindTyCon   = mkKindTyCon constraintKindTyConName   superKind
+anyKindTyCon          = mk_kind_tycon anyKindTyConName          (fsLit "tcAnyK")
+constraintKindTyCon   = mk_kind_tycon constraintKindTyConName   (fsLit "tcConstraint")
+liftedTypeKindTyCon   = mk_kind_tycon liftedTypeKindTyConName   (fsLit "tcLiftedKind")
+openTypeKindTyCon     = mk_kind_tycon openTypeKindTyConName     (fsLit "tcOpenKind")
+unliftedTypeKindTyCon = mk_kind_tycon unliftedTypeKindTyConName (fsLit "tcUnliftedKind")
 
 --------------------------
 -- ... and now their names
 
 --------------------------
 -- ... and now their names
@@ -736,6 +747,7 @@ variables with no constraints on them. It appears in similar circumstances to
 Any, but at the kind level. For example:
 
   type family Length (l :: [k]) :: Nat
 Any, but at the kind level. For example:
 
   type family Length (l :: [k]) :: Nat
+  type instance Length [] = Zero
 
   f :: Proxy (Length []) -> Int
   f = ....
 
   f :: Proxy (Length []) -> Int
   f = ....
@@ -776,7 +788,7 @@ anyTy = mkTyConTy anyTyCon
 anyTyCon :: TyCon
 anyTyCon = mkFamilyTyCon anyTyConName kind [kKiVar] Nothing
                          (ClosedSynFamilyTyCon Nothing)
 anyTyCon :: TyCon
 anyTyCon = mkFamilyTyCon anyTyConName kind [kKiVar] Nothing
                          (ClosedSynFamilyTyCon Nothing)
-                         NoParentTyCon
+                         Nothing
                          NotInjective
   where
     kind = ForAllTy kKiVar (mkTyVarTy kKiVar)
                          NotInjective
   where
     kind = ForAllTy kKiVar (mkTyVarTy kKiVar)
index e8a06e7..067700f 100644 (file)
@@ -99,6 +99,7 @@ import TysPrim
 -- others:
 import CoAxiom
 import Coercion
 -- others:
 import CoAxiom
 import Coercion
+import Id
 import Constants        ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE )
 import Module           ( Module )
 import Type             ( mkTyConApp )
 import Constants        ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE )
 import Module           ( Module )
 import Type             ( mkTyConApp )
@@ -289,7 +290,7 @@ pcTyCon is_enum is_rec is_prom name cType tyvars cons
         is_rec
         is_prom
         False           -- Not in GADT syntax
         is_rec
         is_prom
         False           -- Not in GADT syntax
-        NoParentTyCon
+        (VanillaAlgTyCon (mkPrelTyConRepName name))
 
 pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
 pcDataCon = pcDataConWithFixity False
 
 pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
 pcDataCon = pcDataConWithFixity False
@@ -310,7 +311,7 @@ pcDataConWithFixity' :: Bool -> Name -> Unique -> [TyVar] -> [Type] -> TyCon ->
 pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
   = data_con
   where
 pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
   = data_con
   where
-    data_con = mkDataCon dc_name declared_infix
+    data_con = mkDataCon dc_name declared_infix prom_info
                 (map (const no_bang) arg_tys)
                 []      -- No labelled fields
                 tyvars
                 (map (const no_bang) arg_tys)
                 []      -- No labelled fields
                 tyvars
@@ -327,10 +328,16 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
 
     modu     = ASSERT( isExternalName dc_name )
                nameModule dc_name
 
     modu     = ASSERT( isExternalName dc_name )
                nameModule dc_name
-    wrk_occ  = mkDataConWorkerOcc (nameOccName dc_name)
+    dc_occ   = nameOccName dc_name
+    wrk_occ  = mkDataConWorkerOcc dc_occ
     wrk_name = mkWiredInName modu wrk_occ wrk_key
                              (AnId (dataConWorkId data_con)) UserSyntax
 
     wrk_name = mkWiredInName modu wrk_occ wrk_key
                              (AnId (dataConWorkId data_con)) UserSyntax
 
+    prom_info | Promoted {} <- promotableTyCon_maybe tycon  -- Knot-tied
+              = Promoted (mkPrelTyConRepName dc_name)
+              | otherwise
+              = NotPromoted
+
 {-
 ************************************************************************
 *                                                                      *
 {-
 ************************************************************************
 *                                                                      *
@@ -498,15 +505,19 @@ mk_tuple boxity arity = (tycon, tuple_con)
   where
         tycon   = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con
                                tup_sort
   where
         tycon   = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con
                                tup_sort
-                               prom_tc NoParentTyCon
+                               prom_tc flavour
+
+        flavour = case boxity of
+                    Boxed   -> VanillaAlgTyCon (mkPrelTyConRepName tc_name)
+                    Unboxed -> UnboxedAlgTyCon
 
         tup_sort = case boxity of
                       Boxed   -> BoxedTuple
                       Unboxed -> UnboxedTuple
 
         prom_tc = case boxity of
 
         tup_sort = case boxity of
                       Boxed   -> BoxedTuple
                       Unboxed -> UnboxedTuple
 
         prom_tc = case boxity of
-                    Boxed   -> Just (mkPromotedTyCon tycon (promoteKind tc_kind))
-                    Unboxed -> Nothing
+                    Boxed   -> Promoted (mkPromotedTyCon tycon (promoteKind tc_kind))
+                    Unboxed -> NotPromoted
 
         modu = case boxity of
                     Boxed -> gHC_TUPLE
 
         modu = case boxity of
                     Boxed -> gHC_TUPLE
@@ -732,8 +743,11 @@ mkListTy :: Type -> Type
 mkListTy ty = mkTyConApp listTyCon [ty]
 
 listTyCon :: TyCon
 mkListTy ty = mkTyConApp listTyCon [ty]
 
 listTyCon :: TyCon
-listTyCon = pcTyCon False Recursive True
-                    listTyConName Nothing alpha_tyvar [nilDataCon, consDataCon]
+listTyCon = buildAlgTyCon listTyConName alpha_tyvar [Representational]
+                          Nothing []
+                          (DataTyCon [nilDataCon, consDataCon] False )
+                          Recursive True False
+                          (VanillaAlgTyCon (mkSpecialTyConRepName (fsLit "tcList") listTyConName))
 
 mkPromotedListTy :: Type -> Type
 mkPromotedListTy ty = mkTyConApp promotedListTyCon [ty]
 
 mkPromotedListTy :: Type -> Type
 mkPromotedListTy ty = mkTyConApp promotedListTyCon [ty]
@@ -930,10 +944,10 @@ eqTyCon = mkAlgTyCon eqTyConName
             Nothing
             []      -- No stupid theta
             (DataTyCon [eqBoxDataCon] False)
             Nothing
             []      -- No stupid theta
             (DataTyCon [eqBoxDataCon] False)
-            NoParentTyCon
+            (VanillaAlgTyCon (mkSpecialTyConRepName (fsLit "tcEq") eqTyConName))
             NonRecursive
             False
             NonRecursive
             False
-            Nothing   -- No parent for constraint-kinded types
+            NotPromoted
   where
     kv = kKiVar
     k = mkTyVarTy kv
   where
     kv = kKiVar
     k = mkTyVarTy kv
@@ -949,15 +963,17 @@ eqBoxDataCon = pcDataCon eqBoxDataConName args [TyConApp eqPrimTyCon (map mkTyVa
 
 
 coercibleTyCon :: TyCon
 
 
 coercibleTyCon :: TyCon
-coercibleTyCon = mkClassTyCon
-    coercibleTyConName kind tvs [Nominal, Representational, Representational]
-    rhs coercibleClass NonRecursive
-  where kind = (ForAllTy kv $ mkArrowKinds [k, k] constraintKind)
-        kv = kKiVar
-        k = mkTyVarTy kv
-        [a,b] = mkTemplateTyVars [k,k]
-        tvs = [kv, a, b]
-        rhs = DataTyCon [coercibleDataCon] False
+coercibleTyCon = mkClassTyCon coercibleTyConName kind tvs
+                              [Nominal, Representational, Representational]
+                              rhs coercibleClass NonRecursive
+                              (mkPrelTyConRepName coercibleTyConName)
+  where
+     kind = (ForAllTy kv $ mkArrowKinds [k, k] constraintKind)
+     kv = kKiVar
+     k = mkTyVarTy kv
+     [a,b] = mkTemplateTyVars [k,k]
+     tvs = [kv, a, b]
+     rhs = DataTyCon [coercibleDataCon] False
 
 coercibleDataCon :: DataCon
 coercibleDataCon = pcDataCon coercibleDataConName args [TyConApp eqReprPrimTyCon (map mkTyVarTy args)] coercibleTyCon
 
 coercibleDataCon :: DataCon
 coercibleDataCon = pcDataCon coercibleDataConName args [TyConApp eqReprPrimTyCon (map mkTyVarTy args)] coercibleTyCon
@@ -994,6 +1010,7 @@ ipCoName      = mkWiredInCoAxiomName BuiltInSyntax gHC_CLASSES (fsLit "NTCo:IP")
 -- See Note [The Implicit Parameter class]
 ipTyCon :: TyCon
 ipTyCon = mkClassTyCon ipTyConName kind [ip,a] [] rhs ipClass NonRecursive
 -- See Note [The Implicit Parameter class]
 ipTyCon :: TyCon
 ipTyCon = mkClassTyCon ipTyConName kind [ip,a] [] rhs ipClass NonRecursive
+                       (mkPrelTyConRepName ipTyConName)
   where
     kind = mkArrowKinds [typeSymbolKind, liftedTypeKind] constraintKind
     [ip,a] = mkTemplateTyVars [typeSymbolKind, liftedTypeKind]
   where
     kind = mkArrowKinds [typeSymbolKind, liftedTypeKind] constraintKind
     [ip,a] = mkTemplateTyVars [typeSymbolKind, liftedTypeKind]
index 5390c48..412125a 100644 (file)
@@ -25,7 +25,7 @@ import CoreUtils        ( exprIsDupable, exprIsExpandable, exprType,
 import CoreFVs          ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars )
 import Id               ( isOneShotBndr, idType )
 import Var
 import CoreFVs          ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars )
 import Id               ( isOneShotBndr, idType )
 import Var
-import Type             ( Type, isUnLiftedType, splitFunTy, applyTy )
+import Type             ( Type, isUnLiftedType, isFunTy, splitFunTy, applyTy )
 import VarSet
 import Util
 import UniqFM
 import VarSet
 import Util
 import UniqFM
@@ -168,7 +168,7 @@ fiExpr dflags to_drop ann_expr@(_,AnnApp {})
       = ((applyTy fun_ty ty, extra_fvs), emptyVarSet)
 
     mk_arg_fvs (fun_ty, extra_fvs) (arg_fvs, ann_arg)
       = ((applyTy fun_ty ty, extra_fvs), emptyVarSet)
 
     mk_arg_fvs (fun_ty, extra_fvs) (arg_fvs, ann_arg)
-      | noFloatIntoRhs ann_arg arg_ty
+      | ASSERT( isFunTy fun_ty ) noFloatIntoRhs ann_arg arg_ty
       = ((res_ty, extra_fvs `unionVarSet` arg_fvs), emptyVarSet)
       | otherwise
       = ((res_ty, extra_fvs), arg_fvs)
       = ((res_ty, extra_fvs `unionVarSet` arg_fvs), emptyVarSet)
       | otherwise
       = ((res_ty, extra_fvs), arg_fvs)
index 2177392..d8c0350 100644 (file)
@@ -8,9 +8,9 @@
 {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
 
 module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
 {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
 
 module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
-                 tcHsBootSigs, tcPolyCheck,
+                 tcValBinds, tcHsBootSigs, tcPolyCheck,
                  tcSpecPrags, tcSpecWrapper,
                  tcSpecPrags, tcSpecWrapper,
-                 tcVectDecls,
+                 tcVectDecls, addTypecheckedBinds,
                  TcSigInfo(..), TcSigFun,
                  TcPragEnv, mkPragEnv,
                  instTcTySig, instTcTySigFromId, findScopedTyVars,
                  TcSigInfo(..), TcSigFun,
                  TcPragEnv, mkPragEnv,
                  instTcTySig, instTcTySigFromId, findScopedTyVars,
@@ -66,6 +66,21 @@ import Data.List (partition)
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 
+{- *********************************************************************
+*                                                                      *
+               A useful helper function
+*                                                                      *
+********************************************************************* -}
+
+addTypecheckedBinds :: TcGblEnv -> [LHsBinds Id] -> TcGblEnv
+addTypecheckedBinds tcg_env binds
+  | isHsBoot (tcg_src tcg_env) = tcg_env
+    -- Do not add the code for record-selector bindings
+    -- when compiling hs-boot files
+  | otherwise = tcg_env { tcg_binds = foldr unionBags
+                                            (tcg_binds tcg_env)
+                                            binds }
+
 {-
 ************************************************************************
 *                                                                      *
 {-
 ************************************************************************
 *                                                                      *
@@ -169,10 +184,8 @@ tcTopBinds (ValBindsOut binds sigs)
                ; return (gbl, lcl) }
         ; specs <- tcImpPrags sigs   -- SPECIALISE prags for imported Ids
 
                ; return (gbl, lcl) }
         ; specs <- tcImpPrags sigs   -- SPECIALISE prags for imported Ids
 
-        ; let { tcg_env' = tcg_env { tcg_binds = foldr (unionBags . snd)
-                                                       (tcg_binds tcg_env)
-                                                       binds'
-                                   , tcg_imp_specs = specs ++ tcg_imp_specs tcg_env } }
+        ; let { tcg_env' = tcg_env { tcg_imp_specs = specs ++ tcg_imp_specs tcg_env }
+                           `addTypecheckedBinds` map snd binds' }
 
         ; return (tcg_env', tcl_env) }
         -- The top level bindings are flattened into a giant
 
         ; return (tcg_env', tcl_env) }
         -- The top level bindings are flattened into a giant
@@ -182,15 +195,17 @@ tcTopBinds (ValBindsIn {}) = panic "tcTopBinds"
 
 tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv
 tcRecSelBinds (ValBindsOut binds sigs)
 
 tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv
 tcRecSelBinds (ValBindsOut binds sigs)
-  = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
-    do { (rec_sel_binds, tcg_env) <- discardWarnings (tcValBinds TopLevel binds sigs getGblEnv)
+  = -- tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
+    -- this envt extension happens in tcValBinds
+    do { (rec_sel_binds, tcg_env) <- discardWarnings $
+                                     tcValBinds TopLevel binds sigs getGblEnv
        ; let tcg_env'
               | isHsBoot (tcg_src tcg_env) = tcg_env
               | otherwise = tcg_env { tcg_binds = foldr (unionBags . snd)
                                                         (tcg_binds tcg_env)
                                                         rec_sel_binds }
        ; let tcg_env'
               | isHsBoot (tcg_src tcg_env) = tcg_env
               | otherwise = tcg_env { tcg_binds = foldr (unionBags . snd)
                                                         (tcg_binds tcg_env)
                                                         rec_sel_binds }
-              -- Do not add the code for record-selector bindings when
-              -- compiling hs-boot files
+              -- Do not add the code for record-selector bindings
+              -- when compiling hs-boot files
        ; return tcg_env' }
 tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"
 
        ; return tcg_env' }
 tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"
 
index 5d1c1be..3bb2703 100644 (file)
@@ -631,13 +631,12 @@ tcGetDefaultTys
         -- No use-supplied default
         -- Use [Integer, Double], plus modifications
         { integer_ty <- tcMetaTy integerTyConName
         -- No use-supplied default
         -- Use [Integer, Double], plus modifications
         { integer_ty <- tcMetaTy integerTyConName
-        ; checkWiredInTyCon doubleTyCon
-        ; string_ty <- tcMetaTy stringTyConName
         ; list_ty <- tcMetaTy listTyConName
         ; list_ty <- tcMetaTy listTyConName
+        ; checkWiredInTyCon doubleTyCon
         ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty]
                           -- Note [Extended defaults]
                           ++ [integer_ty, doubleTy]
         ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty]
                           -- Note [Extended defaults]
                           ++ [integer_ty, doubleTy]
-                          ++ opt_deflt ovl_strings [string_ty]
+                          ++ opt_deflt ovl_strings [stringTy]
         ; return (deflt_tys, flags) } } }
   where
     opt_deflt True  xs = xs
         ; return (deflt_tys, flags) } } }
   where
     opt_deflt True  xs = xs
index 83bbcca..1cfa351 100644 (file)
@@ -730,24 +730,27 @@ data EvTerm
   | EvLit EvLit       -- Dictionary for KnownNat and KnownSymbol classes.
                       -- Note [KnownNat & KnownSymbol and EvLit]
 
   | EvLit EvLit       -- Dictionary for KnownNat and KnownSymbol classes.
                       -- Note [KnownNat & KnownSymbol and EvLit]
 
-  | EvCallStack EvCallStack -- Dictionary for CallStack implicit parameters
+  | EvCallStack EvCallStack      -- Dictionary for CallStack implicit parameters
 
 
-  | EvTypeable EvTypeable   -- Dictionary for `Typeable`
+  | EvTypeable Type EvTypeable   -- Dictionary for (Typeable ty)
 
   deriving( Data.Data, Data.Typeable )
 
 
 -- | Instructions on how to make a 'Typeable' dictionary.
 
   deriving( Data.Data, Data.Typeable )
 
 
 -- | Instructions on how to make a 'Typeable' dictionary.
+-- See Note [Typeable evidence terms]
 data EvTypeable
 data EvTypeable
-  = EvTypeableTyCon TyCon [Kind]
-    -- ^ Dictionary for concrete type constructors.
+  = EvTypeableTyCon -- ^ Dictionary for @Typeable (T k1..kn)@
 
 
-  | EvTypeableTyApp (EvTerm,Type) (EvTerm,Type)
-    -- ^ Dictionary for type applications;  this is used when we have
-    -- a type expression starting with a type variable (e.g., @Typeable (f a)@)
+  | EvTypeableTyApp EvTerm EvTerm
+    -- ^ Dictionary for @Typeable (s t)@,
+    -- given a dictionaries for @s@ and @t@
 
 
-  | EvTypeableTyLit (EvTerm,Type)
-    -- ^ Dictionary for a type literal.
+  | EvTypeableTyLit EvTerm
+    -- ^ Dictionary for a type literal,
+    -- e.g. @Typeable "foo"@ or @Typeable 3@
+    -- The 'EvTerm' is evidence of, e.g., @KnownNat 3@
+    -- (see Trac #10348)
 
   deriving ( Data.Data, Data.Typeable )
 
 
   deriving ( Data.Data, Data.Typeable )
 
@@ -769,6 +772,20 @@ data EvCallStack
   deriving( Data.Data, Data.Typeable )
 
 {-
   deriving( Data.Data, Data.Typeable )
 
 {-
+Note [Typeable evidence terms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The EvTypeable data type looks isomorphic to Type, but the EvTerms
+inside can be EvIds.  Eg
+    f :: forall a. Typeable a => a -> TypeRep
+    f x = typeRep (undefined :: Proxy [a])
+Here for the (Typeable [a]) dictionary passed to typeRep we make
+evidence
+    dl :: Typeable [a] = EvTypeable [a]
+                            (EvTypeableTyApp EvTypeableTyCon (EvId d))
+where
+    d :: Typable a
+is the lambda-bound dictionary passed into f.
+
 Note [Coercion evidence terms]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 A "coercion evidence term" takes one of these forms
 Note [Coercion evidence terms]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 A "coercion evidence term" takes one of these forms
@@ -1009,7 +1026,7 @@ evVarsOfTerm (EvCast tm co)       = evVarsOfTerm tm `unionVarSet` coVarsOfTcCo c
 evVarsOfTerm (EvDelayedError _ _) = emptyVarSet
 evVarsOfTerm (EvLit _)            = emptyVarSet
 evVarsOfTerm (EvCallStack cs)     = evVarsOfCallStack cs
 evVarsOfTerm (EvDelayedError _ _) = emptyVarSet
 evVarsOfTerm (EvLit _)            = emptyVarSet
 evVarsOfTerm (EvCallStack cs)     = evVarsOfCallStack cs
-evVarsOfTerm (EvTypeable ev)      = evVarsOfTypeable ev
+evVarsOfTerm (EvTypeable _ ev)    = evVarsOfTypeable ev
 
 evVarsOfTerms :: [EvTerm] -> VarSet
 evVarsOfTerms = mapUnionVarSet evVarsOfTerm
 
 evVarsOfTerms :: [EvTerm] -> VarSet
 evVarsOfTerms = mapUnionVarSet evVarsOfTerm
@@ -1023,9 +1040,9 @@ evVarsOfCallStack cs = case cs of
 evVarsOfTypeable :: EvTypeable -> VarSet
 evVarsOfTypeable ev =
   case ev of
 evVarsOfTypeable :: EvTypeable -> VarSet
 evVarsOfTypeable ev =
   case ev of
-    EvTypeableTyCon _ _    -> emptyVarSet
-    EvTypeableTyApp e1 e2  -> evVarsOfTerms (map fst [e1,e2])
-    EvTypeableTyLit e      -> evVarsOfTerm (fst e)
+    EvTypeableTyCon       -> emptyVarSet
+    EvTypeableTyApp e1 e2 -> evVarsOfTerms [e1,e2]
+    EvTypeableTyLit e     -> evVarsOfTerm e
 
 {-
 ************************************************************************
 
 {-
 ************************************************************************
@@ -1082,16 +1099,16 @@ instance Outputable EvBind where
    -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing
 
 instance Outputable EvTerm where
    -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing
 
 instance Outputable EvTerm where
-  ppr (EvId v)              = ppr v
-  ppr (EvCast v co)         = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co
-  ppr (EvCoercion co)       = ptext (sLit "CO") <+> ppr co
-  ppr (EvSuperClass d n)    = ptext (sLit "sc") <> parens (ppr (d,n))
-  ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
-  ppr (EvLit l)             = ppr l
-  ppr (EvCallStack cs)      = ppr cs
-  ppr (EvDelayedError ty msg) =     ptext (sLit "error")
+  ppr (EvId v)                = ppr v
+  ppr (EvCast v co)           = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co
+  ppr (EvCoercion co)         = ptext (sLit "CO") <+> ppr co
+  ppr (EvSuperClass d n)      = ptext (sLit "sc") <> parens (ppr (d,n))
+  ppr (EvDFunApp df tys ts)   = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
+  ppr (EvLit l)               = ppr l
+  ppr (EvCallStack cs)        = ppr cs
+  ppr (EvDelayedError ty msg) = ptext (sLit "error")
                                 <+> sep [ char '@' <> ppr ty, ppr msg ]
                                 <+> sep [ char '@' <> ppr ty, ppr msg ]
-  ppr (EvTypeable ev)    = ppr ev
+  ppr (EvTypeable ty ev)      = ppr ev <+> dcolon <+> ptext (sLit "Typeable") <+> ppr ty
 
 instance Outputable EvLit where
   ppr (EvNum n) = integer n
 
 instance Outputable EvLit where
   ppr (EvNum n) = integer n
@@ -1106,11 +1123,9 @@ instance Outputable EvCallStack where
     = angleBrackets (ppr (name,loc)) <+> ptext (sLit ":") <+> ppr tm
 
 instance Outputable EvTypeable where
     = angleBrackets (ppr (name,loc)) <+> ptext (sLit ":") <+> ppr tm
 
 instance Outputable EvTypeable where
-  ppr ev =
-    case ev of
-      EvTypeableTyCon tc ks    -> parens (ppr tc <+> sep (map ppr ks))
-      EvTypeableTyApp t1 t2    -> parens (ppr (fst t1) <+> ppr (fst t2))
-      EvTypeableTyLit x        -> ppr (fst x)
+  ppr EvTypeableTyCon         = ptext (sLit "TC")
+  ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2)
+  ppr (EvTypeableTyLit t1)    = ptext (sLit "TyLit") <> ppr t1
 
 
 ----------------------------------------------------------------------
 
 
 ----------------------------------------------------------------------
index f69c137..9a1c506 100644 (file)
@@ -73,23 +73,23 @@ gen_Generic_binds gk tc metaTyCons mod = do
 
 genGenericMetaTyCons :: TyCon -> TcM (MetaTyCons, BagDerivStuff)
 genGenericMetaTyCons tc =
 
 genGenericMetaTyCons :: TyCon -> TcM (MetaTyCons, BagDerivStuff)
 genGenericMetaTyCons tc =
-  do  let
-        tc_name   = tyConName tc
-        mod       = nameModule tc_name
-        tc_cons   = tyConDataCons tc
-        tc_arits  = map dataConSourceArity tc_cons
-
-        tc_occ    = nameOccName tc_name
-        d_occ     = mkGenD mod tc_occ
-        c_occ m   = mkGenC mod tc_occ m
-        s_occ m n = mkGenS mod tc_occ m n
-
-        mkTyCon name = ASSERT( isExternalName name )
-                       buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs
-                                          NonRecursive
-                                          False          -- Not promotable
-                                          False          -- Not GADT syntax
-                                          NoParentTyCon
+  do  let tc_name   = tyConName tc
+      ty_rep_name <- newTyConRepName tc_name
+      let mod       = nameModule tc_name
+          tc_cons   = tyConDataCons tc
+          tc_arits  = map dataConSourceArity tc_cons
+
+          tc_occ    = nameOccName tc_name
+          d_occ     = mkGenD mod tc_occ
+          c_occ m   = mkGenC mod tc_occ m
+          s_occ m n = mkGenS mod tc_occ m n
+
+          mkTyCon name = ASSERT( isExternalName name )
+                         buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs
+                                            NonRecursive
+                                            False          -- Not promotable
+                                            False          -- Not GADT syntax
+                                            (VanillaAlgTyCon ty_rep_name)
 
       loc <- getSrcSpanM
       -- we generate new names in current module
 
       loc <- getSrcSpanM
       -- we generate new names in current module
@@ -265,10 +265,9 @@ canDoGenerics tc tc_args
   where
     -- The tc can be a representation tycon. When we want to display it to the
     -- user (in an error message) we should print its parent
   where
     -- The tc can be a representation tycon. When we want to display it to the
     -- user (in an error message) we should print its parent
-    (tc_name, tc_tys) = case tyConParent tc of
-        FamInstTyCon _ ptc tys -> (ppr ptc, hsep (map ppr
-                                            (tys ++ drop (length tys) tc_args)))
-        _                      -> (ppr tc, hsep (map ppr (tyConTyVars tc)))
+    (tc_name, tc_tys) = case tyConFamInst_maybe tc of
+        Just (ptc, tys) -> (ppr ptc, hsep (map ppr (tys ++ drop (length tys) tc_args)))
+        _               -> (ppr tc, hsep (map ppr (tyConTyVars tc)))
 
         -- Check (d) from Note [Requirements for deriving Generic and Rep].
         --
 
         -- Check (d) from Note [Requirements for deriving Generic and Rep].
         --
index 5aa797c..ddf9c4f 100644 (file)
@@ -1282,19 +1282,10 @@ zonkEvTerm env (EvCast tm co)     = do { tm' <- zonkEvTerm env tm
                                        ; return (mkEvCast tm' co') }
 zonkEvTerm _   (EvLit l)          = return (EvLit l)
 
                                        ; return (mkEvCast tm' co') }
 zonkEvTerm _   (EvLit l)          = return (EvLit l)
 
-zonkEvTerm env (EvTypeable ev) =
-  fmap EvTypeable $
-  case ev of
-    EvTypeableTyCon tc ks    -> return (EvTypeableTyCon tc ks)
-    EvTypeableTyApp t1 t2    -> do e1 <- zonk t1
-                                   e2 <- zonk t2
-                                   return (EvTypeableTyApp e1 e2)
-    EvTypeableTyLit t        -> EvTypeableTyLit `fmap` zonk t
-  where
-  zonk (ev,t) = do ev' <- zonkEvTerm env ev
-                   t'  <- zonkTcTypeToType env t
-                   return (ev',t')
-
+zonkEvTerm env (EvTypeable ty ev) =
+  do { ev' <- zonkEvTypeable env ev
+     ; ty' <- zonkTcTypeToType env ty
+     ; return (EvTypeable ty' ev') }
 zonkEvTerm env (EvCallStack cs)
   = case cs of
       EvCsEmpty -> return (EvCallStack cs)
 zonkEvTerm env (EvCallStack cs)
   = case cs of
       EvCsEmpty -> return (EvCallStack cs)
@@ -1312,6 +1303,16 @@ zonkEvTerm env (EvDelayedError ty msg)
   = do { ty' <- zonkTcTypeToType env ty
        ; return (EvDelayedError ty' msg) }
 
   = do { ty' <- zonkTcTypeToType env ty
        ; return (EvDelayedError ty' msg) }
 
+zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
+zonkEvTypeable _ EvTypeableTyCon
+  = return EvTypeableTyCon
+zonkEvTypeable env (EvTypeableTyApp t1 t2)
+  = do { t1' <- zonkEvTerm env t1
+       ; t2' <- zonkEvTerm env t2
+       ; return (EvTypeableTyApp t1' t2') }
+zonkEvTypeable _ (EvTypeableTyLit t1)
+  = return (EvTypeableTyLit t1)
+
 zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
 zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs
                             ; return (env, [EvBinds (unionManyBags bs')]) }
 zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
 zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs
                             ; return (env, [EvBinds (unionManyBags bs')]) }
index 2f42791..191756a 100644 (file)
@@ -659,7 +659,7 @@ tcTyVar name         -- Could be a tyvar, a tycon, or a datacon
            AGlobal (ATyCon tc) -> inst_tycon (mkTyConApp tc) (tyConKind tc)
 
            AGlobal (AConLike (RealDataCon dc))
            AGlobal (ATyCon tc) -> inst_tycon (mkTyConApp tc) (tyConKind tc)
 
            AGlobal (AConLike (RealDataCon dc))
-             | Just tc <- promoteDataCon_maybe dc
+             | Promoted tc <- promoteDataCon_maybe dc
              -> do { data_kinds <- xoptM Opt_DataKinds
                    ; unless data_kinds $ promotionErr name NoDataKinds
                    ; inst_tycon (mkTyConApp tc) (tyConKind tc) }
              -> do { data_kinds <- xoptM Opt_DataKinds
                    ; unless data_kinds $ promotionErr name NoDataKinds
                    ; inst_tycon (mkTyConApp tc) (tyConKind tc) }
@@ -1619,10 +1619,10 @@ tc_kind_var_app name arg_kis
              -> do { data_kinds <- xoptM Opt_DataKinds
                    ; unless data_kinds $ addErr (dataKindsErr name)
                    ; case promotableTyCon_maybe tc of
              -> do { data_kinds <- xoptM Opt_DataKinds
                    ; unless data_kinds $ addErr (dataKindsErr name)
                    ; case promotableTyCon_maybe tc of
-                       Just prom_tc | arg_kis `lengthIs` tyConArity prom_tc
+                       Promoted prom_tc | arg_kis `lengthIs` tyConArity prom_tc
                                -> return (mkTyConApp prom_tc arg_kis)
                                -> return (mkTyConApp prom_tc arg_kis)
-                       Just _  -> tycon_err tc "is not fully applied"
-                       Nothing -> tycon_err tc "is not promotable" }
+                       Promoted _  -> tycon_err tc "is not fully applied"
+                       NotPromoted -> tycon_err tc "is not promotable" }
 
            -- A lexically scoped kind variable
            ATyVar _ kind_var
 
            -- A lexically scoped kind variable
            ATyVar _ kind_var
index c97e4e1..ef0c4b6 100644 (file)
@@ -434,7 +434,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                          ptext (sLit "Replace the following instance:"))
                      2 (pprInstanceHdr (iSpec i))
 
                          ptext (sLit "Replace the following instance:"))
                      2 (pprInstanceHdr (iSpec i))
 
-    -- Report an error or a warning for a `Typeable` instances.
+    -- Report an error or a warning for a Typeable instances.
     -- If we are working on an .hs-boot file, we just report a warning,
     -- and ignore the instance.  We do this, to give users a chance to fix
     -- their code.
     -- If we are working on an .hs-boot file, we just report a warning,
     -- and ignore the instance.  We do this, to give users a chance to fix
     -- their code.
@@ -445,10 +445,13 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
              then
                do warn <- woptM Opt_WarnDerivingTypeable
                   when warn $ addWarnTc $ vcat
              then
                do warn <- woptM Opt_WarnDerivingTypeable
                   when warn $ addWarnTc $ vcat
-                    [ ptext (sLit "`Typeable` instances in .hs-boot files are ignored.")
-                    , ptext (sLit "This warning will become an error in future versions of the compiler.")
+                    [ ppTypeable <+> ptext (sLit "instances in .hs-boot files are ignored")
+                    , ptext (sLit "This warning will become an error in future versions of the compiler")
                     ]
                     ]
-             else addErrTc $ ptext (sLit "Class `Typeable` does not support user-specified instances.")
+             else addErrTc $ ptext (sLit "Class") <+> ppTypeable
+                             <+> ptext (sLit "does not support user-specified instances")
+    ppTypeable :: SDoc
+    ppTypeable = quotes (ppr typeableClassName)
 
 addClsInsts :: [InstInfo Name] -> TcM a -> TcM a
 addClsInsts infos thing_inside
 
 addClsInsts :: [InstInfo Name] -> TcM a -> TcM a
 addClsInsts infos thing_inside
@@ -633,7 +636,7 @@ tcDataFamInstDecl mb_clsinfo
 
          -- Check that the family declaration is for the right kind
        ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
 
          -- Check that the family declaration is for the right kind
        ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
-       ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
+       ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
 
          -- Kind check type patterns
        ; tcFamTyPats (famTyConShape fam_tc) mb_clsinfo pats
 
          -- Kind check type patterns
        ; tcFamTyPats (famTyConShape fam_tc) mb_clsinfo pats
@@ -659,7 +662,9 @@ tcDataFamInstDecl mb_clsinfo
        ; let orig_res_ty = mkTyConApp fam_tc pats'
 
        ; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) ->
        ; let orig_res_ty = mkTyConApp fam_tc pats'
 
        ; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) ->
-           do { data_cons <- tcConDecls new_or_data rec_rep_tc
+           do { data_cons <- tcConDecls new_or_data
+                                        False   -- Not promotable
+                                        rec_rep_tc
                                         (tvs', orig_res_ty) cons
               ; tc_rhs <- case new_or_data of
                      DataType -> return (mkDataTyConRhs data_cons)
                                         (tvs', orig_res_ty) cons
               ; tc_rhs <- case new_or_data of
                      DataType -> return (mkDataTyConRhs data_cons)
@@ -670,7 +675,7 @@ tcDataFamInstDecl mb_clsinfo
                     axiom    = mkSingleCoAxiom Representational
                                                axiom_name eta_tvs fam_tc eta_pats
                                                (mkTyConApp rep_tc (mkTyVarTys eta_tvs))
                     axiom    = mkSingleCoAxiom Representational
                                                axiom_name eta_tvs fam_tc eta_pats
                                                (mkTyConApp rep_tc (mkTyVarTys eta_tvs))
-                    parent   = FamInstTyCon axiom fam_tc pats'
+                    parent   = DataFamInstTyCon axiom fam_tc pats'
                     roles    = map (const Nominal) tvs'
 
                       -- NB: Use the tvs' from the pats. See bullet toward
                     roles    = map (const Nominal) tvs'
 
                       -- NB: Use the tvs' from the pats. See bullet toward
index 49a5d4c..47147d7 100644 (file)
@@ -16,10 +16,11 @@ import VarSet
 import Type
 import Kind ( isKind )
 import InstEnv( DFunInstType, lookupInstEnv, instanceDFunId )
 import Type
 import Kind ( isKind )
 import InstEnv( DFunInstType, lookupInstEnv, instanceDFunId )
-import CoAxiom(sfInteractTop, sfInteractInert)
+import CoAxiom( sfInteractTop, sfInteractInert )
 
 import Var
 import TcType
 
 import Var
 import TcType
+import Name
 import PrelNames ( knownNatClassName, knownSymbolClassName,
                    callStackTyConKey, typeableClassName )
 import TysWiredIn ( ipClass, typeNatKind, typeSymbolKind )
 import PrelNames ( knownNatClassName, knownSymbolClassName,
                    callStackTyConKey, typeableClassName )
 import TysWiredIn ( ipClass, typeNatKind, typeSymbolKind )
@@ -743,11 +744,11 @@ addFunDepWork inerts work_ev cls
                                                             inert_pred inert_loc }
 
 {-
                                                             inert_pred inert_loc }
 
 {-
-*********************************************************************************
-*                                                                               *
+**********************************************************************
+*                                                                    *
                    Implicit parameters
                    Implicit parameters
-*                                                                               *
-*********************************************************************************
+*                                                                    *
+**********************************************************************
 -}
 
 interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct)
 -}
 
 interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct)
@@ -770,6 +771,26 @@ interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls
 
 interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi)
 
 
 interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi)
 
+-- | Is the constraint for an implicit CallStack parameter?
+-- i.e.   (IP "name" CallStack)
+isCallStackIP :: CtLoc -> Class -> [Type] -> Maybe (EvTerm -> EvCallStack)
+isCallStackIP loc cls tys
+  | cls == ipClass
+  , [_ip_name, ty] <- tys
+  , Just (tc, _) <- splitTyConApp_maybe ty
+  , tc `hasKey` callStackTyConKey
+  = occOrigin (ctLocOrigin loc)
+  | otherwise
+  = Nothing
+  where
+    locSpan = ctLocSpan loc
+
+    -- We only want to grab constraints that arose due to the use of an IP or a
+    -- function call. See Note [Overview of implicit CallStacks]
+    occOrigin (OccurrenceOf n) = Just (EvCsPushCall n locSpan)
+    occOrigin (IPOccOrigin n)  = Just (EvCsTop ('?' `consFS` hsIPNameFS n) locSpan)
+    occOrigin _                = Nothing
+
 {-
 Note [Shadowing of Implicit Parameters]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 {-
 Note [Shadowing of Implicit Parameters]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -821,11 +842,11 @@ I can think of two ways to fix this:
      error if we get multiple givens for the same implicit parameter.
 
 
      error if we get multiple givens for the same implicit parameter.
 
 
-*********************************************************************************
-*                                                                               *
+**********************************************************************
+*                                                                    *
                    interactFunEq
                    interactFunEq
-*                                                                               *
-*********************************************************************************
+*                                                                    *
+**********************************************************************
 -}
 
 interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
 -}
 
 interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
@@ -1056,11 +1077,11 @@ The second is the right thing to do.  Hence the isMetaTyVarTy
 test when solving pairwise CFunEqCan.
 
 
 test when solving pairwise CFunEqCan.
 
 
-*********************************************************************************
-*                                                                               *
+**********************************************************************
+*                                                                    *
                    interactTyVarEq
                    interactTyVarEq
-*                                                                               *
-*********************************************************************************
+*                                                                    *
+**********************************************************************
 -}
 
 interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
 -}
 
 interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
@@ -1233,11 +1254,11 @@ emitFunDepDeriveds fd_eqns
          Pair (Type.substTy subst ty1) (Type.substTy subst ty2)
 
 {-
          Pair (Type.substTy subst ty1) (Type.substTy subst ty2)
 
 {-
-*********************************************************************************
-*                                                                               *
+**********************************************************************
+*                                                                    *
                        The top-reaction Stage
                        The top-reaction Stage
-*                                                                               *
-*********************************************************************************
+*                                                                    *
+**********************************************************************
 -}
 
 topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct)
 -}
 
 topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct)
@@ -1716,6 +1737,12 @@ So the inner binding for ?x::Bool *overrides* the outer one.
 Hence a work-item Given overrides an inert-item Given.
 -}
 
 Hence a work-item Given overrides an inert-item Given.
 -}
 
+{- *******************************************************************
+*                                                                    *
+                       Class lookup
+*                                                                    *
+**********************************************************************-}
+
 -- | Indicates if Instance met the Safe Haskell overlapping instances safety
 -- check.
 --
 -- | Indicates if Instance met the Safe Haskell overlapping instances safety
 -- check.
 --
@@ -1733,116 +1760,36 @@ instance Outputable LookupInstResult where
     where ss = text $ if s then "[safe]" else "[unsafe]"
 
 
     where ss = text $ if s then "[safe]" else "[unsafe]"
 
 
-matchClassInst, match_class_inst
-   :: DynFlags -> InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
-
+matchClassInst :: DynFlags -> InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
 matchClassInst dflags inerts clas tys loc
 matchClassInst dflags inerts clas tys loc
- = do { traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr (mkClassPred clas tys) ]
-      ; res <- match_class_inst dflags inerts clas tys loc
-      ; traceTcS "matchClassInst result" $ ppr res
-      ; return res }
-
 -- First check whether there is an in-scope Given that could
 -- match this constraint.  In that case, do not use top-level
 -- instances.  See Note [Instance and Given overlap]
 -- First check whether there is an in-scope Given that could
 -- match this constraint.  In that case, do not use top-level
 -- instances.  See Note [Instance and Given overlap]
-match_class_inst dflags inerts clas tys loc
   | not (xopt Opt_IncoherentInstances dflags)
   , let matchable_givens = matchableGivens loc pred inerts
   , not (isEmptyBag matchable_givens)
   = do { traceTcS "Delaying instance application" $
   | not (xopt Opt_IncoherentInstances dflags)
   , let matchable_givens = matchableGivens loc pred inerts
   , not (isEmptyBag matchable_givens)
   = do { traceTcS "Delaying instance application" $
-           vcat [ text "Work item=" <+> pprType pred
+           vcat [ text "Work item=" <+> pprClassPred clas tys
                 , text "Potential matching givens:" <+> ppr matchable_givens ]
        ; return NoInstance }
   where
      pred = mkClassPred clas tys
 
                 , text "Potential matching givens:" <+> ppr matchable_givens ]
        ; return NoInstance }
   where
      pred = mkClassPred clas tys
 
-match_class_inst _ _ clas [ ty ] _
-  | className clas == knownNatClassName
-  , Just n <- isNumLitTy ty = makeDict (EvNum n)
-
-  | className clas == knownSymbolClassName
-  , Just s <- isStrLitTy ty = makeDict (EvStr s)
+matchClassInst dflags _ clas tys loc
+ = do { traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr (mkClassPred clas tys) ]
+      ; res <- match_class_inst dflags clas tys loc
+      ; traceTcS "matchClassInst result" $ ppr res
+      ; return res }
 
 
+match_class_inst :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
+match_class_inst dflags clas tys loc
+  | cls_name == knownNatClassName    = matchKnownNat       clas tys
+  | cls_name == knownSymbolClassName = matchKnownSymbol    clas tys
+  | isCTupleClass clas               = matchCTuple         clas tys
+  | cls_name == typeableClassName    = matchTypeable       clas tys
+  | otherwise                        = matchInstEnv dflags clas tys loc
   where
   where
-  {- This adds a coercion that will convert the literal into a dictionary
-     of the appropriate type.  See Note [KnownNat & KnownSymbol and EvLit]
-     in TcEvidence.  The coercion happens in 2 steps:
-
-     Integer -> SNat n     -- representation of literal to singleton
-     SNat n  -> KnownNat n -- singleton to dictionary
-
-     The process is mirrored for Symbols:
-     String    -> SSymbol n
-     SSymbol n -> KnownSymbol n
-  -}
-  makeDict evLit
-    | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty]
-          -- co_dict :: KnownNat n ~ SNat n
-    , [ meth ]   <- classMethods clas
-    , Just tcRep <- tyConAppTyCon_maybe -- SNat
-                      $ funResultTy         -- SNat n
-                      $ dropForAlls         -- KnownNat n => SNat n
-                      $ idType meth         -- forall n. KnownNat n => SNat n
-    , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]
-          -- SNat n ~ Integer
-    , let ev_tm = mkEvCast (EvLit evLit) (mkTcSymCo (mkTcTransCo co_dict co_rep))
-    = return $ GenInst [] (\_ -> ev_tm) True
-
-    | otherwise
-    = panicTcS (text "Unexpected evidence for" <+> ppr (className clas)
-                     $$ vcat (map (ppr . idType) (classMethods clas)))
-
-match_class_inst _ _ clas ts _
-  | isCTupleClass clas
-  , let data_con = tyConSingleDataCon (classTyCon clas)
-        tuple_ev = EvDFunApp (dataConWrapId data_con) ts
-  = return (GenInst ts tuple_ev True)
-            -- The dfun is the data constructor!
-
-match_class_inst _ _ clas [k,t] _
-  | className clas == typeableClassName
-  = matchTypeableClass clas k t
-
-match_class_inst dflags _ clas tys loc
-   = do { instEnvs <- getInstEnvs
-        ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy]
-              (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys
-              safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps)
-        ; case (matches, unify, safeHaskFail) of
-
-            -- Nothing matches
-            ([], _, _)
-                -> do { traceTcS "matchClass not matching" $
-                        vcat [ text "dict" <+> ppr pred ]
-                      ; return NoInstance }
-
-            -- A single match (& no safe haskell failure)
-            ([(ispec, inst_tys)], [], False)
-                -> do   { let dfun_id = instanceDFunId ispec
-                        ; traceTcS "matchClass success" $
-                          vcat [text "dict" <+> ppr pred,
-                                text "witness" <+> ppr dfun_id
-                                               <+> ppr (idType dfun_id) ]
-                                  -- Record that this dfun is needed
-                        ; match_one (null unsafeOverlaps) dfun_id inst_tys }
-
-            -- More than one matches (or Safe Haskell fail!). Defer any
-            -- reactions of a multitude until we learn more about the reagent
-            (matches, _, _)
-                -> do   { traceTcS "matchClass multiple matches, deferring choice" $
-                          vcat [text "dict" <+> ppr pred,
-                                text "matches" <+> ppr matches]
-                        ; return NoInstance } }
-   where
-     pred = mkClassPred clas tys
-
-     match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcS LookupInstResult
-                  -- See Note [DFunInstType: instantiating types] in InstEnv
-     match_one so dfun_id mb_inst_tys
-       = do { checkWellStagedDFun pred dfun_id loc
-            ; (tys, theta) <- instDFunType dfun_id mb_inst_tys
-            ; return $ GenInst theta (EvDFunApp dfun_id tys) so }
-
+    cls_name = className clas
 
 {- Note [Instance and Given overlap]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 {- Note [Instance and Given overlap]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1907,89 +1854,202 @@ Other notes:
   constraint solving.
 -}
 
   constraint solving.
 -}
 
--- | Is the constraint for an implicit CallStack parameter?
--- i.e.   (IP "name" CallStack)
-isCallStackIP :: CtLoc -> Class -> [Type] -> Maybe (EvTerm -> EvCallStack)
-isCallStackIP loc cls tys
-  | cls == ipClass
-  , [_ip_name, ty] <- tys
-  , Just (tc, _) <- splitTyConApp_maybe ty
-  , tc `hasKey` callStackTyConKey
-  = occOrigin (ctLocOrigin loc)
-  | otherwise
-  = Nothing
-  where
-    locSpan = ctLocSpan loc
 
 
-    -- We only want to grab constraints that arose due to the use of an IP or a
-    -- function call. See Note [Overview of implicit CallStacks]
-    occOrigin (OccurrenceOf n) = Just (EvCsPushCall n locSpan)
-    occOrigin (IPOccOrigin n)  = Just (EvCsTop ('?' `consFS` hsIPNameFS n) locSpan)
-    occOrigin _                = Nothing
+{- *******************************************************************
+*                                                                    *
+                Class lookup in the instance environment
+*                                                                    *
+**********************************************************************-}
 
 
--- | Assumes that we've checked that this is the 'Typeable' class,
--- and it was applied to the correct argument.
-matchTypeableClass :: Class -> Kind -> Type -> TcS LookupInstResult
-matchTypeableClass clas k t
+matchInstEnv :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
+matchInstEnv dflags clas tys loc
+   = do { instEnvs <- getInstEnvs
+        ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy]
+              (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys
+              safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps)
+        ; case (matches, unify, safeHaskFail) of
+
+            -- Nothing matches
+            ([], _, _)
+                -> do { traceTcS "matchClass not matching" $
+                        vcat [ text "dict" <+> ppr pred ]
+                      ; return NoInstance }
 
 
-  -- See Note [No Typeable for qualified types]
-  | isForAllTy t                               = return NoInstance
+            -- A single match (& no safe haskell failure)
+            ([(ispec, inst_tys)], [], False)
+                -> do   { let dfun_id = instanceDFunId ispec
+                        ; traceTcS "matchClass success" $
+                          vcat [text "dict" <+> ppr pred,
+                                text "witness" <+> ppr dfun_id
+                                               <+> ppr (idType dfun_id) ]
+                                  -- Record that this dfun is needed
+                        ; match_one (null unsafeOverlaps) dfun_id inst_tys }
 
 
-  -- Is the type of the form `C => t`?
-  | isJust (tcSplitPredFunTy_maybe t)          = return NoInstance
+            -- More than one matches (or Safe Haskell fail!). Defer any
+            -- reactions of a multitude until we learn more about the reagent
+            (matches, _, _)
+                -> do   { traceTcS "matchClass multiple matches, deferring choice" $
+                          vcat [text "dict" <+> ppr pred,
+                                text "matches" <+> ppr matches]
+                        ; return NoInstance } }
+   where
+     pred = mkClassPred clas tys
 
 
-  | eqType k typeNatKind                       = doTyLit knownNatClassName
-  | eqType k typeSymbolKind                    = doTyLit knownSymbolClassName
+     match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcS LookupInstResult
+                  -- See Note [DFunInstType: instantiating types] in InstEnv
+     match_one so dfun_id mb_inst_tys
+       = do { checkWellStagedDFun pred dfun_id loc
+            ; (tys, theta) <- instDFunType dfun_id mb_inst_tys
+            ; return $ GenInst theta (EvDFunApp dfun_id tys) so }
 
 
-  | Just (tc, ks) <- splitTyConApp_maybe t
-  , all isKind ks                              = doTyCon tc ks
 
 
-  | Just (f,kt)       <- splitAppTy_maybe t    = doTyApp f kt
-  | otherwise                                  = return NoInstance
+{- ********************************************************************
+*                                                                     *
+                   Class lookup for CTuples
+*                                                                     *
+***********************************************************************-}
 
 
+matchCTuple :: Class -> [Type] -> TcS LookupInstResult
+matchCTuple clas tys   -- (isCTupleClass clas) holds
+  = return (GenInst tys tuple_ev True)
+            -- The dfun *is* the data constructor!
   where
   where
-  -- Representation for type constructor applied to some kinds
-  doTyCon tc ks =
-    case mapM kindRep ks of
-      Nothing    -> return NoInstance
-      Just kReps ->
-        return $ GenInst [] (\_ -> EvTypeable (EvTypeableTyCon tc kReps) ) True
-
-  {- Representation for an application of a type to a type-or-kind.
-  This may happen when the type expression starts with a type variable.
-  Example (ignoring kind parameter):
-    Typeable (f Int Char)                      -->
-    (Typeable (f Int), Typeable Char)          -->
-    (Typeable f, Typeable Int, Typeable Char)  --> (after some simp. steps)
-    Typeable f
-  -}
-  doTyApp f tk
-    | isKind tk
-    = return NoInstance -- We can't solve until we know the ctr.
+     data_con = tyConSingleDataCon (classTyCon clas)
+     tuple_ev = EvDFunApp (dataConWrapId data_con) tys
+
+{- ********************************************************************
+*                                                                     *
+                   Class lookup for Literals
+*                                                                     *
+***********************************************************************-}
+
+matchKnownNat :: Class -> [Type] -> TcS LookupInstResult
+matchKnownNat clas [ty]     -- clas = KnownNat
+  | Just n <- isNumLitTy ty = makeLitDict clas ty (EvNum n)
+matchKnownNat _ _           = return NoInstance
+
+matchKnownSymbol :: Class -> [Type] -> TcS LookupInstResult
+matchKnownSymbol clas [ty]  -- clas = KnownSymbol
+  | Just n <- isStrLitTy ty = makeLitDict clas ty (EvStr n)
+matchKnownSymbol _ _       = return NoInstance
+
+
+makeLitDict :: Class -> Type -> EvLit -> TcS LookupInstResult
+-- makeLitDict adds a coercion that will convert the literal into a dictionary
+-- of the appropriate type.  See Note [KnownNat & KnownSymbol and EvLit]
+-- in TcEvidence.  The coercion happens in 2 steps:
+--
+--     Integer -> SNat n     -- representation of literal to singleton
+--     SNat n  -> KnownNat n -- singleton to dictionary
+--
+--     The process is mirrored for Symbols:
+--     String    -> SSymbol n
+--     SSymbol n -> KnownSymbol n -}
+makeLitDict clas ty evLit
+    | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty]
+          -- co_dict :: KnownNat n ~ SNat n
+    , [ meth ]   <- classMethods clas
+    , Just tcRep <- tyConAppTyCon_maybe -- SNat
+                      $ funResultTy         -- SNat n
+                      $ dropForAlls         -- KnownNat n => SNat n
+                      $ idType meth         -- forall n. KnownNat n => SNat n
+    , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]
+          -- SNat n ~ Integer
+    , let ev_tm = mkEvCast (EvLit evLit) (mkTcSymCo (mkTcTransCo co_dict co_rep))
+    = return $ GenInst [] (\_ -> ev_tm) True
+
     | otherwise
     | otherwise
-    = return $ GenInst [mk_typeable_pred f, mk_typeable_pred tk]
-                       (\[t1,t2] -> EvTypeable $ EvTypeableTyApp (EvId t1,f) (EvId t2,tk))
-                       True
-
-  -- Representation for concrete kinds.  We just use the kind itself,
-  -- but first check to make sure that it is "simple" (i.e., made entirely
-  -- out of kind constructors).
-  kindRep ki = do (_,ks) <- splitTyConApp_maybe ki
-                  mapM_ kindRep ks
-                  return ki
-
-  -- Emit a `Typeable` constraint for the given type.
-  mk_typeable_pred ty = mkClassPred clas [ typeKind ty, ty ]
-
-  -- Given KnownNat / KnownSymbol, generate appropriate sub-goal
-  -- and make evidence for a type-level literal.
-  doTyLit c = do clas <- tcLookupClass c
-                 let p = mkClassPred clas [ t ]
-                 return $ GenInst [p] (\[i] -> EvTypeable
-                                             $ EvTypeableTyLit (EvId i,t)) True
-
-{- Note [No Typeable for polytype or for constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    = panicTcS (text "Unexpected evidence for" <+> ppr (className clas)
+                     $$ vcat (map (ppr . idType) (classMethods clas)))
+
+
+{- ********************************************************************
+*                                                                     *
+                   Class lookup for Typeable
+*                                                                     *
+***********************************************************************-}
+
+-- | Assumes that we've checked that this is the 'Typeable' class,
+-- and it was applied to the correct argument.
+matchTypeable :: Class -> [Type] -> TcS LookupInstResult
+matchTypeable clas [k,t]  -- clas = Typeable
+  -- For the first two cases, See Note [No Typeable for polytypes or qualified types]
+  | isForAllTy k                      = return NoInstance   -- Polytype
+  | isJust (tcSplitPredFunTy_maybe t) = return NoInstance   -- Qualified type
+
+  -- Now cases that do work
+  | k `eqType` typeNatKind                 = doTyLit knownNatClassName    t
+  | k `eqType` typeSymbolKind              = doTyLit knownSymbolClassName t
+  | Just (_, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)]
+  , all isGroundKind ks                    = doTyConApp t
+  | Just (f,kt)   <- splitAppTy_maybe t    = doTyApp    clas t f kt
+
+matchTypeable _ _ = return NoInstance
+
+doTyConApp :: Type -> TcS LookupInstResult
+-- Representation for type constructor applied to some (ground) kinds
+doTyConApp ty = return $ GenInst [] (\_ -> EvTypeable ty EvTypeableTyCon) True
+
+-- Representation for concrete kinds.  We just use the kind itself,
+-- but first check to make sure that it is "simple" (i.e., made entirely
+-- out of kind constructors).
+isGroundKind :: KindOrType -> Bool
+-- Return True if (a) k is a kind and (b) it is a ground kind
+isGroundKind k
+ = isKind k && is_ground k
+ where
+   is_ground k | Just (_, ks) <- splitTyConApp_maybe k
+               = all is_ground ks
+               | otherwise
+               = False
+
+doTyApp :: Class -> Type -> Type -> KindOrType -> TcS LookupInstResult
+-- Representation for an application of a type to a type-or-kind.
+--  This may happen when the type expression starts with a type variable.
+--  Example (ignoring kind parameter):
+--    Typeable (f Int Char)                      -->
+--    (Typeable (f Int), Typeable Char)          -->
+--    (Typeable f, Typeable Int, Typeable Char)  --> (after some simp. steps)
+--    Typeable f
+doTyApp clas ty f tk
+  | isKind tk
+  = return NoInstance -- We can't solve until we know the ctr.
+  | otherwise
+  = return $ GenInst [mk_typeable_pred clas f, mk_typeable_pred clas tk]
+                     (\[t1,t2] -> EvTypeable ty $ EvTypeableTyApp (EvId t1) (EvId t2))
+                     True
+
+-- Emit a `Typeable` constraint for the given type.
+mk_typeable_pred :: Class -> Type -> PredType
+mk_typeable_pred clas ty = mkClassPred clas [ typeKind ty, ty ]
+
+  -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal
+  -- we generate a sub-goal for the appropriate class. See #10348 for what
+  -- happens when we fail to do this.
+doTyLit :: Name -> Type -> TcS LookupInstResult
+doTyLit kc t = do { kc_clas <- tcLookupClass kc
+                  ; let kc_pred    = mkClassPred kc_clas [ t ]
+                        mk_ev [ev] = EvTypeable t $ EvTypeableTyLit $ EvId ev
+                        mk_ev _    = panic "doTyLit"
+                  ; return (GenInst [kc_pred] mk_ev True) }
+
+{- Note [Typeable (T a b c)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For type applications we always decompose using binary application,
+vai doTyApp, until we get to a *kind* instantiation.  Exmaple
+   Proxy :: forall k. k -> *
+
+To solve Typeable (Proxy (* -> *) Maybe) we
+  - First decompose with doTyApp,
+    to get (Typeable (Proxy (* -> *))) and Typeable Maybe
+  - Then sovle (Typeable (Proxy (* -> *))) with doTyConApp
+
+If we attempt to short-cut by solving it all at once, via
+doTyCOnAPp
+
+
+Note [No Typeable for polytypes or qualified types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We do not support impredicative typeable, such as
    Typeable (forall a. a->a)
    Typeable (Eq a => a -> a)
 We do not support impredicative typeable, such as
    Typeable (forall a. a->a)
    Typeable (Eq a => a -> a)
@@ -2003,9 +2063,9 @@ a TypeRep for them.  For qualified but not polymorphic types, like
  * We don't need a TypeRep for these things.  TypeReps are for
    monotypes only.
 
  * We don't need a TypeRep for these things.  TypeReps are for
    monotypes only.
 
 * Perhaps we could treat `=>` as another type constructor for `Typeable`
-    purposes, and thus support things like `Eq Int => Int`, however,
-    at the current state of affairs this would be an odd exception as
-    no other class works with impredicative types.
-    For now we leave it off, until we have a better story for impredicativity.
+ * Perhaps we could treat `=>` as another type constructor for `Typeable`
+   purposes, and thus support things like `Eq Int => Int`, however,
+   at the current state of affairs this would be an odd exception as
+   no other class works with impredicative types.
+   For now we leave it off, until we have a better story for impredicativity.
 -}
 -}
index f1db883..5c55fce 100644 (file)
@@ -314,7 +314,7 @@ tcPatSynMatcher (L loc name) lpat
 
        ; let matcher_tau   = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
              matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
 
        ; let matcher_tau   = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
              matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
-             matcher_id    = mkExportedLocalId VanillaId matcher_name matcher_sigma
+             matcher_id    = mkExportedLocalId PatSynId matcher_name matcher_sigma
                              -- See Note [Exported LocalIds] in Id
 
              cont_dicts = map nlHsVar prov_dicts
                              -- See Note [Exported LocalIds] in Id
 
              cont_dicts = map nlHsVar prov_dicts
index 45c25e4..4e6b1d3 100644 (file)
@@ -68,6 +68,7 @@ import TcMType
 import MkIface
 import TcSimplify
 import TcTyClsDecls
 import MkIface
 import TcSimplify
 import TcTyClsDecls
+import TcTypeable( mkModIdBindings )
 import LoadIface
 import TidyPgm    ( mkBootModDetailsTc )
 import RnNames
 import LoadIface
 import TidyPgm    ( mkBootModDetailsTc )
 import RnNames
@@ -460,8 +461,14 @@ tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
         -- Returns the variables free in the decls
         -- Reason: solely to report unused imports and bindings
 tcRnSrcDecls explicit_mod_hdr exports decls
         -- Returns the variables free in the decls
         -- Reason: solely to report unused imports and bindings
 tcRnSrcDecls explicit_mod_hdr exports decls
- = do {         -- Do all the declarations
-        ((tcg_env, tcl_env), lie) <- captureConstraints $
+ = do { -- Create a binding for $trModule
+        -- Do this before processing any data type declarations,
+        -- which need tcg_tr_module to be initialised
+      ; tcg_env <- mkModIdBindings
+
+                -- Do all the declarations
+      ; ((tcg_env, tcl_env), lie) <- setGblEnv tcg_env  $
+                                     captureConstraints $
               do { (tcg_env, tcl_env) <- tc_rn_src_decls decls ;
                  ; tcg_env <- setEnvs (tcg_env, tcl_env) $
                               checkMain explicit_mod_hdr
               do { (tcg_env, tcl_env) <- tc_rn_src_decls decls ;
                  ; tcg_env <- setEnvs (tcg_env, tcl_env) $
                               checkMain explicit_mod_hdr
@@ -961,12 +968,13 @@ checkBootTyCon tc1 tc2
   | Just fam_flav1 <- famTyConFlav_maybe tc1
   , Just fam_flav2 <- famTyConFlav_maybe tc2
   = ASSERT(tc1 == tc2)
   | Just fam_flav1 <- famTyConFlav_maybe tc1
   , Just fam_flav2 <- famTyConFlav_maybe tc2
   = ASSERT(tc1 == tc2)
-    let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True
+    let eqFamFlav OpenSynFamilyTyCon   OpenSynFamilyTyCon = True
+        eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True
         eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True
         eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True
         eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)
             = eqClosedFamilyAx ax1 ax2
         eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True
         eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True
         eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)
             = eqClosedFamilyAx ax1 ax2
-        eqFamFlav (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2
+        eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2
         eqFamFlav _ _ = False
         injInfo1 = familyTyConInjectivityInfo tc1
         injInfo2 = familyTyConInjectivityInfo tc2
         eqFamFlav _ _ = False
         injInfo1 = familyTyConInjectivityInfo tc1
         injInfo2 = familyTyConInjectivityInfo tc2
@@ -998,7 +1006,6 @@ checkBootTyCon tc1 tc2
                           (text "The natures of the declarations for" <+>
                            quotes (ppr tc) <+> text "are different")
       | otherwise = checkSuccess
                           (text "The natures of the declarations for" <+>
                            quotes (ppr tc) <+> text "are different")
       | otherwise = checkSuccess
-    eqAlgRhs _  DataFamilyTyCon{} DataFamilyTyCon{} = checkSuccess
     eqAlgRhs _  tc1@DataTyCon{} tc2@DataTyCon{} =
         checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors")
     eqAlgRhs _  tc1@NewTyCon{} tc2@NewTyCon{} =
     eqAlgRhs _  tc1@DataTyCon{} tc2@DataTyCon{} =
         checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors")
     eqAlgRhs _  tc1@NewTyCon{} tc2@NewTyCon{} =
@@ -2063,7 +2070,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
                         tcg_rules     = rules,
                         tcg_vects     = vects,
                         tcg_imports   = imports })
                         tcg_rules     = rules,
                         tcg_vects     = vects,
                         tcg_imports   = imports })
-  = vcat [ ppr_types insts type_env
+  = vcat [ ppr_types type_env
          , ppr_tycons fam_insts type_env
          , ppr_insts insts
          , ppr_fam_insts fam_insts
          , ppr_tycons fam_insts type_env
          , ppr_insts insts
          , ppr_fam_insts fam_insts
@@ -2080,20 +2087,19 @@ pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
                   `thenCmp`
           (is_boot1 `compare` is_boot2)
 
                   `thenCmp`
           (is_boot1 `compare` is_boot2)
 
-ppr_types :: [ClsInst] -> TypeEnv -> SDoc
-ppr_types insts type_env
+ppr_types :: TypeEnv -> SDoc
+ppr_types type_env
   = text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids)
   where
   = text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids)
   where
-    dfun_ids = map instanceDFunId insts
     ids = [id | id <- typeEnvIds type_env, want_sig id]
     ids = [id | id <- typeEnvIds type_env, want_sig id]
-    want_sig id | opt_PprStyle_Debug = True
-                | otherwise          = isLocalId id &&
-                                       isExternalName (idName id) &&
-                                       not (id `elem` dfun_ids)
-        -- isLocalId ignores data constructors, records selectors etc.
-        -- The isExternalName ignores local dictionary and method bindings
-        -- that the type checker has invented.  Top-level user-defined things
-        -- have External names.
+    want_sig id | opt_PprStyle_Debug
+                = True
+                | otherwise
+                = isExternalName (idName id) &&
+                  (case idDetails id of { VanillaId -> True; _ -> False })
+        -- Looking for VanillaId ignores data constructors, records selectors etc.
+        -- The isExternalName ignores local evidence bindings that the type checker
+        -- has invented.  Top-level user-defined things have External names.
 
 ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
 ppr_tycons fam_insts type_env
 
 ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
 ppr_tycons fam_insts type_env
index 601b030..1905564 100644 (file)
@@ -144,7 +144,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_rn_imports     = [],
                 tcg_rn_exports     = maybe_rn_syntax [],
                 tcg_rn_decls       = maybe_rn_syntax emptyRnGroup,
                 tcg_rn_imports     = [],
                 tcg_rn_exports     = maybe_rn_syntax [],
                 tcg_rn_decls       = maybe_rn_syntax emptyRnGroup,
-
+                tcg_tr_module      = Nothing,
                 tcg_binds          = emptyLHsBinds,
                 tcg_imp_specs      = [],
                 tcg_sigs           = emptyNameSet,
                 tcg_binds          = emptyLHsBinds,
                 tcg_imp_specs      = [],
                 tcg_sigs           = emptyNameSet,
index c046704..7375a8c 100644 (file)
@@ -477,6 +477,9 @@ data TcGblEnv
         -- Things defined in this module, or (in GHCi)
         -- in the declarations for a single GHCi command.
         -- For the latter, see Note [The interactive package] in HscTypes
         -- Things defined in this module, or (in GHCi)
         -- in the declarations for a single GHCi command.
         -- For the latter, see Note [The interactive package] in HscTypes
+        tcg_tr_module :: Maybe Id,           -- Id for $trModule :: GHC.Types.Module
+                                             -- for which every module has a top-level defn
+                                             -- except in GHCi in which case we have Nothing
         tcg_binds     :: LHsBinds Id,        -- Value bindings in this module
         tcg_sigs      :: NameSet,            -- ...Top-level names that *lack* a signature
         tcg_imp_specs :: [LTcSpecPrag],      -- ...SPECIALISE prags for imported Ids
         tcg_binds     :: LHsBinds Id,        -- Value bindings in this module
         tcg_sigs      :: NameSet,            -- ...Top-level names that *lack* a signature
         tcg_imp_specs :: [LTcSpecPrag],      -- ...SPECIALISE prags for imported Ids
@@ -898,7 +901,7 @@ pprPECategory RecDataConPE = ptext (sLit "Data constructor")
 pprPECategory NoDataKinds  = ptext (sLit "Data constructor")
 
 {- Note [Bindings with closed types]
 pprPECategory NoDataKinds  = ptext (sLit "Data constructor")
 
 {- Note [Bindings with closed types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
 
   f x = let g ys = map not ys
 Consider
 
   f x = let g ys = map not ys
@@ -915,6 +918,8 @@ iff
    a) all its free variables are imported, or are let-bound with closed types
    b) generalisation is not restricted by the monomorphism restriction
 
    a) all its free variables are imported, or are let-bound with closed types
    b) generalisation is not restricted by the monomorphism restriction
 
+Invariant: a closed variable has no free type variables in its type.
+
 Under OutsideIn we are free to generalise a closed let-binding.
 This is an extension compared to the JFP paper on OutsideIn, which
 used "top-level" as a proxy for "closed".  (It's not a good proxy
 Under OutsideIn we are free to generalise a closed let-binding.
 This is an extension compared to the JFP paper on OutsideIn, which
 used "top-level" as a proxy for "closed".  (It's not a good proxy
index 34b2585..78f1d35 100644 (file)
@@ -16,7 +16,7 @@ module TcTyClsDecls (
         kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon,
         tcFamTyPats, tcTyFamInstEqn, famTyConShape,
         tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,
         kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon,
         tcFamTyPats, tcTyFamInstEqn, famTyConShape,
         tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,
-        wrongKindOfFamily, dataConCtxt, badDataConTyCon
+        wrongKindOfFamily, dataConCtxt, badDataConTyCon, mkOneRecordSelector
     ) where
 
 #include "HsVersions.h"
     ) where
 
 #include "HsVersions.h"
@@ -28,7 +28,6 @@ import TcRnMonad
 import TcEnv
 import TcValidity
 import TcHsSyn
 import TcEnv
 import TcValidity
 import TcHsSyn
-import TcBinds( tcRecSelBinds )
 import TcTyDecls
 import TcClassDcl
 import TcHsType
 import TcTyDecls
 import TcClassDcl
 import TcHsType
@@ -44,6 +43,7 @@ import Class
 import CoAxiom
 import TyCon
 import DataCon
 import CoAxiom
 import TyCon
 import DataCon
+import ConLike
 import Id
 import IdInfo
 import Var
 import Id
 import IdInfo
 import Var
@@ -53,6 +53,7 @@ import Module
 import Name
 import NameSet
 import NameEnv
 import Name
 import NameSet
 import NameEnv
+import RdrName
 import RnEnv
 import Outputable
 import Maybes
 import RnEnv
 import Outputable
 import Maybes
@@ -63,8 +64,10 @@ import ListSetOps
 import Digraph
 import DynFlags
 import FastString
 import Digraph
 import DynFlags
 import FastString
+import Unique           ( mkBuiltinUnique )
 import BasicTypes
 
 import BasicTypes
 
+import Bag
 import Control.Monad
 import Data.List
 
 import Control.Monad
 import Data.List
 
@@ -167,16 +170,7 @@ tcTyClGroup tyclds
            -- Step 4: Add the implicit things;
            -- we want them in the environment because
            -- they may be mentioned in interface files
            -- Step 4: Add the implicit things;
            -- we want them in the environment because
            -- they may be mentioned in interface files
-       ; tcExtendGlobalValEnv (mkDefaultMethodIds tyclss) $
-         tcAddImplicits tyclss } }
-
-tcAddImplicits :: [TyThing] -> TcM TcGblEnv
-tcAddImplicits tyclss
- = tcExtendGlobalEnvImplicit implicit_things $
-   tcRecSelBinds rec_sel_binds
- where
-   implicit_things = concatMap implicitTyThings tyclss
-   rec_sel_binds   = mkRecSelBinds tyclss
+       ; tcAddImplicits tyclss } }
 
 zipRecTyClss :: [(Name, Kind)]
              -> [TyThing]           -- Knot-tied
 
 zipRecTyClss :: [(Name, Kind)]
              -> [TyThing]           -- Knot-tied
index 0da0cb1..bba8080 100644 (file)
@@ -14,28 +14,33 @@ files for imported data types.
 module TcTyDecls(
         calcRecFlags, RecTyInfo(..),
         calcSynCycles, calcClassCycles,
 module TcTyDecls(
         calcRecFlags, RecTyInfo(..),
         calcSynCycles, calcClassCycles,
+
+        -- * Roles
         RoleAnnots, extractRoleAnnots, emptyRoleAnnots, lookupRoleAnnots,
         RoleAnnots, extractRoleAnnots, emptyRoleAnnots, lookupRoleAnnots,
-        mkDefaultMethodIds, mkRecSelBinds, mkOneRecordSelector
+
+        -- * Implicits
+        tcAddImplicits
     ) where
 
 #include "HsVersions.h"
 
 import TcRnMonad
 import TcEnv
     ) where
 
 #include "HsVersions.h"
 
 import TcRnMonad
 import TcEnv
+import TcTypeable( mkTypeableBinds )
+import TcBinds( tcValBinds, addTypecheckedBinds )
+import TypeRep( Type(..) )
 import TcType
 import TysWiredIn( unitTy )
 import MkCore( rEC_SEL_ERROR_ID )
 import TcType
 import TysWiredIn( unitTy )
 import MkCore( rEC_SEL_ERROR_ID )
-import TypeRep
 import HsSyn
 import Class
 import Type
 import HsSyn
 import Class
 import Type
+import HscTypes
 import TyCon
 import TyCon
-import ConLike
 import DataCon
 import Name
 import NameEnv
 import RdrName ( mkVarUnqual )
 import DataCon
 import Name
 import NameEnv
 import RdrName ( mkVarUnqual )
-import Var ( tyVarKind )
 import Id
 import IdInfo
 import VarEnv
 import Id
 import IdInfo
 import VarEnv
@@ -379,7 +384,7 @@ calcRecFlags boot_details is_boot mrole_env tyclss
                    -- Recursion of newtypes/data types can happen via
                    -- the class TyCon, so tyclss includes the class tycons
 
                    -- Recursion of newtypes/data types can happen via
                    -- the class TyCon, so tyclss includes the class tycons
 
-    is_promotable = all (isPromotableTyCon rec_tycon_names) all_tycons
+    is_promotable = all (computeTyConPromotability rec_tycon_names) all_tycons
 
     roles = inferRoles is_boot mrole_env all_tycons
 
 
     roles = inferRoles is_boot mrole_env all_tycons
 
@@ -473,70 +478,6 @@ findLoopBreakers deps
 {-
 ************************************************************************
 *                                                                      *
 {-
 ************************************************************************
 *                                                                      *
-                  Promotion calculation
-*                                                                      *
-************************************************************************
-
-See Note [Checking whether a group is promotable]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We only want to promote a TyCon if all its data constructors
-are promotable; it'd be very odd to promote some but not others.
-
-But the data constructors may mention this or other TyCons.
-
-So we treat the recursive uses as all OK (ie promotable) and
-do one pass to check that each TyCon is promotable.
-
-Currently type synonyms are not promotable, though that
-could change.
--}
-
-isPromotableTyCon :: NameSet -> TyCon -> Bool
-isPromotableTyCon rec_tycons tc
-  =  isAlgTyCon tc    -- Only algebraic; not even synonyms
-                      -- (we could reconsider the latter)
-  && ok_kind (tyConKind tc)
-  && case algTyConRhs tc of
-       DataTyCon { data_cons = cs }   -> all ok_con cs
-       NewTyCon { data_con = c }      -> ok_con c
-       AbstractTyCon {}               -> False
-       DataFamilyTyCon {}             -> False
-       TupleTyCon { tup_sort = sort } -> case sort of
-                                           BoxedTuple      -> True
-                                           UnboxedTuple    -> False
-                                           ConstraintTuple -> False
-  where
-    ok_kind kind = all isLiftedTypeKind args && isLiftedTypeKind res
-            where  -- Checks for * -> ... -> * -> *
-              (args, res) = splitKindFunTys kind
-
-    -- See Note [Promoted data constructors] in TyCon
-    ok_con con = all (isLiftedTypeKind . tyVarKind) ex_tvs
-              && null eq_spec   -- No constraints
-              && null theta
-              && all (isPromotableType rec_tycons) orig_arg_tys
-       where
-         (_, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig con
-
-
-isPromotableType :: NameSet -> Type -> Bool
--- Must line up with DataCon.promoteType
--- But the function lives here because we must treat the
--- *recursive* tycons as promotable
-isPromotableType rec_tcs con_arg_ty
-  = go con_arg_ty
-  where
-    go (TyConApp tc tys) =  tys `lengthIs` tyConArity tc
-                         && (tyConName tc `elemNameSet` rec_tcs
-                             || isJust (promotableTyCon_maybe tc))
-                         && all go tys
-    go (FunTy arg res)   = go arg && go res
-    go (TyVarTy {})      = True
-    go _                 = False
-
-{-
-************************************************************************
-*                                                                      *
         Role annotations
 *                                                                      *
 ************************************************************************
         Role annotations
 *                                                                      *
 ************************************************************************
@@ -859,6 +800,27 @@ updateRoleEnv name n role
                               RIS { role_env = role_env', update = True }
                          else state )
 
                               RIS { role_env = role_env', update = True }
                          else state )
 
+
+{- *********************************************************************
+*                                                                      *
+                Building implicits
+*                                                                      *
+********************************************************************* -}
+
+tcAddImplicits :: [TyThing] -> TcM TcGblEnv
+tcAddImplicits tyclss
+  = discardWarnings $
+    tcExtendGlobalEnvImplicit implicit_things  $
+    tcExtendGlobalValEnv def_meth_ids          $
+    do { (rec_sel_ids, rec_sel_binds)   <- mkRecSelBinds tycons
+       ; (typeable_ids, typeable_binds) <- mkTypeableBinds tycons
+       ; gbl_env <- tcExtendGlobalValEnv (rec_sel_ids ++ typeable_ids) getGblEnv
+       ; return (gbl_env `addTypecheckedBinds` (rec_sel_binds ++ typeable_binds)) }
+ where
+   implicit_things = concatMap implicitTyThings tyclss
+   tycons          = [tc | ATyCon tc <- tyclss]
+   def_meth_ids    = mkDefaultMethodIds tyclss
+
 {-
 ************************************************************************
 *                                                                      *
 {-
 ************************************************************************
 *                                                                      *
@@ -893,53 +855,49 @@ must bring the default method Ids into scope first (so they can be seen
 when typechecking the [d| .. |] quote, and typecheck them later.
 -}
 
 when typechecking the [d| .. |] quote, and typecheck them later.
 -}
 
-mkRecSelBinds :: [TyThing] -> HsValBinds Name
--- NB We produce *un-typechecked* bindings, rather like 'deriving'
---    This makes life easier, because the later type checking will add
---    all necessary type abstractions and applications
+mkRecSelBinds :: [TyCon] -> TcM ([Id], [LHsBinds Id])
 mkRecSelBinds tycons
 mkRecSelBinds tycons
-  = ValBindsOut [(NonRecursive, b) | b <- binds] sigs
-  where
-    (sigs, binds) = unzip rec_sels
-    rec_sels = map mkRecSelBind [ (tc,fld)
-                                | ATyCon tc <- tycons
-                                , fld <- tyConFieldLabels tc ]
-
-
-mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
+  = do { -- We generate *un-typechecked* bindings in mkRecSelBind, and
+         -- then typecheck them, rather like 'deriving'. This makes life
+         -- easier, because the later type checking will add all necessary
+         -- type abstractions and applications
+
+         let sel_binds :: [(RecFlag, LHsBinds Name)]
+             sel_sigs  :: [LSig Name]
+             (sel_sigs, sel_binds)
+                = mapAndUnzip mkRecSelBind [ (tc,fld)
+                                           | tc <- tycons
+                                           , fld <- tyConFieldLabels tc ]
+             sel_ids = [sel_id | L _ (IdSig sel_id) <- sel_sigs]
+       ; (sel_binds, _) <- tcValBinds TopLevel sel_binds sel_sigs (return ())
+       ; return (sel_ids, map snd sel_binds) }
+
+mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, (RecFlag, LHsBinds Name))
 mkRecSelBind (tycon, fl)
 mkRecSelBind (tycon, fl)
-  = mkOneRecordSelector all_cons (RecSelData tycon) fl
-  where
-    all_cons     = map RealDataCon (tyConDataCons tycon)
-
-mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel
-              -> (LSig Name, LHsBinds Name)
-mkOneRecordSelector all_cons idDetails fl =
-    (L loc (IdSig sel_id), unitBag (L loc sel_bind))
+  = (L loc (IdSig sel_id), (NonRecursive, unitBag (L loc sel_bind)))
   where
     loc    = getSrcSpan sel_name
   where
     loc    = getSrcSpan sel_name
+    sel_id = mkExportedLocalId rec_details sel_name sel_ty
     lbl      = flLabel fl
     sel_name = flSelector fl
     lbl      = flLabel fl
     sel_name = flSelector fl
-
-    sel_id = mkExportedLocalId rec_details sel_name sel_ty
-    rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty }
+    rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
 
     -- Find a representative constructor, con1
 
     -- Find a representative constructor, con1
-
-    cons_w_field = conLikesWithFields all_cons [lbl]
+    all_cons     = tyConDataCons tycon
+    cons_w_field = tyConDataConsWithFields tycon [lbl]
     con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
     con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
+
     -- Selector type; Note [Polymorphic selectors]
     -- Selector type; Note [Polymorphic selectors]
-    field_ty   = conLikeFieldType con1 lbl
+    field_ty   = dataConFieldType con1 lbl
+    data_ty    = dataConOrigResTy con1
     data_tvs   = tyVarsOfType data_ty
     is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)
     (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
     sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]
            | otherwise  = mkForAllTys (varSetElemsKvsFirst $
                                        data_tvs `extendVarSetList` field_tvs) $
     data_tvs   = tyVarsOfType data_ty
     is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)
     (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
     sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]
            | otherwise  = mkForAllTys (varSetElemsKvsFirst $
                                        data_tvs `extendVarSetList` field_tvs) $
-                          mkPhiTy (conLikeStupidTheta con1) $   -- Urgh!
+                          mkPhiTy (dataConStupidTheta con1) $   -- Urgh!
                           mkPhiTy field_theta               $   -- Urgh!
                           mkPhiTy field_theta               $   -- Urgh!
-                          -- req_theta is empty for normal DataCon
-                          mkPhiTy req_theta                 $
                           mkFunTy data_ty field_tau
 
     -- Make the binding: sel (C2 { fld = x }) = x
                           mkFunTy data_ty field_tau
 
     -- Make the binding: sel (C2 { fld = x }) = x
@@ -976,14 +934,8 @@ mkOneRecordSelector all_cons idDetails fl =
         --              data instance T Int a where
         --                 A :: { fld :: Int } -> T Int Bool
         --                 B :: { fld :: Int } -> T Int Char
         --              data instance T Int a where
         --                 A :: { fld :: Int } -> T Int Bool
         --                 B :: { fld :: Int } -> T Int Char
-    dealt_with :: ConLike -> Bool
-    dealt_with (PatSynCon _) = False -- We can't predict overlap
-    dealt_with con@(RealDataCon dc) =
-      con `elem` cons_w_field || dataConCannotMatch inst_tys dc
-
-    (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1
-
-    inst_tys = substTyVars (mkTopTvSubst eq_spec) univ_tvs
+    dealt_with con = con `elem` cons_w_field || dataConCannotMatch inst_tys con
+    inst_tys = substTyVars (mkTopTvSubst (dataConEqSpec con1)) (dataConUnivTyVars con1)
 
     unit_rhs = mkLHsTupleExpr []
     msg_lit = HsStringPrim "" (fastStringToByteString lbl)
 
     unit_rhs = mkLHsTupleExpr []
     msg_lit = HsStringPrim "" (fastStringToByteString lbl)
index 1f31d56..e64f43a 100644 (file)
@@ -16,7 +16,7 @@ import Type
 import Pair
 import TcType     ( TcType, tcEqType )
 import TyCon      ( TyCon, FamTyConFlav(..), mkFamilyTyCon
 import Pair
 import TcType     ( TcType, tcEqType )
 import TyCon      ( TyCon, FamTyConFlav(..), mkFamilyTyCon
-                  , Injectivity(..), TyConParent(..)  )
+                  , Injectivity(..) )
 import Coercion   ( Role(..) )
 import TcRnTypes  ( Xi )
 import CoAxiom    ( CoAxiomRule(..), BuiltInSynFamily(..) )
 import Coercion   ( Role(..) )
 import TcRnTypes  ( Xi )
 import CoAxiom    ( CoAxiomRule(..), BuiltInSynFamily(..) )
@@ -45,7 +45,7 @@ import qualified Data.Map as Map
 import Data.Maybe ( isJust )
 
 {-------------------------------------------------------------------------------
 import Data.Maybe ( isJust )
 
 {-------------------------------------------------------------------------------
-Built-in type constructors for functions on type-lelve nats
+Built-in type constructors for functions on type-level nats
 -}
 
 typeNatTyCons :: [TyCon]
 -}
 
 typeNatTyCons :: [TyCon]
@@ -110,7 +110,7 @@ typeNatLeqTyCon =
     (mkTemplateTyVars [ typeNatKind, typeNatKind ])
     Nothing
     (BuiltInSynFamTyCon ops)
     (mkTemplateTyVars [ typeNatKind, typeNatKind ])
     Nothing
     (BuiltInSynFamTyCon ops)
-    NoParentTyCon
+    Nothing
     NotInjective
 
   where
     NotInjective
 
   where
@@ -129,7 +129,7 @@ typeNatCmpTyCon =
     (mkTemplateTyVars [ typeNatKind, typeNatKind ])
     Nothing
     (BuiltInSynFamTyCon ops)
     (mkTemplateTyVars [ typeNatKind, typeNatKind ])
     Nothing
     (BuiltInSynFamTyCon ops)
-    NoParentTyCon
+    Nothing
     NotInjective
 
   where
     NotInjective
 
   where
@@ -148,7 +148,7 @@ typeSymbolCmpTyCon =
     (mkTemplateTyVars [ typeSymbolKind, typeSymbolKind ])
     Nothing
     (BuiltInSynFamTyCon ops)
     (mkTemplateTyVars [ typeSymbolKind, typeSymbolKind ])
     Nothing
     (BuiltInSynFamTyCon ops)
-    NoParentTyCon
+    Nothing
     NotInjective
 
   where
     NotInjective
 
   where
@@ -172,7 +172,7 @@ mkTypeNatFunTyCon2 op tcb =
     (mkTemplateTyVars [ typeNatKind, typeNatKind ])
     Nothing
     (BuiltInSynFamTyCon tcb)
     (mkTemplateTyVars [ typeNatKind, typeNatKind ])
     Nothing
     (BuiltInSynFamTyCon tcb)
-    NoParentTyCon
+    Nothing
     NotInjective
 
 
     NotInjective
 
 
diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs
new file mode 100644 (file)
index 0000000..f015eec
--- /dev/null
@@ -0,0 +1,206 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1999
+-}
+
+module TcTypeable(
+    mkTypeableBinds, mkModIdBindings
+  ) where
+
+
+import TcBinds( addTypecheckedBinds )
+import IfaceEnv( newGlobalBinder )
+import TcEnv
+import TcRnMonad
+import PrelNames( gHC_TYPES, trModuleDataConName, trTyConDataConName, trNameSDataConName )
+import Id
+import IdInfo( IdDetails(..) )
+import Type
+import TyCon
+import DataCon
+import Name( getOccName )
+import OccName
+import Module
+import HsSyn
+import DynFlags
+import Bag
+import Fingerprint(Fingerprint(..), fingerprintString)
+import Outputable
+import Data.Word( Word64 )
+import FastString ( FastString, mkFastString )
+
+{- Note [Grand plan for Typeable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The overall plan is this:
+
+1. Generate a binding for each module p:M
+   (done in TcTypeable by mkModIdBindings)
+       M.$trModule :: GHC.Types.Module
+       M.$trModule = Module "p" "M"
+   ("tr" is short for "type representation"; see GHC.Types)
+
+   We might want to add the filename too.
+   This can be used for the lightweight stack-tracing stuff too
+
+   Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv
+
+2. Generate a binding for every data type declaration T in module M,
+       M.$tcT :: GHC.Types.TyCon
+       M.$tcT = TyCon ...fingerprint info...
+                      $trModule
+                      "T"
+   We define (in TyCon)
+      type TyConRepName = Name
+   to use for these M.$tcT "tycon rep names".
+
+3. Record the TyConRepName in T's TyCon, including for promoted
+   data and type constructors, and kinds like * and #.
+
+   The TyConRepNaem is not an "implicit Id".  It's more like a record
+   selector: the TyCon knows its name but you have to go to the
+   interface file to find its type, value, etc
+
+4. Solve Typeable costraints.  This is done by a custom Typeable solver,
+   currently in TcInteract, that use M.$tcT so solve (Typeable T).
+
+There are many wrinkles:
+
+* Since we generate $tcT for every data type T, the types TyCon and
+  Module must be available right from the start; so they are defined
+  in ghc-prim:GHC.Types
+
+* To save space and reduce dependencies, we need use quite low-level
+  representations for TyCon and Module.  See GHC.Types
+  Note [Runtime representation of modules and tycons]
+
+* It's hard to generate the TyCon/Module bindings when the types TyCon
+  and Module aren't yet available; i.e. when compiling GHC.Types
+  itself.  So we *don't* generate them for types in GHC.Types.  Instead
+  we write them by hand in base:GHC.Typeable.Internal.
+
+* To be able to define them by hand, they need to have user-writable
+  names, thus
+        tcBool    not $tcBool    for the type-rep TyCon for Bool
+  Hence PrelNames.tyConRepModOcc
+
+* Moreover for type constructors with special syntax, they need to have
+  completely hand-crafted names
+    lists    tcList         not $tc[]   for the type-rep TyCon for []
+    kinds    tcLiftedKind   not $tc*    for the type-rep TyCon for *
+  Hence PrelNames.mkSpecialTyConRepName, which takes an extra FastString
+  to use for the TyConRepName
+
+* Since listTyCon, boolTyCon etd are wired in, their TyConRepNames must
+  be wired in as well.  For these wired-in TyCons we generate the
+  TyConRepName's unique from that of the TyCon; see
+  Unique.tyConRepNameUnique, dataConRepNameUnique.
+
+-}
+
+{- *********************************************************************
+*                                                                      *
+            Building top-level binding for $trModule
+*                                                                      *
+********************************************************************* -}
+
+mkModIdBindings :: TcM TcGblEnv
+mkModIdBindings
+  = do { mod <- getModule
+       ; if mod == gHC_TYPES
+         then getGblEnv  -- Do not generate bindings for modules in GHC.Types
+         else
+    do { loc <- getSrcSpanM
+       ; tr_mod_dc  <- tcLookupDataCon trModuleDataConName
+       ; tr_name_dc <- tcLookupDataCon trNameSDataConName
+       ; mod_nm     <- newGlobalBinder mod (mkVarOcc "$trModule") loc
+       ; let mod_id   = mkExportedLocalId ReflectionId mod_nm
+                                          (mkTyConApp (dataConTyCon tr_mod_dc) [])
+             mod_bind = mkVarBind mod_id mod_rhs
+             mod_rhs  = nlHsApps (dataConWrapId tr_mod_dc)
+                           [ trNameLit tr_name_dc (unitIdFS (moduleUnitId mod))
+                           , trNameLit tr_name_dc (moduleNameFS (moduleName mod)) ]
+
+       ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
+       ; return (tcg_env { tcg_tr_module = Just mod_id }
+                 `addTypecheckedBinds` [unitBag mod_bind]) } }
+
+
+{- *********************************************************************
+*                                                                      *
+                Building type-representation bindings
+*                                                                      *
+********************************************************************* -}
+
+mkTypeableBinds :: [TyCon] -> TcM ([Id], [LHsBinds Id])
+mkTypeableBinds tycons
+  = do { dflags  <- getDynFlags
+       ; gbl_env <- getGblEnv
+       ; mod <- getModule
+       ; if mod == gHC_TYPES
+         then return ([], [])  -- Do not generate bindings for modules in GHC.Types
+         else
+    do { tr_datacon  <- tcLookupDataCon trTyConDataConName
+       ; trn_datacon <- tcLookupDataCon trNameSDataConName
+       ; let pkg_str  = unitIdString (moduleUnitId mod)
+             mod_str  = moduleNameString (moduleName mod)
+             mod_expr = case tcg_tr_module gbl_env of  -- Should be set by now
+                           Just mod_id -> nlHsVar mod_id
+                           Nothing     -> pprPanic "tcMkTypeableBinds" (ppr tycons)
+             stuff    = (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon)
+             tc_binds = map (mk_typeable_binds stuff) tycons
+             tycon_rep_ids = foldr ((++) . collectHsBindsBinders) [] tc_binds
+       ; return (tycon_rep_ids, tc_binds) } }
+
+trNameLit :: DataCon -> FastString -> LHsExpr Id
+trNameLit tr_name_dc fs
+  = nlHsApps (dataConWrapId tr_name_dc) [nlHsLit (mkHsStringPrimLit fs)]
+
+type TypeableStuff
+  = ( DynFlags
+    , LHsExpr Id  -- Of type GHC.Types.Module
+    , String      -- Package name
+    , String      -- Module name
+    , DataCon     -- Data constructor GHC.Types.TyCon
+    , DataCon )   -- Data constructor GHC.Types.TrNameS
+
+mk_typeable_binds :: TypeableStuff -> TyCon -> LHsBinds Id
+mk_typeable_binds stuff tycon
+  = mkTyConRepBinds stuff tycon
+    `unionBags`
+    unionManyBags (map (mkTypeableDataConBinds stuff) (tyConDataCons tycon))
+
+mkTyConRepBinds :: TypeableStuff -> TyCon -> LHsBinds Id
+mkTyConRepBinds (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon) tycon
+  = case tyConRepName_maybe tycon of
+      Just rep_name -> unitBag (mkVarBind rep_id rep_rhs)
+         where
+           rep_id  = mkExportedLocalId ReflectionId rep_name (mkTyConApp tr_tycon [])
+      _ -> emptyBag
+  where
+    tr_tycon = dataConTyCon tr_datacon
+    rep_rhs = nlHsApps (dataConWrapId tr_datacon)
+                       [ nlHsLit (word64 high), nlHsLit (word64 low)
+                       , mod_expr
+                       , trNameLit trn_datacon (mkFastString tycon_str) ]
+
+    tycon_str = add_tick (occNameString (getOccName tycon))
+    add_tick s | isPromotedDataCon tycon = '\'' : s
+               | isPromotedTyCon   tycon = '\'' : s
+               | otherwise               = s
+
+    hashThis :: String
+    hashThis = unwords [pkg_str, mod_str, tycon_str]
+
+    Fingerprint high low
+       | gopt Opt_SuppressUniques dflags = Fingerprint 0 0
+       | otherwise                       = fingerprintString hashThis
+
+    word64 :: Word64 -> HsLit
+    word64 | wORD_SIZE dflags == 4 = \n -> HsWord64Prim (show n) (toInteger n)
+           | otherwise             = \n -> HsWordPrim   (show n) (toInteger n)
+
+mkTypeableDataConBinds :: TypeableStuff -> DataCon -> LHsBinds Id
+mkTypeableDataConBinds stuff dc
+  = case promoteDataCon_maybe dc of
+      Promoted tc -> mkTyConRepBinds stuff tc
+      NotPromoted -> emptyBag
index 465ccb1..2159845 100644 (file)
@@ -13,8 +13,8 @@ module TyCon(
         TyCon,
 
         AlgTyConRhs(..), visibleDataCons,
         TyCon,
 
         AlgTyConRhs(..), visibleDataCons,
-        TyConParent(..), isNoParent,
-        FamTyConFlav(..), Role(..), Injectivity(..),
+        AlgTyConFlav(..), isNoParent,
+        FamTyConFlav(..), Role(..), Promoted(..), Injectivity(..),
 
         -- ** Field labels
         tyConFieldLabels, tyConFieldLabelEnv,
 
         -- ** Field labels
         tyConFieldLabels, tyConFieldLabelEnv,
@@ -42,7 +42,7 @@ module TyCon(
         mightBeUnsaturatedTyCon,
         isPromotedDataCon, isPromotedTyCon,
         isPromotedDataCon_maybe, isPromotedTyCon_maybe,
         mightBeUnsaturatedTyCon,
         isPromotedDataCon, isPromotedTyCon,
         isPromotedDataCon_maybe, isPromotedTyCon_maybe,
-        promotableTyCon_maybe, promoteTyCon,
+        promotableTyCon_maybe, isPromotableTyCon, promoteTyCon,
 
         isDataTyCon, isProductTyCon, isDataProductTyCon_maybe,
         isEnumerationTyCon,
 
         isDataTyCon, isProductTyCon, isDataProductTyCon_maybe,
         isEnumerationTyCon,
@@ -71,7 +71,6 @@ module TyCon(
         tyConStupidTheta,
         tyConArity,
         tyConRoles,
         tyConStupidTheta,
         tyConArity,
         tyConRoles,
-        tyConParent,
         tyConFlavour,
         tyConTuple_maybe, tyConClass_maybe,
         tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe,
         tyConFlavour,
         tyConTuple_maybe, tyConClass_maybe,
         tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe,
@@ -89,6 +88,9 @@ module TyCon(
         newTyConCo, newTyConCo_maybe,
         pprPromotionQuote,
 
         newTyConCo, newTyConCo_maybe,
         pprPromotionQuote,
 
+        -- * Runtime type representation
+        TyConRepName, tyConRepName_maybe,
+
         -- * Primitive representations of Types
         PrimRep(..), PrimElemRep(..),
         tyConPrimRep, isVoidRep, isGcPtrRep,
         -- * Primitive representations of Types
         PrimRep(..), PrimElemRep(..),
         tyConPrimRep, isVoidRep, isGcPtrRep,
@@ -190,8 +192,8 @@ See also Note [Wrappers for data instance tycons] in MkId.hs
 
   Note that this is a *representational* coercion
   The R:TInt is the "representation TyCons".
 
   Note that this is a *representational* coercion
   The R:TInt is the "representation TyCons".
-  It has an AlgTyConParent of
-        FamInstTyCon T [Int] ax_ti
+  It has an AlgTyConFlav of
+        DataFamInstTyCon T [Int] ax_ti
 
 * The axiom ax_ti may be eta-reduced; see
   Note [Eta reduction for data family axioms] in TcInstDcls
 
 * The axiom ax_ti may be eta-reduced; see
   Note [Eta reduction for data family axioms] in TcInstDcls
@@ -223,9 +225,9 @@ See also Note [Wrappers for data instance tycons] in MkId.hs
   data instance declaration for T (a,b), to get the result type in the
   representation; e.g.  T (a,b) --> R:TPair a b
 
   data instance declaration for T (a,b), to get the result type in the
   representation; e.g.  T (a,b) --> R:TPair a b
 
-  The representation TyCon R:TList, has an AlgTyConParent of
+  The representation TyCon R:TList, has an AlgTyConFlav of
 
 
-        FamInstTyCon T [(a,b)] ax_pr
+        DataFamInstTyCon T [(a,b)] ax_pr
 
 * Notice that T is NOT translated to a FC type function; it just
   becomes a "data type" with no constructors, which can be coerced inot
 
 * Notice that T is NOT translated to a FC type function; it just
   becomes a "data type" with no constructors, which can be coerced inot
@@ -269,7 +271,7 @@ See also Note [Wrappers for data instance tycons] in MkId.hs
 Note [Associated families and their parent class]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 *Associated* families are just like *non-associated* families, except
 Note [Associated families and their parent class]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 *Associated* families are just like *non-associated* families, except
-that they have a TyConParent of AssocFamilyTyCon, which identifies the
+that they have a famTcParent field of (Just cls), which identifies the
 parent class.
 
 However there is an important sharing relationship between
 parent class.
 
 However there is an important sharing relationship between
@@ -375,15 +377,26 @@ data TyCon
         tyConKind   :: Kind,     -- ^ Kind of this TyCon (full kind, not just
                                  -- the return kind)
 
         tyConKind   :: Kind,     -- ^ Kind of this TyCon (full kind, not just
                                  -- the return kind)
 
-        tyConArity  :: Arity     -- ^ Number of arguments this TyCon must
+        tyConArity  :: Arity,    -- ^ Number of arguments this TyCon must
                                  -- receive to be considered saturated
                                  -- (including implicit kind variables)
                                  -- receive to be considered saturated
                                  -- (including implicit kind variables)
+
+        tcRepName :: TyConRepName
     }
 
     }
 
-  -- | Algebraic type constructors, which are defined to be those
-  -- arising @data@ type and @newtype@ declarations.  All these
-  -- constructors are lifted and boxed. See 'AlgTyConRhs' for more
-  -- information.
+  -- | Algebraic data types, from
+  --     - @data@ declararations
+  --     - @newtype@ declarations
+  --     - data instance declarations
+  --     - type instance declarations
+  --     - the TyCon generated by a class declaration
+  --     - boxed tuples
+  --     - unboxed tuples
+  --     - constraint tuples
+  -- All these constructors are lifted and boxed except unboxed tuples
+  -- which should have an 'UnboxedAlgTyCon' parent.
+  -- Data/newtype/type /families/ are handled by 'FamilyTyCon'.
+  -- See 'AlgTyConRhs' for more information.
   | AlgTyCon {
         tyConUnique  :: Unique,  -- ^ A Unique of this TyCon. Invariant:
                                  -- identical to Unique of Name stored in
   | AlgTyCon {
         tyConUnique  :: Unique,  -- ^ A Unique of this TyCon. Invariant:
                                  -- identical to Unique of Name stored in
@@ -440,12 +453,11 @@ data TyCon
         algTcRec    :: RecFlag,     -- ^ Tells us whether the data type is part
                                     -- of a mutually-recursive group or not
 
         algTcRec    :: RecFlag,     -- ^ Tells us whether the data type is part
                                     -- of a mutually-recursive group or not
 
-        algTcParent :: TyConParent, -- ^ Gives the class or family declaration
-                                    -- 'TyCon' for derived 'TyCon's representing
-                                    -- class or family instances, respectively.
-                                    -- See also 'synTcParent'
+        algTcParent :: AlgTyConFlav, -- ^ Gives the class or family declaration
+                                       -- 'TyCon' for derived 'TyCon's representing
+                                       -- class or family instances, respectively.
 
 
-        tcPromoted  :: Maybe TyCon  -- ^ Promoted TyCon, if any
+        tcPromoted  :: Promoted TyCon  -- ^ Promoted TyCon, if any
     }
 
   -- | Represents type synonyms
     }
 
   -- | Represents type synonyms
@@ -475,7 +487,8 @@ data TyCon
                                  -- of the synonym
     }
 
                                  -- of the synonym
     }
 
-  -- | Represents type families
+  -- | Represents families (both type and data)
+  -- Argument roles are all Nominal
   | FamilyTyCon {
         tyConUnique  :: Unique,  -- ^ A Unique of this TyCon. Invariant:
                                  -- identical to Unique of Name stored in
   | FamilyTyCon {
         tyConUnique  :: Unique,  -- ^ A Unique of this TyCon. Invariant:
                                  -- identical to Unique of Name stored in
@@ -496,7 +509,7 @@ data TyCon
                                  -- Precisely, this list scopes over:
                                  --
                                  -- 1. The 'algTcStupidTheta'
                                  -- Precisely, this list scopes over:
                                  --
                                  -- 1. The 'algTcStupidTheta'
-                                 -- 2. The cached types in algTyConRhs.NewTyCon
+                                 -- 2. The cached types in 'algTyConRhs.NewTyCon'
                                  -- 3. The family instance types if present
                                  --
                                  -- Note that it does /not/ scope over the data
                                  -- 3. The family instance types if present
                                  --
                                  -- Note that it does /not/ scope over the data
@@ -511,8 +524,9 @@ data TyCon
                                       -- abstract, built-in. See comments for
                                       -- FamTyConFlav
 
                                       -- abstract, built-in. See comments for
                                       -- FamTyConFlav
 
-        famTcParent  :: TyConParent,  -- ^ TyCon of enclosing class for
-                                      -- associated type families
+        famTcParent  :: Maybe Class,  -- ^ For *associated* type/data families
+                                      -- The class in whose declaration the family is declared
+                                      -- See Note [Associated families and their parent class]
 
         famTcInj     :: Injectivity   -- ^ is this a type family injective in
                                       -- its type variables? Nothing if no
 
         famTcInj     :: Injectivity   -- ^ is this a type family injective in
                                       -- its type variables? Nothing if no
@@ -521,7 +535,7 @@ data TyCon
 
   -- | Primitive types; cannot be defined in Haskell. This includes
   -- the usual suspects (such as @Int#@) as well as foreign-imported
 
   -- | Primitive types; cannot be defined in Haskell. This includes
   -- the usual suspects (such as @Int#@) as well as foreign-imported
-  -- types and kinds
+  -- types and kinds (@*@, @#@, and @?@)
   | PrimTyCon {
         tyConUnique   :: Unique, -- ^ A Unique of this TyCon. Invariant:
                                  -- identical to Unique of Name stored in
   | PrimTyCon {
         tyConUnique   :: Unique, -- ^ A Unique of this TyCon. Invariant:
                                  -- identical to Unique of Name stored in
@@ -545,9 +559,13 @@ data TyCon
                                  -- pointers). This 'PrimRep' holds that
                                  -- information.  Only relevant if tyConKind = *
 
                                  -- pointers). This 'PrimRep' holds that
                                  -- information.  Only relevant if tyConKind = *
 
-        isUnLifted   :: Bool     -- ^ Most primitive tycons are unlifted (may
+        isUnLifted   :: Bool,    -- ^ Most primitive tycons are unlifted (may
                                  -- not contain bottom) but other are lifted,
                                  -- e.g. @RealWorld@
                                  -- not contain bottom) but other are lifted,
                                  -- e.g. @RealWorld@
+                                 -- Only relevant if tyConKind = *
+
+        primRepName :: Maybe TyConRepName   -- Only relevant for kind TyCons
+                                            -- i.e, *, #, ?
     }
 
   -- | Represents promoted data constructor.
     }
 
   -- | Represents promoted data constructor.
@@ -557,7 +575,8 @@ data TyCon
         tyConArity  :: Arity,
         tyConKind   :: Kind,   -- ^ Translated type of the data constructor
         tcRoles     :: [Role], -- ^ Roles: N for kind vars, R for type vars
         tyConArity  :: Arity,
         tyConKind   :: Kind,   -- ^ Translated type of the data constructor
         tcRoles     :: [Role], -- ^ Roles: N for kind vars, R for type vars
-        dataCon     :: DataCon -- ^ Corresponding data constructor
+        dataCon     :: DataCon,-- ^ Corresponding data constructor
+        tcRepName   :: TyConRepName
     }
 
   -- | Represents promoted type constructor.
     }
 
   -- | Represents promoted type constructor.
@@ -566,7 +585,8 @@ data TyCon
         tyConName   :: Name,   -- ^ Same Name as the type constructor
         tyConArity  :: Arity,  -- ^ n if ty_con :: * -> ... -> *  n times
         tyConKind   :: Kind,   -- ^ Always TysPrim.superKind
         tyConName   :: Name,   -- ^ Same Name as the type constructor
         tyConArity  :: Arity,  -- ^ n if ty_con :: * -> ... -> *  n times
         tyConKind   :: Kind,   -- ^ Always TysPrim.superKind
-        ty_con      :: TyCon   -- ^ Corresponding type constructor
+        ty_con      :: TyCon,  -- ^ Corresponding type constructor
+        tcRepName   :: TyConRepName
     }
 
   deriving Typeable
     }
 
   deriving Typeable
@@ -582,20 +602,6 @@ data AlgTyConRhs
       Bool      -- True  <=> It's definitely a distinct data type,
                 --           equal only to itself; ie not a newtype
                 -- False <=> Not sure
       Bool      -- True  <=> It's definitely a distinct data type,
                 --           equal only to itself; ie not a newtype
                 -- False <=> Not sure
-                -- See Note [AbstractTyCon and type equality]
-
-    -- | Represents an open type family without a fixed right hand
-    -- side.  Additional instances can appear at any time.
-    --
-    -- These are introduced by either a top level declaration:
-    --
-    -- > data T a :: *
-    --
-    -- Or an associated data type declaration, within a class declaration:
-    --
-    -- > class C a b where
-    -- >   data T b :: *
-  | DataFamilyTyCon
 
     -- | Information about those 'TyCon's derived from a @data@
     -- declaration. This includes data types with no constructors at
 
     -- | Information about those 'TyCon's derived from a @data@
     -- declaration. This includes data types with no constructors at
@@ -649,18 +655,15 @@ data AlgTyConRhs
                              -- again check Trac #1072.
     }
 
                              -- again check Trac #1072.
     }
 
-{-
-Note [AbstractTyCon and type equality]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-TODO
--}
+-- | Isomorphic to Maybe, but used when the question is
+-- whether or not something is promoted
+data Promoted a = NotPromoted | Promoted a
 
 -- | Extract those 'DataCon's that we are able to learn about.  Note
 -- that visibility in this sense does not correspond to visibility in
 -- the context of any particular user program!
 visibleDataCons :: AlgTyConRhs -> [DataCon]
 visibleDataCons (AbstractTyCon {})            = []
 
 -- | Extract those 'DataCon's that we are able to learn about.  Note
 -- that visibility in this sense does not correspond to visibility in
 -- the context of any particular user program!
 visibleDataCons :: AlgTyConRhs -> [DataCon]
 visibleDataCons (AbstractTyCon {})            = []
-visibleDataCons DataFamilyTyCon {}            = []
 visibleDataCons (DataTyCon{ data_cons = cs }) = cs
 visibleDataCons (NewTyCon{ data_con = c })    = [c]
 visibleDataCons (TupleTyCon{ data_con = c })  = [c]
 visibleDataCons (DataTyCon{ data_cons = cs }) = cs
 visibleDataCons (NewTyCon{ data_con = c })    = [c]
 visibleDataCons (TupleTyCon{ data_con = c })  = [c]
@@ -668,26 +671,35 @@ visibleDataCons (TupleTyCon{ data_con = c })  = [c]
 -- ^ Both type classes as well as family instances imply implicit
 -- type constructors.  These implicit type constructors refer to their parent
 -- structure (ie, the class or family from which they derive) using a type of
 -- ^ Both type classes as well as family instances imply implicit
 -- type constructors.  These implicit type constructors refer to their parent
 -- structure (ie, the class or family from which they derive) using a type of
--- the following form.  We use 'TyConParent' for both algebraic and synonym
--- types, but the variant 'ClassTyCon' will only be used by algebraic 'TyCon's.
-data TyConParent
+-- the following form.
+data AlgTyConFlav
   = -- | An ordinary type constructor has no parent.
   = -- | An ordinary type constructor has no parent.
-    NoParentTyCon
+    VanillaAlgTyCon
+       TyConRepName
+
+    -- | An unboxed type constructor. Note that this carries no TyConRepName
+    -- as it is not representable.
+  | UnboxedAlgTyCon
 
   -- | Type constructors representing a class dictionary.
   -- See Note [ATyCon for classes] in TypeRep
   | ClassTyCon
         Class           -- INVARIANT: the classTyCon of this Class is the
                         -- current tycon
 
   -- | Type constructors representing a class dictionary.
   -- See Note [ATyCon for classes] in TypeRep
   | ClassTyCon
         Class           -- INVARIANT: the classTyCon of this Class is the
                         -- current tycon
-
-  -- | An *associated* type of a class.
-  | AssocFamilyTyCon
-        Class           -- The class in whose declaration the family is declared
-                        -- See Note [Associated families and their parent class]
-
-  -- | Type constructors representing an instance of a *data* family.
-  -- See Note [Data type families] and source comments for more info.
-  | FamInstTyCon          -- See Note [Data type families]
+        TyConRepName
+
+  -- | Type constructors representing an *instance* of a *data* family.
+  -- Parameters:
+  --
+  --  1) The type family in question
+  --
+  --  2) Instance types; free variables are the 'tyConTyVars'
+  --  of the current 'TyCon' (not the family one). INVARIANT:
+  --  the number of types matches the arity of the family 'TyCon'
+  --
+  --  3) A 'CoTyCon' identifying the representation
+  --  type with the type instance family
+  | DataFamInstTyCon          -- See Note [Data type families]
         (CoAxiom Unbranched)  -- The coercion axiom.
                -- A *Representational* coercion,
                -- of kind   T ty1 ty2   ~R   R:T a b c
         (CoAxiom Unbranched)  -- The coercion axiom.
                -- A *Representational* coercion,
                -- of kind   T ty1 ty2   ~R   R:T a b c
@@ -708,27 +720,26 @@ data TyConParent
         -- gives a representation tycon:
         --      data R:TList a = ...
         --      axiom co a :: T [a] ~ R:TList a
         -- gives a representation tycon:
         --      data R:TList a = ...
         --      axiom co a :: T [a] ~ R:TList a
-        -- with R:TList's algTcParent = FamInstTyCon T [a] co
-
-instance Outputable TyConParent where
-    ppr NoParentTyCon           = text "No parent"
-    ppr (ClassTyCon cls)        = text "Class parent" <+> ppr cls
-    ppr (AssocFamilyTyCon cls)  =
-        text "Class parent (assoc. family)" <+> ppr cls
-    ppr (FamInstTyCon _ tc tys) =
+        -- with R:TList's algTcParent = DataFamInstTyCon T [a] co
+
+instance Outputable AlgTyConFlav where
+    ppr (VanillaAlgTyCon {})        = text "Vanilla ADT"
+    ppr (UnboxedAlgTyCon {})        = text "Unboxed ADT"
+    ppr (ClassTyCon cls _)          = text "Class parent" <+> ppr cls
+    ppr (DataFamInstTyCon _ tc tys) =
         text "Family parent (family instance)" <+> ppr tc <+> sep (map ppr tys)
 
         text "Family parent (family instance)" <+> ppr tc <+> sep (map ppr tys)
 
--- | Checks the invariants of a 'TyConParent' given the appropriate type class
+-- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class
 -- name, if any
 -- name, if any
-okParent :: Name -> TyConParent -> Bool
-okParent _       NoParentTyCon               = True
-okParent tc_name (AssocFamilyTyCon cls)      = tc_name `elem` map tyConName (classATs cls)
-okParent tc_name (ClassTyCon cls)            = tc_name == tyConName (classTyCon cls)
-okParent _       (FamInstTyCon _ fam_tc tys) = tyConArity fam_tc == length tys
+okParent :: Name -> AlgTyConFlav -> Bool
+okParent _       (VanillaAlgTyCon {})            = True
+okParent _       (UnboxedAlgTyCon)               = True
+okParent tc_name (ClassTyCon cls _)              = tc_name == tyConName (classTyCon cls)
+okParent _       (DataFamInstTyCon _ fam_tc tys) = tyConArity fam_tc == length tys
 
 
-isNoParent :: TyConParent -> Bool
-isNoParent NoParentTyCon = True
-isNoParent _             = False
+isNoParent :: AlgTyConFlav -> Bool
+isNoParent (VanillaAlgTyCon {}) = True
+isNoParent _                   = False
 
 --------------------
 
 
 --------------------
 
@@ -739,8 +750,22 @@ data Injectivity
 
 -- | Information pertaining to the expansion of a type synonym (@type@)
 data FamTyConFlav
 
 -- | Information pertaining to the expansion of a type synonym (@type@)
 data FamTyConFlav
-  = -- | An open type synonym family  e.g. @type family F x y :: * -> *@
-     OpenSynFamilyTyCon
+  = -- | Represents an open type family without a fixed right hand
+    -- side.  Additional instances can appear at any time.
+    --
+    -- These are introduced by either a top level declaration:
+    --
+    -- > data T a :: *
+    --
+    -- Or an associated data type declaration, within a class declaration:
+    --
+    -- > class C a b where
+    -- >   data T b :: *
+     DataFamilyTyCon
+       TyConRepName
+
+     -- | An open type synonym family  e.g. @type family F x y :: * -> *@
+   | OpenSynFamilyTyCon
 
    -- | A closed type synonym family  e.g.
    -- @type family F x where { F Int = Bool }@
 
    -- | A closed type synonym family  e.g.
    -- @type family F x where { F Int = Bool }@
@@ -878,7 +903,34 @@ so the coercion tycon CoT must have
 
 ************************************************************************
 *                                                                      *
 
 ************************************************************************
 *                                                                      *
-\subsection{PrimRep}
+                 TyConRepName
+*                                                                      *
+********************************************************************* -}
+
+type TyConRepName = Name -- The Name of the top-level declaration
+                         --    $tcMaybe :: Data.Typeable.Internal.TyCon
+                         --    $tcMaybe = TyCon { tyConName = "Maybe", ... }
+
+tyConRepName_maybe :: TyCon -> Maybe TyConRepName
+tyConRepName_maybe (FunTyCon   { tcRepName = rep_nm })
+  = Just rep_nm
+tyConRepName_maybe (PrimTyCon  { primRepName = mb_rep_nm })
+  = mb_rep_nm
+tyConRepName_maybe (AlgTyCon { algTcParent = parent })
+  | VanillaAlgTyCon rep_nm <- parent = Just rep_nm
+  | ClassTyCon _ rep_nm    <- parent = Just rep_nm
+tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm })
+  = Just rep_nm
+tyConRepName_maybe (PromotedDataCon { tcRepName = rep_nm })
+  = Just rep_nm
+tyConRepName_maybe (PromotedTyCon { tcRepName = rep_nm })
+  = Just rep_nm
+tyConRepName_maybe _ = Nothing
+
+
+{- *********************************************************************
+*                                                                      *
+                 PrimRep
 *                                                                      *
 ************************************************************************
 
 *                                                                      *
 ************************************************************************
 
@@ -1062,13 +1114,14 @@ So we compromise, and move their Kind calculation to the call site.
 -- | Given the name of the function type constructor and it's kind, create the
 -- corresponding 'TyCon'. It is reccomended to use 'TypeRep.funTyCon' if you want
 -- this functionality
 -- | Given the name of the function type constructor and it's kind, create the
 -- corresponding 'TyCon'. It is reccomended to use 'TypeRep.funTyCon' if you want
 -- this functionality
-mkFunTyCon :: Name -> Kind -> TyCon
-mkFunTyCon name kind
+mkFunTyCon :: Name -> Kind -> Name -> TyCon
+mkFunTyCon name kind rep_nm
   = FunTyCon {
         tyConUnique = nameUnique name,
         tyConName   = name,
         tyConKind   = kind,
   = FunTyCon {
         tyConUnique = nameUnique name,
         tyConName   = name,
         tyConKind   = kind,
-        tyConArity  = 2
+        tyConArity  = 2,
+        tcRepName   = rep_nm
     }
 
 -- | This is the making of an algebraic 'TyCon'. Notably, you have to
     }
 
 -- | This is the making of an algebraic 'TyCon'. Notably, you have to
@@ -1084,11 +1137,12 @@ mkAlgTyCon :: Name
            -> Maybe CType       -- ^ The C type this type corresponds to
                                 --   when using the CAPI FFI
            -> [PredType]        -- ^ Stupid theta: see 'algTcStupidTheta'
            -> Maybe CType       -- ^ The C type this type corresponds to
                                 --   when using the CAPI FFI
            -> [PredType]        -- ^ Stupid theta: see 'algTcStupidTheta'
-           -> AlgTyConRhs       -- ^ Information about dat aconstructors
-           -> TyConParent
+           -> AlgTyConRhs       -- ^ Information about data constructors
+           -> AlgTyConFlav      -- ^ What flavour is it?
+                                -- (e.g. vanilla, type family)
            -> RecFlag           -- ^ Is the 'TyCon' recursive?
            -> Bool              -- ^ Was the 'TyCon' declared with GADT syntax?
            -> RecFlag           -- ^ Is the 'TyCon' recursive?
            -> Bool              -- ^ Was the 'TyCon' declared with GADT syntax?
-           -> Maybe TyCon       -- ^ Promoted version
+           -> Promoted TyCon    -- ^ Promoted version
            -> TyCon
 mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_tc
   = AlgTyCon {
            -> TyCon
 mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_tc
   = AlgTyCon {
@@ -1110,11 +1164,12 @@ mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_t
 
 -- | Simpler specialization of 'mkAlgTyCon' for classes
 mkClassTyCon :: Name -> Kind -> [TyVar] -> [Role] -> AlgTyConRhs -> Class
 
 -- | Simpler specialization of 'mkAlgTyCon' for classes
 mkClassTyCon :: Name -> Kind -> [TyVar] -> [Role] -> AlgTyConRhs -> Class
-             -> RecFlag -> TyCon
-mkClassTyCon name kind tyvars roles rhs clas is_rec