diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 8d701af329346d27633c66cbcfc694c982c7f562..d833baf1ebb6b2848d0a58972b64f90a32151c47 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -302,7 +302,7 @@ repDataDefn tc bndrs opt_tys tv_names
_cs -> failWithDs (ptext
(sLit "Multiple constructors for newtype:")
<+> pprQuotedList
- (con_names $ unLoc $ head cons))
+ (getConNames $ unLoc $ head cons))
}
DataType -> do { consL <- concatMapM (repC tv_names) cons
; cons1 <- coreList conQTyConName consL
@@ -623,26 +623,54 @@ repAnnProv ModuleAnnProvenance
-------------------------------------------------------
repC :: [Name] -> LConDecl Name -> DsM [Core TH.ConQ]
-repC _ (L _ (ConDecl { con_names = con, con_qvars = con_tvs, con_cxt = L _ []
- , con_details = details, con_res = ResTyH98 }))
- | null (hsQTvBndrs con_tvs)
- = do { con1 <- mapM lookupLOcc con -- See Note [Binders and occurrences]
- ; mapM (\c -> repConstr c details) con1 }
-
-repC tvs (L _ (ConDecl { con_names = cons
- , con_qvars = con_tvs, con_cxt = L _ ctxt
- , con_details = details
- , con_res = res_ty }))
- = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
+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_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs)
, hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) }
- ; binds <- mapM dupBinder con_tv_subst
+ ; let binds = []
; 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]
- ; c' <- mapM (\c -> repConstr c details) cons1
+ do { con1 <- lookupLOcc con -- See Note [Binders and occurrences]
+ ; c' <- repConstr con1 details
; ctxt' <- repContext (eq_ctxt ++ ctxt)
+ ; if (null (hsq_kvs ex_tvs) && null (hsq_tvs 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_kvs = con_kvs
+ , hsib_tvs = con_tvns })}))
+ = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
+ ; let con_tvs = map (noLoc . UserTyVar . noLoc) con_tvns
+ ; let ex_tvs
+ = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) con_kvs
+ , hsq_tvs = filterOut
+ (in_subst con_tv_subst . hsLTyVarName)
+ con_tvs }
+
+ ; 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]
}
@@ -651,8 +679,37 @@ 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
- -> ResType (LHsType Name)
+ -> 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
@@ -666,16 +723,16 @@ mkGadtCtxt :: [Name] -- Tyvars of the data type
-- (b~[e], c~e), [d->a]
--
-- This function is fiddly, but not really hard
-mkGadtCtxt _ ResTyH98
- = return ([], [])
-mkGadtCtxt data_tvs (ResTyGADT _ res_ty)
- | Just (_, tys) <- hsTyGetAppHead_maybe res_ty
+mkGadtCtxt data_tvs res_ty
+ | Just (_, tys) <- hsTyGetAppHead_maybe ty
, data_tvs `equalLength` tys
= return (go [] [] (data_tvs `zip` tys))
| otherwise
= failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
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
@@ -692,7 +749,6 @@ mkGadtCtxt data_tvs (ResTyGADT _ res_ty)
is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty
is_hs_tyvar _ = Nothing
-
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
repBangTy ty = do
MkC s <- rep2 str []
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 1fc4f09ad9481cc6b75560f0ea1cec173f14b5c8..4decbe12bb573bffc6610bace150c81afee3878c 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -45,7 +45,7 @@ import Control.Applicative (Applicative(..))
import Data.Char ( chr )
import Data.Word ( Word8 )
-import Data.Maybe( catMaybes )
+import Data.Maybe( catMaybes, fromMaybe )
import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH
@@ -423,13 +423,13 @@ cvtConstr (NormalC c strtys)
= do { c' <- cNameL c
; cxt' <- returnL []
; tys' <- mapM cvt_arg strtys
- ; returnL $ mkSimpleConDecl c' Nothing cxt' (PrefixCon tys') }
+ ; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') }
cvtConstr (RecC c varstrtys)
= do { c' <- cNameL c
; cxt' <- returnL []
; args' <- mapM cvt_id_arg varstrtys
- ; returnL $ mkSimpleConDecl c' Nothing cxt'
+ ; returnL $ mkConDeclH98 c' Nothing cxt'
(RecCon (noLoc args')) }
cvtConstr (InfixC st1 c st2)
@@ -437,15 +437,23 @@ cvtConstr (InfixC st1 c st2)
; cxt' <- returnL []
; st1' <- cvt_arg st1
; st2' <- cvt_arg st2
- ; returnL $ mkSimpleConDecl c' Nothing cxt' (InfixCon st1' st2') }
+ ; returnL $ mkConDeclH98 c' Nothing cxt' (InfixCon st1' st2') }
cvtConstr (ForallC tvs ctxt con)
= do { tvs' <- cvtTvs tvs
; L loc ctxt' <- cvtContext ctxt
; L _ con' <- cvtConstr con
- ; returnL $ con' { con_qvars = mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (con_qvars con'))
- , con_explicit = True
- , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
+ ; let qvars = case (tvs,con_qvars con') of
+ ([],Nothing) -> Nothing
+ _ ->
+ Just $ mkHsQTvs (hsQTvBndrs tvs' ++
+ hsQTvBndrs (fromMaybe (HsQTvs PlaceHolder [])
+ (con_qvars con')))
+ ; returnL $ con' { con_qvars = qvars
+ , con_cxt = Just $
+ L loc (ctxt' ++
+ unLoc (fromMaybe (noLoc [])
+ (con_cxt con'))) } }
cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
cvt_arg (NotStrict, ty) = cvtType ty
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index b8612ed2be4c4398d7fc7c0166a11e3a00fd19ff..48348cc2e1c6254171254a8a4c3b0df2cc375849 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -60,8 +60,11 @@ module HsDecls (
noForeignImportCoercionYet, noForeignExportCoercionYet,
CImportSpec(..),
-- ** Data-constructor declarations
- ConDecl(..), LConDecl, ResType(..),
+ ConDecl(..), LConDecl,
HsConDeclDetails, hsConDeclArgTys,
+ getConNames,
+ getConDetails,
+ gadtDeclDetails,
-- ** Document comments
DocDecl(..), LDocDecl, docDeclDoc,
-- ** Deprecations
@@ -106,6 +109,7 @@ import SrcLoc
import FastString
import Bag
+import Data.Maybe ( fromMaybe )
import Data.Data hiding (TyCon,Fixity)
#if __GLASGOW_HASKELL__ < 709
import Data.Foldable ( Foldable )
@@ -956,9 +960,9 @@ data HsDataDefn name -- The payload of a data type defn
-- ^ Data constructors
--
-- For @data T a = T1 | T2 a@
- -- the 'LConDecl's all have 'ResTyH98'.
+ -- the 'LConDecl's all have 'ConDeclH98'.
-- For @data T a where { T1 :: T a }@
- -- the 'LConDecls' all have 'ResTyGADT'.
+ -- the 'LConDecls' all have 'ConDeclGADT'.
dd_derivs :: HsDeriving name -- ^ Optional 'deriving' claues
@@ -1020,71 +1024,64 @@ type LConDecl name = Located (ConDecl name)
-- For details on above see note [Api annotations] in ApiAnnotation
data ConDecl name
- = ConDecl
- { con_names :: [Located name]
- -- ^ Constructor names. This is used for the DataCon itself, and for
- -- the user-callable wrapper Id.
- -- It is a list to deal with GADT constructors of the form
- -- T1, T2, T3 :: <payload>
-
- , con_explicit :: Bool
- -- ^ Is there an user-written forall?
- -- For ResTyH98, "explicit" means something like:
- -- data T = forall a. MkT { x :: a -> a }
- -- For ResTyGADT, "explicit" means something like
- -- data T where { MkT :: forall a. <blah> }
-
- , con_qvars :: LHsQTyVars name
- -- ^ Type variables. Depending on 'con_res' this describes the
- -- following entities
- --
- -- - ResTyH98: the constructor's *existential* type variables
+ = ConDeclGADT
+ { con_names :: [Located name]
+ , con_type :: LHsSigType name
+ -- ^ The type after the ‘::’
+ , con_doc :: Maybe LHsDocString
+ -- ^ A possible Haddock comment.
+ }
+
+ | ConDeclH98
+ { con_name :: Located name
+
+ , con_qvars :: Maybe (LHsQTyVars name)
+ -- User-written forall (if any), and its implicit
+ -- kind variables
+ -- Non-Nothing needs -XExistentialQuantification
-- e.g. data T a = forall b. MkT b (b->a)
-- con_qvars = {b}
- --
- -- - ResTyGADT: *all* the constructor's quantified type variables
- -- e.g. data T a where
- -- MkT :: forall a b. b -> (b->a) -> T a
- -- con_qvars = {a,b}
- --
- -- If con_explicit is False, then con_qvars is irrelevant
- -- until after renaming.
- , con_cxt :: LHsContext name
- -- ^ The context. This /does not/ include the \"stupid theta\" which
- -- lives only in the 'TyData' decl.
+ , con_cxt :: Maybe (LHsContext name)
+ -- ^ User-written context (if any)
- , con_details :: HsConDeclDetails name
- -- ^ The main payload
+ , con_details :: HsConDeclDetails name
+ -- ^ Arguments
- , con_res :: ResType (LHsType name)
- -- ^ Result type of the constructor
-
- , con_doc :: Maybe LHsDocString
- -- ^ A possible Haddock comment.
- } deriving (Typeable)
+ , con_doc :: Maybe LHsDocString
+ -- ^ A possible Haddock comment.
+ } deriving (Typeable)
deriving instance (DataId name) => Data (ConDecl name)
type HsConDeclDetails name
= HsConDetails (LBangType name) (Located [LConDeclField name])
+getConNames :: ConDecl name -> [Located name]
+getConNames ConDeclH98 {con_name = name} = [name]
+getConNames ConDeclGADT {con_names = names} = names
+
+getConDetails :: ConDecl name -> HsConDeclDetails name
+getConDetails ConDeclH98 {con_details = details} = details
+getConDetails ConDeclGADT {con_type = ty } = details
+ where
+ (details,_,_,_) = gadtDeclDetails ty
+
+gadtDeclDetails :: LHsSigType name
+ -> (HsConDeclDetails name,LHsType name,LHsContext name,[LHsTyVarBndr name])
+gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs)
+ where
+ (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)
+ _other -> (PrefixCon [], tau)
+
hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
hsConDeclArgTys (PrefixCon tys) = tys
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds)
-data ResType ty
- = ResTyH98 -- Constructor was declared using Haskell 98 syntax
- | ResTyGADT SrcSpan ty -- Constructor was declared using GADT-style syntax,
- -- and here is its result type, and the SrcSpan
- -- of the original sigtype, for API Annotations
- deriving (Data, Typeable)
-
-instance Outputable ty => Outputable (ResType ty) where
- -- Debugging only
- ppr ResTyH98 = ptext (sLit "ResTyH98")
- ppr (ResTyGADT _ ty) = ptext (sLit "ResTyGADT") <+> ppr ty
-
pp_data_defn :: OutputableBndr name
=> (HsContext name -> SDoc) -- Printing the header
-> HsDataDefn name
@@ -1115,7 +1112,7 @@ instance Outputable NewOrData where
ppr DataType = ptext (sLit "data")
pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
-pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ _ } : _) -- In GADT syntax
+pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax
= hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
pp_condecls cs -- In H98 syntax
= equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
@@ -1124,50 +1121,27 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where
ppr = pprConDecl
pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
-pprConDecl (ConDecl { con_names = [L _ con] -- NB: non-GADT means 1 con
- , con_explicit = expl, con_qvars = tvs
- , con_cxt = cxt, con_details = details
- , con_res = ResTyH98, con_doc = doc })
- = sep [ppr_mbDoc doc, ppr_con_forall expl tvs cxt, ppr_details details]
+pprConDecl (ConDeclH98 { con_name = L _ con
+ , con_qvars = mtvs
+ , con_cxt = mcxt
+ , con_details = details
+ , con_doc = doc })
+ = sep [ppr_mbDoc doc, pprHsForAll tvs cxt, ppr_details details]
where
ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2]
ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con
: map (pprParendHsType . unLoc) tys)
ppr_details (RecCon fields) = pprPrefixOcc con
<+> pprConDeclFields (unLoc fields)
+ tvs = case mtvs of
+ Nothing -> []
+ Just (HsQTvs _ tvs) -> tvs
-pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
- , con_cxt = cxt, con_details = PrefixCon arg_tys
- , con_res = ResTyGADT _ res_ty, con_doc = doc })
- = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon <+>
- sep [ppr_con_forall expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
- where
- mk_fun_ty a b = noLoc (HsFunTy a b)
+ cxt = fromMaybe (noLoc []) mcxt
-pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
- , con_cxt = cxt, con_details = RecCon fields
- , con_res = ResTyGADT _ res_ty, con_doc = doc })
+pprConDecl (ConDeclGADT { con_names = cons, con_type = res_ty, con_doc = doc })
= sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
- <+> ppr_con_forall expl tvs cxt,
- pprConDeclFields (unLoc fields) <+> arrow <+> ppr res_ty]
-
-pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {} })
- = pprConDecl (decl { con_details = PrefixCon [ty1,ty2] })
- -- In GADT syntax we don't allow infix constructors
- -- so if we ever trip over one (albeit I can't see how that
- -- can happen) print it like a prefix one
-
--- this fallthrough would happen with a non-GADT-syntax ConDecl with more
--- than one constructor, which should indeed be impossible
-pprConDecl (ConDecl { con_names = cons }) = pprPanic "pprConDecl" (ppr cons)
-
-ppr_con_forall :: OutputableBndr name => Bool -> LHsQTyVars name
- -> LHsContext name -> SDoc
-ppr_con_forall explicit_forall qtvs (L _ ctxt)
- | explicit_forall
- = pprHsForAllTvs (hsQTvBndrs qtvs) <+> pprHsContext ctxt
- | otherwise
- = pprHsContext ctxt
+ <+> ppr res_ty]
ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc
ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs
index e890b3bd9319c39c19e6c6c76d32604d426ddbf3..b929f867610d600ab3e51069eaba69a1306072c7 100644
--- a/compiler/hsSyn/HsLit.hs
+++ b/compiler/hsSyn/HsLit.hs
@@ -195,4 +195,3 @@ pmPprHsLit (HsInteger _ i _) = integer i
pmPprHsLit (HsRat f _) = ppr f
pmPprHsLit (HsFloatPrim f) = ppr f
pmPprHsLit (HsDoublePrim d) = ppr d
-
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index cd8f20342c7cf6dfe1ea33339208b637bd951f62..5546a918432f1620e2e84ec143c0bdba17d64c40 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -137,7 +137,7 @@ See also Note [Kind and type-variable binders] in RnTypes
Note [HsType binders]
~~~~~~~~~~~~~~~~~~~~~
-The system fr recording type and kind-variable binders in HsTypes
+The system for recording type and kind-variable binders in HsTypes
is a bit complicated. Here's how it works.
* In a HsType,
@@ -146,7 +146,7 @@ is a bit complicated. Here's how it works.
HsQualTy reprsents an /explicit, user-written/ context
e.g. (Eq a, Show a) => ...
The context can be empty if that's what the user wrote
- These constructors reprsents what the user wrote, no more
+ These constructors represent what the user wrote, no more
and no less.
* HsTyVarBndr describes a quantified type variable written by the
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 19996fd0f171b367df6fdb83db0681f6e39b84ba..ca3cae5260eddafaeda712fbd5084cffd4391ef7 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -953,14 +953,32 @@ hsConDeclsBinders cons = go id cons
case r of
-- remove only the first occurrence of any seen field in order to
-- avoid circumventing detection of duplicate fields (#9156)
- L loc (ConDecl { con_names = names, con_details = RecCon flds }) ->
- (map (L loc . unLoc) names ++ ns, r' ++ fs)
+ L loc (ConDeclGADT { con_names = names
+ , con_type = HsIB { hsib_body = res_ty}}) ->
+ case tau of
+ L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty)
+ -> (map (L loc . unLoc) names ++ ns, r' ++ fs)
+ where r' = remSeen (concatMap (cd_fld_names . unLoc)
+ flds)
+ remSeen'
+ = foldr (.) remSeen
+ [deleteBy ((==) `on`
+ rdrNameFieldOcc . unLoc) v
+ | v <- r']
+ (ns, fs) = go remSeen' rs
+ _other -> (map (L loc . unLoc) names ++ ns, fs)
+ where (ns, fs) = go remSeen rs
+ where
+ (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
+ L loc (ConDeclH98 { con_name = name
+ , con_details = RecCon flds }) ->
+ ([L loc (unLoc name)] ++ ns, r' ++ fs)
where r' = remSeen (concatMap (cd_fld_names . unLoc)
(unLoc flds))
remSeen' = foldr (.) remSeen [deleteBy ((==) `on` rdrNameFieldOcc . unLoc) v | v <- r']
(ns, fs) = go remSeen' rs
- L loc (ConDecl { con_names = names }) ->
- (map (L loc . unLoc) names ++ ns, fs)
+ L loc (ConDeclH98 { con_name = name }) ->
+ ([L loc (unLoc name)] ++ ns, fs)
where (ns, fs) = go remSeen rs
{-
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index fb5c8dbd45ccb61efc8448c7524ff46361508578..bbde989293dd7606232fde250126450c2f62711d 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1895,10 +1895,9 @@ gadt_constr_with_doc
gadt_constr :: { LConDecl RdrName }
-- see Note [Difference in parsing GADT and data constructors]
-- Returns a list because of: C,D :: ty
- : con_list '::' ctype
- {% do { let { (anns,gadtDecl) = mkGadtDecl (unLoc $1) $3 }
- ; ams (sLL $1 $> gadtDecl)
- (mu AnnDcolon $2:anns) } }
+ : con_list '::' sigtype
+ {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) (mkLHsSigType $3)))
+ [mu AnnDcolon $2] }
{- Note [Difference in parsing GADT and data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1925,13 +1924,13 @@ constrs1 :: { Located [LConDecl RdrName] }
constr :: { LConDecl RdrName }
: maybe_docnext forall context '=>' constr_stuff maybe_docprev
{% ams (let (con,details) = unLoc $5 in
- addConDoc (L (comb4 $2 $3 $4 $5) (mkSimpleConDecl con
+ addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con
(snd $ unLoc $2) $3 details))
($1 `mplus` $6))
(mu AnnDarrow $4:(fst $ unLoc $2)) }
| maybe_docnext forall constr_stuff maybe_docprev
{% ams ( let (con,details) = unLoc $3 in
- addConDoc (L (comb2 $2 $3) (mkSimpleConDecl con
+ addConDoc (L (comb2 $2 $3) (mkConDeclH98 con
(snd $ unLoc $2) (noLoc []) details))
($1 `mplus` $4))
(fst $ unLoc $2) }
@@ -2671,7 +2670,6 @@ stmtlist :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) }
-- here, because we need too much lookahead if we see do { e ; }
-- So we use BodyStmts throughout, and switch the last one over
-- in ParseUtils.checkDo instead
--- AZ: TODO check that we can retrieve multiple semis.
stmts :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) }
: stmts ';' stmt {% if null (snd $ unLoc $1)
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 4b744fe69a56e900cbad75d972639363359d630c..53e6184491e547a180b87efb338abc905aa79502 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -35,7 +35,7 @@ module RdrHsSyn (
mkExport,
mkExtName, -- RdrName -> CLabelString
mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
- mkSimpleConDecl,
+ mkConDeclH98,
mkATDefault,
-- Bunch of functions in the parser monad for
@@ -487,58 +487,25 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
quotes (ppr patsyn_name) $$ ppr decl
-mkSimpleConDecl :: Located RdrName -> Maybe [LHsTyVarBndr RdrName]
+mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr RdrName]
-> LHsContext RdrName -> HsConDeclDetails RdrName
-> ConDecl RdrName
-mkSimpleConDecl name mb_forall cxt details
- = ConDecl { con_names = [name]
- , con_explicit = explicit
- , con_qvars = qvars
- , con_cxt = cxt
- , con_details = details
- , con_res = ResTyH98
- , con_doc = Nothing }
- where
- (explicit, qvars) = case mb_forall of
- Nothing -> (False, mkHsQTvs [])
- Just tvs -> (True, mkHsQTvs tvs)
+mkConDeclH98 name mb_forall cxt details
+ = ConDeclH98 { con_name = name
+ , con_qvars = fmap mkHsQTvs mb_forall
+ , con_cxt = Just cxt
+ -- AZ:TODO: when can cxt be Nothing?
+ -- remembering that () is a valid context.
+ , con_details = details
+ , con_doc = Nothing }
mkGadtDecl :: [Located RdrName]
- -> LHsType RdrName -- Always a HsForAllTy
- -> ([AddAnn], ConDecl RdrName)
-mkGadtDecl names ty = ([], mkGadtDecl' names ty)
-
-mkGadtDecl' :: [Located RdrName]
- -> LHsType RdrName
- -> ConDecl RdrName
--- We allow C,D :: ty
--- and expand it as if it had been
--- C :: ty; D :: ty
--- (Just like type signatures in general.)
-
-mkGadtDecl' names lbody_ty@(L loc body_ty)
- = mk_gadt_con names
- where
- (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)
- _other -> (PrefixCon [], tau)
-
- explicit = case body_ty of
- HsForAllTy {} -> True
- _ -> False
-
- mk_gadt_con names
- = ConDecl { con_names = names
- , con_explicit = explicit
- , con_qvars = mkHsQTvs tvs
- , con_cxt = cxt
- , con_details = details
- , con_res = ResTyGADT loc res_ty
- , con_doc = Nothing }
+ -> LHsSigType RdrName -- Always a HsForAllTy
+ -> ConDecl RdrName
+mkGadtDecl names ty = ConDeclGADT { con_names = names
+ , con_type = ty
+ , con_doc = Nothing }
tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
tyConToDataCon loc tc
@@ -639,19 +606,19 @@ 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 ResTyGADT for now; the renamer will unravel it once it
--- has sorted out operator fixities. Consider for example
+-- 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
-- C :: a :*: b -> a :*: b -> a :+: b
-- Initially this type will parse as
-- 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
-- { 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:
--- * For PrefixCon we keep all the args in the ResTyGADT
+-- * For PrefixCon we keep all the args in the res_ty
-- * For RecCon we do not
checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsQTyVars RdrName)
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 57b427b0def7bcbb403be3e506b2b98791ec25e2..42a159f3d4d462684be9eba1eeeec722206511cf 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -2123,6 +2123,8 @@ checkTupSize tup_size
************************************************************************
-}
+-- AZ:TODO: Change these all to be Name instead of RdrName.
+-- Merge TcType.UserTypeContext in to it.
data HsDocContext
= TypeSigCtx SDoc
| PatCtx
@@ -2135,7 +2137,7 @@ data HsDocContext
| TySynCtx (Located RdrName)
| TyFamilyCtx (Located RdrName)
| FamPatCtx (Located RdrName) -- The patterns of a type/data family instance
- | ConDeclCtx [Located RdrName]
+ | ConDeclCtx [Located Name]
| ClassDeclCtx (Located RdrName)
| ExprWithTySigCtx
| TypBrCtx
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index b0b79f55e687b57eba1430325caba09a07574871..c673ac3729accc55180bd30a6b932ab627efa975 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -610,11 +610,22 @@ 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 _ (ConDecl { con_names = rdrs
+ 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 _ (ConDeclGADT
+ { con_names = rdrs
+ , con_type = (HsIB { hsib_body = res_ty})}))
+ = map (\ (L _ rdr) -> ( find_con_name rdr
+ , concatMap find_con_decl_flds cdflds))
rdrs
+ where
+ (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
+ cdflds = case tau of
+ L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds
+ _ -> []
find_con_flds _ = []
find_con_name rdr
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 2fbbea41790d5eee22e80593fd8e8ee1f122b804..dafae7cf5f9b7f56e4aa73d4459c04fced22fb2c 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -1242,8 +1242,8 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
}
where
h98_style = case condecls of -- Note [Stupid theta]
- L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False
- _ -> True
+ L _ (ConDeclGADT {}) : _ -> False
+ _ -> True
rn_derivs Nothing
= return (Nothing, emptyFVs)
@@ -1454,7 +1454,7 @@ depAnalTyClDecls ds_w_fvs
DataDecl { tcdLName = L _ data_name
, tcdDataDefn = HsDataDefn { dd_cons = cons } }
-> do L _ dc <- cons
- return $ zip (map unLoc $ con_names dc) (repeat data_name)
+ return $ zip (map unLoc $ getConNames dc) (repeat data_name)
_ -> []
{-
@@ -1506,29 +1506,6 @@ modules), we get better error messages, too.
\subsection{Support code for type/data declarations}
* *
*********************************************************
-
-Note [Quantification in data constructor declarations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Four cases, afer renaming
- * ResTyH98
- - data T a = forall b. MkT { x :: b -> a }
- The 'b' is explicitly declared;
- con_qvars = [b]
-
- - data T a = MkT { x :: a -> b }
- Do *not* implicitly quantify over 'b'; it is
- simply out of scope. con_qvars = []
-
- * ResTyGADT
- - data T a where { MkT :: forall b. (b -> a) -> T a }
- con_qvars = [a,b]
-
- - data T a where { MkT :: (b -> a) -> T a }
- con_qvars = [a,b], by implicit quantification
- of the type signature
- It is uncomfortable that we add implicitly-bound
- type variables to the HsQTyVars, which usually
- only has explicitly-bound type variables
-}
---------------
@@ -1543,75 +1520,61 @@ rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
-rnConDecl decl@(ConDecl { con_names = names, con_qvars = qtvs
- , con_cxt = lcxt@(L loc cxt), con_details = details
- , con_res = res_ty, con_doc = mb_doc
- , con_explicit = explicit })
- = do { mapM_ (addLocM checkConName) names
- ; new_names <- mapM lookupLocatedTopBndrRn names
+rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
+ , con_cxt = mcxt, con_details = details
+ , con_doc = mb_doc })
+ = do { _ <- addLocM checkConName name
+ ; new_name <- lookupLocatedTopBndrRn name
+ ; let doc = ConDeclCtx [new_name]
; mb_doc' <- rnMbLHsDoc mb_doc
- ; let (kvs, qtvs') = get_con_qtvs qtvs (hsConDeclArgTys details) res_ty
+ ; let (kvs, qtvs') = get_con_qtvs qtvs (hsConDeclArgTys details)
; bindHsQTyVars doc Nothing kvs qtvs' $ \new_tyvars -> do
- { (new_context, fvs1) <- rnContext doc lcxt
- ; (new_details, fvs2) <- rnConDeclDetails (unLoc $ head new_names) doc details
- ; (new_details', new_res_ty, fvs3)
- <- rnConResult doc (map unLoc new_names) new_details res_ty
- ; traceRn (text "rnConDecl" <+> ppr names <+> vcat
+ { (new_context, fvs1) <- case mcxt of
+ Nothing -> return (Nothing,emptyFVs)
+ Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt
+ ; return (Just lctx',fvs) }
+ ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details
+ ; let (new_details',fvs3) = (new_details,emptyFVs)
+ ; traceRn (text "rnConDecl" <+> ppr name <+> vcat
[ text "free_kvs:" <+> ppr kvs
, text "qtvs:" <+> ppr qtvs
, text "qtvs':" <+> ppr qtvs' ])
; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
; warnUnusedForAlls (inHsDocContext doc) (hsQTvBndrs new_tyvars) all_fvs
- ; return (decl { con_names = new_names, con_qvars = new_tyvars
+ ; let new_tyvars' = case qtvs of
+ Nothing -> Nothing
+ Just _ -> Just new_tyvars
+ ; return (decl { con_name = new_name, con_qvars = new_tyvars'
, con_cxt = new_context, con_details = new_details'
- , con_res = new_res_ty, con_doc = mb_doc' },
+ , con_doc = mb_doc' },
all_fvs) }}
where
- doc = ConDeclCtx names
+ cxt = maybe [] unLoc mcxt
get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
- get_con_qtvs :: LHsQTyVars RdrName -> [LHsType RdrName]
- -> ResType (LHsType RdrName)
+ get_con_qtvs :: Maybe (LHsQTyVars RdrName) -> [LHsType RdrName]
-> ([RdrName], LHsQTyVars RdrName)
- get_con_qtvs qtvs arg_tys ResTyH98
- | explicit -- data T = forall a. MkT (a -> a)
- = (free_kvs, qtvs)
- | otherwise -- data T = MkT (a -> a)
+ get_con_qtvs Nothing _arg_tys
= ([], mkHsQTvs [])
+ get_con_qtvs (Just qtvs) arg_tys
+ = (free_kvs, qtvs)
where
(free_kvs, _) = get_rdr_tvs arg_tys
- get_con_qtvs qtvs arg_tys (ResTyGADT _ ty)
- | explicit -- data T x where { MkT :: forall a. a -> T a }
- = (free_kvs, qtvs)
- | otherwise -- data T x where { MkT :: a -> T a }
- = (free_kvs, mkHsQTvs (userHsTyVarBndrs loc free_tvs))
- where
- (free_kvs, free_tvs) = get_rdr_tvs (ty : arg_tys)
-
-rnConResult :: HsDocContext -> [Name]
- -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
- -> ResType (LHsType RdrName)
- -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]),
- ResType (LHsType Name), FreeVars)
-rnConResult _ _ details ResTyH98 = return (details, ResTyH98, emptyFVs)
-rnConResult doc _con details (ResTyGADT ls ty)
- = do { (ty', fvs) <- rnLHsType doc ty
- ; 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 "rnConResult" (ppr ty)
- -- See Note [Sorting out the result type] in RdrHsSyn
-
- RecCon {} -> do { unless (null arg_tys)
- (addErr (badRecResTy doc))
- ; return (details, ResTyGADT ls res_ty, fvs) }
-
- PrefixCon {} -> return (PrefixCon arg_tys, ResTyGADT ls res_ty, fvs)}
+rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty
+ , con_doc = mb_doc })
+ = do { mapM_ (addLocM checkConName) names
+ ; new_names <- mapM lookupLocatedTopBndrRn names
+ ; let doc = ConDeclCtx new_names
+ ; mb_doc' <- rnMbLHsDoc mb_doc
+
+ ; (ty', fvs) <- rnHsSigType doc ty
+ ; traceRn (text "rnConDecl" <+> ppr names <+> vcat
+ [ text "fvs:" <+> ppr fvs ])
+ ; return (decl { con_names = new_names, con_type = ty'
+ , con_doc = mb_doc' },
+ fvs) }
rnConDeclDetails
:: Name
@@ -1635,9 +1598,6 @@ rnConDeclDetails con doc (RecCon (L l fields))
; return (RecCon (L l new_fields), fvs) }
-------------------------------------------------
-badRecResTy :: HsDocContext -> SDoc
-badRecResTy ctxt = withHsDocContext ctxt $
- ptext (sLit "Malformed constructor signature")
-- | Brings pattern synonym names and also pattern synonym selectors
-- from record pattern synonyms into scope.
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index 49b707c3708a9115f64ca8efc587ddf7a4942995..b716ee07210971c6242f4c9ab2605fd60a2e5ea2 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -363,6 +363,14 @@ rnHsTyKi _ doc (HsBangTy b ty)
= do { (ty', fvs) <- rnLHsType doc 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
+ ; (flds', fvs) <- rnConDeclFields fls doc flds
+ ; return (HsRecTy flds', fvs) }
+
rnHsTyKi _ doc ty@(HsRecTy flds)
= do { addErr (hang (ptext (sLit "Record syntax is illegal here:"))
2 (ppr ty))
@@ -1200,14 +1208,18 @@ extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
extract_mb (extract_sig_tys . unLoc) derivs $
foldr (extract_con . unLoc) ([],[]) cons
where
- extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc
- extract_con (ConDecl { con_res = ResTyH98, con_qvars = qvs
- , con_cxt = ctxt, con_details = details }) acc
- = extract_hs_tv_bndrs (hsQTvBndrs qvs) acc $
- extract_lctxt ctxt $
+ extract_con (ConDeclGADT { }) acc = acc
+ extract_con (ConDeclH98 { con_qvars = qvs
+ , con_cxt = ctxt, con_details = details }) acc
+ = extract_hs_tv_bndrs (maybe [] hsQTvBndrs qvs) acc $
+ extract_mlctxt ctxt $
extract_ltys (hsConDeclArgTys details) ([],[])
+extract_mlctxt :: Maybe (LHsContext RdrName) -> FreeKiTyVars -> FreeKiTyVars
+extract_mlctxt Nothing = mempty
+extract_mlctxt (Just ctxt) = extract_lctxt ctxt
+
extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars
extract_lctxt ctxt = extract_ltys (unLoc ctxt)
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index c0fef87334bc717866a0cd228219bd8beec0246f..2b671463cd845f9b6a9fad3368d1f6aaee152cf1 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -9,7 +9,7 @@
module TcHsType (
-- Type signatures
- kcClassSigType, tcClassSigType,
+ kcHsSigType, tcClassSigType,
tcHsSigType, tcHsSigWcType,
zonkSigType, zonkAndCheckValidity,
funsSigCtxt, addSigCtxt,
@@ -183,8 +183,8 @@ tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType Name -> TcM Type
-- alrady checked this, so we can simply ignore it.
tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)
-kcClassSigType :: [Located Name] -> LHsSigType Name -> TcM ()
-kcClassSigType names (HsIB { hsib_body = hs_ty
+kcHsSigType :: [Located Name] -> LHsSigType Name -> TcM ()
+kcHsSigType names (HsIB { hsib_body = hs_ty
, hsib_kvs = sig_kvs
, hsib_tvs = sig_tvs })
= addSigCtxt (funsSigCtxt names) hs_ty $
@@ -387,9 +387,10 @@ tc_hs_type ty@(HsBangTy {}) _
-- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of
-- bangs are invalid, so fail. (#7210)
= failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty)
-tc_hs_type (HsRecTy _) _ = panic "tc_hs_type: record" -- Unwrapped by con decls
+tc_hs_type ty@(HsRecTy _) _
-- Record types (which only show up temporarily in constructor
-- signatures) should have been removed by now
+ = failWithTc (ptext (sLit "Record syntax is illegal here:") <+> ppr ty)
---------- Functions and applications
tc_hs_type hs_ty@(HsTyVar (L _ name)) exp_kind
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index ee95bb5594f3238442467fac455ddb8fce44b418..27b807455a2c7b9ddc2ea3ea29323a695aa97fac 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -1444,7 +1444,7 @@ tcTyClsInstDecls tycl_decls inst_decls deriv_decls
get_fi_cons :: DataFamInstDecl Name -> [Name]
get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
- = map unLoc $ concatMap (con_names . unLoc) cons
+ = map unLoc $ concatMap (getConNames . unLoc) cons
{-
Note [AFamDataCon: not promoting data family constructors]
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index a2b6a6386e9f0b0437c8c5842f9ecec7e59dcd4a..1cb71d61825daec0d85f554d781e52dcdb320a27 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -67,6 +67,7 @@ import BasicTypes
import Control.Monad
import Data.List
+import Data.Monoid ( mempty )
{-
************************************************************************
@@ -381,7 +382,7 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name
; return (res_k, ()) }
; let main_pr = (name, AThing decl_kind)
inner_prs = [ (unLoc con, APromotionErr RecDataConPE)
- | L _ con' <- cons, con <- con_names con' ]
+ | L _ con' <- cons, con <- getConNames con' ]
; return (main_pr : inner_prs) }
getInitialKind (FamDecl { tcdFam = decl })
@@ -480,7 +481,7 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs
do { _ <- tcHsContext ctxt
; mapM_ (wrapLocM kc_sig) sigs }
where
- kc_sig (ClassOpSig _ nms op_ty) = kcClassSigType nms op_ty
+ kc_sig (ClassOpSig _ nms op_ty) = kcHsSigType nms op_ty
kc_sig _ = return ()
-- closed type families look at their equations, but other families don't
@@ -495,20 +496,25 @@ kcTyClDecl (FamDecl {}) = return ()
-------------------
kcConDecl :: ConDecl Name -> TcM ()
-kcConDecl (ConDecl { con_names = names, con_qvars = ex_tvs
- , con_cxt = ex_ctxt, con_details = details
- , con_res = res })
- = addErrCtxt (dataConCtxtName names) $
+kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs
+ , con_cxt = ex_ctxt, con_details = details })
+ = addErrCtxt (dataConCtxtName [name]) $
-- the 'False' says that the existentials don't have a CUSK, as the
-- concept doesn't really apply here. We just need to bring the variables
-- into scope!
- do { _ <- kcHsTyVarBndrs False ex_tvs $
- do { _ <- tcHsContext ex_ctxt
+ do { _ <- kcHsTyVarBndrs False ((fromMaybe (HsQTvs mempty []) ex_tvs)) $
+ do { _ <- tcHsContext (fromMaybe (noLoc []) ex_ctxt)
; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details)
- ; _ <- tcConRes res
; return (panic "kcConDecl", ()) }
; return () }
+kcConDecl (ConDeclGADT { con_names = names
+ , con_type = ty })
+ = addErrCtxt (dataConCtxtName names) $
+ do { _ <- tcGadtSigType (ppr names) (unLoc $ head names) ty
+ ; return () }
+
+
{-
Note [Recursion and promoting data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1241,8 +1247,8 @@ dataDeclChecks tc_name new_or_data stupid_theta cons
-----------------------------------
consUseGadtSyntax :: [LConDecl a] -> Bool
-consUseGadtSyntax (L _ (ConDecl { con_res = ResTyGADT _ _ }) : _) = True
-consUseGadtSyntax _ = False
+consUseGadtSyntax (L _ (ConDeclGADT { }) : _) = True
+consUseGadtSyntax _ = False
-- All constructors have same shape
-----------------------------------
@@ -1261,41 +1267,72 @@ tcConDecl :: NewOrData
-> TcM [DataCon]
tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
- (ConDecl { con_names = names
- , con_qvars = hs_tvs, con_cxt = hs_ctxt
- , con_details = hs_details, con_res = hs_res_ty })
- = addErrCtxt (dataConCtxtName names) $
- do { traceTc "tcConDecl 1" (ppr names)
- ; (ctxt, arg_tys, res_ty, field_lbls, stricts)
- <- tcHsQTyVars hs_tvs $ \ _ ->
- do { traceTc "tcConDecl" (ppr names <+> text "tvs:" <+> ppr hs_tvs)
- ; ctxt <- tcHsContext hs_ctxt
+ (ConDeclH98 { con_name = name
+ , con_qvars = hs_tvs, con_cxt = hs_ctxt
+ , con_details = hs_details })
+ = addErrCtxt (dataConCtxtName [name]) $
+ do { traceTc "tcConDecl 1" (ppr name)
+ ; (ctxt, arg_tys, field_lbls, stricts)
+ <- tcHsQTyVars (fromMaybe (HsQTvs [] []) hs_tvs) $ \ _ ->
+ do { traceTc "tcConDecl" (ppr name <+> text "tvs:" <+> ppr hs_tvs)
+ ; ctxt <- tcHsContext (fromMaybe (noLoc []) hs_ctxt)
; btys <- tcConArgs new_or_data hs_details
- ; res_ty <- tcConRes hs_res_ty
- ; field_lbls <- lookupConstructorFields (unLoc $ head names)
+ ; field_lbls <- lookupConstructorFields (unLoc name)
; let (arg_tys, stricts) = unzip btys
- ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)
+ ; return (ctxt, arg_tys, field_lbls, stricts)
}
- -- Generalise the kind variables (returning quantified TcKindVars)
- -- and quantify the type variables (substituting their kinds)
- -- REMEMBER: 'tkvs' are:
- -- ResTyH98: the *existential* type variables only
- -- ResTyGADT: *all* the quantified type variables
- -- c.f. the comment on con_qvars in HsDecls
- ; tkvs <- case res_ty of
- ResTyH98 -> quantifyTyVars (mkVarSet tmpl_tvs)
- (tyVarsOfTypes (ctxt++arg_tys))
- ResTyGADT _ res_ty -> quantifyTyVars emptyVarSet
- (tyVarsOfTypes (res_ty:ctxt++arg_tys))
+ ; tkvs <- quantifyTyVars (mkVarSet tmpl_tvs)
+ (tyVarsOfTypes (ctxt++arg_tys))
-- Zonk to Types
; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv tkvs
; arg_tys <- zonkTcTypeToTypes ze arg_tys
; ctxt <- zonkTcTypeToTypes ze ctxt
- ; res_ty <- case res_ty of
- ResTyH98 -> return ResTyH98
- ResTyGADT ls ty -> ResTyGADT ls <$> zonkTcTypeToType ze ty
+
+ ; let (univ_tvs, ex_tvs, eq_preds) = (tmpl_tvs, qtkvs, [])
+ -- AZ:TODO: Is this comment needed here for ConDeclH98?
+ -- NB: this is a /lazy/ binding, so we pass four thunks to buildDataCon
+ -- without yet forcing the guards in rejigConRes
+ -- See Note [Checking GADT return types]
+
+ ; fam_envs <- tcGetFamInstEnvs
+
+ -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here
+ ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls)
+ ; let
+ buildOneDataCon (L _ name) = do
+ { is_infix <- tcConIsInfixH98 name hs_details
+ ; rep_nm <- newTyConRepName name
+
+ ; buildDataCon fam_envs name is_infix
+ (if is_prom then Promoted rep_nm else NotPromoted)
+ -- Must be lazy in is_prom because it is knot-tied
+ stricts Nothing field_lbls
+ univ_tvs ex_tvs eq_preds ctxt arg_tys
+ res_tmpl rep_tycon
+ -- NB: we put data_tc, the type constructor gotten from the
+ -- constructor type signature into the data constructor;
+ -- that way checkValidDataCon can complain if it's wrong.
+ }
+ ; traceTc "tcConDecl 2" (ppr name)
+ ; mapM buildOneDataCon [name]
+ }
+
+tcConDecl _new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
+ (ConDeclGADT { con_names = names, con_type = ty })
+ = addErrCtxt (dataConCtxtName names) $
+ do { traceTc "tcConDecl 1" (ppr names)
+ ; (ctxt, stricts, field_lbls, arg_tys, res_ty,hs_details)
+ <- tcGadtSigType (ppr names) (unLoc $ head names) ty
+ ; tkvs <- quantifyTyVars emptyVarSet
+ (tyVarsOfTypes (res_ty:ctxt++arg_tys))
+
+ -- Zonk to Types
+ ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv tkvs
+ ; arg_tys <- zonkTcTypeToTypes ze arg_tys
+ ; ctxt <- zonkTcTypeToTypes ze ctxt
+ ; res_ty <- zonkTcTypeToType ze res_ty
; let (univ_tvs, ex_tvs, eq_preds, res_ty') = rejigConRes tmpl_tvs res_tmpl qtkvs res_ty
-- NB: this is a /lazy/ binding, so we pass four thunks to buildDataCon
@@ -1308,7 +1345,7 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)
; let
buildOneDataCon (L _ name) = do
- { is_infix <- tcConIsInfix name hs_details res_ty
+ { is_infix <- tcConIsInfixGADT name hs_details
; rep_nm <- newTyConRepName name
; buildDataCon fam_envs name is_infix
@@ -1326,19 +1363,72 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
}
-tcConIsInfix :: Name
+tcGadtSigType :: SDoc -> Name -> LHsSigType Name
+ -> TcM ([PredType],[HsSrcBang], [FieldLabel], [Type], Type
+ ,HsConDetails (LHsType Name) (Located [LConDeclField Name]))
+tcGadtSigType doc name ty@(HsIB { hsib_kvs = kvs, hsib_tvs = tvs})
+ = do { let (hs_details',res_ty',cxt,gtvs) = gadtDeclDetails ty
+ ; (hs_details,res_ty) <- tcUpdateConResult doc hs_details' res_ty'
+ ; let hs_tvs = HsQTvs { hsq_kvs = kvs
+ , hsq_tvs = gtvs ++
+ map (noLoc . UserTyVar . noLoc) tvs }
+ ; (ctxt, arg_tys, res_ty, field_lbls, stricts)
+ <- tcHsQTyVars hs_tvs $ \ _ ->
+ do { ctxt <- tcHsContext cxt
+ ; btys <- tcConArgs DataType hs_details
+ ; ty' <- tcHsLiftedType res_ty
+ ; field_lbls <- lookupConstructorFields name
+ ; let (arg_tys, stricts) = unzip btys
+ ; return (ctxt, arg_tys, ty', field_lbls, stricts)
+ }
+ ; 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])
- -> ResType Type
-> TcM Bool
-tcConIsInfix _ details ResTyH98
+tcConIsInfixH98 _ details
= case details of
InfixCon {} -> return True
_ -> return False
-tcConIsInfix con details (ResTyGADT _ _)
+
+tcConIsInfixGADT :: Name
+ -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
+ -> TcM Bool
+tcConIsInfixGADT con details
= case details of
InfixCon {} -> return True
RecCon {} -> return False
- PrefixCon arg_tys -- See Note [Infix GADT cons]
+ PrefixCon arg_tys -- See Note [Infix GADT constructors]
| isSymOcc (getOccName con)
, [_ty1,_ty2] <- arg_tys
-> do { fix_env <- getFixityEnv
@@ -1372,11 +1462,6 @@ tcConArg new_or_data bty
; traceTc "tcConArg 2" (ppr bty)
; return (arg_ty, getBangStrictness bty) }
-tcConRes :: ResType (LHsType Name) -> TcM (ResType Type)
-tcConRes ResTyH98 = return ResTyH98
-tcConRes (ResTyGADT ls res_ty) = do { res_ty' <- tcHsLiftedType res_ty
- ; return (ResTyGADT ls res_ty') }
-
{-
Note [Infix GADT constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1432,7 +1517,7 @@ rejigConRes :: [TyVar] -> Type -- Template for result type; e.g.
-- data instance T [a] b c = ...
-- gives template ([a,b,c], T [a] b c)
-> [TyVar] -- where MkT :: forall x y z. ...
- -> ResType Type
+ -> Type -- res_ty
-> ([TyVar], -- Universal
[TyVar], -- Existential (distinct OccNames from univs)
[(TyVar,Type)], -- Equality predicates
@@ -1440,13 +1525,7 @@ rejigConRes :: [TyVar] -> Type -- Template for result type; e.g.
-- We don't check that the TyCon given in the ResTy is
-- the same as the parent tycon, because checkValidDataCon will do it
-rejigConRes tmpl_tvs res_ty dc_tvs ResTyH98
- = (tmpl_tvs, dc_tvs, [], res_ty)
- -- In H98 syntax the dc_tvs are the existential ones
- -- data T a b c = forall d e. MkT ...
- -- The universals {a,b,c} are tc_tvs, and the existentials {d,e} are dc_tvs
-
-rejigConRes tmpl_tvs res_tmpl dc_tvs (ResTyGADT _ res_ty)
+rejigConRes tmpl_tvs res_tmpl dc_tvs res_ty
-- E.g. data T [a] b c where
-- MkT :: forall x y z. T [(x,y)] z z
-- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs
@@ -1499,7 +1578,7 @@ data SList s as where
We call tcResultType with
tmpl_tvs = [(k :: BOX), (s :: k -> *), (as :: List k)]
res_tmpl = SList k s as
- res_ty = ResTyGADT (SList k1 (s1 :: k1 -> *) (Nil k1))
+ res_ty = (SList k1 (s1 :: k1 -> *) (Nil k1))
We get subst:
k -> k1
diff --git a/testsuite/tests/ghc-api/annotations/T10399.stdout b/testsuite/tests/ghc-api/annotations/T10399.stdout
index 58a4093aaeb2aeb7bd16cf176d6dd2349e5c1ce1..612ecfd734b823e0325f0b1f38548629ab2f443f 100644
--- a/testsuite/tests/ghc-api/annotations/T10399.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10399.stdout
@@ -44,9 +44,7 @@
((Test10399.hs:15:45-46,AnnBang), [Test10399.hs:15:45]),
((Test10399.hs:15:45-46,AnnRarrow), [Test10399.hs:15:48-49]),
((Test10399.hs:15:45-64,AnnRarrow), [Test10399.hs:15:48-49]),
-((Test10399.hs:(16,5)-(17,69),AnnCloseP), [Test10399.hs:17:69]),
((Test10399.hs:(16,5)-(17,69),AnnDcolon), [Test10399.hs:16:12-13]),
-((Test10399.hs:(16,5)-(17,69),AnnOpenP), [Test10399.hs:16:27]),
((Test10399.hs:(16,15)-(17,69),AnnDot), [Test10399.hs:16:25]),
((Test10399.hs:(16,15)-(17,69),AnnForall), [Test10399.hs:16:15-20]),
((Test10399.hs:(16,27)-(17,69),AnnCloseP), [Test10399.hs:17:69]),
diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T
index 4104bceebf41680fbf17ff9b73c002610fa81488..c7c8542a11f7ef77d12eb977bde905bfcc61a2cd 100644
--- a/testsuite/tests/ghc-api/annotations/all.T
+++ b/testsuite/tests/ghc-api/annotations/all.T
@@ -16,7 +16,7 @@ test('T10358', normal, run_command, ['$MAKE -s --no-print-directory T10358'
test('T10278', normal, run_command, ['$MAKE -s --no-print-directory T10278'])
test('T10354', normal, run_command, ['$MAKE -s --no-print-directory T10354'])
test('T10396', normal, run_command, ['$MAKE -s --no-print-directory T10396'])
-test('T10399', expect_broken(11028), run_command, ['$MAKE -s --no-print-directory T10399'])
+test('T10399', normal, run_command, ['$MAKE -s --no-print-directory T10399'])
test('T10313', normal, run_command, ['$MAKE -s --no-print-directory T10313'])
test('T11018', normal, run_command, ['$MAKE -s --no-print-directory T11018'])
test('bundle-export', normal, run_command, ['$MAKE -s --no-print-directory bundle-export'])
diff --git a/testsuite/tests/ghc-api/landmines/landmines.stdout b/testsuite/tests/ghc-api/landmines/landmines.stdout
index db0b651dfa0904624c469438f27a64713a0d037e..551b2cf8d7b47f7494db917d20f2bffeae0b6d32 100644
--- a/testsuite/tests/ghc-api/landmines/landmines.stdout
+++ b/testsuite/tests/ghc-api/landmines/landmines.stdout
@@ -1,4 +1,4 @@
(12,12,7)
-(66,62,0)
+(63,63,0)
(13,13,7)
(10,10,7)
diff --git a/testsuite/tests/rename/should_compile/T5331.stderr b/testsuite/tests/rename/should_compile/T5331.stderr
index 13249b0e17851d69094585f97410f736ade1d82c..965e15a9b48ffed43710e79e65a9b90149a36d40 100644
--- a/testsuite/tests/rename/should_compile/T5331.stderr
+++ b/testsuite/tests/rename/should_compile/T5331.stderr
@@ -5,7 +5,7 @@ T5331.hs:8:17: warning:
T5331.hs:11:16: warning:
Unused quantified type variable ‘a’
- In the definition of data constructor ‘W1’
+ In the type ‘forall a. W’
T5331.hs:13:13: warning:
Unused quantified type variable ‘a’
diff --git a/testsuite/tests/rename/should_fail/T7943.stderr b/testsuite/tests/rename/should_fail/T7943.stderr
index 8594a25e2f783960c7887ca6fc7bc7cd4da754fe..c6bf7ae9b5daf4ba27874322d7e59d9e63d8d3fb 100644
--- a/testsuite/tests/rename/should_fail/T7943.stderr
+++ b/testsuite/tests/rename/should_fail/T7943.stderr
@@ -1,2 +1,6 @@
-T7943.hs:4:22: Record syntax is illegal here: {bar :: String}
+T7943.hs:4:22:
+ Record syntax is illegal here: {bar :: String}
+ In the type ‘{bar :: String}’
+ In the definition of data constructor ‘B’
+ In the data declaration for ‘Foo’
\ No newline at end of file
diff --git a/utils/haddock b/utils/haddock
index a6deefad581cbeb62048826bc1d626c41a0dd56c..222954753de7a8a3708baff1d75a4b7c3a675f4b 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit a6deefad581cbeb62048826bc1d626c41a0dd56c
+Subproject commit 222954753de7a8a3708baff1d75a4b7c3a675f4b