Add proper GADTs support to Template Haskell

Until now GADTs were supported in Template Haskell by encoding them using
normal data types.  This patch adds proper support for representing GADTs
in TH.

Test Plan: T10828

Reviewers: goldfire, austin, bgamari

Subscribers: thomie, mpickering

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

GHC Trac Issues: #10828

compiler/hsSyn/Convert.hs

@@ -35,7 +35,7 @@ import Lexeme
 import Util
 import FastString
 import Outputable
---import TcEvidence
+import MonadUtils ( foldrM )
 
 import qualified Data.ByteString as BS
 import Control.Monad( unless, liftM, ap )
@@ -45,7 +45,7 @@ import Control.Applicative (Applicative(..))
 
 import Data.Char ( chr )
 import Data.Word ( Word8 )
-import Data.Maybe( catMaybes, fromMaybe )
+import Data.Maybe( catMaybes, fromMaybe, isNothing )
 import Language.Haskell.TH as TH hiding (sigP)
 import Language.Haskell.TH.Syntax as TH
 
@@ -193,25 +193,38 @@ cvtDec (TySynD tc tvs rhs)
                   , tcdTyVars = tvs', tcdFVs = placeHolderNames
                   , tcdRhs = rhs' } }
 
-cvtDec (DataD ctxt tc tvs constrs derivs)
-  = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
+cvtDec (DataD ctxt tc tvs ksig constrs derivs)
+  = do  { let isGadtCon (GadtC    _ _ _ _) = True
+              isGadtCon (RecGadtC _ _ _ _) = True
+              isGadtCon (ForallC  _ _ c  ) = isGadtCon c
+              isGadtCon _                  = False
+              isGadtDecl  = all isGadtCon constrs
+              isH98Decl   = all (not . isGadtCon) constrs
+        ; unless (isGadtDecl || isH98Decl)
+                 (failWith (text "Cannot mix GADT constructors with Haskell 98"
+                        <+> text "constructors"))
+        ; unless (isNothing ksig || isGadtDecl)
+                 (failWith (text "Kind signatures are only allowed on GADTs"))
+        ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
+        ; ksig' <- cvtKind `traverse` ksig
         ; cons' <- mapM cvtConstr constrs
         ; derivs' <- cvtDerivs derivs
         ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
                                 , dd_ctxt = ctxt'
-                                , dd_kindSig = Nothing
+                                , dd_kindSig = ksig'
                                 , dd_cons = cons', dd_derivs = derivs' }
         ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
                                         , tcdDataDefn = defn
                                         , tcdFVs = placeHolderNames }) }
 
-cvtDec (NewtypeD ctxt tc tvs constr derivs)
+cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
   = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
+        ; ksig' <- cvtKind `traverse` ksig
         ; con' <- cvtConstr constr
         ; derivs' <- cvtDerivs derivs
         ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
                                 , dd_ctxt = ctxt'
-                                , dd_kindSig = Nothing
+                                , dd_kindSig = ksig'
                                 , dd_cons = [con']
                                 , dd_derivs = derivs' }
         ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
@@ -223,7 +236,8 @@ cvtDec (ClassD ctxt cl tvs fds decs)
         ; fds'  <- mapM cvt_fundep fds
         ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
         ; unless (null adts')
-            (failWith $ (ptext (sLit "Default data instance declarations are not allowed:"))
+            (failWith $ (text "Default data instance declarations"
+                     <+> text "are not allowed:")
                    $$ (Outputable.ppr adts'))
         ; at_defs <- mapM cvt_at_def ats'
         ; returnJustL $ TyClD $
@@ -265,13 +279,14 @@ cvtDec (DataFamilyD tc tvs kind)
        ; returnJustL $ TyClD $ FamDecl $
          FamilyDecl DataFamily tc' tvs' result Nothing }
 
-cvtDec (DataInstD ctxt tc tys constrs derivs)
+cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
   = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
+       ; ksig' <- cvtKind `traverse` ksig
        ; cons' <- mapM cvtConstr constrs
        ; derivs' <- cvtDerivs derivs
        ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
                                , dd_ctxt = ctxt'
-                               , dd_kindSig = Nothing
+                               , dd_kindSig = ksig'
                                , dd_cons = cons', dd_derivs = derivs' }
 
        ; returnJustL $ InstD $ DataFamInstD
@@ -279,13 +294,14 @@ cvtDec (DataInstD ctxt tc tys constrs derivs)
                                          , dfid_defn = defn
                                          , dfid_fvs = placeHolderNames } }}
 
-cvtDec (NewtypeInstD ctxt tc tys constr derivs)
+cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
   = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
+       ; ksig' <- cvtKind `traverse` ksig
        ; con' <- cvtConstr constr
        ; derivs' <- cvtDerivs derivs
        ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
                                , dd_ctxt = ctxt'
-                               , dd_kindSig = Nothing
+                               , dd_kindSig = ksig'
                                , dd_cons = [con'], dd_derivs = derivs' }
        ; returnJustL $ InstD $ DataFamInstD
            { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
@@ -423,7 +439,6 @@ mkBadDecMsg doc bads
 
 ---------------------------------------------------
 --      Data types
--- Can't handle GADTs yet
 ---------------------------------------------------
 
 cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)
@@ -442,27 +457,51 @@ cvtConstr (RecC c varstrtys)
                                    (RecCon (noLoc args')) }
 
 cvtConstr (InfixC st1 c st2)
-  = do  { c' <- cNameL c
+  = do  { c'   <- cNameL c
         ; cxt' <- returnL []
         ; st1' <- cvt_arg st1
         ; st2' <- cvt_arg st2
         ; returnL $ mkConDeclH98 c' Nothing cxt' (InfixCon st1' st2') }
 
 cvtConstr (ForallC tvs ctxt con)
-  = do  { tvs'  <- cvtTvs tvs
+  = do  { tvs'        <- cvtTvs tvs
         ; L loc ctxt' <- cvtContext ctxt
-        ; L _ con' <- cvtConstr con
-        ; let qvars = case (tvs,con_qvars con') of
-                ([],Nothing) -> Nothing
-                _  ->
-                  Just $ mkHsQTvs (hsQTvExplicit tvs' ++
-                                   hsQTvExplicit (fromMaybe (HsQTvs PlaceHolder [])
-                                                            (con_qvars con')))
-        ; returnL $ con' { con_qvars = qvars
-                         , con_cxt = Just $
-                                     L loc (ctxt' ++
-                                            unLoc (fromMaybe (noLoc [])
-                                                   (con_cxt con'))) } }
+        ; L _ con'    <- cvtConstr con
+        ; returnL $ case con' of
+                ConDeclGADT { con_type = conT } ->
+                  con' { con_type =
+                         HsIB PlaceHolder
+                         (noLoc $ HsForAllTy (hsq_explicit tvs') $
+                          (noLoc $ HsQualTy (L loc ctxt') (hsib_body conT))) }
+                ConDeclH98  {} ->
+                  let qvars = case (tvs, con_qvars con') of
+                        ([], Nothing) -> Nothing
+                        (_ , m_qvs  ) -> Just $
+                          mkHsQTvs (hsQTvExplicit tvs' ++
+                                    maybe [] hsQTvExplicit m_qvs)
+                  in con' { con_qvars = qvars
+                          , con_cxt = Just $
+                            L loc (ctxt' ++
+                                   unLoc (fromMaybe (noLoc [])
+                                          (con_cxt con'))) } }
+
+cvtConstr (GadtC c strtys ty idx)
+  = do  { c'   <- mapM cNameL c
+        ; args <- mapM cvt_arg strtys
+        ; idx' <- mapM cvtType idx
+        ; ty'  <- tconNameL ty
+        ; L _ ret_ty <- mk_apps (HsTyVar ty') idx'
+        ; c_ty       <- mk_arr_apps args ret_ty
+        ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}
+
+cvtConstr (RecGadtC c varstrtys ty idx)
+  = do  { c'       <- mapM cNameL c
+        ; ty'      <- tconNameL ty
+        ; rec_flds <- mapM cvt_id_arg varstrtys
+        ; idx'     <- mapM cvtType idx
+        ; ret_ty   <- mk_apps (HsTyVar ty') idx'
+        ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ret_ty)
+        ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
 
 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
 cvt_arg (NotStrict, ty) = cvtType ty
@@ -1159,11 +1198,19 @@ cvtTypeKind ty_str ty
            _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
     }
 
+-- | Constructs an application of a type to arguments passed in a list.
 mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName)
 mk_apps head_ty []       = returnL head_ty
 mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
                               ; mk_apps (HsAppTy head_ty' ty) tys }
 
+-- | Constructs an arrow type with a specified return type
+mk_arr_apps :: [LHsType RdrName] -> HsType RdrName -> CvtM (LHsType RdrName)
+mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL
+    where go :: LHsType RdrName -> HsType RdrName -> CvtM (HsType RdrName)
+          go arg ret_ty = do { ret_ty_l <- returnL ret_ty
+                             ; return (HsFunTy arg ret_ty_l) }
+
 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
 split_ty_app ty = go ty []
   where

compiler/hsSyn/HsDecls.hs

@@ -89,7 +89,6 @@ import {-# SOURCE #-}   HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr, pprSplice )
         -- Because Expr imports Decls via HsBracket
 
 import HsBinds
-import HsPat
 import HsTypes
 import HsDoc
 import TyCon
@@ -1078,8 +1077,8 @@ gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs)
     (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty
     (details, res_ty)           -- See Note [Sorting out the result type]
       = case tau of
-          L _ (HsFunTy (L l (HsRecTy flds)) res_ty)
-                  -> (RecCon (L l flds), res_ty)
+          L _ (HsFunTy (L l (HsRecTy flds)) res_ty')
+                  -> (RecCon (L l flds), res_ty')
           _other  -> (PrefixCon [], tau)
 
 hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]

compiler/hsSyn/HsPat.hs

@@ -17,7 +17,6 @@
 module HsPat (
         Pat(..), InPat, OutPat, LPat,
 
-        HsConDetails(..),
         HsConPatDetails, hsConPatArgs,
         HsRecFields(..), HsRecField'(..), LHsRecField',
         HsRecField, LHsRecField,
@@ -224,14 +223,6 @@ data Pat id
   deriving (Typeable)
 deriving instance (DataId id) => Data (Pat id)
 
--- HsConDetails is use for patterns/expressions *and* for data type declarations
-
-data HsConDetails arg rec
-  = PrefixCon [arg]             -- C p1 p2 p3
-  | RecCon    rec               -- C { x = p1, y = p2 }
-  | InfixCon  arg arg           -- p1 `C` p2
-  deriving (Data, Typeable)
-
 type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id))
 
 hsConPatArgs :: HsConPatDetails id -> [LPat id]
@@ -239,16 +230,8 @@ hsConPatArgs (PrefixCon ps)   = ps
 hsConPatArgs (RecCon fs)      = map (hsRecFieldArg . unLoc) (rec_flds fs)
 hsConPatArgs (InfixCon p1 p2) = [p1,p2]
 
-instance (Outputable arg, Outputable rec)
-         => Outputable (HsConDetails arg rec) where
-  ppr (PrefixCon args) = text "PrefixCon" <+> ppr args
-  ppr (RecCon rec)     = text "RecCon:" <+> ppr rec
-  ppr (InfixCon l r)   = text "InfixCon:" <+> ppr [l, r]
-
-{-
-However HsRecFields is used only for patterns and expressions
-(not data type declarations)
--}
+-- HsRecFields is used only for patterns and expressions (not data type
+-- declarations)
 
 data HsRecFields id arg         -- A bunch of record fields
                                 --      { x = 3, y = True }

compiler/hsSyn/HsTypes.hs

@@ -34,7 +34,9 @@ module HsTypes (
         SrcStrictness(..), SrcUnpackedness(..),
         getBangType, getBangStrictness,
 
-        ConDeclField(..), LConDeclField, pprConDeclFields,
+        ConDeclField(..), LConDeclField, pprConDeclFields, updateGadtResult,
+
+        HsConDetails(..),
 
         FieldOcc(..), LFieldOcc, mkFieldOcc,
         AmbiguousFieldOcc(..), mkAmbiguousFieldOcc,
@@ -47,7 +49,8 @@ module HsTypes (
 
         mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
         mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
-        mkHsQTvs, hsQTvExplicit, isHsKindedTyVar, hsTvbAllKinded,
+        mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs,
+        isHsKindedTyVar, hsTvbAllKinded,
         hsScopedTvs, hsWcScopedTvs, dropWildCards,
         hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,
         hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames,
@@ -85,6 +88,7 @@ import Maybes( isJust )
 
 import Data.Data hiding ( Fixity )
 import Data.Maybe ( fromMaybe )
+import Control.Monad ( unless )
 #if __GLASGOW_HASKELL > 710
 import Data.Semigroup   ( Semigroup )
 import qualified Data.Semigroup as Semigroup
@@ -216,6 +220,13 @@ mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs }
 hsQTvExplicit :: LHsQTyVars name -> [LHsTyVarBndr name]
 hsQTvExplicit = hsq_explicit
 
+emptyLHsQTvs :: LHsQTyVars Name
+emptyLHsQTvs = HsQTvs [] []
+
+isEmptyLHsQTvs :: LHsQTyVars Name -> Bool
+isEmptyLHsQTvs (HsQTvs [] []) = True
+isEmptyLHsQTvs _              = False
+
 ------------------------------------------------
 --            HsImplicitBndrs
 -- Used to quantify the binders of a type in cases
@@ -669,6 +680,22 @@ data ConDeclField name  -- Record fields have Haddoc docs on them
   deriving (Typeable)
 deriving instance (DataId name) => Data (ConDeclField name)
 
+instance (OutputableBndr name) => Outputable (ConDeclField name) where
+  ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
+
+-- HsConDetails is used for patterns/expressions *and* for data type
+-- declarations
+data HsConDetails arg rec
+  = PrefixCon [arg]             -- C p1 p2 p3
+  | RecCon    rec               -- C { x = p1, y = p2 }
+  | InfixCon  arg arg           -- p1 `C` p2
+  deriving (Data, Typeable)
+
+instance (Outputable arg, Outputable rec)
+         => Outputable (HsConDetails arg rec) where
+  ppr (PrefixCon args) = text "PrefixCon" <+> ppr args
+  ppr (RecCon rec)     = text "RecCon:" <+> ppr rec
+  ppr (InfixCon l r)   = text "InfixCon:" <+> ppr [l, r]
 
 type LFieldOcc name = Located (FieldOcc name)
 
@@ -735,6 +762,30 @@ unambiguousFieldOcc (Ambiguous   rdr sel) = FieldOcc rdr sel
 ambiguousFieldOcc :: FieldOcc name -> AmbiguousFieldOcc name
 ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel
 
+-- Takes details and result type of a GADT data constructor as created by the
+-- parser and rejigs them using information about fixities from the renamer.
+-- See Note [Sorting out the result type] in RdrHsSyn
+updateGadtResult
+  :: (Monad m)
+     => (SDoc -> m ())
+     -> SDoc
+     -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
+                     -- ^ Original details
+     -> LHsType Name -- ^ Original result type
+     -> m (HsConDetails (LHsType Name) (Located [LConDeclField Name]),
+           LHsType Name)
+updateGadtResult failWith doc details ty
+  = do { let (arg_tys, res_ty) = splitHsFunType ty
+             badConSig         = text "Malformed constructor signature"
+       ; case details of
+           InfixCon {}  -> pprPanic "updateGadtResult" (ppr ty)
+
+           RecCon {}    -> do { unless (null arg_tys)
+                                       (failWith (doc <+> badConSig))
+                              ; return (details, res_ty) }
+
+           PrefixCon {} -> return (PrefixCon arg_tys, res_ty)}
+
 {-
 Note [ConDeclField names]
 ~~~~~~~~~~~~~~~~~~~~~~~~~

compiler/parser/RdrHsSyn.hs

@@ -614,7 +614,7 @@ really doesn't matter!
 -}
 
 -- | Note [Sorting out the result type]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -- In a GADT declaration which is not a record, we put the whole constr type
 -- into the res_ty for a ConDeclGADT for now; the renamer will unravel it once
 -- it has sorted out operator fixities. Consider for example
@@ -623,7 +623,7 @@ really doesn't matter!
 --       a :*: (b -> (a :*: (b -> (a :+: b))))
 --
 -- so it's hard to split up the arguments until we've done the precedence
--- resolution (in the renamer) On the other hand, for a record
+-- resolution (in the renamer). On the other hand, for a record
 --         { x,y :: Int } -> a :*: b
 -- there is no doubt.  AND we need to sort records out so that
 -- we can bring x,y into scope.  So:

compiler/prelude/THNames.hs

@@ -76,7 +76,7 @@ templateHaskellNames = [
     -- Strict
     isStrictName, notStrictName, unpackedName,
     -- Con
-    normalCName, recCName, infixCName, forallCName,
+    normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName,
     -- StrictType
     strictTypeName,
     -- VarStrictType
@@ -356,11 +356,13 @@ notStrictName     = libFun  (fsLit "notStrict")     notStrictKey
 unpackedName      = libFun  (fsLit "unpacked")      unpackedKey
 
 -- data Con = ...
-normalCName, recCName, infixCName, forallCName :: Name
-normalCName = libFun (fsLit "normalC") normalCIdKey
-recCName    = libFun (fsLit "recC")    recCIdKey
-infixCName  = libFun (fsLit "infixC")  infixCIdKey
-forallCName  = libFun (fsLit "forallC")  forallCIdKey
+normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name
+normalCName  = libFun (fsLit "normalC" ) normalCIdKey
+recCName     = libFun (fsLit "recC"    ) recCIdKey
+infixCName   = libFun (fsLit "infixC"  ) infixCIdKey
+forallCName  = libFun (fsLit "forallC" ) forallCIdKey
+gadtCName    = libFun (fsLit "gadtC"   ) gadtCIdKey
+recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey
 
 -- type StrictType = ...
 strictTypeName :: Name
@@ -801,19 +803,22 @@ notStrictKey        = mkPreludeMiscIdUnique 364
 unpackedKey         = mkPreludeMiscIdUnique 365
 
 -- data Con = ...
-normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
+normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey,
+  recGadtCIdKey :: Unique
 normalCIdKey      = mkPreludeMiscIdUnique 370
 recCIdKey         = mkPreludeMiscIdUnique 371
 infixCIdKey       = mkPreludeMiscIdUnique 372
 forallCIdKey      = mkPreludeMiscIdUnique 373
+gadtCIdKey        = mkPreludeMiscIdUnique 374
+recGadtCIdKey     = mkPreludeMiscIdUnique 375
 
 -- type StrictType = ...
 strictTKey :: Unique
-strictTKey        = mkPreludeMiscIdUnique 374
+strictTKey        = mkPreludeMiscIdUnique 376
 
 -- type VarStrictType = ...
 varStrictTKey :: Unique
-varStrictTKey     = mkPreludeMiscIdUnique 375
+varStrictTKey     = mkPreludeMiscIdUnique 377
 
 -- data Type = ...
 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,

compiler/rename/RnNames.hs

@@ -615,11 +615,10 @@ getLocalNonValBinders fixity_env
     mk_fld_env :: HsDataDefn RdrName -> [Name] -> [FieldLabel] -> [(Name, [FieldLabel])]
     mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)
       where
-        find_con_flds (L _ (ConDeclH98 { con_name   = rdrs
-                                    , con_details = RecCon cdflds }))
-            = map (\ (L _ rdr) -> ( find_con_name rdr
-                                  , concatMap find_con_decl_flds (unLoc cdflds)))
-                  [rdrs] -- AZ:TODO remove map
+        find_con_flds (L _ (ConDeclH98 { con_name    = L _ rdr
+                                       , con_details = RecCon cdflds }))
+            = [( find_con_name rdr
+               , concatMap find_con_decl_flds (unLoc cdflds) )]
         find_con_flds (L _ (ConDeclGADT
                               { con_names = rdrs
                               , con_type = (HsIB { hsib_body = res_ty})}))
@@ -630,6 +629,7 @@ getLocalNonValBinders fixity_env
               (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
               cdflds = case tau of
                  L _ (HsFunTy (L _ (HsAppsTy [HsAppPrefix (L _ (HsRecTy flds))])) _) -> flds
+                 L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds
                  _                                    -> []
         find_con_flds _ = []
 

compiler/rename/RnTypes.hs

@@ -469,10 +469,7 @@ rnHsTyKi _ doc (HsBangTy b ty)
        ; return (HsBangTy b ty', fvs) }
 
 rnHsTyKi _ doc@(ConDeclCtx names) (HsRecTy flds)
-  = do {
-       -- AZ:reviewers: is there a monadic version of concatMap?
-         flss <- mapM (lookupConstructorFields . unLoc) names
-       ; let fls = concat flss
+  = do { fls <- concatMapM (lookupConstructorFields . unLoc) names
        ; (flds', fvs) <- rnConDeclFields fls doc flds
        ; return (HsRecTy flds', fvs) }
 

compiler/typecheck/TcSplice.hs

@@ -1312,43 +1312,87 @@ reifyTyCon tc
 
   | otherwise
   = do  { cxt <- reifyCxt (tyConStupidTheta tc)
-        ; let tvs = tyConTyVars tc
-        ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
+        ; let tvs      = tyConTyVars tc
+              dataCons = tyConDataCons tc
+              -- see Note [Reifying GADT data constructors]
+              isGadt   = any (not . null . dataConEqSpec) dataCons
+        ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons
         ; r_tvs <- reifyTyVars tvs (Just tc)
         ; let name = reifyName tc
               deriv = []        -- Don't know about deriving
-              decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
-                   | otherwise     = TH.DataD    cxt name r_tvs cons        deriv
+              decl | isNewTyCon tc =
+                       TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv
+                   | otherwise     =
+                       TH.DataD    cxt name r_tvs Nothing       cons  deriv
         ; return (TH.TyConI decl) }
 
-reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
--- For GADTs etc, see Note [Reifying data constructors]
-reifyDataCon tys dc
-  = do { let (ex_tvs, theta, arg_tys) = dataConInstSig dc tys
-             stricts  = map reifyStrict (dataConSrcBangs dc)
-             fields   = dataConFieldLabels dc
-             name     = reifyName dc
-
-       ; r_arg_tys <- reifyTypes arg_tys
-
-       ; let main_con | not (null fields)
-                      = TH.RecC name
-                          (zip3 (map reifyFieldLabel fields) stricts r_arg_tys)
+reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con
+-- For GADTs etc, see Note [Reifying GADT data constructors]
+reifyDataCon isGadtDataCon tys dc
+  = do { let -- used for H98 data constructors
+             (ex_tvs, theta, arg_tys)
+                 = dataConInstSig dc tys
+             -- used for GADTs data constructors
+             (g_univ_tvs, g_ex_tvs, g_eq_spec, g_theta, g_arg_tys, _)
+                 = dataConFullSig dc
+             stricts   = map reifyStrict (dataConSrcBangs dc)
+             fields    = dataConFieldLabels dc
+             name      = reifyName dc
+             r_ty_name = reifyName (dataConTyCon dc) -- return type for GADTs
+             -- return type indices
+             subst     = mkTopTCvSubst (map eqSpecPair g_eq_spec)
+             idx       = substTyVars subst g_univ_tvs
+             -- universal tvs that were not substituted
+             g_unsbst_univ_tvs = filter (`notElemTCvSubst` subst) g_univ_tvs
+
+       ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys)
+       ; idx_tys   <- reifyTypes idx
+
+       ; let main_con | not (null fields) && not isGadtDataCon
+                      = TH.RecC name (zip3 (map reifyFieldLabel fields)
+                                      stricts r_arg_tys)
+                      | not (null fields)
+                      = TH.RecGadtC [name]
+                                   (zip3 (map (reifyName . flSelector) fields)
+                                    stricts r_arg_tys) r_ty_name idx_tys
                       | dataConIsInfix dc
                       = ASSERT( length arg_tys == 2 )
                         TH.InfixC (s1,r_a1) name (s2,r_a2)
+                      | isGadtDataCon
+                      = TH.GadtC [name] (stricts `zip` r_arg_tys) r_ty_name
+                                 idx_tys
                       | otherwise
                       = TH.NormalC name (stricts `zip` r_arg_tys)
              [r_a1, r_a2] = r_arg_tys
              [s1,   s2]   = stricts
-
+             (ex_tvs', theta') | isGadtDataCon = ( g_unsbst_univ_tvs ++ g_ex_tvs
+                                                 , g_theta )
+                               | otherwise     = ( ex_tvs, theta )
+             ret_con | null ex_tvs' && null theta' = return main_con
+                     | otherwise                   = do
+                         { cxt <- reifyCxt theta'
+                         ; ex_tvs'' <- reifyTyVars ex_tvs' Nothing
+                         ; return (TH.ForallC ex_tvs'' cxt main_con) }
        ; ASSERT( length arg_tys == length stricts )
-         if null ex_tvs && null theta then
-             return main_con
-         else do
-         { cxt <- reifyCxt theta
-         ; ex_tvs' <- reifyTyVars ex_tvs Nothing
-         ; return (TH.ForallC ex_tvs' cxt main_con) } }
+         ret_con }
+
+-- Note [Reifying GADT data constructors]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- At this point in the compilation pipeline we have no way of telling whether a
+-- data type was declared as a H98 data type or as a GADT.  We have to rely on
+-- heuristics here.  We look at dcEqSpec field of all data constructors in a
+-- data type declaration.  If at least one data constructor has non-empty
+-- dcEqSpec this means that the data type must have been declared as a GADT.
+-- Consider these declarations:
+--
+--   data T a where
+--      MkT :: forall a. (a ~ Int) => T a
+--
+--   data T a where
+--      MkT :: T Int
+--
+-- First declaration will be reified as a GADT.  Second declaration will be
+-- reified as a normal H98 data type declaration.
 
 ------------------------------
 reifyClass :: Class -> TcM TH.Info
@@ -1483,13 +1527,18 @@ reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
                  (_rep_tc, rep_tc_args) = splitTyConApp rhs
                  etad_tyvars            = dropList rep_tc_args tvs
                  eta_expanded_lhs = lhs `chkAppend` mkTyVarTys etad_tyvars
-           ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons rep_tc)
+                 dataCons               = tyConDataCons rep_tc
+                 -- see Note [Reifying GADT data constructors]
+                 isGadt   = any (not . null . dataConEqSpec) dataCons
+           ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons
            ; let types_only = filterOutInvisibleTypes fam_tc eta_expanded_lhs
            ; th_tys <- reifyTypes types_only
            ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys
-           ; return (if isNewTyCon rep_tc
-                     then TH.NewtypeInstD [] fam' annot_th_tys (head cons) []
-                     else TH.DataInstD    [] fam' annot_th_tys cons        []) }
+           ; return $
+               if isNewTyCon rep_tc
+               then TH.NewtypeInstD [] fam' annot_th_tys Nothing (head cons) []
+               else TH.DataInstD    [] fam' annot_th_tys Nothing       cons  []
+           }
   where