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
repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
repC (L _ (ConDeclH98 { con_name = con
, con_qvars = Nothing, con_cxt = Nothing
, con_details = details }))
= repDataCon con details
, con_forall = False
, con_mb_cxt = Nothing
, con_args = args }))
= repDataCon con args
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
, con_forall = is_existential
, con_ex_tvs = con_tvs
, con_mb_cxt = mcxt
, con_args = args }))
= do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
do { c' <- repDataCon con args
; ctxt' <- repMbContext mcxt
; if not is_existential && isNothing mcxt
then return c'
else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
}
}
repC (L _ (ConDeclGADT { con_names = cons
, con_type = res_ty@(HsIB { hsib_vars = imp_tvs })}))
| (details, res_ty', L _ [] , []) <- gadtDetails
, [] <- imp_tvs
-- 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, 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
, con_qvars = qtvs, con_mb_cxt = mcxt
, con_args = args, con_res_ty = res_ty }))
| isEmptyLHsQTvs qtvs -- No implicit or explicit variables
, Nothing <- mcxt -- No context
-- ==> no need for a forall
= repGadtDataCons cons args res_ty
| otherwise
= addTyVarBinds qtvs $ \ ex_bndrs ->
-- See Note [Don't quantify implicit type variables in quotes]
; 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)
; if null exp_tvs && null (unLoc ctxt)
do { c' <- repGadtDataCons cons args res_ty
; ctxt' <- repMbContext mcxt
; if null (hsQTvExplicit qtvs) && isNothing mcxt
then return c'
else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } }
where
gadtDetails = gadtDeclDetails res_ty
else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }
repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
repMbContext Nothing = repContext []
repMbContext (Just (L _ cxt)) = repContext cxt
repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName []
......@@ -867,25 +861,31 @@ addSimpleTyVarBinds names thing_inside
; term <- addBinds fresh_names thing_inside
; wrapGenSyms fresh_names term }
addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added
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))
-- 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
-- meta environment and gets the *new* names on Core-level as an argument
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 $
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)
; m kbs }
; wrapGenSyms fresh_names term }
; 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
-> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env
-> DsM (Core (TH.Q a))
-- 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
-- meta environment and gets the *new* names on Core-level as an argument
addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs })
thing_inside
= addSimpleTyVarBinds imp_tvs $
addHsTyVarBinds exp_tvs $
thing_inside
addTyClTyVarBinds :: LHsQTyVars GhcRn
-> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))
-> DsM (Core (TH.Q a))
......@@ -943,12 +943,9 @@ repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
repHsSigType (HsIB { hsib_vars = implicit_tvs
, hsib_body = body })
| (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body
= addTyVarBinds (HsQTvs { hsq_implicit = implicit_tvs
, hsq_explicit = explicit_tvs
, hsq_dependent = emptyNameSet })
-- NB: Don't pass implicit_tvs to the hsq_explicit field above
= addSimpleTyVarBinds implicit_tvs $
-- See Note [Don't quantify implicit type variables in quotes]
$ \ th_explicit_tvs ->
addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->
do { th_ctxt <- repLContext ctxt
; th_ty <- repLTy ty
; if null explicit_tvs && null (unLoc ctxt)
......@@ -958,20 +955,15 @@ repHsSigType (HsIB { hsib_vars = implicit_tvs
repHsPatSynSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs
, hsib_body = body })
= addTyVarBinds (newTvs implicit_tvs univs) $ \th_univs ->
addTyVarBinds (newTvs [] exis) $ \th_exis ->
= addSimpleTyVarBinds implicit_tvs $
-- See Note [Don't quantify implicit type variables in quotes]
addHsTyVarBinds univs $ \th_univs ->
addHsTyVarBinds exis $ \th_exis ->
do { th_reqs <- repLContext reqs
; th_provs <- repLContext provs
; th_ty <- repLTy ty
; repTForall th_univs th_reqs =<< (repTForall th_exis th_provs th_ty) }
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
repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ)
......@@ -990,8 +982,7 @@ repForall :: HsType GhcRn -> DsM (Core TH.TypeQ)
-- Arg of repForall is always HsForAllTy or HsQualTy
repForall ty
| (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
= addTyVarBinds (HsQTvs { hsq_implicit = [], hsq_explicit = tvs
, hsq_dependent = emptyNameSet }) $ \bndrs ->
= addHsTyVarBinds tvs $ \bndrs ->
do { ctxt1 <- repLContext ctxt
; ty1 <- repLTy tau
; repTForall bndrs ctxt1 ty1 }
......
......@@ -42,7 +42,7 @@ import MonadUtils ( foldrM )
import qualified Data.ByteString as BS
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.Syntax as TH
......@@ -490,59 +490,57 @@ cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)
cvtConstr (NormalC c strtys)
= do { c' <- cNameL c
; cxt' <- returnL []
; tys' <- mapM cvt_arg strtys
; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') }
; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') }
cvtConstr (RecC c varstrtys)
= do { c' <- cNameL c
; cxt' <- returnL []
; args' <- mapM cvt_id_arg varstrtys
; returnL $ mkConDeclH98 c' Nothing cxt'
; returnL $ mkConDeclH98 c' Nothing Nothing
(RecCon (noLoc args')) }
cvtConstr (InfixC st1 c st2)
= do { c' <- cNameL c
; cxt' <- returnL []
; st1' <- cvt_arg st1
; 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)
= do { tvs' <- cvtTvs tvs
; L loc ctxt' <- cvtContext ctxt
; ctxt' <- cvtContext ctxt
; L _ con' <- cvtConstr con
; returnL $ case con' of
ConDeclGADT { con_type = conT } ->
let hs_ty = mkHsForAllTy tvs noSrcSpan tvs' rho_ty
rho_ty = mkHsQualTy ctxt noSrcSpan (L loc ctxt')
(hsib_body conT)
in con' { con_type = mkHsImplicitBndrs hs_ty }
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'))) } }
; returnL $ add_forall tvs' ctxt' con' }
where
add_cxt lcxt Nothing = Just lcxt
add_cxt (L loc cxt1) (Just (L _ cxt2)) = Just (L loc (cxt1 ++ cxt2))
add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
= con { con_forall = not (null all_tvs)
, con_qvars = mkHsQTvs all_tvs
, con_mb_cxt = add_cxt cxt' cxt }
where
all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars
add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })
= con { con_forall = not (null all_tvs)
, con_ex_tvs = all_tvs
, con_mb_cxt = add_cxt cxt' cxt }
where
all_tvs = hsQTvExplicit tvs' ++ ex_tvs
cvtConstr (GadtC c strtys ty)
= do { c' <- mapM cNameL c
; args <- mapM cvt_arg strtys
; L _ ty' <- cvtType ty
; c_ty <- mk_arr_apps args ty'
; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}
; returnL $ mkGadtDecl c' c_ty}
cvtConstr (RecGadtC c varstrtys ty)
= do { c' <- mapM cNameL c
; ty' <- cvtType ty
; rec_flds <- mapM cvt_id_arg varstrtys
; 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 NoSourceUnpackedness = NoSrcUnpack
......
......@@ -63,10 +63,8 @@ module HsDecls (
CImportSpec(..),
-- ** Data-constructor declarations
ConDecl(..), LConDecl,
HsConDeclDetails, hsConDeclArgTys,
getConNames,
getConDetails,
gadtDeclDetails,
HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta,
getConNames, getConArgs,
-- ** Document comments
DocDecl(..), LDocDecl, docDeclDoc,
-- ** Deprecations
......@@ -1151,8 +1149,19 @@ type LConDecl pass = Located (ConDecl pass)
data ConDecl pass
= ConDeclGADT
{ 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
-- ^ A possible Haddock comment.
}
......@@ -1160,24 +1169,56 @@ data ConDecl pass
| ConDeclH98
{ con_name :: Located (IdP pass)
, con_qvars :: Maybe (LHsQTyVars pass)
-- User-written forall (if any), and its implicit
-- kind variables
-- Non-Nothing means an explicit user-written forall
, con_forall :: Bool -- ^ True <=> explicit user-written forall
-- e.g. data T a = forall b. MkT b (b->a)
-- con_qvars = {b}
, con_cxt :: Maybe (LHsContext pass)
-- ^ User-written context (if any)
, con_details :: HsConDeclDetails pass
-- ^ Arguments
-- con_ex_tvs = {b}
-- False => con_ex_tvs is empty
, con_ex_tvs :: [LHsTyVarBndr pass] -- ^ Existentials only
, con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)
, con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon
, con_doc :: Maybe LHsDocString
-- ^ A possible Haddock comment.
}
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
type HsConDeclDetails pass
= HsConDetails (LBangType pass) (Located [LConDeclField pass])
......@@ -1186,36 +1227,21 @@ getConNames :: ConDecl pass -> [Located (IdP pass)]
getConNames ConDeclH98 {con_name = name} = [name]
getConNames ConDeclGADT {con_names = names} = names
-- don't call with RdrNames, because it can't deal with HsAppsTy
getConDetails :: ConDecl pass -> HsConDeclDetails pass
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)
getConArgs :: ConDecl pass -> HsConDeclDetails pass
getConArgs d = con_args d
hsConDeclArgTys :: HsConDeclDetails pass -> [LBangType pass]
hsConDeclArgTys (PrefixCon tys) = tys
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds)
pp_data_defn :: (SourceTextX pass, OutputableBndrId pass)
=> (HsContext pass -> SDoc) -- Printing the header
-> HsDataDefn pass
hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass]
hsConDeclTheta Nothing = []
hsConDeclTheta (Just (L _ theta)) = theta
pp_data_defn :: (SourceTextX p, OutputableBndrId p)
=> (HsContext p -> SDoc) -- Printing the header
-> HsDataDefn p
-> SDoc
pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
, dd_cType = mb_ct
......@@ -1258,26 +1284,34 @@ instance (SourceTextX pass, OutputableBndrId pass)
pprConDecl :: (SourceTextX pass, OutputableBndrId pass) => ConDecl pass -> SDoc
pprConDecl (ConDeclH98 { con_name = L _ con
, con_qvars = mtvs
, con_cxt = mcxt
, con_details = details
, con_ex_tvs = ex_tvs
, con_mb_cxt = mcxt
, con_args = args
, 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
ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2]
ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con
: map (pprHsType . unLoc) tys)
ppr_details (RecCon fields) = pprPrefixOcc con
<+> pprConDeclFields (unLoc fields)
tvs = case mtvs of
Nothing -> []
Just (HsQTvs { hsq_explicit = tvs }) -> tvs
cxt = fromMaybe (noLoc []) mcxt
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
pprConDecl (ConDeclGADT { con_names = cons, con_type = res_ty, con_doc = doc })
= sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
<+> ppr res_ty]
ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)
ppr_arrow_chain [] = empty
ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc
ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
......
......@@ -35,7 +35,7 @@ module HsTypes (
SrcStrictness(..), SrcUnpackedness(..),
getBangType, getBangStrictness,
ConDeclField(..), LConDeclField, pprConDeclFields, updateGadtResult,
ConDeclField(..), LConDeclField, pprConDeclFields,
HsConDetails(..),
......@@ -50,7 +50,7 @@ module HsTypes (
mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs,
isHsKindedTyVar, hsTvbAllKinded,
isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy,
hsScopedTvs, hsWcScopedTvs, dropWildCards,
hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,
hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames,
......@@ -59,7 +59,7 @@ module HsTypes (
splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy,
splitHsFunType, splitHsAppsTy,
splitHsAppTys, getAppsTyHead_maybe, hsTyGetAppHead_maybe,
mkHsOpTy, mkHsAppTy, mkHsAppTys,
mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppsTy,
ignoreParens, hsSigType, hsSigWcType,
hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
......@@ -93,7 +93,6 @@ import Maybes( isJust )
import Data.Data hiding ( Fixity, Prefix, Infix )
import Data.Maybe ( fromMaybe )
import Control.Monad ( unless )
{-
************************************************************************
......@@ -785,30 +784,6 @@ instance (Outputable arg, Outputable rec)
ppr (RecCon rec) = text "RecCon:" <+> ppr rec
ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
-- 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 GhcRn) (Located [LConDeclField GhcRn])
-- ^ Original details
-> LHsType GhcRn -- ^ Original result type
-> m (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
LHsType GhcRn)
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 passs]
~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -918,9 +893,12 @@ sameWildCard (L l1 (AnonWildCard _)) (L l2 (AnonWildCard _)) = l1 == l2
ignoreParens :: LHsType pass -> LHsType pass
ignoreParens (L _ (HsParTy ty)) = ignoreParens ty
ignoreParens (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = ignoreParens ty
ignoreParens ty = ty
isLHsForAllTy :: LHsType p -> Bool
isLHsForAllTy (L _ (HsForAllTy {})) = True
isLHsForAllTy _ = False
{-
************************************************************************
* *
......@@ -941,6 +919,11 @@ mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
mkHsAppTys :: LHsType pass -> [LHsType pass] -> LHsType pass
mkHsAppTys = foldl mkHsAppTy
mkHsAppsTy :: [LHsAppType GhcPs] -> HsType GhcPs
-- In the common case of a singleton non-operator,
-- avoid the clutter of wrapping in a HsAppsTy
mkHsAppsTy [L _ (HsAppPrefix (L _ ty))] = ty
mkHsAppsTy app_tys = HsAppsTy app_tys
{-
************************************************************************
......
......@@ -84,7 +84,6 @@ module HsUtils(
hsLTyClDeclBinders, hsTyClForeignBinders,
hsPatSynSelectors, getPatSynBinds,
hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
hsDataDefnBinders,
-- Collecting implicit binders
lStmtsImplicits, hsValBindsImplicits, lPatImplicits
......@@ -1106,55 +1105,48 @@ hsDataDefnBinders (HsDataDefn { dd_cons = cons })
-- See Note [Binders in family instances]
-------------------
type Seen pass = [LFieldOcc pass] -> [LFieldOcc pass]
-- Filters out ones that have already been seen
hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass])
-- See hsLTyClDeclBinders for what this does
-- The function is boringly complicated because of the records
-- And since we only have equality, we have to be a little careful
hsConDeclsBinders cons = go id cons
where go :: ([LFieldOcc pass] -> [LFieldOcc pass])
-> [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass])
hsConDeclsBinders cons
= go id cons
where
go :: Seen pass -> [LConDecl pass]
-> ([Located (IdP pass)], [LFieldOcc pass])
go _ [] = ([], [])
go remSeen (r:rs) =
-- don't re-mangle the location of field names, because we don't
go remSeen (r:rs)
-- Don't re-mangle the location of field names, because we don't
-- have a record of the full location of the field declaration anyway
case r of
= case r of
-- remove only the first occurrence of any seen field in order to
-- avoid circumventing detection of duplicate fields (#9156)
L loc (ConDeclGADT { con_names = names
, con_type = HsIB { hsib_body = res_ty}}) ->
case tau of
L _ (HsFunTy
(L _ (HsAppsTy
[L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _res_ty)
-> record_gadt flds
L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty)
-> record_gadt flds
_other -> (map (L loc . unLoc) names ++ ns, fs)
where (ns, fs) = go remSeen rs
L loc (ConDeclGADT { con_names = names, con_args = args })
-> (map (L loc . unLoc) names ++ ns, flds ++ fs)
where
(_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs)
where r' = remSeen (concatMap (cd_fld_names . unLoc) flds)
remSeen' = foldr (.) remSeen
[deleteBy ((==) `on`
unLoc . rdrNameFieldOcc . unLoc) v
| v <- r']
(remSeen', flds) = get_flds remSeen args
(ns, fs) = go remSeen' rs
L loc (ConDeclH98 { con_name = name
, con_details = RecCon flds }) ->
([L loc (unLoc name)] ++ ns, r' ++ fs)