Commit 51a5e68d authored by Alan Zimmerman's avatar Alan Zimmerman Committed by Ben Gamari

Refactor ConDecl

The ConDecl type in HsDecls is an uneasy compromise. For the most part,
HsSyn directly reflects the syntax written by the programmer; and that
gives just the right "pegs" on which to hang Alan's API annotations. But
ConDecl doesn't properly reflect the syntax of Haskell-98 and GADT-style
data type declarations.

To be concrete, here's a draft new data type

```lang=hs
data ConDecl name
  | ConDeclGADT
      { con_names   :: [Located name]
      , con_type    :: LHsSigType name  -- The type after the ‘::’
      , con_doc     :: Maybe LHsDocString }

  | ConDeclH98
      { con_name    :: Located name

      , con_qvars     :: Maybe (LHsQTyVars name)
        -- User-written forall (if any), and its implicit
        -- kind variables
        -- Non-Nothing needs -XExistentialQuantification

      , con_cxt       :: Maybe (LHsContext name)
        -- ^ User-written context (if any)

      , con_details   :: HsConDeclDetails name
          -- ^ Arguments

      , con_doc       :: Maybe LHsDocString
          -- ^ A possible Haddock comment.
      } deriving (Typeable)
```

Note that

    For GADTs, just keep a type. That's what the user writes.
    NB:HsType can represent records on the LHS of an arrow:

      { x:Int,y:Bool} -> T

    con_qvars and con_cxt are both Maybe because they are both
    optional (the forall and the context of an existential data type

    For ConDeclGADT the type variables of the data type do not scope
    over the con_type; whereas for ConDeclH98 they do scope over con_cxt
    and con_details.

Updates haddock submodule.

Test Plan: ./validate

Reviewers: simonpj, erikd, hvr, goldfire, austin, bgamari

Subscribers: erikd, goldfire, thomie, mpickering

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

GHC Trac Issues: #11028
parent 700c42b5
......@@ -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 []
......
......@@ -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
......
......@@ -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)
......
......@@ -195,4 +195,3 @@ pmPprHsLit (HsInteger _ i _) = integer i
pmPprHsLit (HsRat f _) = ppr f
pmPprHsLit (HsFloatPrim f) = ppr f
pmPprHsLit (HsDoublePrim d) = ppr d
......@@ -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
......
......@@ -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
{-
......
......@@ -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)
......
......@@ -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