Commit fa29df02 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactor ConDecl: Trac #14529

This patch refactors HsDecls.ConDecl.  Specifically

* ConDeclGADT was horrible, with all the information hidden
  inside con_res_ty.  Now it's kept separate, as it should be.

* ConDeclH98: use [LHsTyVarBndr] instead of LHsQTyVars for the
  existentials. There is no implicit binding here.

* Add a field con_forall to both ConDeclGADT and ConDeclH98
  which says if there is an explicit user-written forall.

* Field renamings in ConDecl
     con_cxt     to con_mb_cxt
     con_details to con_args

There is an accompanying submodule update to Haddock.

Also the following change turned out to remove a lot of clutter:

* add a smart constructor for HsAppsTy, namely mkHsAppsTy,
  and use it consistently. This avoids a lot of painful pattern
  matching for the common singleton case.

Two api-annotation tests (T10278, and T10399) are broken, hence marking
them as expect_broken(14529).  Alan is going to fix them, probably by
changing the con_forall field to
   con_forall :: Maybe SrcSpan
instead of Bool
parent 5f332e1d
...@@ -630,51 +630,45 @@ repAnnProv ModuleAnnProvenance ...@@ -630,51 +630,45 @@ repAnnProv ModuleAnnProvenance
repC :: LConDecl GhcRn -> DsM (Core TH.ConQ) repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
repC (L _ (ConDeclH98 { con_name = con repC (L _ (ConDeclH98 { con_name = con
, con_qvars = Nothing, con_cxt = Nothing , con_forall = False
, con_details = details })) , con_mb_cxt = Nothing
= repDataCon con details , con_args = args }))
= repDataCon con args
repC (L _ (ConDeclH98 { con_name = con repC (L _ (ConDeclH98 { con_name = con
, con_qvars = mcon_tvs, con_cxt = mcxt , con_forall = is_existential
, con_details = details })) , con_ex_tvs = con_tvs
= do { let con_tvs = fromMaybe emptyLHsQTvs mcon_tvs , con_mb_cxt = mcxt
ctxt = unLoc $ fromMaybe (noLoc []) mcxt , con_args = args }))
; addTyVarBinds con_tvs $ \ ex_bndrs -> = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
do { c' <- repDataCon con details do { c' <- repDataCon con args
; ctxt' <- repContext ctxt ; ctxt' <- repMbContext mcxt
; if isEmptyLHsQTvs con_tvs && null ctxt ; if not is_existential && isNothing mcxt
then return c' then return c'
else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
} }
} }
repC (L _ (ConDeclGADT { con_names = cons repC (L _ (ConDeclGADT { con_names = cons
, con_type = res_ty@(HsIB { hsib_vars = imp_tvs })})) , con_qvars = qtvs, con_mb_cxt = mcxt
| (details, res_ty', L _ [] , []) <- gadtDetails , con_args = args, con_res_ty = res_ty }))
, [] <- imp_tvs | isEmptyLHsQTvs qtvs -- No implicit or explicit variables
-- no implicit or explicit variables, no context = no need for a forall , Nothing <- mcxt -- No context
= do { let doc = text "In the constructor for " <+> ppr (head cons) -- ==> no need for a forall
; (hs_details, gadt_res_ty) <- = repGadtDataCons cons args res_ty
updateGadtResult failWithDs doc details res_ty'
; repGadtDataCons cons hs_details gadt_res_ty } | otherwise
= addTyVarBinds qtvs $ \ ex_bndrs ->
| (details,res_ty',ctxt, exp_tvs) <- gadtDetails
= do { let doc = text "In the constructor for " <+> ppr (head cons)
con_tvs = HsQTvs { hsq_implicit = imp_tvs
, hsq_explicit = exp_tvs
, hsq_dependent = emptyNameSet }
-- NB: Don't put imp_tvs into the hsq_explicit field above
-- See Note [Don't quantify implicit type variables in quotes] -- See Note [Don't quantify implicit type variables in quotes]
; addTyVarBinds con_tvs $ \ ex_bndrs -> do do { c' <- repGadtDataCons cons args res_ty
{ (hs_details, gadt_res_ty) <- ; ctxt' <- repMbContext mcxt
updateGadtResult failWithDs doc details res_ty' ; if null (hsQTvExplicit qtvs) && isNothing mcxt
; c' <- repGadtDataCons cons hs_details gadt_res_ty
; ctxt' <- repContext (unLoc ctxt)
; if null exp_tvs && null (unLoc ctxt)
then return c' then return c'
else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } } else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }
where
gadtDetails = gadtDeclDetails res_ty repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
repMbContext Nothing = repContext []
repMbContext (Just (L _ cxt)) = repContext cxt
repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ) repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName [] repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName []
...@@ -867,24 +861,30 @@ addSimpleTyVarBinds names thing_inside ...@@ -867,24 +861,30 @@ addSimpleTyVarBinds names thing_inside
; term <- addBinds fresh_names thing_inside ; term <- addBinds fresh_names thing_inside
; wrapGenSyms fresh_names term } ; wrapGenSyms fresh_names term }
addHsTyVarBinds :: [LHsTyVarBndr GhcRn] -- the binders to be added
-> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env
-> DsM (Core (TH.Q a))
addHsTyVarBinds exp_tvs thing_inside
= do { fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)
; term <- addBinds fresh_exp_names $
do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
(exp_tvs `zip` fresh_exp_names)
; thing_inside kbs }
; wrapGenSyms fresh_exp_names term }
where
mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added
-> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env
-> DsM (Core (TH.Q a)) -> DsM (Core (TH.Q a))
-- gensym a list of type variables and enter them into the meta environment; -- gensym a list of type variables and enter them into the meta environment;
-- the computations passed as the second argument is executed in that extended -- 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 -- meta environment and gets the *new* names on Core-level as an argument
addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs })
addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m thing_inside
= do { fresh_imp_names <- mkGenSyms imp_tvs = addSimpleTyVarBinds imp_tvs $
; fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs) addHsTyVarBinds exp_tvs $
; let fresh_names = fresh_imp_names ++ fresh_exp_names thing_inside
; term <- addBinds fresh_names $
do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
(exp_tvs `zip` fresh_exp_names)
; m kbs }
; wrapGenSyms fresh_names term }
where
mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
addTyClTyVarBinds :: LHsQTyVars GhcRn addTyClTyVarBinds :: LHsQTyVars GhcRn
-> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))
...@@ -943,12 +943,9 @@ repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ) ...@@ -943,12 +943,9 @@ repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
repHsSigType (HsIB { hsib_vars = implicit_tvs repHsSigType (HsIB { hsib_vars = implicit_tvs
, hsib_body = body }) , hsib_body = body })
| (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body
= addTyVarBinds (HsQTvs { hsq_implicit = implicit_tvs = addSimpleTyVarBinds implicit_tvs $
, hsq_explicit = explicit_tvs -- See Note [Don't quantify implicit type variables in quotes]
, hsq_dependent = emptyNameSet }) addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->
-- NB: Don't pass implicit_tvs to the hsq_explicit field above
-- See Note [Don't quantify implicit type variables in quotes]
$ \ th_explicit_tvs ->
do { th_ctxt <- repLContext ctxt do { th_ctxt <- repLContext ctxt
; th_ty <- repLTy ty ; th_ty <- repLTy ty
; if null explicit_tvs && null (unLoc ctxt) ; if null explicit_tvs && null (unLoc ctxt)
...@@ -958,20 +955,15 @@ repHsSigType (HsIB { hsib_vars = implicit_tvs ...@@ -958,20 +955,15 @@ repHsSigType (HsIB { hsib_vars = implicit_tvs
repHsPatSynSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ) repHsPatSynSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs
, hsib_body = body }) , hsib_body = body })
= addTyVarBinds (newTvs implicit_tvs univs) $ \th_univs -> = addSimpleTyVarBinds implicit_tvs $
addTyVarBinds (newTvs [] exis) $ \th_exis -> -- See Note [Don't quantify implicit type variables in quotes]
addHsTyVarBinds univs $ \th_univs ->
addHsTyVarBinds exis $ \th_exis ->
do { th_reqs <- repLContext reqs do { th_reqs <- repLContext reqs
; th_provs <- repLContext provs ; th_provs <- repLContext provs
; th_ty <- repLTy ty ; th_ty <- repLTy ty
; repTForall th_univs th_reqs =<< (repTForall th_exis th_provs th_ty) } ; repTForall th_univs th_reqs =<< (repTForall th_exis th_provs th_ty) }
where where
newTvs impl_tvs expl_tvs = HsQTvs
{ hsq_implicit = impl_tvs
, hsq_explicit = expl_tvs
, hsq_dependent = emptyNameSet }
-- NB: Don't pass impl_tvs to the hsq_explicit field above
-- See Note [Don't quantify implicit type variables in quotes]
(univs, reqs, exis, provs, ty) = splitLHsPatSynTy body (univs, reqs, exis, provs, ty) = splitLHsPatSynTy body
repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ) repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ)
...@@ -990,8 +982,7 @@ repForall :: HsType GhcRn -> DsM (Core TH.TypeQ) ...@@ -990,8 +982,7 @@ repForall :: HsType GhcRn -> DsM (Core TH.TypeQ)
-- Arg of repForall is always HsForAllTy or HsQualTy -- Arg of repForall is always HsForAllTy or HsQualTy
repForall ty repForall ty
| (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty) | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
= addTyVarBinds (HsQTvs { hsq_implicit = [], hsq_explicit = tvs = addHsTyVarBinds tvs $ \bndrs ->
, hsq_dependent = emptyNameSet }) $ \bndrs ->
do { ctxt1 <- repLContext ctxt do { ctxt1 <- repLContext ctxt
; ty1 <- repLTy tau ; ty1 <- repLTy tau
; repTForall bndrs ctxt1 ty1 } ; repTForall bndrs ctxt1 ty1 }
......
...@@ -42,7 +42,7 @@ import MonadUtils ( foldrM ) ...@@ -42,7 +42,7 @@ import MonadUtils ( foldrM )
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Control.Monad( unless, liftM, ap, (<=<) ) import Control.Monad( unless, liftM, ap, (<=<) )
import Data.Maybe( catMaybes, fromMaybe, isNothing ) import Data.Maybe( catMaybes, isNothing )
import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH import Language.Haskell.TH.Syntax as TH
...@@ -490,59 +490,57 @@ cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs) ...@@ -490,59 +490,57 @@ cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)
cvtConstr (NormalC c strtys) cvtConstr (NormalC c strtys)
= do { c' <- cNameL c = do { c' <- cNameL c
; cxt' <- returnL []
; tys' <- mapM cvt_arg strtys ; tys' <- mapM cvt_arg strtys
; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') } ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') }
cvtConstr (RecC c varstrtys) cvtConstr (RecC c varstrtys)
= do { c' <- cNameL c = do { c' <- cNameL c
; cxt' <- returnL []
; args' <- mapM cvt_id_arg varstrtys ; args' <- mapM cvt_id_arg varstrtys
; returnL $ mkConDeclH98 c' Nothing cxt' ; returnL $ mkConDeclH98 c' Nothing Nothing
(RecCon (noLoc args')) } (RecCon (noLoc args')) }
cvtConstr (InfixC st1 c st2) cvtConstr (InfixC st1 c st2)
= do { c' <- cNameL c = do { c' <- cNameL c
; cxt' <- returnL []
; st1' <- cvt_arg st1 ; st1' <- cvt_arg st1
; st2' <- cvt_arg st2 ; st2' <- cvt_arg st2
; returnL $ mkConDeclH98 c' Nothing cxt' (InfixCon st1' st2') } ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') }
cvtConstr (ForallC tvs ctxt con) cvtConstr (ForallC tvs ctxt con)
= do { tvs' <- cvtTvs tvs = do { tvs' <- cvtTvs tvs
; L loc ctxt' <- cvtContext ctxt ; ctxt' <- cvtContext ctxt
; L _ con' <- cvtConstr con ; L _ con' <- cvtConstr con
; returnL $ case con' of ; returnL $ add_forall tvs' ctxt' con' }
ConDeclGADT { con_type = conT } -> where
let hs_ty = mkHsForAllTy tvs noSrcSpan tvs' rho_ty add_cxt lcxt Nothing = Just lcxt
rho_ty = mkHsQualTy ctxt noSrcSpan (L loc ctxt') add_cxt (L loc cxt1) (Just (L _ cxt2)) = Just (L loc (cxt1 ++ cxt2))
(hsib_body conT)
in con' { con_type = mkHsImplicitBndrs hs_ty } add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
ConDeclH98 {} -> = con { con_forall = not (null all_tvs)
let qvars = case (tvs, con_qvars con') of , con_qvars = mkHsQTvs all_tvs
([], Nothing) -> Nothing , con_mb_cxt = add_cxt cxt' cxt }
(_ , m_qvs ) -> Just $ where
mkHsQTvs (hsQTvExplicit tvs' ++ all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars
maybe [] hsQTvExplicit m_qvs)
in con' { con_qvars = qvars add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })
, con_cxt = Just $ = con { con_forall = not (null all_tvs)
L loc (ctxt' ++ , con_ex_tvs = all_tvs
unLoc (fromMaybe (noLoc []) , con_mb_cxt = add_cxt cxt' cxt }
(con_cxt con'))) } } where
all_tvs = hsQTvExplicit tvs' ++ ex_tvs
cvtConstr (GadtC c strtys ty) cvtConstr (GadtC c strtys ty)
= do { c' <- mapM cNameL c = do { c' <- mapM cNameL c
; args <- mapM cvt_arg strtys ; args <- mapM cvt_arg strtys
; L _ ty' <- cvtType ty ; L _ ty' <- cvtType ty
; c_ty <- mk_arr_apps args ty' ; c_ty <- mk_arr_apps args ty'
; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)} ; returnL $ mkGadtDecl c' c_ty}
cvtConstr (RecGadtC c varstrtys ty) cvtConstr (RecGadtC c varstrtys ty)
= do { c' <- mapM cNameL c = do { c' <- mapM cNameL c
; ty' <- cvtType ty ; ty' <- cvtType ty
; rec_flds <- mapM cvt_id_arg varstrtys ; rec_flds <- mapM cvt_id_arg varstrtys
; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty') ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')
; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) } ; returnL $ mkGadtDecl c' rec_ty }
cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
......
...@@ -63,10 +63,8 @@ module HsDecls ( ...@@ -63,10 +63,8 @@ module HsDecls (
CImportSpec(..), CImportSpec(..),
-- ** Data-constructor declarations -- ** Data-constructor declarations
ConDecl(..), LConDecl, ConDecl(..), LConDecl,
HsConDeclDetails, hsConDeclArgTys, HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta,
getConNames, getConNames, getConArgs,
getConDetails,
gadtDeclDetails,
-- ** Document comments -- ** Document comments
DocDecl(..), LDocDecl, docDeclDoc, DocDecl(..), LDocDecl, docDeclDoc,
-- ** Deprecations -- ** Deprecations
...@@ -909,7 +907,7 @@ data FamilyDecl pass = FamilyDecl ...@@ -909,7 +907,7 @@ data FamilyDecl pass = FamilyDecl
{ fdInfo :: FamilyInfo pass -- type/data, closed/open { fdInfo :: FamilyInfo pass -- type/data, closed/open
, fdLName :: Located (IdP pass) -- type constructor , fdLName :: Located (IdP pass) -- type constructor
, fdTyVars :: LHsQTyVars pass -- type variables , fdTyVars :: LHsQTyVars pass -- type variables
, fdFixity :: LexicalFixity -- Fixity used in the declaration , fdFixity :: LexicalFixity -- Fixity used in the declaration
, fdResultSig :: LFamilyResultSig pass -- result signature , fdResultSig :: LFamilyResultSig pass -- result signature
, fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann
} }
...@@ -1151,8 +1149,19 @@ type LConDecl pass = Located (ConDecl pass) ...@@ -1151,8 +1149,19 @@ type LConDecl pass = Located (ConDecl pass)
data ConDecl pass data ConDecl pass
= ConDeclGADT = ConDeclGADT
{ con_names :: [Located (IdP pass)] { con_names :: [Located (IdP pass)]
, con_type :: LHsSigType pass
-- ^ The type after the ‘::’ -- The next four fields describe the type after the '::'
-- See Note [GADT abstract syntax]
, con_forall :: Bool -- ^ True <=> explicit forall
-- False => hsq_explicit is empty
, con_qvars :: LHsQTyVars pass
-- Whether or not there is an /explicit/ forall, we still
-- need to capture the implicitly-bound type/kind variables
, con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)
, con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon
, con_res_ty :: LHsType pass -- ^ Result type
, con_doc :: Maybe LHsDocString , con_doc :: Maybe LHsDocString
-- ^ A possible Haddock comment. -- ^ A possible Haddock comment.
} }
...@@ -1160,24 +1169,56 @@ data ConDecl pass ...@@ -1160,24 +1169,56 @@ data ConDecl pass
| ConDeclH98 | ConDeclH98
{ con_name :: Located (IdP pass) { con_name :: Located (IdP pass)
, con_qvars :: Maybe (LHsQTyVars pass) , con_forall :: Bool -- ^ True <=> explicit user-written forall
-- User-written forall (if any), and its implicit -- e.g. data T a = forall b. MkT b (b->a)
-- kind variables -- con_ex_tvs = {b}
-- Non-Nothing means an explicit user-written forall -- False => con_ex_tvs is empty
-- e.g. data T a = forall b. MkT b (b->a) , con_ex_tvs :: [LHsTyVarBndr pass] -- ^ Existentials only
-- con_qvars = {b} , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)
, con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon
, con_cxt :: Maybe (LHsContext pass)
-- ^ User-written context (if any)
, con_details :: HsConDeclDetails pass
-- ^ Arguments
, con_doc :: Maybe LHsDocString , con_doc :: Maybe LHsDocString
-- ^ A possible Haddock comment. -- ^ A possible Haddock comment.
} }
deriving instance (DataId pass) => Data (ConDecl pass) deriving instance (DataId pass) => Data (ConDecl pass)
{- Note [GADT abstract syntax]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There's a wrinkle in ConDeclGADT
* For record syntax, it's all uniform. Given:
data T a where
K :: forall a. Ord a => { x :: [a], ... } -> T a
we make the a ConDeclGADT for K with
con_qvars = {a}
con_mb_cxt = Just [Ord a]
con_args = RecCon <the record fields>
con_res_ty = T a
We need the RecCon before the reanmer, so we can find the record field
binders in HsUtils.hsConDeclsBinders.
* However for a GADT constr declaration which is not a record, it can
be hard parse until we know 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).
So: - In the parser (RdrHsSyn.mkGadtDecl), we put the whole constr
type into the res_ty for a ConDeclGADT for now, and use
PrefixCon []
con_args = PrefixCon []
con_res_ty = a :*: (b -> (a :*: (b -> (a :+: b))))
- In the renamer (RnSource.rnConDecl), we unravel it afer
operator fixities are sorted. So we generate. So we end
up with
con_args = PrefixCon [ a :*: b, a :*: b ]
con_res_ty = a :+: b
-}
-- | Haskell data Constructor Declaration Details -- | Haskell data Constructor Declaration Details
type HsConDeclDetails pass type HsConDeclDetails pass
= HsConDetails (LBangType pass) (Located [LConDeclField pass]) = HsConDetails (LBangType pass) (Located [LConDeclField pass])
...@@ -1186,36 +1227,21 @@ getConNames :: ConDecl pass -> [Located (IdP pass)] ...@@ -1186,36 +1227,21 @@ getConNames :: ConDecl pass -> [Located (IdP pass)]
getConNames ConDeclH98 {con_name = name} = [name] getConNames ConDeclH98 {con_name = name} = [name]
getConNames ConDeclGADT {con_names = names} = names getConNames ConDeclGADT {con_names = names} = names
-- don't call with RdrNames, because it can't deal with HsAppsTy getConArgs :: ConDecl pass -> HsConDeclDetails pass
getConDetails :: ConDecl pass -> HsConDeclDetails pass getConArgs d = con_args d
getConDetails ConDeclH98 {con_details = details} = details
getConDetails ConDeclGADT {con_type = ty } = details
where
(details,_,_,_) = gadtDeclDetails ty
-- don't call with RdrNames, because it can't deal with HsAppsTy
gadtDeclDetails :: LHsSigType pass
-> ( HsConDeclDetails pass
, LHsType pass
, LHsContext pass
, [LHsTyVarBndr pass] )
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 pass -> [LBangType pass] hsConDeclArgTys :: HsConDeclDetails pass -> [LBangType pass]
hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (PrefixCon tys) = tys
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds)
pp_data_defn :: (SourceTextX pass, OutputableBndrId pass) hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass]
=> (HsContext pass -> SDoc) -- Printing the header hsConDeclTheta Nothing = []
-> HsDataDefn pass hsConDeclTheta (Just (L _ theta)) = theta
pp_data_defn :: (SourceTextX p, OutputableBndrId p)
=> (HsContext p -> SDoc) -- Printing the header
-> HsDataDefn p
-> SDoc -> SDoc
pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
, dd_cType = mb_ct , dd_cType = mb_ct
...@@ -1258,26 +1284,34 @@ instance (SourceTextX pass, OutputableBndrId pass) ...@@ -1258,26 +1284,34 @@ instance (SourceTextX pass, OutputableBndrId pass)
pprConDecl :: (SourceTextX pass, OutputableBndrId pass) => ConDecl pass -> SDoc pprConDecl :: (SourceTextX pass, OutputableBndrId pass) => ConDecl pass -> SDoc
pprConDecl (ConDeclH98 { con_name = L _ con pprConDecl (ConDeclH98 { con_name = L _ con
, con_qvars = mtvs , con_ex_tvs = ex_tvs
, con_cxt = mcxt , con_mb_cxt = mcxt
, con_details = details , con_args = args
, con_doc = doc }) , con_doc = doc })
= sep [ppr_mbDoc doc, pprHsForAll tvs cxt, ppr_details details] = sep [ppr_mbDoc doc, pprHsForAll ex_tvs cxt, ppr_details args]
where where
ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2] ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2]
ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con
: map (pprHsType . unLoc) tys) : map (pprHsType . unLoc) tys)
ppr_details (RecCon fields) = pprPrefixOcc con ppr_details (RecCon fields) = pprPrefixOcc con
<+> pprConDeclFields (unLoc fields) <+> pprConDeclFields (unLoc fields)
tvs = case mtvs of cxt = fromMaybe (noLoc []) mcxt
Nothing -> []
Just (HsQTvs { hsq_explicit = tvs }) -> tvs pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
, con_mb_cxt = mcxt, con_args = args
, con_res_ty = res_ty, con_doc = doc })
= ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
<+> (sep [pprHsForAll (hsq_explicit qvars) cxt,
ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])
where
get_args (PrefixCon args) = map ppr args
get_args (RecCon fields) = [pprConDeclFields (unLoc fields)]
get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr cons)
cxt = fromMaybe (noLoc []) mcxt cxt = fromMaybe (noLoc []) mcxt
pprConDecl (ConDeclGADT { con_names = cons, con_type = res_ty, con_doc = doc }) ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)
= sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon ppr_arrow_chain [] = empty
<+> ppr res_ty]
ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc
ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
......
...@@ -35,7 +35,7 @@ module HsTypes ( ...@@ -35,7 +35,7 @@ module HsTypes (
SrcStrictness(..), SrcUnpackedness(..), SrcStrictness(..), SrcUnpackedness(..),
getBangType, getBangStrictness, getBangType, getBangStrictness,
ConDeclField(..), LConDeclField, pprConDeclFields, updateGadtResult, ConDeclField(..), LConDeclField, pprConDeclFields,
HsConDetails(..), HsConDetails(..),
...@@ -50,7 +50,7 @@ module HsTypes ( ...@@ -50,7 +50,7 @@ module HsTypes (
mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody, mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
mkEmptyImplicitBndrs, mkEmptyWildCardBndrs, mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs, mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs,
isHsKindedTyVar, hsTvbAllKinded, isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy,
hsScopedTvs, hsWcScopedTvs, dropWildCards, hsScopedTvs, hsWcScopedTvs, dropWildCards,
hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames, hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,
hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames, hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames,
...@@ -59,7 +59,7 @@ module HsTypes ( ...@@ -59,7 +59,7 @@ module HsTypes (
splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy, splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy,
splitHsFunType, splitHsAppsTy, splitHsFunType, splitHsAppsTy,
splitHsAppTys, getAppsTyHead_maybe, hsTyGetAppHead_maybe, splitHsAppTys, getAppsTyHead_maybe, hsTyGetAppHead_maybe,
mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppsTy,
ignoreParens, hsSigType, hsSigWcType, ignoreParens, hsSigType, hsSigWcType,
hsLTyVarBndrToType, hsLTyVarBndrsToTypes, hsLTyVarBndrToType, hsLTyVarBndrsToTypes,