Add proper GADTs support to Template Haskell
authorJan Stolarek <jan.stolarek@p.lodz.pl>
Wed, 11 Nov 2015 09:49:22 +0000 (10:49 +0100)
committerJan Stolarek <jan.stolarek@p.lodz.pl>
Mon, 21 Dec 2015 19:47:16 +0000 (20:47 +0100)
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

49 files changed:
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsDecls.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsTypes.hs
compiler/parser/RdrHsSyn.hs
compiler/prelude/THNames.hs
compiler/rename/RnNames.hs
compiler/rename/RnTypes.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcTyClsDecls.hs
docs/users_guide/7.12.1-notes.rst
libraries/template-haskell/Language/Haskell/TH.hs
libraries/template-haskell/Language/Haskell/TH/Lib.hs
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
libraries/template-haskell/Language/Haskell/TH/PprLib.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
testsuite/tests/overloadedrecflds/should_fail/T11103.hs
testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs
testsuite/tests/rts/T7919A.hs
testsuite/tests/safeHaskell/safeLanguage/SafeLang11_B.hs
testsuite/tests/safeHaskell/safeLanguage/SafeLang12_B.hs
testsuite/tests/th/T10819_Lib.hs
testsuite/tests/th/T10828.hs [new file with mode: 0644]
testsuite/tests/th/T10828.stderr [new file with mode: 0644]
testsuite/tests/th/T10828a.hs [new file with mode: 0644]
testsuite/tests/th/T10828a.stderr [new file with mode: 0644]
testsuite/tests/th/T10828b.hs [new file with mode: 0644]
testsuite/tests/th/T10828b.stderr [new file with mode: 0644]
testsuite/tests/th/T4188.stderr
testsuite/tests/th/T5217.hs
testsuite/tests/th/T5217.stderr
testsuite/tests/th/T5290.hs
testsuite/tests/th/T5290.stderr
testsuite/tests/th/T5665a.hs
testsuite/tests/th/T5984_Lib.hs
testsuite/tests/th/T7241.hs
testsuite/tests/th/T7532a.hs
testsuite/tests/th/T8499.hs
testsuite/tests/th/T8624.hs
testsuite/tests/th/T8624.stdout
testsuite/tests/th/TH_RichKinds2.stderr
testsuite/tests/th/TH_Roles1.hs
testsuite/tests/th/TH_Roles2.hs
testsuite/tests/th/TH_dataD1.hs
testsuite/tests/th/TH_genExLib.hs
testsuite/tests/th/TH_spliceDecl1.hs
testsuite/tests/th/TH_spliceDecl3_Lib.hs
testsuite/tests/th/all.T

index 30eb388..0c72a9f 100644 (file)
@@ -252,9 +252,8 @@ repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
 
 repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))
   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
-       ; tc_tvs <- mk_extra_tvs tc tvs defn
-       ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs ->
-                repDataDefn tc1 bndrs Nothing (map hsLTyVarName $ hsQTvExplicit tc_tvs) defn
+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+                repDataDefn tc1 bndrs Nothing defn
        ; return (Just (loc, dec)) }
 
 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
@@ -287,25 +286,27 @@ repRoleD (L loc (RoleAnnotDecl tycon roles))
 -------------------------
 repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]
             -> Maybe (Core [TH.TypeQ])
-            -> [Name] -> HsDataDefn Name
+            -> HsDataDefn Name
             -> DsM (Core TH.DecQ)
-repDataDefn tc bndrs opt_tys tv_names
-          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt
+repDataDefn tc bndrs opt_tys
+          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
                       , dd_cons = cons, dd_derivs = mb_derivs })
   = do { cxt1     <- repLContext cxt
        ; derivs1  <- repDerivs mb_derivs
-       ; case new_or_data of
-           NewType  -> do { con1 <- repC tv_names (head cons)
-                          ; case con1 of
-                             [c] -> repNewtype cxt1 tc bndrs opt_tys c derivs1
-                             _cs -> failWithDs (ptext
-                                     (sLit "Multiple constructors for newtype:")
-                                      <+> pprQuotedList
-                                              (getConNames $ unLoc $ head cons))
-                          }
-           DataType -> do { consL <- concatMapM (repC tv_names) cons
-                          ; cons1 <- coreList conQTyConName consL
-                          ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
+       ; case (new_or_data, cons) of
+           (NewType, [con])  -> do { con'  <- repC con
+                                   ; ksig' <- repMaybeLKind ksig
+                                   ; repNewtype cxt1 tc bndrs opt_tys ksig' con'
+                                                derivs1 }
+           (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
+                                       <+> pprQuotedList
+                                       (getConNames $ unLoc $ head cons))
+           (DataType, _) -> do { ksig' <- repMaybeLKind ksig
+                               ; consL <- mapM repC cons
+                               ; cons1 <- coreList conQTyConName consL
+                               ; repData cxt1 tc bndrs opt_tys ksig' cons1
+                                         derivs1 }
+       }
 
 repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
           -> LHsType Name
@@ -399,34 +400,6 @@ repAssocTyFamDefaults = mapM rep_deflt
            ; repTySynInst tc1 eqn1 }
 
 -------------------------
-mk_extra_tvs :: Located Name -> LHsQTyVars Name
-             -> HsDataDefn Name -> DsM (LHsQTyVars Name)
--- If there is a kind signature it must be of form
---    k1 -> .. -> kn -> *
--- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
-mk_extra_tvs tc tvs defn
-  | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
-  = do { extra_tvs <- go hs_kind
-       ; return (tvs { hsq_explicit = hsq_explicit tvs ++ extra_tvs }) }
-  | otherwise
-  = return tvs
-  where
-    go :: LHsKind Name -> DsM [LHsTyVarBndr Name]
-    go (L loc (HsFunTy kind rest))
-      = do { uniq <- newUnique
-           ; let { occ = mkTyVarOccFS (fsLit "t")
-                 ; nm = mkInternalName uniq occ loc
-                 ; hs_tv = L loc (KindedTyVar (noLoc nm) kind) }
-           ; hs_tvs <- go rest
-           ; return (hs_tv : hs_tvs) }
-
-    go (L _ (HsTyVar (L _ n)))
-      |  isLiftedTypeKindTyConName n
-      = return []
-
-    go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
-
--------------------------
 -- represent fundeps
 --
 repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])
@@ -514,7 +487,7 @@ repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
                              , hsq_explicit = [] }   -- Yuk
        ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
          do { tys1 <- repList typeQTyConName repLTy tys
-            ; repDataDefn tc bndrs (Just tys1) var_names defn } }
+            ; repDataDefn tc bndrs (Just tys1) defn } }
 
 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
 repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
@@ -620,131 +593,49 @@ repAnnProv ModuleAnnProvenance
 --                      Constructors
 -------------------------------------------------------
 
-repC :: [Name] -> LConDecl Name -> DsM [Core TH.ConQ]
-repC _ (L _ (ConDeclH98 { con_name = con
-                        , con_qvars = Nothing, con_cxt = Nothing
-                        , con_details = details }))
-  = do { con1 <- lookupLOcc con
-                 -- See Note [Binders and occurrences]
-       ; mapM (\c -> repConstr c details) [con1] }
-
-repC _ (L _ (ConDeclH98 { con_name = con
-                        , con_qvars = mcon_tvs, con_cxt = mcxt
-                        , con_details = details }))
-  = do { let (eq_ctxt, con_tv_subst) = ([], [])
-       ; let con_tvs = fromMaybe (HsQTvs [] []) mcon_tvs
-       ; let ctxt = unLoc $ fromMaybe (noLoc []) mcxt
-       ; let ex_tvs = HsQTvs { hsq_implicit = filterOut (in_subst con_tv_subst) (hsq_implicit con_tvs)
-                             , hsq_explicit = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_explicit con_tvs) }
-
-       ; let binds = []
-       ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
-         addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
-    do { con1     <- lookupLOcc con -- See Note [Binders and occurrences]
-       ; c'        <- repConstr con1 details
-       ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
-       ; if (null (hsq_implicit ex_tvs) && null (hsq_explicit ex_tvs)
-             && null (eq_ctxt ++ ctxt))
-            then return c'
-            else rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ [unC c']) }
-    ; return [b]
-    }
-repC tvs (L _ (ConDeclGADT { con_names = cons
-                           , con_type = res_ty@(HsIB { hsib_vars = con_vars })}))
-  = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
-       ; let ex_tvs
-               = HsQTvs { hsq_implicit = []
-                        , hsq_explicit = map (noLoc . UserTyVar . noLoc) $
-                                         filterOut
-                                          (in_subst con_tv_subst)
-                                          con_vars }
-
-       ; binds <- mapM dupBinder con_tv_subst
-       ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
-         addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
-    do { cons1 <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
-       ; let (details,res_ty',_,_) = gadtDeclDetails res_ty
-       ; let doc = ptext (sLit "In the constructor for ") <+> ppr (head cons)
-       ; (hs_details,_res_ty) <- update_con_result doc details res_ty'
-       ; c'        <- mapM (\c -> repConstr c hs_details) cons1
-       ; ctxt'     <- repContext eq_ctxt
-       ; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) }
-    ; return [b]
-    }
-
-in_subst :: [(Name,Name)] -> Name -> Bool
-in_subst []          _ = False
-in_subst ((n',_):ns) n = n==n' || in_subst ns n
-
-update_con_result :: SDoc
-            -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
-                    -- Original details
-            -> LHsType Name -- The original result type
-            -> DsM (HsConDetails (LHsType Name) (Located [LConDeclField Name]),
-                    LHsType Name)
-update_con_result doc details ty
-  = do {  let (arg_tys, res_ty) = splitHsFunType ty
-                -- We can finally split it up,
-                -- now the renamer has dealt with fixities
-                -- See Note [Sorting out the result type] in RdrHsSyn
-
-       ; case details of
-           InfixCon {}  -> pprPanic "update_con_result" (ppr ty)
-           -- See Note [Sorting out the result type] in RdrHsSyn
-
-           RecCon {}    -> do { unless (null arg_tys)
-                                       (failWithDs (badRecResTy doc))
-                                -- AZ: This error used to be reported during
-                                --     renaming, will now be reported in type
-                                --     checking. Is this a problem?
-                              ; return (details, res_ty) }
-
-           PrefixCon {} -> return (PrefixCon arg_tys, res_ty)}
-    where
-        badRecResTy :: SDoc -> SDoc
-        badRecResTy ctxt = ctxt <+>
-                        ptext (sLit "Malformed constructor signature")
-
-mkGadtCtxt :: [Name]            -- Tyvars of the data type
-           -> LHsSigType Name
-           -> DsM (HsContext Name, [(Name,Name)])
--- Given a data type in GADT syntax, figure out the equality
--- context, so that we can represent it with an explicit
--- equality context, because that is the only way to express
--- the GADT in TH syntax
---
--- Example:
--- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e
---     mkGadtCtxt [a,b,c] [d,e] (T d [e] e)
---   returns
---     (b~[e], c~e), [d->a]
---
--- This function is fiddly, but not really hard
-mkGadtCtxt data_tvs res_ty
-  | Just (_, tys) <- hsTyGetAppHead_maybe ty
-  , data_tvs `equalLength` tys
-  = return (go [] [] (data_tvs `zip` tys))
+repC :: LConDecl Name -> DsM (Core TH.ConQ)
+repC (L _ (ConDeclH98 { con_name = con
+                      , con_qvars = Nothing, con_cxt = Nothing
+                      , con_details = details }))
+  = repDataCon con details
+
+repC (L _ (ConDeclH98 { con_name = con
+                      , con_qvars = mcon_tvs, con_cxt = mcxt
+                      , con_details = details }))
+  = do { let con_tvs = fromMaybe emptyLHsQTvs mcon_tvs
+             ctxt    = unLoc $ fromMaybe (noLoc []) mcxt
+       ; addTyVarBinds con_tvs $ \ ex_bndrs ->
+         do { c'    <- repDataCon con details
+            ; ctxt' <- repContext ctxt
+            ; if isEmptyLHsQTvs con_tvs && null ctxt
+              then return c'
+              else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
+            }
+       }
 
-  | otherwise
-  = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
+repC (L _ (ConDeclGADT { con_names = cons
+                       , con_type = res_ty@(HsIB { hsib_vars = con_vars })}))
+  | (details, res_ty', L _ [] , []) <- gadtDetails
+  , [] <- con_vars
+    -- no implicit or explicit variables, no context = no need for a forall
+  = do { let doc = text "In the constructor for " <+> ppr (head cons)
+       ; (hs_details, gadt_res_ty) <-
+           updateGadtResult failWithDs doc details res_ty'
+       ; repGadtDataCons cons hs_details gadt_res_ty }
+
+  | (details,res_ty',ctxt, tvs) <- gadtDetails
+  = do { let doc = text "In the constructor for " <+> ppr (head cons)
+             con_tvs = HsQTvs { hsq_implicit = []
+                              , hsq_explicit = (map (noLoc . UserTyVar . noLoc)
+                                                   con_vars) ++ tvs }
+       ; addTyVarBinds con_tvs $ \ ex_bndrs -> do
+       { (hs_details, gadt_res_ty) <-
+           updateGadtResult failWithDs doc details res_ty'
+       ; c'    <- repGadtDataCons cons hs_details gadt_res_ty
+       ; ctxt' <- repContext (unLoc ctxt)
+       ; rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } }
   where
-    (_,ty',_,_) = gadtDeclDetails res_ty
-    (_arg_tys,ty) = splitHsFunType ty'
-    go cxt subst [] = (cxt, subst)
-    go cxt subst ((data_tv, ty) : rest)
-       | Just con_tv <- is_hs_tyvar ty
-       , isTyVarName con_tv
-       , not (in_subst subst con_tv)
-       = go cxt ((con_tv, data_tv) : subst) rest
-       | otherwise
-       = go (eq_pred : cxt) subst rest
-       where
-         loc = getLoc ty
-         eq_pred = L loc (HsEqTy (L loc (HsTyVar (L loc data_tv))) ty)
-
-    is_hs_tyvar (L _ (HsTyVar (L _ n))) = Just n  -- Type variables *and* tycons
-    is_hs_tyvar (L _ (HsParTy ty))      = is_hs_tyvar ty
-    is_hs_tyvar _                       = Nothing
+     gadtDetails = gadtDeclDetails res_ty
 
 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
 repBangTy ty = do
@@ -766,8 +657,8 @@ repBangTy ty = do
 repDerivs :: HsDeriving Name -> DsM (Core TH.CxtQ)
 repDerivs deriv = do
     let clauses
-          | Nothing <- deriv         = []
           | Just (L _ ctxt) <- deriv = ctxt
+          | otherwise                = []
     tys <- repList typeQTyConName
                    (rep_deriv . hsSigType)
                    clauses
@@ -903,12 +794,13 @@ addTyVarBinds :: LHsQTyVars Name                            -- the binders to be
 -- the computations passed as the second argument is executed in that extended
 -- meta environment and gets the *new* names on Core-level as an argument
 
-addTyVarBinds (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs }) m
-  = do { fresh_kv_names <- mkGenSyms kvs
-       ; fresh_tv_names <- mkGenSyms (map hsLTyVarName tvs)
-       ; let fresh_names = fresh_kv_names ++ fresh_tv_names
+addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m
+  = do { fresh_imp_names <- mkGenSyms imp_tvs
+       ; fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)
+       ; let fresh_names = fresh_imp_names ++ fresh_exp_names
        ; term <- addBinds fresh_names $
-                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (tvs `zip` fresh_tv_names)
+                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr
+                                     (exp_tvs `zip` fresh_exp_names)
                     ; m kbs }
        ; wrapGenSyms fresh_names term }
   where
@@ -1089,6 +981,15 @@ repLKind ki
        ; foldrM f ki'_rep kis_rep
        }
 
+-- | Represent a kind wrapped in a Maybe
+repMaybeLKind :: Maybe (LHsKind Name)
+              -> DsM (Core (Maybe TH.Kind))
+repMaybeLKind Nothing =
+    do { coreNothing kindTyConName }
+repMaybeLKind (Just ki) =
+    do { ki' <- repLKind ki
+       ; coreJust kindTyConName ki' }
+
 repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind)
 repNonArrowLKind (L _ ki) = repNonArrowKind ki
 
@@ -1631,13 +1532,6 @@ addBinds :: [GenSymBind] -> DsM a -> DsM a
 -- by the desugarer monad)
 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m
 
-dupBinder :: (Name, Name) -> DsM (Name, DsMetaVal)
-dupBinder (new, old)
-  = do { mb_val <- dsLookupMetaEnv old
-       ; case mb_val of
-           Just val -> return (new, val)
-           Nothing  -> pprPanic "dupBinder" (ppr old) }
-
 -- Look up a locally bound name
 --
 lookupLBinder :: Located Name -> DsM (Core TH.Name)
@@ -1755,9 +1649,6 @@ dataCon' n args = do { id <- dsLookupDataCon n
 dataCon :: Name -> DsM (Core a)
 dataCon n = dataCon' n []
 
--- Then we make "repConstructors" which use the phantom types for each of the
--- smart constructors of the Meta.Meta datatypes.
-
 
 -- %*********************************************************************
 -- %*                                                                   *
@@ -1936,20 +1827,23 @@ repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
 
 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
-        -> Maybe (Core [TH.TypeQ])
+        -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind)
         -> Core [TH.ConQ] -> Core TH.CxtQ -> DsM (Core TH.DecQ)
-repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
-  = rep2 dataDName [cxt, nm, tvs, cons, derivs]
-repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
-  = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
+repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs)
+  = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
+repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons)
+        (MkC derivs)
+  = rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs]
 
 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
-           -> Maybe (Core [TH.TypeQ])
+           -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind)
            -> Core TH.ConQ -> Core TH.CxtQ -> DsM (Core TH.DecQ)
-repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
-  = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
-repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
-  = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
+repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con)
+           (MkC derivs)
+  = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
+repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con)
+           (MkC derivs)
+  = rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs]
 
 repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
          -> Core TH.TypeQ -> DsM (Core TH.DecQ)
@@ -2036,16 +1930,50 @@ repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
 repCtxt (MkC tys) = rep2 cxtName [tys]
 
-repConstr :: Core TH.Name -> HsConDeclDetails Name
+repDataCon :: Located Name
+           -> HsConDeclDetails Name
+           -> DsM (Core TH.ConQ)
+repDataCon con details
+    = do con' <- lookupLOcc con -- See Note [Binders and occurrences]
+         repConstr details Nothing [con']
+
+repGadtDataCons :: [Located Name]
+                -> HsConDeclDetails Name
+                -> LHsType Name
+                -> DsM (Core TH.ConQ)
+repGadtDataCons cons details res_ty
+    = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
+         repConstr details (Just res_ty) cons'
+
+-- Invariant:
+--   * for plain H98 data constructors second argument is Nothing and third
+--     argument is a singleton list
+--   * for GADTs data constructors second argument is (Just return_type) and
+--     third argument is a non-empty list
+repConstr :: HsConDeclDetails Name
+          -> Maybe (LHsType Name)
+          -> [Core TH.Name]
           -> DsM (Core TH.ConQ)
-repConstr con (PrefixCon ps)
+repConstr (PrefixCon ps) Nothing [con]
     = do arg_tys  <- repList strictTypeQTyConName repBangTy ps
          rep2 normalCName [unC con, unC arg_tys]
 
-repConstr con (RecCon (L _ ips))
-    = do { args <- concatMapM rep_ip ips
-         ; arg_vtys <- coreList varStrictTypeQTyConName args
-         ; rep2 recCName [unC con, unC arg_vtys] }
+repConstr (PrefixCon ps) (Just res_ty) cons
+    = do arg_tys      <- repList strictTypeQTyConName repBangTy ps
+         (res_n, idx) <- repGadtReturnTy res_ty
+         rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_n
+                        , unC idx]
+
+repConstr (RecCon (L _ ips)) resTy cons
+    = do args     <- concatMapM rep_ip ips
+         arg_vtys <- coreList varStrictTypeQTyConName args
+         case resTy of
+           Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
+           Just res_ty -> do
+             (res_n, idx) <- repGadtReturnTy res_ty
+             rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
+                                unC res_n, unC idx]
+
     where
       rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
 
@@ -2054,11 +1982,23 @@ repConstr con (RecCon (L _ ips))
                           ; MkC ty <- repBangTy  t
                           ; rep2 varStrictTypeName [v,ty] }
 
-repConstr con (InfixCon st1 st2)
+repConstr (InfixCon st1 st2) Nothing [con]
     = do arg1 <- repBangTy st1
          arg2 <- repBangTy st2
          rep2 infixCName [unC arg1, unC con, unC arg2]
 
+repConstr (InfixCon {}) (Just _) _ = panic "repConstr: infix GADT constructor?"
+repConstr _ _ _                    = panic "repConstr: invariant violated"
+
+repGadtReturnTy :: LHsType Name -> DsM (Core TH.Name, Core [TH.TypeQ])
+repGadtReturnTy res_ty | Just (n, tys) <- hsTyGetAppHead_maybe res_ty
+  = do { n'   <- lookupLOcc n
+       ; tys' <- repList typeQTyConName repLTy tys
+       ; return (n', tys') }
+repGadtReturnTy res_ty
+  = failWithDs (ptext (sLit "Malformed constructor result type:")
+            <+> ppr res_ty)
+
 ------------ Types -------------------
 
 repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
index d4e225a..8d84378 100644 (file)
@@ -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
index 3f49f42..bcb47e4 100644 (file)
@@ -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]
index 38f0626..1751b96 100644 (file)
@@ -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 }
index 1c2d383..a2bdc04 100644 (file)
@@ -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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
index 39a3d0e..5da1bab 100644 (file)
@@ -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:
index 571487a..d683b1a 100644 (file)
@@ -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,
index 119efc1..4c96861 100644 (file)
@@ -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 _ = []
 
index ebcab85..dc6b7a6 100644 (file)
@@ -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) }
 
index e5090a0..9cce515 100644 (file)
@@ -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
     fam_tc = famInstTyCon inst
 
@@ -1772,21 +1821,6 @@ ppr_th :: TH.Ppr a => a -> SDoc
 ppr_th x = text (TH.pprint x)
 
 {-
-Note [Reifying data constructors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Template Haskell syntax is rich enough to express even GADTs,
-provided we do so in the equality-predicate form.  So a GADT
-like
-
-  data T a where
-     MkT1 :: a -> T [a]
-     MkT2 :: T Int
-
-will appear in TH syntax like this
-
-  data T a = forall b. (a ~ [b]) => MkT1 b
-           | (a ~ Int) => MkT2
-
 Note [Reifying field labels]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When reifying a datatype declared with DuplicateRecordFields enabled, we want
index 47b2fc2..dc7f0f4 100644 (file)
@@ -1482,7 +1482,8 @@ tcGadtSigType :: SDoc -> Name -> LHsSigType Name
                                     (Located [LConDeclField Name]) )
 tcGadtSigType doc name ty@(HsIB { hsib_vars = vars })
   = do { let (hs_details', res_ty', cxt, gtvs) = gadtDeclDetails ty
-       ; (hs_details, res_ty) <- tcUpdateConResult doc hs_details' res_ty'
+       ; (hs_details, res_ty) <-
+           updateGadtResult failWithTc doc hs_details' res_ty'
        ; (_, (ctxt, arg_tys, res_ty, field_lbls, stricts))
            <- solveEqualities $
               tcImplicitTKBndrs vars $
@@ -1500,35 +1501,6 @@ tcGadtSigType doc name ty@(HsIB { hsib_vars = vars })
        ; return (ctxt,stricts,field_lbls,arg_tys,res_ty,hs_details)
        }
 
-tcUpdateConResult :: SDoc
-            -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
-                    -- Original details
-            -> LHsType Name -- The original result type
-            -> TcM (HsConDetails (LHsType Name) (Located [LConDeclField Name]),
-                    LHsType Name)
-tcUpdateConResult doc details ty
-  = do {  let (arg_tys, res_ty) = splitHsFunType ty
-                -- We can finally split it up,
-                -- now the renamer has dealt with fixities
-                -- See Note [Sorting out the result type] in RdrHsSyn
-
-       ; case details of
-           InfixCon {}  -> pprPanic "tcUpdateConResult" (ppr ty)
-           -- See Note [Sorting out the result type] in RdrHsSyn
-
-           RecCon {}    -> do { unless (null arg_tys)
-                                       (failWithTc (badRecResTy doc))
-                                -- AZ: This error used to be reported during
-                                --     renaming, will now be reported in type
-                                --     checking. Is this a problem?
-                              ; return (details, res_ty) }
-
-           PrefixCon {} -> return (PrefixCon arg_tys, res_ty)}
-    where
-        badRecResTy :: SDoc -> SDoc
-        badRecResTy ctxt = ctxt <+>
-                        ptext (sLit "Malformed constructor signature")
-
 tcConIsInfixH98 :: Name
              -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
              -> TcM Bool
index 9bac1c5..14af3a0 100644 (file)
@@ -284,6 +284,11 @@ Template Haskell
    have also been introduced, serving the same functions as their
    pattern and expression counterparts.
 
+- ``Template Haskell`` has now explicit support for representing GADTs.  Until
+  now GADTs were encoded using ``NormalC``, ``RecC`` (record syntax) and
+  ``ForallC`` constructors.  Two new constructors - ``GadtC`` and ``RecGadtC`` -
+  are now supported during quoting, splicing and reification.
+
 -  Primitive chars (e.g., ``[| 'a'# |]``) and primitive strings (e.g.,
    ``[| "abc"# |]``) can now be quoted with Template Haskell. The
    ``Lit`` data type also has a new constructor, ``CharPrimL``, for
index a41faf5..66d507c 100644 (file)
@@ -121,7 +121,9 @@ module Language.Haskell.TH(
     -- **** Strictness
     isStrict, notStrict, strictType, varStrictType,
     -- **** Class Contexts
-    cxt, classP, equalP, normalC, recC, infixC, forallC,
+    cxt, classP, equalP,
+    -- **** Constructors
+    normalC, recC, infixC, forallC, gadtC, recGadtC,
 
     -- *** Kinds
     varK, conK, tupleK, arrowK, listK, appK, starK, constraintK,
index 71e614b..737b9d4 100644 (file)
@@ -11,7 +11,7 @@ module Language.Haskell.TH.Lib where
 
 import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn)
 import qualified Language.Haskell.TH.Syntax as TH
-import Control.Monad( liftM, liftM2 )
+import Control.Monad( liftM, liftM2, liftM3 )
 import Data.Word( Word8 )
 
 ----------------------------------------------------------
@@ -338,21 +338,21 @@ funD nm cs =
 tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ
 tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) }
 
-dataD :: CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> CxtQ -> DecQ
-dataD ctxt tc tvs cons derivs =
+dataD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> [ConQ] -> CxtQ -> DecQ
+dataD ctxt tc tvs ksig cons derivs =
   do
     ctxt1 <- ctxt
     cons1 <- sequence cons
     derivs1 <- derivs
-    return (DataD ctxt1 tc tvs cons1 derivs1)
+    return (DataD ctxt1 tc tvs ksig cons1 derivs1)
 
-newtypeD :: CxtQ -> Name -> [TyVarBndr] -> ConQ -> CxtQ -> DecQ
-newtypeD ctxt tc tvs con derivs =
+newtypeD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> ConQ -> CxtQ -> DecQ
+newtypeD ctxt tc tvs ksig con derivs =
   do
     ctxt1 <- ctxt
     con1 <- con
     derivs1 <- derivs
-    return (NewtypeD ctxt1 tc tvs con1 derivs1)
+    return (NewtypeD ctxt1 tc tvs ksig con1 derivs1)
 
 classD :: CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ
 classD ctxt cls tvs fds decs =
@@ -425,23 +425,23 @@ pragAnnD target expr
 pragLineD :: Int -> String -> DecQ
 pragLineD line file = return $ PragmaD $ LineP line file
 
-dataInstD :: CxtQ -> Name -> [TypeQ] -> [ConQ] -> CxtQ -> DecQ
-dataInstD ctxt tc tys cons derivs =
+dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> CxtQ -> DecQ
+dataInstD ctxt tc tys ksig cons derivs =
   do
     ctxt1 <- ctxt
     tys1  <- sequence tys
     cons1 <- sequence cons
     derivs1 <- derivs
-    return (DataInstD ctxt1 tc tys1 cons1 derivs1)
+    return (DataInstD ctxt1 tc tys1 ksig cons1 derivs1)
 
-newtypeInstD :: CxtQ -> Name -> [TypeQ] -> ConQ -> CxtQ -> DecQ
-newtypeInstD ctxt tc tys con derivs =
+newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> CxtQ -> DecQ
+newtypeInstD ctxt tc tys ksig con derivs =
   do
     ctxt1 <- ctxt
     tys1  <- sequence tys
     con1  <- con
     derivs1 <- derivs
-    return (NewtypeInstD ctxt1 tc tys1 con1 derivs1)
+    return (NewtypeInstD ctxt1 tc tys1 ksig con1 derivs1)
 
 tySynInstD :: Name -> TySynEqnQ -> DecQ
 tySynInstD tc eqn =
@@ -543,6 +543,13 @@ infixC st1 con st2 = do st1' <- st1
 forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ
 forallC ns ctxt con = liftM2 (ForallC ns) ctxt con
 
+gadtC :: [Name] -> [StrictTypeQ] -> Name -> [TypeQ] -> ConQ
+gadtC cons strtys ty idx = liftM3 (GadtC cons) (sequence strtys)
+                                  (return ty)  (sequence idx)
+
+recGadtC :: [Name] -> [VarStrictTypeQ] -> Name -> [TypeQ] -> ConQ
+recGadtC cons varstrtys ty idx = liftM3 (RecGadtC cons) (sequence varstrtys)
+                                        (return ty)     (sequence idx)
 
 -------------------------------------------------------------------------------
 -- *   Type
index 0a7f98d..bf240f4 100644 (file)
@@ -128,8 +128,8 @@ pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat ap
                                            <+> text "->" <+> ppr e
 pprExp i (LamCaseE ms) = parensIf (i > noPrec)
                        $ text "\\case" $$ nest nestDepth (ppr ms)
-pprExp _ (TupE es) = parens $ sep $ punctuate comma $ map ppr es
-pprExp _ (UnboxedTupE es) = hashParens $ sep $ punctuate comma $ map ppr es
+pprExp _ (TupE es) = parens (commaSep es)
+pprExp _ (UnboxedTupE es) = hashParens (commaSep es)
 -- Nesting in Cond is to avoid potential problems in do statments
 pprExp i (CondE guard true false)
  = parensIf (i > noPrec) $ sep [text "if"   <+> ppr guard,
@@ -146,7 +146,7 @@ pprExp i (LetE ds_ e) = parensIf (i > noPrec) $ text "let" <+> pprDecs ds_
   where
     pprDecs []  = empty
     pprDecs [d] = ppr d
-    pprDecs ds  = braces $ sep $ punctuate semi $ map ppr ds
+    pprDecs ds  = braces (semiSep ds)
 
 pprExp i (CaseE e ms)
  = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"
@@ -155,18 +155,18 @@ pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_
   where
     pprStms []  = empty
     pprStms [s] = ppr s
-    pprStms ss  = braces $ sep $ punctuate semi $ map ppr ss
+    pprStms ss  = braces (semiSep ss)
 
 pprExp _ (CompE []) = text "<<Empty CompExp>>"
 -- This will probably break with fixity declarations - would need a ';'
 pprExp _ (CompE ss) = text "[" <> ppr s
                   <+> text "|"
-                  <+> (sep $ punctuate comma $ map ppr ss')
+                  <+> commaSep ss'
                    <> text "]"
     where s = last ss
           ss' = init ss
 pprExp _ (ArithSeqE d) = ppr d
-pprExp _ (ListE es) = brackets $ sep $ punctuate comma $ map ppr es
+pprExp _ (ListE es) = brackets (commaSep es)
 pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> dcolon <+> ppr t
 pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)
 pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
@@ -184,10 +184,10 @@ pprMaybeExp i (Just e) = pprExp i e
 ------------------------------
 instance Ppr Stmt where
     ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e
-    ppr (LetS ds) = text "let" <+> (braces $ sep $ punctuate semi $ map ppr ds)
+    ppr (LetS ds) = text "let" <+> (braces (semiSep ds))
     ppr (NoBindS e) = ppr e
     ppr (ParS sss) = sep $ punctuate (text "|")
-                         $ map (sep . punctuate comma . map ppr) sss
+                         $ map commaSep sss
 
 ------------------------------
 instance Ppr Match where
@@ -245,8 +245,8 @@ instance Ppr Pat where
 pprPat :: Precedence -> Pat -> Doc
 pprPat i (LitP l)     = pprLit i l
 pprPat _ (VarP v)     = pprName' Applied v
-pprPat _ (TupP ps)    = parens $ sep $ punctuate comma $ map ppr ps
-pprPat _ (UnboxedTupP ps) = hashParens $ sep $ punctuate comma $ map ppr ps
+pprPat _ (TupP ps)    = parens (commaSep ps)
+pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps)
 pprPat i (ConP s ps)  = parensIf (i >= appPrec) $ pprName' Applied s
                                               <+> sep (map (pprPat appPrec) ps)
 pprPat _ (ParensP p)  = parens $ pprPat noPrec p
@@ -267,7 +267,7 @@ pprPat _ (RecP nm fs)
  = parens $     ppr nm
             <+> braces (sep $ punctuate comma $
                         map (\(s,p) -> ppr s <+> equals <+> ppr p) fs)
-pprPat _ (ListP ps) = brackets $ sep $ punctuate comma $ map ppr ps
+pprPat _ (ListP ps) = brackets (commaSep ps)
 pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t
 pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p
 
@@ -283,10 +283,10 @@ ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r
                           $$ where_clause ds
 ppr_dec _ (TySynD t xs rhs)
   = ppr_tySyn empty t (hsep (map ppr xs)) rhs
-ppr_dec _ (DataD ctxt t xs cs decs)
-  = ppr_data empty ctxt t (hsep (map ppr xs)) cs decs
-ppr_dec _ (NewtypeD ctxt t xs c decs)
-  = ppr_newtype empty ctxt t (sep (map ppr xs)) c decs
+ppr_dec _ (DataD ctxt t xs ksig cs decs)
+  = ppr_data empty ctxt t (hsep (map ppr xs)) ksig cs decs
+ppr_dec _ (NewtypeD ctxt t xs ksig c decs)
+  = ppr_newtype empty ctxt t (sep (map ppr xs)) ksig c decs
 ppr_dec _  (ClassD ctxt c xs fds ds)
   = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
     $$ where_clause ds
@@ -303,13 +303,13 @@ ppr_dec isTop (DataFamilyD tc tvs kind)
                 | otherwise = empty
     maybeKind | (Just k') <- kind = dcolon <+> ppr k'
               | otherwise = empty
-ppr_dec isTop (DataInstD ctxt tc tys cs decs)
-  = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) cs decs
+ppr_dec isTop (DataInstD ctxt tc tys ksig cs decs)
+  = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) ksig cs decs
   where
     maybeInst | isTop     = text "instance"
               | otherwise = empty
-ppr_dec isTop (NewtypeInstD ctxt tc tys c decs)
-  = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) c decs
+ppr_dec isTop (NewtypeInstD ctxt tc tys ksig c decs)
+  = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) ksig c decs
   where
     maybeInst | isTop     = text "instance"
               | otherwise = empty
@@ -339,11 +339,11 @@ ppr_dec _ (StandaloneDerivD cxt ty)
 ppr_dec _ (DefaultSigD n ty)
   = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ]
 
-ppr_data :: Doc -> Cxt -> Name -> Doc -> [Con] -> Cxt -> Doc
-ppr_data maybeInst ctxt t argsDoc cs decs
+ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> Cxt -> Doc
+ppr_data maybeInst ctxt t argsDoc ksig cs decs
   = sep [text "data" <+> maybeInst
             <+> pprCxt ctxt
-            <+> ppr t <+> argsDoc,
+            <+> ppr t <+> argsDoc <+> ksigDoc <+> maybeWhere,
          nest nestDepth (sep (pref $ map ppr cs)),
          if null decs
            then empty
@@ -351,19 +351,39 @@ ppr_data maybeInst ctxt t argsDoc cs decs
               $ text "deriving" <+> ppr_cxt_preds decs]
   where
     pref :: [Doc] -> [Doc]
-    pref []     = []      -- No constructors; can't happen in H98
-    pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds
-
-ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Con -> Cxt -> Doc
-ppr_newtype maybeInst ctxt t argsDoc c decs
+    pref xs | isGadtDecl = xs
+    pref []              = []      -- No constructors; can't happen in H98
+    pref (d:ds)          = (char '=' <+> d):map (char '|' <+>) ds
+
+    maybeWhere :: Doc
+    maybeWhere | isGadtDecl = text "where"
+               | otherwise  = empty
+
+    isGadtDecl :: Bool
+    isGadtDecl = not (null cs) && all isGadtCon cs
+        where isGadtCon (GadtC _ _ _ _   ) = True
+              isGadtCon (RecGadtC _ _ _ _) = True
+              isGadtCon (ForallC _ _ x   ) = isGadtCon x
+              isGadtCon  _                 = False
+
+    ksigDoc = case ksig of
+                Nothing -> empty
+                Just k  -> dcolon <+> ppr k
+
+ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> Con -> Cxt -> Doc
+ppr_newtype maybeInst ctxt t argsDoc ksig c decs
   = sep [text "newtype" <+> maybeInst
             <+> pprCxt ctxt
-            <+> ppr t <+> argsDoc,
+            <+> ppr t <+> argsDoc <+> ksigDoc,
          nest 2 (char '=' <+> ppr c),
          if null decs
            then empty
            else nest nestDepth
                 $ text "deriving" <+> ppr_cxt_preds decs]
+  where
+    ksigDoc = case ksig of
+                Nothing -> empty
+                Just k  -> dcolon <+> ppr k
 
 ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc
 ppr_tySyn maybeInst t argsDoc rhs
@@ -380,7 +400,7 @@ ppr_tf_head (TypeFamilyHead tc tvs res inj)
 instance Ppr FunDep where
     ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)
     ppr_list [] = empty
-    ppr_list xs = char '|' <+> sep (punctuate (text ", ") (map ppr xs))
+    ppr_list xs = char '|' <+> commaSep xs
 
 ------------------------------
 instance Ppr FamFlavour where
@@ -478,13 +498,46 @@ instance Ppr Clause where
 ------------------------------
 instance Ppr Con where
     ppr (NormalC c sts) = ppr c <+> sep (map pprStrictType sts)
+
     ppr (RecC c vsts)
         = ppr c <+> braces (sep (punctuate comma $ map pprVarStrictType vsts))
+
     ppr (InfixC st1 c st2) = pprStrictType st1
                          <+> pprName' Infix c
                          <+> pprStrictType st2
-    ppr (ForallC ns ctxt con) = text "forall" <+> hsep (map ppr ns)
-                            <+> char '.' <+> sep [pprCxt ctxt, ppr con]
+
+    ppr (ForallC ns ctxt (GadtC c sts ty idx))
+        = commaSep c <+> dcolon <+> pprForall ns ctxt <+> pprGadtRHS sts ty idx
+
+    ppr (ForallC ns ctxt (RecGadtC c vsts ty idx))
+        = commaSep c <+> dcolon <+> pprForall ns ctxt
+      <+> pprRecFields vsts ty idx
+
+    ppr (ForallC ns ctxt con)
+        = pprForall ns ctxt <+> ppr con
+
+    ppr (GadtC c sts ty idx)
+        = commaSep c <+> dcolon <+> pprGadtRHS sts ty idx
+
+    ppr (RecGadtC c vsts ty idx)
+        = commaSep c <+> dcolon <+> pprRecFields vsts ty idx
+
+pprForall :: [TyVarBndr] -> Cxt -> Doc
+pprForall ns ctxt
+    = text "forall" <+> hsep (map ppr ns)
+  <+> char '.' <+> pprCxt ctxt
+
+pprRecFields :: [(Name, Strict, Type)] -> Name -> [Type] -> Doc
+pprRecFields vsts ty idx
+    = braces (sep (punctuate comma $ map pprVarStrictType vsts))
+  <+> arrow <+> ppr ty <+> sep (map ppr idx)
+
+pprGadtRHS :: [(Strict, Type)] -> Name -> [Type] -> Doc
+pprGadtRHS [] ty idx
+    = ppr ty <+> sep (map ppr idx)
+pprGadtRHS sts ty idx
+    = sep (punctuate (space <> arrow) (map pprStrictType sts))
+  <+> arrow <+> ppr ty <+> sep (map ppr idx)
 
 ------------------------------
 pprVarStrictType :: (Name, Strict, Type) -> Doc
@@ -548,9 +601,9 @@ pprTyApp (EqualityT, [arg1, arg2]) =
     sep [pprFunArgType arg1 <+> text "~", ppr arg2]
 pprTyApp (ListT, [arg]) = brackets (ppr arg)
 pprTyApp (TupleT n, args)
- | length args == n = parens (sep (punctuate comma (map ppr args)))
+ | length args == n = parens (commaSep args)
 pprTyApp (PromotedTupleT n, args)
- | length args == n = quoteParens (sep (punctuate comma (map ppr args)))
+ | length args == n = quoteParens (commaSep args)
 pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args)
 
 pprFunArgType :: Type -> Doc    -- Should really use a precedence argument
@@ -591,7 +644,7 @@ pprCxt ts = ppr_cxt_preds ts <+> text "=>"
 ppr_cxt_preds :: Cxt -> Doc
 ppr_cxt_preds [] = empty
 ppr_cxt_preds [t] = ppr t
-ppr_cxt_preds ts = parens (sep $ punctuate comma $ map ppr ts)
+ppr_cxt_preds ts = parens (commaSep ts)
 
 ------------------------------
 instance Ppr Range where
@@ -629,3 +682,13 @@ instance Ppr Loc where
            , parens $ int start_ln <> comma <> int start_col
            , text "-"
            , parens $ int end_ln <> comma <> int end_col ]
+
+-- Takes a list of printable things and prints them separated by commas followed
+-- by space.
+commaSep :: Ppr a => [a] -> Doc
+commaSep = sep . punctuate comma . map ppr
+
+-- Takes a list of printable things and prints them separated by semicolons
+-- followed by space.
+semiSep :: Ppr a => [a] -> Doc
+semiSep = sep . punctuate semi . map ppr
index 1a99207..acef327 100644 (file)
@@ -21,10 +21,10 @@ module Language.Haskell.TH.PprLib (
         parens, brackets, braces, quotes, doubleQuotes,
 
         -- * Combining documents
-        (<>), (<+>), hcat, hsep, 
-        ($$), ($+$), vcat, 
-        sep, cat, 
-        fsep, fcat, 
+        (<>), (<+>), hcat, hsep,
+        ($$), ($+$), vcat,
+        sep, cat,
+        fsep, fcat,
         nest,
         hang, punctuate,
 
@@ -98,8 +98,8 @@ hcat   :: [Doc] -> Doc;          -- ^List version of '<>'
 hsep   :: [Doc] -> Doc;          -- ^List version of '<+>'
 
 ($$)   :: Doc -> Doc -> Doc;     -- ^Above; if there is no
-                                -- overlap it \"dovetails\" the two
-($+$)   :: Doc -> Doc -> Doc;    -- ^Above, without dovetailing.
+                                 -- overlap it \"dovetails\" the two
+($+$)  :: Doc -> Doc -> Doc;     -- ^Above, without dovetailing.
 vcat   :: [Doc] -> Doc;          -- ^List version of '$$'
 
 cat    :: [Doc] -> Doc;          -- ^ Either hcat or vcat
@@ -112,9 +112,9 @@ nest   :: Int -> Doc -> Doc;     -- ^ Nested
 
 -- GHC-specific ones.
 
-hang :: Doc -> Int -> Doc -> Doc;       -- ^ @hang d1 n d2 = sep [d1, nest n d2]@
-punctuate :: Doc -> [Doc] -> [Doc];      -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
-
+hang :: Doc -> Int -> Doc -> Doc;      -- ^ @hang d1 n d2 = sep [d1, nest n d2]@
+punctuate :: Doc -> [Doc] -> [Doc]
+   -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
 
 -- ---------------------------------------------------------------------------
 -- The "implementation"
@@ -227,4 +227,3 @@ punctuate p (d:ds) = go d ds
                    where
                      go d' [] = [d']
                      go d' (e:es) = (d' <> p) : go e es
-
index a9a8c39..b333b00 100644 (file)
@@ -1473,10 +1473,13 @@ data Dec
   = FunD Name [Clause]            -- ^ @{ f p1 p2 = b where decs }@
   | ValD Pat Body [Dec]           -- ^ @{ p = b where decs }@
   | DataD Cxt Name [TyVarBndr]
-         [Con] Cxt                -- ^ @{ data Cxt x => T x = A x | B (T x)
-                                  --       deriving (Z,W Q)}@
+          (Maybe Kind)            -- Kind signature (allowed only for GADTs)
+          [Con] Cxt
+                                  -- ^ @{ data Cxt x => T x = A x | B (T x)
+                                  --       deriving (Z,W)}@
   | NewtypeD Cxt Name [TyVarBndr]
-         Con Cxt                  -- ^ @{ newtype Cxt x => T x = A (B x)
+             (Maybe Kind)         -- Kind signature
+             Con Cxt              -- ^ @{ newtype Cxt x => T x = A (B x)
                                   --       deriving (Z,W Q)}@
   | TySynD Name [TyVarBndr] Type  -- ^ @{ type T x = (x,x) }@
   | ClassD Cxt Name [TyVarBndr]
@@ -1498,12 +1501,14 @@ data Dec
          -- ^ @{ data family T a b c :: * }@
 
   | DataInstD Cxt Name [Type]
-         [Con] Cxt                -- ^ @{ data instance Cxt x => T [x] = A x
-                                  --                                | B (T x)
-                                  --       deriving (Z,W Q)}@
+             (Maybe Kind)         -- Kind signature
+             [Con] Cxt            -- ^ @{ data instance Cxt x => T [x]
+                                  --       = A x | B (T x) deriving (Z,W)}@
+
   | NewtypeInstD Cxt Name [Type]
-         Con Cxt                  -- ^ @{ newtype instance Cxt x => T [x] = A (B x)
-                                  --       deriving (Z,W)}@
+                 (Maybe Kind)     -- Kind signature
+                 Con Cxt          -- ^ @{ newtype instance Cxt x => T [x]
+                                  --        = A (B x) deriving (Z,W)}@
   | TySynInstD Name TySynEqn      -- ^ @{ type instance ... }@
 
   -- | open type families (may also appear in [Dec] of 'ClassD' and 'InstanceD')
@@ -1591,12 +1596,31 @@ type Pred = Type
 data Strict = IsStrict | NotStrict | Unpacked
          deriving( Show, Eq, Ord, Data, Typeable, Generic )
 
-data Con = NormalC Name [StrictType]          -- ^ @C Int a@
-         | RecC Name [VarStrictType]          -- ^ @C { v :: Int, w :: a }@
-         | InfixC StrictType Name StrictType  -- ^ @Int :+ a@
-         | ForallC [TyVarBndr] Cxt Con        -- ^ @forall a. Eq a => C [a]@
+data Con = NormalC Name [StrictType]         -- ^ @C Int a@
+         | RecC Name [VarStrictType]         -- ^ @C { v :: Int, w :: a }@
+         | InfixC StrictType Name StrictType -- ^ @Int :+ a@
+         | ForallC [TyVarBndr] Cxt Con       -- ^ @forall a. Eq a => C [a]@
+         | GadtC [Name] [StrictType]
+                 Name                        -- See Note [GADT return type]
+                 [Type]                      -- Indices of the type constructor
+                                             -- ^ @C :: a -> b -> T b Int@
+         | RecGadtC [Name] [VarStrictType]
+                    Name                     -- See Note [GADT return type]
+                    [Type]                   -- Indices of the type constructor
+                                             -- ^ @C :: { v :: Int } -> T b Int@
          deriving( Show, Eq, Ord, Data, Typeable, Generic )
 
+-- Note [GADT return type]
+-- ~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- The name of the return type stored by a GADT constructor does not necessarily
+-- match the name of the data type:
+--
+-- type S = T
+--
+-- data T a where
+--     MkT :: S Int
+
 type StrictType = (Strict, Type)
 type VarStrictType = (Name, Strict, Type)
 
index 2ba8e41..2791dc4 100644 (file)
@@ -12,7 +12,7 @@ data S = MkS { foo :: Int }
 
 $(do info <- reify ''R
      case info of
-       TyConI (DataD _ _ _ [RecC _ [(foo_n, _, _), (bar_n, _, _)]] _)
+       TyConI (DataD _ _ _ [RecC _ [(foo_n, _, _), (bar_n, _, _)]] _)
          -> do { reify bar_n -- This is unambiguous
                ; reify foo_n -- This is ambiguous
                ; return []
index e70c5db..e97fdce 100644 (file)
@@ -6,7 +6,8 @@ import Language.Haskell.TH
 import Language.Haskell.TH.Syntax
 
 -- Splice in a datatype with field...
-$(return [DataD [] (mkName "R") [] [RecC (mkName "MkR") [(mkName "foo", NotStrict, ConT ''Int)]] []])
+$(return [DataD [] (mkName "R") [] Nothing
+          [RecC (mkName "MkR") [(mkName "foo", NotStrict, ConT ''Int)]] []])
 
 -- New TH story means reify only sees R if we do this:
 $(return [])
@@ -14,7 +15,7 @@ $(return [])
 -- ... and check that we can inspect it
 main = do  putStrLn $(do { info <- reify ''R
                          ; case info of
-                             TyConI (DataD _ _ _ [RecC _ [(n, _, _)]] _) ->
+                             TyConI (DataD _ _ _ [RecC _ [(n, _, _)]] _) ->
                                  do { info' <- reify n
                                     ; lift (pprint info ++ "\n" ++ pprint info')
                                     }
index 4bca2ad..4dc013a 100644 (file)
@@ -19,6 +19,7 @@ largeData =
     (cxt [])
     (dataName)
     []
+    Nothing
     [normalC dataName (replicate size (((,) <$> notStrict) `ap` [t| Int |]))]
     (cxt [])
 
index 8d81be6..ec4f7c9 100644 (file)
@@ -8,7 +8,7 @@ class Class a where
 
 mkSimpleClass :: Name -> Q [Dec]
 mkSimpleClass name = do
-       TyConI (DataD [] dname [] cs _) <- reify name
+       TyConI (DataD [] dname [] Nothing cs _) <- reify name
        ((NormalC conname []):_) <- return cs
        ClassI (ClassD [] cname [_] [] [SigD mname _]) _ <- reify ''Class
        return [InstanceD [] (AppT (ConT cname) (ConT dname)) [FunD mname
index 1e5b225..af7e5cf 100644 (file)
@@ -9,7 +9,7 @@ class Class a where
 
 mkSimpleClass :: Name -> Q [Dec]
 mkSimpleClass name = do
-       TyConI (DataD [] dname [] cs _) <- reify name
+       TyConI (DataD [] dname [] Nothing cs _) <- reify name
        ((NormalC conname []):_) <- return cs
        ClassI (ClassD [] cname [_] [] [SigD mname _]) _ <- reify ''Class
        return [InstanceD [] (AppT (ConT cname) (ConT dname)) [FunD mname
index aa52a18..94f352e 100644 (file)
@@ -2,5 +2,6 @@ module T10819_Lib where
 
 import Language.Haskell.TH.Syntax
 
-doSomeTH s tp drv = return [NewtypeD [] n [] (NormalC n [(NotStrict, ConT tp)]) drv]
+doSomeTH s tp drv = return [NewtypeD [] n [] Nothing
+                            (NormalC n [(NotStrict, ConT tp)]) drv]
   where n = mkName s
diff --git a/testsuite/tests/th/T10828.hs b/testsuite/tests/th/T10828.hs
new file mode 100644 (file)
index 0000000..f01c5b9
--- /dev/null
@@ -0,0 +1,61 @@
+{-# LANGUAGE TemplateHaskell, GADTs, ExplicitForAll, KindSignatures,
+             TypeFamilies, DataKinds #-}
+
+module T10828 where
+
+import Language.Haskell.TH
+import System.IO
+
+$( do { decl <- [d| data family D a :: * -> *
+                    data instance D Int Bool :: * where
+                         DInt :: D Int Bool
+
+                    data E where
+                      MkE :: a -> E
+
+                    data Foo a b where
+                      MkFoo, MkFoo' :: a -> Foo a b
+
+                    newtype Bar :: * -> Bool -> * where
+                      MkBar :: a -> Bar a b
+                 |]
+
+      ; runIO $ putStrLn (pprint decl) >> hFlush stdout
+      ; return decl }
+ )
+
+-- data T a :: * where
+--    MkT :: a -> a -> T a
+--    MkC :: forall a b. (a ~ Int) => { foo :: a, bar :: b } -> T Int
+
+$( return
+   [ DataD [] (mkName "T")
+           [ PlainTV (mkName "a") ]
+           (Just StarT)
+           [ GadtC [(mkName "MkT")]
+                   [ (NotStrict, VarT (mkName "a"))
+                   , (NotStrict, VarT (mkName "a"))]
+                   ( mkName "T" )
+                   [ VarT (mkName "a") ]
+           , ForallC [PlainTV (mkName "a"), PlainTV (mkName "b")]
+                     [AppT (AppT EqualityT (VarT $ mkName "a"  ) )
+                                           (ConT $ mkName "Int") ] $
+             RecGadtC [(mkName "MkC")]
+                  [ (mkName "foo", NotStrict, VarT (mkName "a"))
+                  , (mkName "bar", NotStrict, VarT (mkName "b"))]
+                  ( mkName "T" )
+                  [ ConT (mkName "Int") ] ]
+           [] ])
+
+$( do { -- test reification
+        TyConI dec <- runQ $ reify (mkName "T")
+      ; runIO $ putStrLn (pprint dec) >> hFlush stdout
+
+        -- test quoting
+      ; d <- runQ $ [d|
+             data T' a :: * where
+                MkT' :: a -> a -> T' a
+                MkC' :: forall a b. (a ~ Int) => { foo :: a, bar :: b }
+                                              -> T' Int |]
+      ; runIO $ putStrLn (pprint d) >> hFlush stdout
+      ; return [] } )
diff --git a/testsuite/tests/th/T10828.stderr b/testsuite/tests/th/T10828.stderr
new file mode 100644 (file)
index 0000000..91653f9
--- /dev/null
@@ -0,0 +1,100 @@
+data family D_0 a_1 :: * -> *
+data instance D_0 GHC.Types.Int GHC.Types.Bool :: * where
+    DInt_2 :: D_0 GHC.Types.Int GHC.Types.Bool
+data E_3 where MkE_4 :: forall a_5 . a_5 -> E_3
+data Foo_6 a_7 b_8 where
+    MkFoo_9, MkFoo'_10 :: forall a_11 b_12 . a_11 -> Foo_6 a_11 b_12
+newtype Bar_13 :: * -> GHC.Types.Bool -> *
+  = MkBar_14 :: forall a_15 b_16 . a_15 -> Bar_13 a_15 b_16
+data T10828.T (a_0 :: *) where
+    T10828.MkT :: forall (a_1 :: *) . a_1 -> a_1 -> T10828.T a_1
+    T10828.MkC :: forall (a_2 :: *) (b_3 :: *) . Data.Type.Equality.~ a_2
+                                                                       GHC.Types.Int => {T10828.foo :: a_2,
+                                                                                         T10828.bar :: b_3} -> T10828.T GHC.Types.Int
+data T'_0 a_1 :: * where
+    MkT'_2 :: forall a_3 . a_3 -> a_3 -> T'_0 a_3
+    MkC'_4 :: forall a_5 b_6 . a_5 ~ GHC.Types.Int => {foo_7 :: a_5,
+                                                       bar_8 :: b_6} -> T'_0 GHC.Types.Int
+TYPE SIGNATURES
+TYPE CONSTRUCTORS
+  type role Bar representational phantom
+  newtype Bar a (b :: Bool) where
+    MkBar :: a -> Bar a b
+    Kind: GHC.Types.Type -> Bool -> GHC.Types.Type
+  data family D a0 b
+  data E where
+    MkE :: a0 -> E
+    Kind: *
+  type role Foo representational phantom
+  data Foo a0 b0 where
+    MkFoo :: a0 -> Foo a0 b0
+    MkFoo' :: a0 -> Foo a0 b0
+    Kind: * -> * -> *
+  type role T nominal
+  data T a where
+    MkT :: a -> a -> T a
+    MkC :: a1 ~ Int => {foo :: a1, bar :: b} -> T Int
+    Kind: * -> GHC.Types.Type
+COERCION AXIOMS
+  axiom T10828.NTCo:Bar :: Bar a b = a -- Defined at T10828.hs:9:4
+  axiom T10828.TFCo:R:DIntBool ::
+    D Int Bool = T10828.R:DIntBool -- Defined at T10828.hs:9:4
+FAMILY INSTANCES
+  data instance D Int Bool
+Dependent modules: []
+Dependent packages: [array-<VERSION>, base-<VERSION>, binary-<VERSION>,
+                     bytestring-<VERSION>, containers-<VERSION>, deepseq-<VERSION>,
+                     ghc-boot-<VERSION>, ghc-prim-<VERSION>, integer-<IMPL>-<VERSION>,
+                     pretty-<VERSION>, template-haskell-<VERSION>]
+
+==================== Typechecker ====================
+foo = ()
+bar = ()
+T10828.$tcT
+  = GHC.Types.TyCon 0## 0## T10828.$trModule
+      (GHC.Types.TrNameS "T"#)
+T10828.$tc'MkT
+  = GHC.Types.TyCon
+      0## 0## T10828.$trModule
+      (GHC.Types.TrNameS "'MkT"#)
+T10828.$tc'MkC
+  = GHC.Types.TyCon
+      0## 0## T10828.$trModule
+      (GHC.Types.TrNameS "'MkC"#)
+T10828.$tc'DInt
+  = GHC.Types.TyCon
+      0## 0## T10828.$trModule
+      (GHC.Types.TrNameS "'DInt"#)
+T10828.$tcBar
+  = GHC.Types.TyCon
+      0## 0## T10828.$trModule
+      (GHC.Types.TrNameS "Bar"#)
+T10828.$tc'MkBar
+  = GHC.Types.TyCon
+      0## 0## T10828.$trModule
+      (GHC.Types.TrNameS "'MkBar"#)
+T10828.$tcFoo
+  = GHC.Types.TyCon
+      0## 0## T10828.$trModule
+      (GHC.Types.TrNameS "Foo"#)
+T10828.$tc'MkFoo
+  = GHC.Types.TyCon
+      0## 0## T10828.$trModule
+      (GHC.Types.TrNameS "'MkFoo"#)
+T10828.$tc'MkFoo'
+  = GHC.Types.TyCon
+      0## 0## T10828.$trModule
+      (GHC.Types.TrNameS "'MkFoo'"#)
+T10828.$tcE
+  = GHC.Types.TyCon 0## 0## T10828.$trModule
+      (GHC.Types.TrNameS "E"#)
+T10828.$tc'MkE
+  = GHC.Types.TyCon
+      0## 0## T10828.$trModule
+      (GHC.Types.TrNameS "'MkE"#)
+T10828.$tcD
+  = GHC.Types.TyCon 0## 0## T10828.$trModule
+      (GHC.Types.TrNameS "D"#)
+T10828.$trModule
+  = GHC.Types.Module
+      (GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "T10828"#)
diff --git a/testsuite/tests/th/T10828a.hs b/testsuite/tests/th/T10828a.hs
new file mode 100644 (file)
index 0000000..8bf13cf
--- /dev/null
@@ -0,0 +1,17 @@
+{-# LANGUAGE TemplateHaskell, GADTs, ExplicitForAll, KindSignatures #-}
+
+module T10828a where
+
+import Language.Haskell.TH
+import System.IO
+
+-- attempting to place a kind signature on a H98 data type
+$( return
+   [ DataD [] (mkName "T")
+           [ PlainTV (mkName "a") ]
+           (Just StarT)
+           [ NormalC (mkName "MkT")
+                   [ (NotStrict, VarT (mkName "a"))
+                   , (NotStrict, VarT (mkName "a"))]
+           ]
+           [] ])
diff --git a/testsuite/tests/th/T10828a.stderr b/testsuite/tests/th/T10828a.stderr
new file mode 100644 (file)
index 0000000..9c05b83
--- /dev/null
@@ -0,0 +1,4 @@
+
+T10828a.hs:9:4:
+    Kind signatures are only allowed on GADTs
+    When splicing a TH declaration: data T a :: * = MkT a a
diff --git a/testsuite/tests/th/T10828b.hs b/testsuite/tests/th/T10828b.hs
new file mode 100644 (file)
index 0000000..55d8889
--- /dev/null
@@ -0,0 +1,25 @@
+{-# LANGUAGE TemplateHaskell, GADTs, ExplicitForAll, KindSignatures #-}
+
+module T10828b where
+
+import Language.Haskell.TH
+import System.IO
+
+-- attempting to mix GADT and normal constructors
+$( return
+   [ DataD [] (mkName "T")
+           [ PlainTV (mkName "a") ]
+           (Just StarT)
+           [ NormalC (mkName "MkT")
+                   [ (NotStrict, VarT (mkName "a"))
+                   , (NotStrict, VarT (mkName "a"))]
+           , ForallC [PlainTV (mkName "a")]
+                     [AppT (AppT EqualityT (VarT $ mkName "a"  ) )
+                                           (ConT $ mkName "Int") ] $
+             RecGadtC [(mkName "MkC")]
+                  [ (mkName "foo", NotStrict, VarT (mkName "a"))
+                  , (mkName "bar", NotStrict, VarT (mkName "b"))]
+                  ( mkName "T" )
+                  [ ConT (mkName "Int") ]
+           ]
+           [] ])
diff --git a/testsuite/tests/th/T10828b.stderr b/testsuite/tests/th/T10828b.stderr
new file mode 100644 (file)
index 0000000..bbc57dd
--- /dev/null
@@ -0,0 +1,7 @@
+
+T10828b.hs:9:4:
+    Cannot mix GADT constructors with Haskell 98 constructors
+    When splicing a TH declaration:
+      data T a :: *
+    = MkT a a
+    | MkC :: forall a . a ~ Int => {foo :: a, bar :: b} -> T Int
index bea2e80..2e4155f 100644 (file)
@@ -1,9 +1,8 @@
 data T4188.T1 (a_0 :: *) = forall (b_1 :: *) . T4188.MkT1 a_0 b_1
 data T4188.T2 (a_0 :: *)
-    = forall (b_1 :: *) . (T4188.C a_0, T4188.C b_1) =>
-                          T4188.MkT2 a_0 b_1
-data T4188.T3 (x_0 :: *)
-    = forall (x_1 :: *) (y_2 :: *) . (x_0 ~ (x_1, y_2),
-                                      T4188.C x_1,
-                                      T4188.C y_2) =>
-                                     T4188.MkT3 x_1 y_2
+    = forall (b_1 :: *) . (T4188.C a_0, T4188.C b_1) => T4188.MkT2 a_0
+                                                                   b_1
+data T4188.T3 (x_0 :: *) where
+    T4188.MkT3 :: forall (x_1 :: *) (y_2 :: *) . (T4188.C x_1,
+                                                  T4188.C y_2) => x_1 -> y_2 -> T4188.T3 (x_1, y_2)
+
index 9dd1f1c..ea28c74 100644 (file)
@@ -1,11 +1,9 @@
-{-# LANGUAGE GADTs #-}\r
-\r
-module T5217 where\r
-import Language.Haskell.TH\r
-\r
-$([d| data T a b where { T1 :: Int -> T Int Char \r
-                       ; T2 :: a -> T a a\r
-                       ; T3 :: a -> T [a] a\r
-                       ; T4 :: a -> b -> T b [a] } |])\r
-\r
-\r
+{-# LANGUAGE GADTs #-}
+
+module T5217 where
+import Language.Haskell.TH
+
+$([d| data T a b where { T1 :: Int -> T Int Char
+                       ; T2 :: a -> T a a
+                       ; T3 :: a -> T [a] a
+                       ; T4 :: a -> b -> T b [a] } |])
index f69875b..fe9150d 100644 (file)
@@ -7,7 +7,8 @@ T5217.hs:(6,3)-(9,53): Splicing declarations
             T4 :: a -> b -> T b [a] |]\r
   ======>\r
     data T a b\r
-      = (b ~ Char, a ~ Int) => T1 Int |\r
-        b ~ a => T2 a |\r
-        a ~ [b] => T3 b |\r
-        forall a. b ~ [a] => T4 a a\r
+      where\r
+        T1 :: Int -> T Int Char\r
+        T2 :: forall a. a -> T a a\r
+        T3 :: forall a. a -> T [a] a\r
+        T4 :: forall a b. a -> b -> T b [a]\r
index 7973a13..50ad2d5 100644 (file)
@@ -5,4 +5,4 @@ module T5290 where
 import Language.Haskell.TH
 
 $( let n = mkName "T"
-   in return [DataD [] n [] [NormalC n [(Unpacked,ConT ''Int)]] []] )
+   in return [DataD [] n [] Nothing [NormalC n [(Unpacked,ConT ''Int)]] []] )
index 2b4275d..d6996d0 100644 (file)
@@ -1,5 +1,7 @@
-T5290.hs:(7,4)-(8,67): Splicing declarations
+T5290.hs:(7,4)-(8,75): Splicing declarations
     let n = mkName "T"
-    in return [DataD [] n [] [NormalC n [(Unpacked, ConT ''Int)]] []]
+    in
+      return
+        [DataD [] n [] Nothing [NormalC n [(Unpacked, ConT ''Int)]] []]
   ======>
     data T = T {-# UNPACK #-} !Int
index eba5a1a..b34131e 100644 (file)
@@ -1,6 +1,7 @@
-module T5665a where\r
-\r
-import Language.Haskell.TH\r
-\r
-doSomeTH s tp = return [NewtypeD [] n [] (NormalC n [(NotStrict, ConT tp)]) []]\r
-   where n = mkName s\r
+module T5665a where
+
+import Language.Haskell.TH
+
+doSomeTH s tp = return [NewtypeD [] n [] Nothing
+                        (NormalC n [(NotStrict, ConT tp)]) []]
+   where n = mkName s
index c3abfa2..a929086 100644 (file)
@@ -5,9 +5,10 @@ module T5984_Lib where
 import Language.Haskell.TH
 
 nt :: Q [Dec]
-nt = return [NewtypeD [] foo [] (NormalC foo [(NotStrict, ConT ''Int)]) []]
+nt = return [NewtypeD [] foo [] Nothing
+             (NormalC foo [(NotStrict, ConT ''Int)]) []]
   where foo = mkName "Foo"
 
 dt :: Q [Dec]
-dt = return [DataD [] bar [] [NormalC bar [(NotStrict, ConT ''Int)]] []]
+dt = return [DataD [] bar [] Nothing [NormalC bar [(NotStrict, ConT ''Int)]] []]
   where bar = mkName "Bar"
index 971a267..8eee280 100644 (file)
@@ -4,4 +4,4 @@ module T7241 where
 
 import Language.Haskell.TH
 
-$(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] []])
+$(newName "Foo" >>= \o -> return [DataD [] o [] Nothing [RecC o []] []])
index 5a5f45a..42976b3 100644 (file)
@@ -11,5 +11,5 @@ class C a where
 bang :: DecsQ
 bang = return [
      InstanceD [] (AppT (ConT ''C) (ConT ''Int)) [
-         DataInstD [] ''D [ConT ''Int] [
-             NormalC (mkName "T") []] []]] 
+         DataInstD [] ''D [ConT ''Int] Nothing [
+             NormalC (mkName "T") []] []]]
index 7829e99..29b9e16 100644 (file)
@@ -5,7 +5,7 @@ module T8499 where
 
 import Language.Haskell.TH
 
-$( do TyConI (DataD _ _ [KindedTV tvb_a _] _ _) <- reify ''Maybe
+$( do TyConI (DataD _ _ [KindedTV tvb_a _] _ _ _) <- reify ''Maybe
       my_a <- newName "a"
       return [TySynD (mkName "SMaybe")
                      [KindedTV my_a (AppT (ConT ''Maybe) (VarT tvb_a))]
index 49f67d5..eda7781 100644 (file)
@@ -4,4 +4,5 @@ module T8624 (THDec(..)) where
 
 import Language.Haskell.TH
 
-$(return [DataD [] (mkName "THDec") [] [NormalC (mkName "THDec") []] []])
+$(return [DataD [] (mkName "THDec") [] Nothing
+          [NormalC (mkName "THDec") []] []])
index 82ea195..0dcc7b0 100644 (file)
@@ -1,2 +1,2 @@
--- T8624.hs:7:3-72: Splicing declarations
+-- T8624.hs:(7,3)-(8,43): Splicing declarations
 data THDec = THDec
index 4f8729d..e141b40 100644 (file)
@@ -1,8 +1,9 @@
 
 TH_RichKinds2.hs:24:4: Warning:
-    data SMaybe_0 (t_1 :: k_0 -> *) (t_3 :: GHC.Base.Maybe k_0)
-    = forall . t_3 ~ 'GHC.Base.Nothing => SNothing_4
-    | forall a_5 . t_3 ~ 'GHC.Base.Just a_5 => SJust_6 (t_1 a_5)
+    data SMaybe_0 :: (k_0 -> *) -> GHC.Base.Maybe k_0 -> * where
+    SNothing_2 :: forall s_3 . SMaybe_0 s_3 'GHC.Base.Nothing
+    SJust_4 :: forall s_5 a_6 . (s_5 a_6) -> SMaybe_0 s_5
+                                                      'GHC.Base.Just a_6
 type instance TH_RichKinds2.Map f_7 '[] = '[]
 type instance TH_RichKinds2.Map f_8
                                 ('GHC.Types.: h_9 t_10) = 'GHC.Types.: (f_8 h_9)
index d746fc9..89d072c 100644 (file)
@@ -4,6 +4,6 @@ module TH_Roles1 where
 
 import Language.Haskell.TH
 
-$( return [ DataD [] (mkName "T") [PlainTV (mkName "a")] [] []
+$( return [ DataD [] (mkName "T") [PlainTV (mkName "a")] Nothing [] []
           , RoleAnnotD (mkName "T") [RepresentationalR] ] )
 
index 30f4fc7..3f7b535 100644 (file)
@@ -4,6 +4,7 @@ module TH_Roles2 where
 
 import Language.Haskell.TH
 
-$( return [ DataD [] (mkName "T") [KindedTV (mkName "a") (VarT (mkName "k"))] [] []
+$( return [ DataD [] (mkName "T") [KindedTV (mkName "a") (VarT (mkName "k"))]
+            Nothing [] []
           , RoleAnnotD (mkName "T") [RepresentationalR] ] )
 
index c28d38b..1a51ac4 100644 (file)
@@ -5,7 +5,8 @@ import Language.Haskell.TH
 
 ds :: Q [Dec]
 ds = [d|
-          $(do { d <- dataD (cxt []) (mkName "D") [] [normalC (mkName "K") []] (cxt [])
+          $(do { d <- dataD (cxt []) (mkName "D") [] Nothing
+                             [normalC (mkName "K") []] (cxt [])
                ; return [d]})
        |]
 
index d439231..5e1ee0b 100644 (file)
@@ -12,7 +12,7 @@ genAny decl = do { d <- decl
 
 genAnyClass :: Name -> [Dec] -> Dec
 genAnyClass name decls
-  = DataD [] anyName [] [constructor] []
+  = DataD [] anyName [] Nothing [constructor] []
   where
     anyName = mkName ("Any" ++ nameBase name ++ "1111")
     constructor = ForallC [PlainTV var_a] [AppT (ConT name) (VarT var_a)] $
index 618218d..94070a3 100644 (file)
@@ -7,4 +7,4 @@ import Language.Haskell.TH
 
 
 -- splice a simple data declaration
-$(return [DataD [] (mkName "T") [] [NormalC (mkName "C") []] []])
+$(return [DataD [] (mkName "T") [] Nothing [NormalC (mkName "C") []] []])
index 1b8d44e..bc1c268 100644 (file)
@@ -4,8 +4,9 @@ where
 import Language.Haskell.TH
 
 rename' :: Dec -> Q [Dec]
-rename' (DataD ctxt tyName tyvars cons derivs) =
-  return [DataD ctxt (stripMod tyName) tyvars (map renameCons cons) derivs]
+rename' (DataD ctxt tyName tyvars ksig cons derivs) =
+  return [DataD ctxt (stripMod tyName) tyvars ksig
+          (map renameCons cons) derivs]
   where
     renameCons (NormalC conName tys) = NormalC (stripMod conName) tys
     --
index 45ee2df..5a55b6f 100644 (file)
@@ -369,6 +369,13 @@ test('T10796a', normal, compile, ['-v0'])
 test('T10796b', normal, compile_fail, ['-v0'])
 test('T10811', normal, compile, ['-v0'])
 test('T10810', normal, compile, ['-v0'])
+test('T10828', normalise_version('array', 'base', 'binary', 'bytestring',
+                                 'containers', 'deepseq', 'ghc-boot',
+                                 'ghc-prim', 'integer-gmp', 'pretty',
+                                 'template-haskell'
+                              ), compile, ['-v0 -ddump-tc -dsuppress-uniques'])
+test('T10828a', normal, compile_fail, ['-v0'])
+test('T10828b', normal, compile_fail, ['-v0'])
 test('T10891', normal, compile, ['-v0'])
 test('T10945', normal, compile_fail, ['-v0'])
 test('T10946', expect_broken(10946), compile, ['-v0'])