Re-add FunTy (big patch)
[ghc.git] / compiler / types / TyCon.hs
index 787da10..c7c225d 100644 (file)
@@ -6,7 +6,7 @@
 The @TyCon@ datatype
 -}
 
-{-# LANGUAGE CPP, DeriveDataTypeable #-}
+{-# LANGUAGE CPP #-}
 
 module TyCon(
         -- * Main TyCon data types
@@ -85,6 +85,7 @@ module TyCon(
         algTcFields,
         tyConRuntimeRepInfo,
         tyConBinders, tyConResKind,
+        tcTyConScopedTyVars,
 
         -- ** Manipulating TyCons
         expandSynTyCon_maybe,
@@ -110,7 +111,7 @@ module TyCon(
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, TyBinder, mkForAllTys )
+import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, TyBinder, pprType, mkPiTys )
 import {-# SOURCE #-} TysWiredIn  ( runtimeRepTyCon, constraintKind
                                   , vecCountTyCon, vecElemTyCon, liftedTypeKind )
 import {-# SOURCE #-} DataCon ( DataCon, dataConExTyVars, dataConFieldLabels )
@@ -136,7 +137,6 @@ import UniqSet
 import Module
 
 import qualified Data.Data as Data
-import Data.Typeable (Typeable)
 
 {-
 -----------------------------------------------
@@ -367,6 +367,15 @@ See also:
 ************************************************************************
 -}
 
+{- Note [TyCon binders]
+~~~~~~~~~~~~~~~~~~~~~~~
+
+data TyConBinder = TCB TyVar TcConBinderVis
+
+data TyConBinderVis = NamedTCB VisiblityFlag
+                    | AnonTCB
+-}
+
 -- | TyCons represent type constructors. Type constructors are introduced by
 -- things such as:
 --
@@ -599,12 +608,15 @@ data TyCon
         tyConUnsat  :: Bool,  -- ^ can this tycon be unsaturated?
 
         -- See Note [The binders/kind/arity fields of a TyCon]
+        tyConTyVars  :: [TyVar],    -- ^ The TyCon's parameterised tyvars
         tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind.
         tyConResKind :: Kind,       -- ^ Result kind
         tyConKind    :: Kind,       -- ^ Kind of this TyCon
-        tyConArity   :: Arity       -- ^ Arity
+        tyConArity   :: Arity,      -- ^ Arity
+
+        tcTyConScopedTyVars :: [TyVar] -- ^ Scoped tyvars over the
+                                       -- tycon's body. See Note [TcTyCon]
       }
-  deriving Typeable
 
 
 -- | Represents right-hand-sides of 'TyCon's for algebraic types
@@ -750,8 +762,8 @@ 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)
+    ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)"
+                                      <+> ppr tc <+> sep (map pprType tys)
 
 -- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class
 -- name, if any
@@ -808,7 +820,7 @@ data FamTyConFlav
 All TyCons have this group of fields
   tyConBinders :: [TyBinder]
   tyConResKind :: Kind
-  tyConKind    :: Kind   -- Cached = mkForAllTys tyConBinders tyConResKind
+  tyConKind    :: Kind   -- Cached = mkPiTys tyConBinders tyConResKind
   tyConArity   :: Arity  -- Cached = length tyConBinders
 
 They fit together like so:
@@ -829,8 +841,8 @@ They fit together like so:
   considered saturated.  Here we mean "applied to in the actual Type",
   not surface syntax; i.e. including implicit kind variables.
 
-Note [tyConBinders and tyConTyVars]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [tyConTyVars and tyConBinders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
   type App a (b :: k) = a b
     -- App :: forall {k}; (k->*) -> k -> *
@@ -953,6 +965,45 @@ so the coercion tycon CoT must have
         kind:    T ~ []
  and    arity:   0
 
+Note [TcTyCon]
+~~~~~~~~~~~~~~
+When checking a type/class declaration (in module TcTyClsDecls), we come
+upon knowledge of the eventual tycon in bits and pieces. First, we use
+getInitialKinds to look over the user-provided kind signature of a tycon
+(including, for example, the number of parameters written to the tycon)
+to get an initial shape of the tycon's kind. Then, using these initial
+kinds, we kind-check the body of the tycon (class methods, data constructors,
+etc.), filling in the metavariables in the tycon's initial kind.
+We then generalize to get the tycon's final, fixed kind. Finally, once
+this has happened for all tycons in a mutually recursive group, we
+can desugar the lot.
+
+For convenience, we store partially-known tycons in TcTyCons, which
+might store meta-variables. These TcTyCons are stored in the local
+environment in TcTyClsDecls, until the real full TyCons can be created
+during desugaring. A desugared program should never have a TcTyCon.
+
+A challenging piece in all of this is that we end up taking three separate
+passes over every declaration: one in getInitialKind (this pass look only
+at the head, not the body), one in kcTyClDecls (to kind-check the body),
+and a final one in tcTyClDecls (to desugar). In the latter two passes,
+we need to connect the user-written type variables in an LHsQTyVars
+with the variables in the tycon's inferred kind. Because the tycon might
+not have a CUSK, this matching up is, in general, quite hard to do.
+(Look through the git history between Dec 2015 and Apr 2016 for
+TcHsType.splitTelescopeTvs!) Instead of trying, we just store the list
+of type variables to bring into scope in the later passes when we create
+a TcTyCon in getInitialKinds. Much easier this way! These tyvars are
+brought into scope in kcTyClTyVars and tcTyClTyVars, both in TcHsType.
+
+It is important that the scoped type variables not be zonked, as some
+scoped type variables come into existence as SigTvs. If we zonk, the
+Unique will change and the user-written occurrences won't match up with
+what we expect.
+
+In a TcTyCon, everything is zonked (except the scoped vars) after
+the kind-checking pass.
+
 ************************************************************************
 *                                                                      *
                  TyConRepName
@@ -1153,20 +1204,20 @@ primRepIsFloat  _            = Just False
 
 -- | The labels for the fields of this particular 'TyCon'
 tyConFieldLabels :: TyCon -> [FieldLabel]
-tyConFieldLabels tc = fsEnvElts $ tyConFieldLabelEnv tc
+tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc
 
 -- | The labels for the fields of this particular 'TyCon'
 tyConFieldLabelEnv :: TyCon -> FieldLabelEnv
 tyConFieldLabelEnv tc
   | isAlgTyCon tc = algTcFields tc
-  | otherwise     = emptyFsEnv
+  | otherwise     = emptyDFsEnv
 
 
 -- | Make a map from strings to FieldLabels from all the data
 -- constructors of this algebraic tycon
 fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv
-fieldsOfAlgTcRhs rhs = mkFsEnv [ (flLabel fl, fl)
-                               | fl <- dataConsFields (visibleDataCons rhs) ]
+fieldsOfAlgTcRhs rhs = mkDFsEnv [ (flLabel fl, fl)
+                                | fl <- dataConsFields (visibleDataCons rhs) ]
   where
     -- Duplicates in this list will be removed by 'mkFsEnv'
     dataConsFields dcs = concatMap dataConFieldLabels dcs
@@ -1196,7 +1247,7 @@ mkFunTyCon name binders rep_nm
         tyConName    = name,
         tyConBinders = binders,
         tyConResKind = liftedTypeKind,
-        tyConKind    = mkForAllTys binders liftedTypeKind,
+        tyConKind    = mkPiTys binders liftedTypeKind,
         tyConArity   = 2,
         tcRepName    = rep_nm
     }
@@ -1227,7 +1278,7 @@ mkAlgTyCon name binders res_kind tyvars roles cType stupid rhs parent is_rec gad
         tyConUnique      = nameUnique name,
         tyConBinders     = binders,
         tyConResKind     = res_kind,
-        tyConKind        = mkForAllTys binders res_kind,
+        tyConKind        = mkPiTys binders res_kind,
         tyConArity       = length tyvars,
         tyConTyVars      = tyvars,
         tcRoles          = roles,
@@ -1264,7 +1315,7 @@ mkTupleTyCon name binders res_kind arity tyvars con sort parent
         tyConUnique      = nameUnique name,
         tyConBinders     = binders,
         tyConResKind     = res_kind,
-        tyConKind        = mkForAllTys binders res_kind,
+        tyConKind        = mkPiTys binders res_kind,
         tyConArity       = arity,
         tyConTyVars      = tyvars,
         tcRoles          = replicate arity Representational,
@@ -1272,7 +1323,7 @@ mkTupleTyCon name binders res_kind arity tyvars con sort parent
         algTcStupidTheta = [],
         algTcRhs         = TupleTyCon { data_con = con,
                                         tup_sort = sort },
-        algTcFields      = emptyFsEnv,
+        algTcFields      = emptyDFsEnv,
         algTcParent      = parent,
         algTcRec         = NonRecursive,
         algTcGadtSyntax  = False
@@ -1284,17 +1335,21 @@ mkTupleTyCon name binders res_kind arity tyvars con sort parent
 -- TcErrors sometimes calls typeKind.
 -- See also Note [Kind checking recursive type and class declarations]
 -- in TcTyClsDecls.
-mkTcTyCon :: Name -> [TyBinder] -> Kind  -- ^ /result/ kind only
-          -> Bool  -- ^ Can this be unsaturated?
+mkTcTyCon :: Name -> [TyVar]
+          -> [TyBinder] -> Kind  -- ^ /result/ kind only
+          -> Bool                -- ^ Can this be unsaturated?
+          -> [TyVar]             -- ^ Scoped type variables, see Note [TcTyCon]
           -> TyCon
-mkTcTyCon name binders res_kind unsat
+mkTcTyCon name tvs binders res_kind unsat scoped_tvs
   = TcTyCon { tyConUnique  = getUnique name
             , tyConName    = name
+            , tyConTyVars  = tvs
             , tyConBinders = binders
             , tyConResKind = res_kind
-            , tyConKind    = mkForAllTys binders res_kind
+            , tyConKind    = mkPiTys binders res_kind
             , tyConUnsat   = unsat
-            , tyConArity   = length binders }
+            , tyConArity   = length binders
+            , tcTyConScopedTyVars = scoped_tvs }
 
 -- | Create an unlifted primitive 'TyCon', such as @Int#@
 mkPrimTyCon :: Name -> [TyBinder]
@@ -1317,7 +1372,8 @@ mkLiftedPrimTyCon :: Name -> [TyBinder]
                   -> Kind   -- ^ /result/ kind
                   -> [Role] -> TyCon
 mkLiftedPrimTyCon name binders res_kind roles
-  = mkPrimTyCon' name binders res_kind roles False Nothing
+  = mkPrimTyCon' name binders res_kind roles False (Just rep_nm)
+  where rep_nm = mkPrelTyConRepName name
 
 mkPrimTyCon' :: Name -> [TyBinder]
              -> Kind    -- ^ /result/ kind
@@ -1329,7 +1385,7 @@ mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm
         tyConUnique  = nameUnique name,
         tyConBinders = binders,
         tyConResKind = res_kind,
-        tyConKind    = mkForAllTys binders res_kind,
+        tyConKind    = mkPiTys binders res_kind,
         tyConArity   = length roles,
         tcRoles      = roles,
         isUnlifted   = is_unlifted,
@@ -1345,7 +1401,7 @@ mkSynonymTyCon name binders res_kind tyvars roles rhs
         tyConUnique  = nameUnique name,
         tyConBinders = binders,
         tyConResKind = res_kind,
-        tyConKind    = mkForAllTys binders res_kind,
+        tyConKind    = mkPiTys binders res_kind,
         tyConArity   = length tyvars,
         tyConTyVars  = tyvars,
         tcRoles      = roles,
@@ -1362,7 +1418,7 @@ mkFamilyTyCon name binders res_kind tyvars resVar flav parent inj
       , tyConName    = name
       , tyConBinders = binders
       , tyConResKind = res_kind
-      , tyConKind    = mkForAllTys binders res_kind
+      , tyConKind    = mkPiTys binders res_kind
       , tyConArity   = length tyvars
       , tyConTyVars  = tyvars
       , famTcResVar  = resVar
@@ -1386,7 +1442,7 @@ mkPromotedDataCon con name rep_name binders res_kind roles rep_info
         tcRoles       = roles,
         tyConBinders  = binders,
         tyConResKind  = res_kind,
-        tyConKind     = mkForAllTys binders res_kind,
+        tyConKind     = mkPiTys binders res_kind,
         dataCon       = con,
         tcRepName     = rep_name,
         promDcRepInfo = rep_info
@@ -1407,8 +1463,9 @@ isAbstractTyCon _ = False
 -- Used when recovering from errors
 makeTyConAbstract :: TyCon -> TyCon
 makeTyConAbstract tc
-  = mkTcTyCon (tyConName tc) (tyConBinders tc) (tyConResKind tc)
-              (mightBeUnsaturatedTyCon tc)
+  = mkTcTyCon (tyConName tc) (tyConTyVars tc)
+              (tyConBinders tc) (tyConResKind tc)
+              (mightBeUnsaturatedTyCon tc) [{- no scoped vars -}]
 
 -- | Does this 'TyCon' represent something that cannot be defined in Haskell?
 isPrimTyCon :: TyCon -> Bool
@@ -1461,7 +1518,7 @@ isDataTyCon _ = False
 -- (where X is the role passed in):
 --   If (T a1 b1 c1) ~X (T a2 b2 c2), then (a1 ~X1 a2), (b1 ~X2 b2), and (c1 ~X3 c2)
 -- (where X1, X2, and X3, are the roles given by tyConRolesX tc X)
--- See also Note [Decomposing equalities] in TcCanonical
+-- See also Note [Decomposing equality] in TcCanonical
 isInjectiveTyCon :: TyCon -> Role -> Bool
 isInjectiveTyCon _                             Phantom          = False
 isInjectiveTyCon (FunTyCon {})                 _                = True
@@ -1481,7 +1538,7 @@ isInjectiveTyCon tc@(TcTyCon {})               _
 -- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds
 -- (where X is the role passed in):
 --   If (T tys ~X t), then (t's head ~X T).
--- See also Note [Decomposing equalities] in TcCanonical
+-- See also Note [Decomposing equality] in TcCanonical
 isGenerativeTyCon :: TyCon -> Role -> Bool
 isGenerativeTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True
 isGenerativeTyCon (FamilyTyCon {}) _ = False
@@ -2024,8 +2081,8 @@ tyConRuntimeRepInfo _                                         = NoRRI
 -}
 
 instance Eq TyCon where
-    a == b = case (a `compare` b) of { EQ -> True;   _ -> False }
-    a /= b = case (a `compare` b) of { EQ -> False;  _ -> True  }
+    a == b = getUnique a == getUnique b
+    a /= b = getUnique a /= getUnique b
 
 instance Ord TyCon where
     a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }