summaryrefslogtreecommitdiff
path: root/compiler/hsSyn
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/hsSyn')
-rw-r--r--compiler/hsSyn/Convert.hs17
-rw-r--r--compiler/hsSyn/HsDecls.hs133
-rw-r--r--compiler/hsSyn/HsTypes.hs4
-rw-r--r--compiler/hsSyn/HsUtils.hs19
4 files changed, 71 insertions, 102 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 1fc4f09ad9..ec13c4e216 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,18 @@ 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 b8612ed2be..981a59f95f 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -60,8 +60,9 @@ module HsDecls (
noForeignImportCoercionYet, noForeignExportCoercionYet,
CImportSpec(..),
-- ** Data-constructor declarations
- ConDecl(..), LConDecl, ResType(..),
+ ConDecl(..), LConDecl,
HsConDeclDetails, hsConDeclArgTys,
+ getConNames,
-- ** Document comments
DocDecl(..), LDocDecl, docDeclDoc,
-- ** Deprecations
@@ -106,6 +107,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 +958,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 +1022,47 @@ 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
+
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 +1093,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 +1102,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/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index ed4c3be44b..01902ea63e 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 19996fd0f1..01cc9abca3 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -953,14 +953,25 @@ 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
{-
View Lorry Controller Status