summaryrefslogtreecommitdiff
path: root/compiler/hsSyn/HsDecls.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/hsSyn/HsDecls.hs')
-rw-r--r--compiler/hsSyn/HsDecls.hs161
1 files changed, 104 insertions, 57 deletions
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 4b54a8d702..6fcfa6724d 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -38,13 +38,15 @@ module HsDecls (
TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
+ HsTyPats,
LClsInstDecl, ClsInstDecl(..),
-- ** Standalone deriving declarations
DerivDecl(..), LDerivDecl,
-- ** @RULE@ declarations
- RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr,
+ LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr,
collectRuleBndrSigTys,
+ flattenRuleDecls,
-- ** @VECTORISE@ declarations
VectDecl(..), LVectDecl,
lvectDeclName, lvectInstDecl,
@@ -64,6 +66,7 @@ module HsDecls (
DocDecl(..), LDocDecl, docDeclDoc,
-- ** Deprecations
WarnDecl(..), LWarnDecl,
+ WarnDecls(..), LWarnDecls,
-- ** Annotations
AnnDecl(..), LAnnDecl,
AnnProvenance(..), annProvenanceName_maybe,
@@ -130,9 +133,9 @@ data HsDecl id
| SigD (Sig id)
| DefD (DefaultDecl id)
| ForD (ForeignDecl id)
- | WarningD (WarnDecl id)
+ | WarningD (WarnDecls id)
| AnnD (AnnDecl id)
- | RuleD (RuleDecl id)
+ | RuleD (RuleDecls id)
| VectD (VectDecl id)
| SpliceD (SpliceDecl id)
| DocD (DocDecl)
@@ -179,9 +182,9 @@ data HsGroup id
hs_defds :: [LDefaultDecl id],
hs_fords :: [LForeignDecl id],
- hs_warnds :: [LWarnDecl id],
+ hs_warnds :: [LWarnDecls id],
hs_annds :: [LAnnDecl id],
- hs_ruleds :: [LRuleDecl id],
+ hs_ruleds :: [LRuleDecls id],
hs_vects :: [LVectDecl id],
hs_docs :: [LDocDecl]
@@ -497,10 +500,11 @@ data TyClDecl name
| ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context...
tcdLName :: Located name, -- ^ Name of the class
tcdTyVars :: LHsTyVarBndrs name, -- ^ Class type variables
- tcdFDs :: [Located (FunDep name)], -- ^ Functional deps
+ tcdFDs :: [Located (FunDep (Located name))],
+ -- ^ Functional deps
tcdSigs :: [LSig name], -- ^ Methods' signatures
tcdMeths :: LHsBinds name, -- ^ Default methods
- tcdATs :: [LFamilyDecl name], -- ^ Associated types; ie
+ tcdATs :: [LFamilyDecl name], -- ^ Associated types;
tcdATDefs :: [LTyFamDefltEqn name], -- ^ Associated type defaults
tcdDocs :: [LDocDecl], -- ^ Haddock docs
tcdFVs :: PostRn name NameSet
@@ -889,23 +893,25 @@ data ConDecl name
} deriving (Typeable)
deriving instance (DataId name) => Data (ConDecl name)
-type HsConDeclDetails name = HsConDetails (LBangType name) [LConDeclField name]
+type HsConDeclDetails name
+ = HsConDetails (LBangType name) (Located [LConDeclField name])
hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
hsConDeclArgTys (PrefixCon tys) = tys
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
-hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) flds
+hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds)
data ResType ty
- = ResTyH98 -- Constructor was declared using Haskell 98 syntax
- | ResTyGADT ty -- Constructor was declared using GADT-style syntax,
- -- and here is its result type
+ = 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
+ ppr ResTyH98 = ptext (sLit "ResTyH98")
+ ppr (ResTyGADT _ ty) = ptext (sLit "ResTyGADT") <+> ppr ty
pp_data_defn :: OutputableBndr name
=> (HsContext name -> SDoc) -- Printing the header
@@ -937,7 +943,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 _ ConDecl{ con_res = ResTyGADT _ _ } : _) -- 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))
@@ -955,20 +961,21 @@ pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
ppr_details (PrefixCon tys) = hsep (pprPrefixOcc cons
: map (pprParendHsType . unLoc) tys)
ppr_details (RecCon fields) = ppr_con_names cons
- <+> pprConDeclFields fields
+ <+> pprConDeclFields (unLoc fields)
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_res = ResTyGADT _ res_ty })
= ppr_con_names cons <+> dcolon <+>
sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
where
mk_fun_ty a b = noLoc (HsFunTy a b)
pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
- , con_cxt = cxt, con_details = RecCon fields, con_res = ResTyGADT res_ty })
+ , con_cxt = cxt, con_details = RecCon fields
+ , con_res = ResTyGADT _ res_ty })
= sep [ppr_con_names cons <+> dcolon <+> pprHsForAll expl tvs cxt,
- pprConDeclFields fields <+> arrow <+> ppr res_ty]
+ 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] })
@@ -1190,11 +1197,11 @@ ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc
ppOverlapPragma mb =
case mb of
Nothing -> empty
- Just (L _ NoOverlap) -> ptext (sLit "{-# NO_OVERLAP #-}")
- Just (L _ Overlappable) -> ptext (sLit "{-# OVERLAPPABLE #-}")
- Just (L _ Overlapping) -> ptext (sLit "{-# OVERLAPPING #-}")
- Just (L _ Overlaps) -> ptext (sLit "{-# OVERLAPS #-}")
- Just (L _ Incoherent) -> ptext (sLit "{-# INCOHERENT #-}")
+ Just (L _ (NoOverlap _)) -> ptext (sLit "{-# NO_OVERLAP #-}")
+ Just (L _ (Overlappable _)) -> ptext (sLit "{-# OVERLAPPABLE #-}")
+ Just (L _ (Overlapping _)) -> ptext (sLit "{-# OVERLAPPING #-}")
+ Just (L _ (Overlaps _)) -> ptext (sLit "{-# OVERLAPS #-}")
+ Just (L _ (Incoherent _)) -> ptext (sLit "{-# INCOHERENT #-}")
@@ -1333,9 +1340,9 @@ data ForeignImport = -- import of a C entity
--
CImport (Located CCallConv) -- ccall or stdcall
(Located Safety) -- interruptible, safe or unsafe
- (Maybe Header) -- name of C header
- CImportSpec -- details of the C entity
- (Located FastString) -- original source text for
+ (Maybe Header) -- name of C header
+ CImportSpec -- details of the C entity
+ (Located SourceText) -- original source text for
-- the C entity
deriving (Data, Typeable)
@@ -1352,7 +1359,7 @@ data CImportSpec = CLabel CLabelString -- import address of a C label
--
data ForeignExport = CExport (Located CExportSpec) -- contains the calling
-- convention
- (Located FastString) -- original source text for
+ (Located SourceText) -- original source text for
-- the C entity
deriving (Data, Typeable)
@@ -1399,6 +1406,14 @@ instance Outputable ForeignExport where
************************************************************************
-}
+type LRuleDecls name = Located (RuleDecls name)
+
+ -- Note [Pragma source text] in BasicTypes
+data RuleDecls name = HsRules { rds_src :: SourceText
+ , rds_rules :: [LRuleDecl name] }
+ deriving (Typeable)
+deriving instance (DataId name) => Data (RuleDecls name)
+
type LRuleDecl name = Located (RuleDecl name)
data RuleDecl name
@@ -1412,13 +1427,18 @@ data RuleDecl name
(Located (HsExpr name)) -- RHS
(PostRn name NameSet) -- Free-vars from the RHS
-- ^
- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
- -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnVal',
- -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnTilde',
+ -- - 'ApiAnnotation.AnnKeywordId' :
+ -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde',
+ -- 'ApiAnnotation.AnnVal',
+ -- 'ApiAnnotation.AnnClose',
-- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot',
+ -- 'ApiAnnotation.AnnEqual',
deriving (Typeable)
deriving instance (DataId name) => Data (RuleDecl name)
+flattenRuleDecls :: [LRuleDecls name] -> [LRuleDecl name]
+flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
+
type LRuleBndr name = Located (RuleBndr name)
data RuleBndr name
= RuleBndr (Located name)
@@ -1432,6 +1452,9 @@ deriving instance (DataId name) => Data (RuleBndr name)
collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs name (LHsType name)]
collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
+instance OutputableBndr name => Outputable (RuleDecls name) where
+ ppr (HsRules _ rules) = ppr rules
+
instance OutputableBndr name => Outputable (RuleDecl name) where
ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)
= sep [text "{-# RULES" <+> doubleQuotes (ftext $ unLoc name)
@@ -1467,15 +1490,18 @@ type LVectDecl name = Located (VectDecl name)
data VectDecl name
= HsVect
+ SourceText -- Note [Pragma source text] in BasicTypes
(Located name)
(LHsExpr name)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnClose'
| HsNoVect
+ SourceText -- Note [Pragma source text] in BasicTypes
(Located name)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-- 'ApiAnnotation.AnnClose'
| HsVectTypeIn -- pre type-checking
+ SourceText -- Note [Pragma source text] in BasicTypes
Bool -- 'TRUE' => SCALAR declaration
(Located name)
(Maybe (Located name)) -- 'Nothing' => no right-hand side
@@ -1487,6 +1513,7 @@ data VectDecl name
TyCon
(Maybe TyCon) -- 'Nothing' => no right-hand side
| HsVectClassIn -- pre type-checking
+ SourceText -- Note [Pragma source text] in BasicTypes
(Located name)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-- 'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose',
@@ -1500,14 +1527,16 @@ data VectDecl name
deriving instance (DataId name) => Data (VectDecl name)
lvectDeclName :: NamedThing name => LVectDecl name -> Name
-lvectDeclName (L _ (HsVect (L _ name) _)) = getName name
-lvectDeclName (L _ (HsNoVect (L _ name))) = getName name
-lvectDeclName (L _ (HsVectTypeIn _ (L _ name) _)) = getName name
-lvectDeclName (L _ (HsVectTypeOut _ tycon _)) = getName tycon
-lvectDeclName (L _ (HsVectClassIn (L _ name))) = getName name
-lvectDeclName (L _ (HsVectClassOut cls)) = getName cls
-lvectDeclName (L _ (HsVectInstIn _)) = panic "HsDecls.lvectDeclName: HsVectInstIn"
-lvectDeclName (L _ (HsVectInstOut _)) = panic "HsDecls.lvectDeclName: HsVectInstOut"
+lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName name
+lvectDeclName (L _ (HsNoVect _ (L _ name))) = getName name
+lvectDeclName (L _ (HsVectTypeIn _ _ (L _ name) _)) = getName name
+lvectDeclName (L _ (HsVectTypeOut _ tycon _)) = getName tycon
+lvectDeclName (L _ (HsVectClassIn _ (L _ name))) = getName name
+lvectDeclName (L _ (HsVectClassOut cls)) = getName cls
+lvectDeclName (L _ (HsVectInstIn _))
+ = panic "HsDecls.lvectDeclName: HsVectInstIn"
+lvectDeclName (L _ (HsVectInstOut _))
+ = panic "HsDecls.lvectDeclName: HsVectInstOut"
lvectInstDecl :: LVectDecl name -> Bool
lvectInstDecl (L _ (HsVectInstIn _)) = True
@@ -1515,19 +1544,19 @@ lvectInstDecl (L _ (HsVectInstOut _)) = True
lvectInstDecl _ = False
instance OutputableBndr name => Outputable (VectDecl name) where
- ppr (HsVect v rhs)
+ ppr (HsVect _ v rhs)
= sep [text "{-# VECTORISE" <+> ppr v,
nest 4 $
pprExpr (unLoc rhs) <+> text "#-}" ]
- ppr (HsNoVect v)
+ ppr (HsNoVect _ v)
= sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ]
- ppr (HsVectTypeIn False t Nothing)
+ ppr (HsVectTypeIn _ False t Nothing)
= sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ]
- ppr (HsVectTypeIn False t (Just t'))
+ ppr (HsVectTypeIn _ False t (Just t'))
= sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ]
- ppr (HsVectTypeIn True t Nothing)
+ ppr (HsVectTypeIn _ True t Nothing)
= sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
- ppr (HsVectTypeIn True t (Just t'))
+ ppr (HsVectTypeIn _ True t (Just t'))
= sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ]
ppr (HsVectTypeOut False t Nothing)
= sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ]
@@ -1537,7 +1566,7 @@ instance OutputableBndr name => Outputable (VectDecl name) where
= sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
ppr (HsVectTypeOut True t (Just t'))
= sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ]
- ppr (HsVectClassIn c)
+ ppr (HsVectClassIn _ c)
= sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
ppr (HsVectClassOut c)
= sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
@@ -1583,11 +1612,24 @@ docDeclDoc (DocGroup _ d) = d
We use exported entities for things to deprecate.
-}
+
+type LWarnDecls name = Located (WarnDecls name)
+
+ -- Note [Pragma source text] in BasicTypes
+data WarnDecls name = Warnings { wd_src :: SourceText
+ , wd_warnings :: [LWarnDecl name]
+ }
+ deriving (Data, Typeable)
+
+
type LWarnDecl name = Located (WarnDecl name)
-data WarnDecl name = Warning name WarningTxt
+data WarnDecl name = Warning [Located name] WarningTxt
deriving (Data, Typeable)
+instance OutputableBndr name => Outputable (WarnDecls name) where
+ ppr (Warnings _ decls) = ppr decls
+
instance OutputableBndr name => Outputable (WarnDecl name) where
ppr (Warning thing txt)
= hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
@@ -1602,7 +1644,9 @@ instance OutputableBndr name => Outputable (WarnDecl name) where
type LAnnDecl name = Located (AnnDecl name)
-data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name))
+data AnnDecl name = HsAnnotation
+ SourceText -- Note [Pragma source text] in BasicTypes
+ (AnnProvenance name) (Located (HsExpr name))
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-- 'ApiAnnotation.AnnType'
-- 'ApiAnnotation.AnnModule'
@@ -1611,24 +1655,27 @@ data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name))
deriving instance (DataId name) => Data (AnnDecl name)
instance (OutputableBndr name) => Outputable (AnnDecl name) where
- ppr (HsAnnotation provenance expr)
+ ppr (HsAnnotation _ provenance expr)
= hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
-
-data AnnProvenance name = ValueAnnProvenance name
- | TypeAnnProvenance name
+data AnnProvenance name = ValueAnnProvenance (Located name)
+ | TypeAnnProvenance (Located name)
| ModuleAnnProvenance
- deriving (Data, Typeable, Functor, Foldable, Traversable)
+ deriving (Data, Typeable, Functor)
+deriving instance Foldable AnnProvenance
+deriving instance Traversable AnnProvenance
annProvenanceName_maybe :: AnnProvenance name -> Maybe name
-annProvenanceName_maybe (ValueAnnProvenance name) = Just name
-annProvenanceName_maybe (TypeAnnProvenance name) = Just name
+annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name
+annProvenanceName_maybe (TypeAnnProvenance (L _ name)) = Just name
annProvenanceName_maybe ModuleAnnProvenance = Nothing
pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc
pprAnnProvenance ModuleAnnProvenance = ptext (sLit "ANN module")
-pprAnnProvenance (ValueAnnProvenance name) = ptext (sLit "ANN") <+> ppr name
-pprAnnProvenance (TypeAnnProvenance name) = ptext (sLit "ANN type") <+> ppr name
+pprAnnProvenance (ValueAnnProvenance (L _ name))
+ = ptext (sLit "ANN") <+> ppr name
+pprAnnProvenance (TypeAnnProvenance (L _ name))
+ = ptext (sLit "ANN type") <+> ppr name
{-
************************************************************************
View Lorry Controller Status