diff options
Diffstat (limited to 'compiler/hsSyn/HsExtension.hs')
| -rw-r--r-- | compiler/hsSyn/HsExtension.hs | 328 |
1 files changed, 242 insertions, 86 deletions
diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs index 80dfa67ea3..b88906b2d0 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -7,6 +7,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder module HsExtension where @@ -55,6 +58,10 @@ haskell-src-exts ASTs as well. -} +-- | Used when constructing a term with an unused extension point. +noExt :: PlaceHolder +noExt = PlaceHolder + -- | Used as a data type index for the hsSyn AST data GhcPass (c :: Pass) deriving instance Eq (GhcPass c) @@ -76,6 +83,8 @@ type instance PostTc GhcPs ty = PlaceHolder type instance PostTc GhcRn ty = PlaceHolder type instance PostTc GhcTc ty = ty +-- deriving instance (Data ty) => Data (PostTc (GhcPass 'Parsed) ty) + -- | Types that are not defined until after renaming type family PostRn x ty -- Note [Pass sensitive types] in PlaceHolder type instance PostRn GhcPs ty = PlaceHolder @@ -87,88 +96,214 @@ type family IdP p type instance IdP GhcPs = RdrName type instance IdP GhcRn = Name type instance IdP GhcTc = Id +-- type instance IdP (GHC x) = IdP x + +type LIdP p = Located (IdP p) + +-- --------------------------------------------------------------------- +-- type families for the Pat extension points +type family XWildPat x +type family XVarPat x +type family XLazyPat x +type family XAsPat x +type family XParPat x +type family XBangPat x +type family XListPat x +type family XTuplePat x +type family XSumPat x +type family XPArrPat x +type family XConPat x +type family XViewPat x +type family XSplicePat x +type family XLitPat x +type family XNPat x +type family XNPlusKPat x +type family XSigPat x +type family XCoPat x +type family XXPat x + + +type ForallXPat (c :: * -> Constraint) (x :: *) = + ( c (XWildPat x) + , c (XVarPat x) + , c (XLazyPat x) + , c (XAsPat x) + , c (XParPat x) + , c (XBangPat x) + , c (XListPat x) + , c (XTuplePat x) + , c (XSumPat x) + , c (XPArrPat x) + , c (XViewPat x) + , c (XSplicePat x) + , c (XLitPat x) + , c (XNPat x) + , c (XNPlusKPat x) + , c (XSigPat x) + , c (XCoPat x) + , c (XXPat x) + ) +-- --------------------------------------------------------------------- +-- ValBindsLR type families +type family XValBinds x x' +type family XXValBindsLR x x' --- We define a type family for each extension point. This is based on prepending --- 'X' to the constructor name, for ease of reference. -type family XHsChar x -type family XHsCharPrim x -type family XHsString x +type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *)= + ( c (XValBinds x x') + , c (XXValBindsLR x x') + ) + + + + +-- We define a type family for each HsLit extension point. This is based on +-- prepending 'X' to the constructor name, for ease of reference. +type family XHsChar x +type family XHsCharPrim x +type family XHsString x type family XHsStringPrim x -type family XHsInt x -type family XHsIntPrim x -type family XHsWordPrim x -type family XHsInt64Prim x +type family XHsInt x +type family XHsIntPrim x +type family XHsWordPrim x +type family XHsInt64Prim x type family XHsWord64Prim x -type family XHsInteger x -type family XHsRat x -type family XHsFloatPrim x +type family XHsInteger x +type family XHsRat x +type family XHsFloatPrim x type family XHsDoublePrim x +type family XXLit x --- | Helper to apply a constraint to all extension points. It has one +-- | Helper to apply a constraint to all HsLit extension points. It has one -- entry per extension point type family. -type ForallX (c :: * -> Constraint) (x :: *) = - ( c (XHsChar x) - , c (XHsCharPrim x) - , c (XHsString x) +type ForallXHsLit (c :: * -> Constraint) (x :: *) = + ( c (XHsChar x) + , c (XHsCharPrim x) + , c (XHsString x) , c (XHsStringPrim x) - , c (XHsInt x) - , c (XHsIntPrim x) - , c (XHsWordPrim x) - , c (XHsInt64Prim x) + , c (XHsInt x) + , c (XHsIntPrim x) + , c (XHsWordPrim x) + , c (XHsInt64Prim x) , c (XHsWord64Prim x) - , c (XHsInteger x) - , c (XHsRat x) - , c (XHsFloatPrim x) + , c (XHsInteger x) + , c (XHsRat x) + , c (XHsFloatPrim x) , c (XHsDoublePrim x) + , c (XXLit x) ) --- Provide the specific extension types for the parser phase. -type instance XHsChar GhcPs = SourceText -type instance XHsCharPrim GhcPs = SourceText -type instance XHsString GhcPs = SourceText -type instance XHsStringPrim GhcPs = SourceText -type instance XHsInt GhcPs = () -type instance XHsIntPrim GhcPs = SourceText -type instance XHsWordPrim GhcPs = SourceText -type instance XHsInt64Prim GhcPs = SourceText -type instance XHsWord64Prim GhcPs = SourceText -type instance XHsInteger GhcPs = SourceText -type instance XHsRat GhcPs = () -type instance XHsFloatPrim GhcPs = () -type instance XHsDoublePrim GhcPs = () - --- Provide the specific extension types for the renamer phase. -type instance XHsChar GhcRn = SourceText -type instance XHsCharPrim GhcRn = SourceText -type instance XHsString GhcRn = SourceText -type instance XHsStringPrim GhcRn = SourceText -type instance XHsInt GhcRn = () -type instance XHsIntPrim GhcRn = SourceText -type instance XHsWordPrim GhcRn = SourceText -type instance XHsInt64Prim GhcRn = SourceText -type instance XHsWord64Prim GhcRn = SourceText -type instance XHsInteger GhcRn = SourceText -type instance XHsRat GhcRn = () -type instance XHsFloatPrim GhcRn = () -type instance XHsDoublePrim GhcRn = () - --- Provide the specific extension types for the typechecker phase. -type instance XHsChar GhcTc = SourceText -type instance XHsCharPrim GhcTc = SourceText -type instance XHsString GhcTc = SourceText -type instance XHsStringPrim GhcTc = SourceText -type instance XHsInt GhcTc = () -type instance XHsIntPrim GhcTc = SourceText -type instance XHsWordPrim GhcTc = SourceText -type instance XHsInt64Prim GhcTc = SourceText -type instance XHsWord64Prim GhcTc = SourceText -type instance XHsInteger GhcTc = SourceText -type instance XHsRat GhcTc = () -type instance XHsFloatPrim GhcTc = () -type instance XHsDoublePrim GhcTc = () +type family XOverLit x +type family XXOverLit x +type ForallXOverLit (c :: * -> Constraint) (x :: *) = + ( c (XOverLit x) + , c (XXOverLit x) + ) + +-- --------------------------------------------------------------------- +-- Type families for the Type type families + +type family XForAllTy x +type family XQualTy x +type family XTyVar x +type family XAppsTy x +type family XAppTy x +type family XFunTy x +type family XListTy x +type family XPArrTy x +type family XTupleTy x +type family XSumTy x +type family XOpTy x +type family XParTy x +type family XIParamTy x +type family XEqTy x +type family XKindSig x +type family XSpliceTy x +type family XDocTy x +type family XBangTy x +type family XRecTy x +type family XExplicitListTy x +type family XExplicitTupleTy x +type family XTyLit x +type family XWildCardTy x +type family XXType x + +-- | Helper to apply a constraint to all extension points. It has one +-- entry per extension point type family. +type ForallXType (c :: * -> Constraint) (x :: *) = + ( c (XForAllTy x) + , c (XQualTy x) + , c (XTyVar x) + , c (XAppsTy x) + , c (XAppTy x) + , c (XFunTy x) + , c (XListTy x) + , c (XPArrTy x) + , c (XTupleTy x) + , c (XSumTy x) + , c (XOpTy x) + , c (XParTy x) + , c (XIParamTy x) + , c (XEqTy x) + , c (XKindSig x) + , c (XSpliceTy x) + , c (XDocTy x) + , c (XBangTy x) + , c (XRecTy x) + , c (XExplicitListTy x) + , c (XExplicitTupleTy x) + , c (XTyLit x) + , c (XWildCardTy x) + , c (XXType x) + ) + +-- --------------------------------------------------------------------- + +type family XUserTyVar x +type family XKindedTyVar x +type family XXTyVarBndr x + +type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) = + ( c (XUserTyVar x) + , c (XKindedTyVar x) + , c (XXTyVarBndr x) + ) + +-- --------------------------------------------------------------------- + +type family XAppInfix x +type family XAppPrefix x +type family XXAppType x + +type ForallXAppType (c :: * -> Constraint) (x :: *) = + ( c (XAppInfix x) + , c (XAppPrefix x) + , c (XXAppType x) + ) + +-- --------------------------------------------------------------------- + +type family XFieldOcc x +type family XXFieldOcc x + +type ForallXFieldOcc (c :: * -> Constraint) (x :: *) = + ( c (XFieldOcc x) + , c (XXFieldOcc x) + ) + +-- --------------------------------------------------------------------- + +type family XUnambiguous x +type family XAmbiguous x +type family XXAmbiguousFieldOcc x + +type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) = + ( c (XUnambiguous x) + , c (XAmbiguous x) + , c (XXAmbiguousFieldOcc x) + ) -- --------------------------------------------------------------------- @@ -212,22 +347,6 @@ instance HasSourceText SourceText where -- ---------------------------------------------------------------------- --- | Defaults for each annotation, used to simplify creation in arbitrary --- contexts -class HasDefault a where - def :: a - -instance HasDefault () where - def = () - -instance HasDefault SourceText where - def = NoSourceText - --- | Provide a single constraint that captures the requirement for a default --- across all the extension points. -type HasDefaultX x = ForallX HasDefault x - --- ---------------------------------------------------------------------- -- | Conversion of annotations from one type index to another. This is required -- where the AST is converted from one pass to another, and the extension values -- need to be brought along if possible. So for example a 'SourceText' is @@ -254,15 +373,46 @@ type ConvertIdX a b = XHsStringPrim a ~ XHsStringPrim b, XHsString a ~ XHsString b, XHsCharPrim a ~ XHsCharPrim b, - XHsChar a ~ XHsChar b) + XHsChar a ~ XHsChar b, + XXLit a ~ XXLit b) +-- ---------------------------------------------------------------------- + +-- | Provide a summary constraint that gives all am Outputable constraint to +-- extension points needing one +type OutputableX p = + ( Outputable (XXPat p) + , Outputable (XXPat GhcRn) + , Outputable (XSigPat p) + , Outputable (XSigPat GhcRn) + , Outputable (XXLit p) + , Outputable (XXOverLit p) + , Outputable (XXType p) + ) +-- TODO: Should OutputableX be included in OutputableBndrId? -- ---------------------------------------------------------------------- -- type DataId p = ( Data p - , ForallX Data p + + , ForallXHsLit Data p + , ForallXPat Data p + + -- AZ: The following ForAllXXXX shoulbe be unnecessary? Driven by ValBindsOut + -- , ForallXPat Data (GhcPass 'Parsed) + , ForallXPat Data (GhcPass 'Renamed) + -- , ForallXPat Data (GhcPass 'Typechecked) + , ForallXType Data (GhcPass 'Renamed) + + , ForallXOverLit Data p + , ForallXType Data p + , ForallXTyVarBndr Data p + , ForallXAppType Data p + , ForallXFieldOcc Data p + , ForallXAmbiguousFieldOcc Data p + , Data (NameOrRdrName (IdP p)) , Data (IdP p) @@ -282,10 +432,16 @@ type DataId p = , Data (PostTc p [Type]) ) +type DataIdLR pL pR = + ( DataId pL + , DataId pR + , ForallXValBindsLR Data pL pR + ) -- |Constraint type to bundle up the requirement for 'OutputableBndr' on both -- the @id@ and the 'NameOrRdrName' type for it type OutputableBndrId id = ( OutputableBndr (NameOrRdrName (IdP id)) , OutputableBndr (IdP id) + , OutputableX id ) |