summaryrefslogtreecommitdiff
path: root/compiler/hsSyn
diff options
context:
space:
mode:
authorKavon Farvardin <kavon@farvard.in>2018-09-23 15:29:37 -0500
committerKavon Farvardin <kavon@farvard.in>2018-09-23 15:29:37 -0500
commit84c2ad99582391005b5e873198b15e9e9eb4f78d (patch)
treecaa8c2f2ec7e97fbb4977263c6817c9af5025cf4 /compiler/hsSyn
parent8ddb47cfcf5776e9a3c55fd37947c8a95e00fa12 (diff)
parente68b439fe5de61b9a2ca51af472185c62ccb8b46 (diff)
downloadhaskell-wip/T13904.tar.gz
update to current master againwip/T13904
Diffstat (limited to 'compiler/hsSyn')
-rw-r--r--compiler/hsSyn/Convert.hs749
-rw-r--r--compiler/hsSyn/HsBinds.hs518
-rw-r--r--compiler/hsSyn/HsDecls.hs1309
-rw-r--r--compiler/hsSyn/HsDoc.hs138
-rw-r--r--compiler/hsSyn/HsDumpAst.hs162
-rw-r--r--compiler/hsSyn/HsExpr.hs1407
-rw-r--r--compiler/hsSyn/HsExpr.hs-boot40
-rw-r--r--compiler/hsSyn/HsExtension.hs1105
-rw-r--r--compiler/hsSyn/HsImpExp.hs105
-rw-r--r--compiler/hsSyn/HsInstances.hs416
-rw-r--r--compiler/hsSyn/HsLit.hs132
-rw-r--r--compiler/hsSyn/HsPat.hs420
-rw-r--r--compiler/hsSyn/HsPat.hs-boot7
-rw-r--r--compiler/hsSyn/HsSyn.hs23
-rw-r--r--compiler/hsSyn/HsTypes.hs792
-rw-r--r--compiler/hsSyn/HsUtils.hs907
-rw-r--r--compiler/hsSyn/PlaceHolder.hs26
17 files changed, 5417 insertions, 2839 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index de36a85937..5d0f5afce1 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -8,13 +8,16 @@ This module converts Template Haskell syntax into HsSyn
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
convertToHsType,
thRdrNameGuesses ) where
+import GhcPrelude
+
import HsSyn as Hs
-import qualified Class
+import PrelNames
import RdrName
import qualified Name
import Module
@@ -25,7 +28,6 @@ import SrcLoc
import Type
import qualified Coercion ( Role(..) )
import TysWiredIn
-import TysPrim (eqPrimTyCon)
import BasicTypes as Hs
import ForeignCall
import Unique
@@ -40,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
@@ -142,15 +144,15 @@ cvtDec (TH.ValD pat body ds)
| TH.VarP s <- pat
= do { s' <- vNameL s
; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
- ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] }
+ ; returnJustL $ Hs.ValD noExt $ mkFunBind s' [cl'] }
| otherwise
= do { pat' <- cvtPat pat
; body' <- cvtGuard body
; ds' <- cvtLocalDecs (text "a where clause") ds
- ; returnJustL $ Hs.ValD $
- PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds')
- , pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames
+ ; returnJustL $ Hs.ValD noExt $
+ PatBind { pat_lhs = pat', pat_rhs = GRHSs noExt body' (noLoc ds')
+ , pat_ext = noExt
, pat_ticks = ([],[]) } }
cvtDec (TH.FunD nm cls)
@@ -161,12 +163,13 @@ cvtDec (TH.FunD nm cls)
| otherwise
= do { nm' <- vNameL nm
; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
- ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' }
+ ; returnJustL $ Hs.ValD noExt $ mkFunBind nm' cls' }
cvtDec (TH.SigD nm typ)
= do { nm' <- vNameL nm
; ty' <- cvtType typ
- ; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) }
+ ; returnJustL $ Hs.SigD noExt
+ (TypeSig noExt [nm'] (mkLHsSigWcType ty')) }
cvtDec (TH.InfixD fx nm)
-- Fixity signatures are allowed for variables, constructors, and types
@@ -174,7 +177,8 @@ cvtDec (TH.InfixD fx nm)
-- the RdrName says it's a variable or a constructor. So, just assume
-- it's a variable or constructor and proceed.
= do { nm' <- vcNameL nm
- ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }
+ ; returnJustL (Hs.SigD noExt (FixSig noExt
+ (FixitySig noExt [nm'] (cvtFixity fx)))) }
cvtDec (PragmaD prag)
= cvtPragmaD prag
@@ -182,10 +186,9 @@ cvtDec (PragmaD prag)
cvtDec (TySynD tc tvs rhs)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
; rhs' <- cvtType rhs
- ; returnJustL $ TyClD $
- SynDecl { tcdLName = tc', tcdTyVars = tvs'
+ ; returnJustL $ TyClD noExt $
+ SynDecl { tcdSExt = noExt, tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
- , tcdFVs = placeHolderNames
, tcdRhs = rhs' } }
cvtDec (DataD ctxt tc tvs ksig constrs derivs)
@@ -204,31 +207,33 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs)
; ksig' <- cvtKind `traverse` ksig
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
- ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
+ ; let defn = HsDataDefn { dd_ext = noExt
+ , dd_ND = DataType, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = ksig'
, dd_cons = cons', dd_derivs = derivs' }
- ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
+ ; returnJustL $ TyClD noExt (DataDecl
+ { tcdDExt = noExt
+ , tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
- , tcdDataDefn = defn
- , tcdDataCusk = PlaceHolder
- , tcdFVs = placeHolderNames }) }
+ , tcdDataDefn = defn }) }
cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
; ksig' <- cvtKind `traverse` ksig
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
- ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
+ ; let defn = HsDataDefn { dd_ext = noExt
+ , dd_ND = NewType, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = ksig'
, dd_cons = [con']
, dd_derivs = derivs' }
- ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
+ ; returnJustL $ TyClD noExt (DataDecl
+ { tcdDExt = noExt
+ , tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
- , tcdDataDefn = defn
- , tcdDataCusk = PlaceHolder
- , tcdFVs = placeHolderNames }) }
+ , tcdDataDefn = defn }) }
cvtDec (ClassD ctxt cl tvs fds decs)
= do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
@@ -239,13 +244,13 @@ cvtDec (ClassD ctxt cl tvs fds decs)
<+> text "are not allowed:")
$$ (Outputable.ppr adts'))
; at_defs <- mapM cvt_at_def ats'
- ; returnJustL $ TyClD $
- ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
+ ; returnJustL $ TyClD noExt $
+ ClassDecl { tcdCExt = noExt
+ , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
, tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
, tcdMeths = binds'
- , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []
- , tcdFVs = placeHolderNames }
+ , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] }
-- no docs in TH ^^
}
where
@@ -262,8 +267,8 @@ cvtDec (InstanceD o ctxt ty decs)
; ctxt' <- cvtContext ctxt
; L loc ty' <- cvtType ty
; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty'
- ; returnJustL $ InstD $ ClsInstD $
- ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty'
+ ; returnJustL $ InstD noExt $ ClsInstD noExt $
+ ClsInstDecl { cid_ext = noExt, cid_poly_ty = mkLHsSigType inst_ty'
, cid_binds = binds'
, cid_sigs = Hs.mkClassOpSigs sigs'
, cid_tyfam_insts = ats', cid_datafam_insts = adts'
@@ -281,97 +286,107 @@ cvtDec (InstanceD o ctxt ty decs)
cvtDec (ForeignD ford)
= do { ford' <- cvtForD ford
- ; returnJustL $ ForD ford' }
+ ; returnJustL $ ForD noExt ford' }
cvtDec (DataFamilyD tc tvs kind)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
; result <- cvtMaybeKindToFamilyResultSig kind
- ; returnJustL $ TyClD $ FamDecl $
- FamilyDecl DataFamily tc' tvs' Prefix result Nothing }
+ ; returnJustL $ TyClD noExt $ FamDecl noExt $
+ FamilyDecl noExt DataFamily tc' tvs' Prefix result Nothing }
cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
= do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
; ksig' <- cvtKind `traverse` ksig
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
- ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
+ ; let defn = HsDataDefn { dd_ext = noExt
+ , dd_ND = DataType, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = ksig'
, dd_cons = cons', dd_derivs = derivs' }
- ; returnJustL $ InstD $ DataFamInstD
- { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
- , dfid_defn = defn
- , dfid_fixity = Prefix
- , dfid_fvs = placeHolderNames } }}
+ ; returnJustL $ InstD noExt $ DataFamInstD
+ { dfid_ext = noExt
+ , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
+ FamEqn { feqn_ext = noExt
+ , feqn_tycon = tc', feqn_pats = typats'
+ , feqn_rhs = defn
+ , feqn_fixity = Prefix } }}}
cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
= do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
; ksig' <- cvtKind `traverse` ksig
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
- ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
+ ; let defn = HsDataDefn { dd_ext = noExt
+ , dd_ND = NewType, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = ksig'
, dd_cons = [con'], dd_derivs = derivs' }
- ; returnJustL $ InstD $ DataFamInstD
- { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
- , dfid_defn = defn
- , dfid_fixity = Prefix
- , dfid_fvs = placeHolderNames } }}
+ ; returnJustL $ InstD noExt $ DataFamInstD
+ { dfid_ext = noExt
+ , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
+ FamEqn { feqn_ext = noExt
+ , feqn_tycon = tc', feqn_pats = typats'
+ , feqn_rhs = defn
+ , feqn_fixity = Prefix } }}}
cvtDec (TySynInstD tc eqn)
= do { tc' <- tconNameL tc
- ; eqn' <- cvtTySynEqn tc' eqn
- ; returnJustL $ InstD $ TyFamInstD
- { tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
- , tfid_fvs = placeHolderNames } } }
+ ; L _ eqn' <- cvtTySynEqn tc' eqn
+ ; returnJustL $ InstD noExt $ TyFamInstD
+ { tfid_ext = noExt
+ , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }
cvtDec (OpenTypeFamilyD head)
= do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
- ; returnJustL $ TyClD $ FamDecl $
- FamilyDecl OpenTypeFamily tc' tyvars' Prefix result' injectivity' }
+ ; returnJustL $ TyClD noExt $ FamDecl noExt $
+ FamilyDecl noExt OpenTypeFamily tc' tyvars' Prefix result' injectivity'
+ }
cvtDec (ClosedTypeFamilyD head eqns)
= do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
; eqns' <- mapM (cvtTySynEqn tc') eqns
- ; returnJustL $ TyClD $ FamDecl $
- FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix result'
- injectivity' }
+ ; returnJustL $ TyClD noExt $ FamDecl noExt $
+ FamilyDecl noExt (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix
+ result' injectivity' }
cvtDec (TH.RoleAnnotD tc roles)
= do { tc' <- tconNameL tc
; let roles' = map (noLoc . cvtRole) roles
- ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
+ ; returnJustL $ Hs.RoleAnnotD noExt (RoleAnnotDecl noExt tc' roles') }
cvtDec (TH.StandaloneDerivD ds cxt ty)
= do { cxt' <- cvtContext cxt
+ ; ds' <- traverse cvtDerivStrategy ds
; L loc ty' <- cvtType ty
; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'
- ; returnJustL $ DerivD $
- DerivDecl { deriv_strategy = fmap (L loc . cvtDerivStrategy) ds
- , deriv_type = mkLHsSigType inst_ty'
+ ; returnJustL $ DerivD noExt $
+ DerivDecl { deriv_ext =noExt
+ , deriv_strategy = ds'
+ , deriv_type = mkLHsSigWcType inst_ty'
, deriv_overlap_mode = Nothing } }
cvtDec (TH.DefaultSigD nm typ)
= do { nm' <- vNameL nm
; ty' <- cvtType typ
- ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') }
+ ; returnJustL $ Hs.SigD noExt
+ $ ClassOpSig noExt True [nm'] (mkLHsSigType ty')}
cvtDec (TH.PatSynD nm args dir pat)
= do { nm' <- cNameL nm
; args' <- cvtArgs args
; dir' <- cvtDir nm' dir
; pat' <- cvtPat pat
- ; returnJustL $ Hs.ValD $ PatSynBind $
- PSB nm' placeHolderType args' pat' dir' }
+ ; returnJustL $ Hs.ValD noExt $ PatSynBind noExt $
+ PSB noExt nm' args' pat' dir' }
where
- cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixPatSyn <$> mapM vNameL args
- cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixPatSyn <$> vNameL a1 <*> vNameL a2
+ cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args
+ cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2
cvtArgs (TH.RecordPatSyn sels)
= do { sels' <- mapM vNameL sels
; vars' <- mapM (vNameL . mkNameS . nameBase) sels
- ; return $ Hs.RecordPatSyn $ zipWith RecordPatSynField sels' vars' }
+ ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' }
cvtDir _ Unidir = return Unidirectional
cvtDir _ ImplBidir = return ImplicitBidirectional
@@ -382,17 +397,25 @@ cvtDec (TH.PatSynD nm args dir pat)
cvtDec (TH.PatSynSigD nm ty)
= do { nm' <- cNameL nm
; ty' <- cvtPatSynSigTy ty
- ; returnJustL $ Hs.SigD $ PatSynSig [nm'] (mkLHsSigType ty') }
+ ; returnJustL $ Hs.SigD noExt $ PatSynSig noExt [nm'] (mkLHsSigType ty')}
+
+-- Implicit parameter bindings are handled in cvtLocalDecs and
+-- cvtImplicitParamBind. They are not allowed in any other scope, so
+-- reaching this case indicates an error.
+cvtDec (TH.ImplicitParamBindD _ _)
+ = failWith (text "Implicit parameter binding only allowed in let or where")
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn tc (TySynEqn lhs rhs)
= do { lhs' <- mapM (wrap_apps <=< cvtType) lhs
; rhs' <- cvtType rhs
- ; returnL $ TyFamEqn { tfe_tycon = tc
- , tfe_pats = mkHsImplicitBndrs lhs'
- , tfe_fixity = Prefix
- , tfe_rhs = rhs' } }
+ ; returnL $ mkHsImplicitBndrs
+ $ FamEqn { feqn_ext = noExt
+ , feqn_tycon = tc
+ , feqn_pats = lhs'
+ , feqn_fixity = Prefix
+ , feqn_rhs = rhs' } }
----------------
cvt_ci_decs :: MsgDoc -> [TH.Dec]
@@ -430,12 +453,12 @@ cvt_tycl_hdr cxt tc tvs
cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
-> CvtM ( LHsContext GhcPs
, Located RdrName
- , HsImplicitBndrs GhcPs [LHsType GhcPs])
+ , HsTyPats GhcPs)
cvt_tyinst_hdr cxt tc tys
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
; tys' <- mapM (wrap_apps <=< cvtType) tys
- ; return (cxt', tc', mkHsImplicitBndrs tys') }
+ ; return (cxt', tc', tys') }
----------------
cvt_tyfam_head :: TypeFamilyHead
@@ -455,25 +478,33 @@ cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)
-------------------------------------------------------------------
is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
-is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d)
+is_fam_decl (L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (L loc d)
is_fam_decl decl = Right decl
is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
-is_tyfam_inst (L loc (Hs.InstD (TyFamInstD { tfid_inst = d }))) = Left (L loc d)
-is_tyfam_inst decl = Right decl
+is_tyfam_inst (L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))
+ = Left (L loc d)
+is_tyfam_inst decl
+ = Right decl
is_datafam_inst :: LHsDecl GhcPs
-> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
-is_datafam_inst (L loc (Hs.InstD (DataFamInstD { dfid_inst = d }))) = Left (L loc d)
-is_datafam_inst decl = Right decl
+is_datafam_inst (L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d })))
+ = Left (L loc d)
+is_datafam_inst decl
+ = Right decl
is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
-is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
-is_sig decl = Right decl
+is_sig (L loc (Hs.SigD _ sig)) = Left (L loc sig)
+is_sig decl = Right decl
is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
-is_bind (L loc (Hs.ValD bind)) = Left (L loc bind)
-is_bind decl = Right decl
+is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind)
+is_bind decl = Right decl
+
+is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec
+is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)
+is_ip_bind decl = Right decl
mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
mkBadDecMsg doc bads
@@ -488,59 +519,60 @@ 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
- ; 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'))) } }
+ = do { tvs' <- cvtTvs tvs
+ ; ctxt' <- cvtContext ctxt
+ ; L _ con' <- cvtConstr 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 = noLoc $ 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 = noLoc $ not (null all_tvs)
+ , con_ex_tvs = all_tvs
+ , con_mb_cxt = add_cxt cxt' cxt }
+ where
+ all_tvs = hsQTvExplicit tvs' ++ ex_tvs
+
+ add_forall _ _ (XConDecl _) = panic "cvtConstr"
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 $ fst $ 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) }
+ ; let rec_ty = noLoc (HsFunTy noExt
+ (noLoc $ HsRecTy noExt rec_flds) ty')
+ ; returnL $ fst $ mkGadtDecl c' rec_ty }
cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
@@ -558,15 +590,16 @@ cvt_arg (Bang su ss, ty)
; ty' <- wrap_apps ty''
; let su' = cvtSrcUnpackedness su
; let ss' = cvtSrcStrictness ss
- ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' }
+ ; returnL $ HsBangTy noExt (HsSrcBang NoSourceText su' ss') ty' }
cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
cvt_id_arg (i, str, ty)
= do { L li i' <- vNameL i
; ty' <- cvt_arg (str,ty)
; return $ noLoc (ConDeclField
- { cd_fld_names
- = [L li $ FieldOcc (L li i') PlaceHolder]
+ { cd_fld_ext = noExt
+ , cd_fld_names
+ = [L li $ FieldOcc noExt (L li i')]
, cd_fld_type = ty'
, cd_fld_doc = Nothing}) }
@@ -574,7 +607,7 @@ cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs
; returnL cs' }
-cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
+cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)
cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
; ys' <- mapM tNameL ys
; returnL (xs', ys') }
@@ -604,9 +637,9 @@ cvtForD (ImportF callconv safety from nm ty)
mk_imp impspec
= do { nm' <- vNameL nm
; ty' <- cvtType ty
- ; return (ForeignImport { fd_name = nm'
+ ; return (ForeignImport { fd_i_ext = noExt
+ , fd_name = nm'
, fd_sig_ty = mkLHsSigType ty'
- , fd_co = noForeignImportCoercionYet
, fd_fi = impspec })
}
safety' = case safety of
@@ -621,9 +654,9 @@ cvtForD (ExportF callconv as nm ty)
(mkFastString as)
(cvt_conv callconv)))
(noLoc (SourceText as))
- ; return $ ForeignExport { fd_name = nm'
+ ; return $ ForeignExport { fd_e_ext = noExt
+ , fd_name = nm'
, fd_sig_ty = mkLHsSigType ty'
- , fd_co = noForeignExportCoercionYet
, fd_fe = e } }
cvt_conv :: TH.Callconv -> CCallConv
@@ -649,7 +682,7 @@ cvtPragmaD (InlineP nm inline rm phases)
, inl_rule = cvtRuleMatch rm
, inl_act = cvtPhases phases dflt
, inl_sat = Nothing }
- ; returnJustL $ Hs.SigD $ InlineSig nm' ip }
+ ; returnJustL $ Hs.SigD noExt $ InlineSig noExt nm' ip }
cvtPragmaD (SpecialiseP nm ty inline phases)
= do { nm' <- vNameL nm
@@ -660,19 +693,19 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
; let (inline', dflt,srcText) = case inline of
Just inline1 -> (cvtInline inline1, dfltActivation inline1,
src inline1)
- Nothing -> (EmptyInlineSpec, AlwaysActive,
+ Nothing -> (NoUserInline, AlwaysActive,
"{-# SPECIALISE")
; let ip = InlinePragma { inl_src = SourceText srcText
, inl_inline = inline'
, inl_rule = Hs.FunLike
, inl_act = cvtPhases phases dflt
, inl_sat = Nothing }
- ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip }
+ ; returnJustL $ Hs.SigD noExt $ SpecSig noExt nm' [mkLHsSigType ty'] ip }
cvtPragmaD (SpecialiseInstP ty)
= do { ty' <- cvtType ty
- ; returnJustL $ Hs.SigD $
- SpecInstSig (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
+ ; returnJustL $ Hs.SigD noExt $
+ SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
cvtPragmaD (RuleP nm bndrs lhs rhs phases)
= do { let nm' = mkFastString nm
@@ -680,11 +713,10 @@ cvtPragmaD (RuleP nm bndrs lhs rhs phases)
; bndrs' <- mapM cvtRuleBndr bndrs
; lhs' <- cvtl lhs
; rhs' <- cvtl rhs
- ; returnJustL $ Hs.RuleD
- $ HsRules (SourceText "{-# RULES")
- [noLoc $ HsRule (noLoc (SourceText nm,nm')) act bndrs'
- lhs' placeHolderNames
- rhs' placeHolderNames]
+ ; returnJustL $ Hs.RuleD noExt
+ $ HsRules noExt (SourceText "{-# RULES")
+ [noLoc $ HsRule noExt (noLoc (quotedSourceText nm,nm'))
+ act bndrs' lhs' rhs']
}
cvtPragmaD (AnnP target exp)
@@ -697,8 +729,8 @@ cvtPragmaD (AnnP target exp)
ValueAnnotation n -> do
n' <- vcName n
return (ValueAnnProvenance (noLoc n'))
- ; returnJustL $ Hs.AnnD $ HsAnnotation (SourceText "{-# ANN") target'
- exp'
+ ; returnJustL $ Hs.AnnD noExt
+ $ HsAnnotation noExt (SourceText "{-# ANN") target' exp'
}
cvtPragmaD (LineP line file)
@@ -708,8 +740,8 @@ cvtPragmaD (LineP line file)
cvtPragmaD (CompleteP cls mty)
= do { cls' <- noLoc <$> mapM cNameL cls
; mty' <- traverse tconNameL mty
- ; returnJustL $ Hs.SigD
- $ CompleteMatchSig NoSourceText cls' mty' }
+ ; returnJustL $ Hs.SigD noExt
+ $ CompleteMatchSig noExt NoSourceText cls' mty' }
dfltActivation :: TH.Inline -> Activation
dfltActivation TH.NoInline = NeverActive
@@ -732,11 +764,11 @@ cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i
cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)
cvtRuleBndr (RuleVar n)
= do { n' <- vNameL n
- ; return $ noLoc $ Hs.RuleBndr n' }
+ ; return $ noLoc $ Hs.RuleBndr noExt n' }
cvtRuleBndr (TypedRuleVar n ty)
= do { n' <- vNameL n
; ty' <- cvtType ty
- ; return $ noLoc $ Hs.RuleBndrSig n' $ mkLHsSigWcType ty' }
+ ; return $ noLoc $ Hs.RuleBndrSig noExt n' $ mkLHsSigWcType ty' }
---------------------------------------------------
-- Declarations
@@ -744,25 +776,34 @@ cvtRuleBndr (TypedRuleVar n ty)
cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs doc ds
- | null ds
- = return EmptyLocalBinds
- | otherwise
- = do { ds' <- cvtDecs ds
- ; let (binds, prob_sigs) = partitionWith is_bind ds'
- ; let (sigs, bads) = partitionWith is_sig prob_sigs
- ; unless (null bads) (failWith (mkBadDecMsg doc bads))
- ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
+ = case partitionWith is_ip_bind ds of
+ ([], []) -> return (EmptyLocalBinds noExt)
+ ([], _) -> do
+ ds' <- cvtDecs ds
+ let (binds, prob_sigs) = partitionWith is_bind ds'
+ let (sigs, bads) = partitionWith is_sig prob_sigs
+ unless (null bads) (failWith (mkBadDecMsg doc bads))
+ return (HsValBinds noExt (ValBinds noExt (listToBag binds) sigs))
+ (ip_binds, []) -> do
+ binds <- mapM (uncurry cvtImplicitParamBind) ip_binds
+ return (HsIPBinds noExt (IPBinds noExt binds))
+ ((_:_), (_:_)) ->
+ failWith (text "Implicit parameters mixed with other bindings")
cvtClause :: HsMatchContext RdrName
-> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtClause ctxt (Clause ps body wheres)
= do { ps' <- cvtPats ps
- ; pps <- mapM wrap_conpat ps'
+ ; let pps = map (parenthesizePat appPrec) ps'
; g' <- cvtGuard body
; ds' <- cvtLocalDecs (text "a where clause") wheres
- ; returnL $ Hs.Match ctxt pps Nothing
- (GRHSs g' (noLoc ds')) }
+ ; returnL $ Hs.Match noExt ctxt pps (GRHSs noExt g' (noLoc ds')) }
+cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
+cvtImplicitParamBind n e = do
+ n' <- wrapL (ipName n)
+ e' <- cvtl e
+ returnL (IPBind noExt (Left n') e')
-------------------------------------------------------------------
-- Expressions
@@ -771,77 +812,105 @@ cvtClause ctxt (Clause ps body wheres)
cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
cvtl e = wrapL (cvt e)
where
- cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
- cvt (ConE s) = do { s' <- cName s; return $ HsVar (noLoc s') }
+ cvt (VarE s) = do { s' <- vName s; return $ HsVar noExt (noLoc s') }
+ cvt (ConE s) = do { s' <- cName s; return $ HsVar noExt (noLoc s') }
cvt (LitE l)
- | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
- | otherwise = do { l' <- cvtLit l; return $ HsLit l' }
+ | overloadedLit l = go cvtOverLit (HsOverLit noExt)
+ (hsOverLitNeedsParens appPrec)
+ | otherwise = go cvtLit (HsLit noExt)
+ (hsLitNeedsParens appPrec)
+ where
+ go :: (Lit -> CvtM (l GhcPs))
+ -> (l GhcPs -> HsExpr GhcPs)
+ -> (l GhcPs -> Bool)
+ -> CvtM (HsExpr GhcPs)
+ go cvt_lit mk_expr is_compound_lit = do
+ l' <- cvt_lit l
+ let e' = mk_expr l'
+ return $ if is_compound_lit l' then HsPar noExt (noLoc e') else e'
cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
- ; return $ HsApp (mkLHsPar x') (mkLHsPar y')}
+ ; return $ HsApp noExt (mkLHsPar x')
+ (mkLHsPar y')}
cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y
- ; return $ HsApp (mkLHsPar x') (mkLHsPar y')}
+ ; return $ HsApp noExt (mkLHsPar x')
+ (mkLHsPar y')}
cvt (AppTypeE e t) = do { e' <- cvtl e
; t' <- cvtType t
; tp <- wrap_apps t'
- ; return $ HsAppType e' $ mkHsWildCardBndrs tp }
+ ; let tp' = parenthesizeHsType appPrec tp
+ ; return $ HsAppType (mkHsWildCardBndrs tp') e' }
cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its
-- own expression to avoid pretty-printing
-- oddities that can result from zero-argument
-- lambda expressions. See #13856.
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
- ; return $ HsLam (mkMatchGroup FromSource
- [mkSimpleMatch LambdaExpr ps' e'])}
- cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch LambdaExpr) ms
- ; return $ HsLamCase (mkMatchGroup FromSource ms')
+ ; let pats = map (parenthesizePat appPrec) ps'
+ ; return $ HsLam noExt (mkMatchGroup FromSource
+ [mkSimpleMatch LambdaExpr
+ pats e'])}
+ cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch CaseAlt) ms
+ ; return $ HsLamCase noExt
+ (mkMatchGroup FromSource ms')
}
- cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' }
+ cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar noExt e' }
-- Note [Dropping constructors]
-- Singleton tuples treated like nothing (just parens)
cvt (TupE es) = do { es' <- mapM cvtl es
- ; return $ ExplicitTuple (map (noLoc . Present) es')
- Boxed }
+ ; return $ ExplicitTuple noExt
+ (map (noLoc . (Present noExt)) es')
+ Boxed }
cvt (UnboxedTupE es) = do { es' <- mapM cvtl es
- ; return $ ExplicitTuple
- (map (noLoc . Present) es') Unboxed }
+ ; return $ ExplicitTuple noExt
+ (map (noLoc . (Present noExt)) es')
+ Unboxed }
cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
; unboxedSumChecks alt arity
- ; return $ ExplicitSum
- alt arity e' placeHolderType }
+ ; return $ ExplicitSum noExt
+ alt arity e'}
cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
- ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
+ ; return $ HsIf noExt (Just noSyntaxExpr) x' y' z' }
cvt (MultiIfE alts)
| null alts = failWith (text "Multi-way if-expression with no alternatives")
| otherwise = do { alts' <- mapM cvtpair alts
- ; return $ HsMultiIf placeHolderType alts' }
+ ; return $ HsMultiIf noExt alts' }
cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds
- ; e' <- cvtl e; return $ HsLet (noLoc ds') e' }
+ ; e' <- cvtl e; return $ HsLet noExt (noLoc ds') e'}
cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
- ; return $ HsCase e' (mkMatchGroup FromSource ms') }
+ ; return $ HsCase noExt e'
+ (mkMatchGroup FromSource ms') }
cvt (DoE ss) = cvtHsDo DoExpr ss
+ cvt (MDoE ss) = cvtHsDo MDoExpr ss
cvt (CompE ss) = cvtHsDo ListComp ss
- cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }
+ cvt (ArithSeqE dd) = do { dd' <- cvtDD dd
+ ; return $ ArithSeq noExt Nothing dd' }
cvt (ListE xs)
- | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
+ | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s)
+ ; return (HsLit noExt l') }
-- Note [Converting strings]
| otherwise = do { xs' <- mapM cvtl xs
- ; return $ ExplicitList placeHolderType Nothing xs'
+ ; return $ ExplicitList noExt Nothing xs'
}
-- Infix expressions
cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
- ; wrapParL HsPar $
- OpApp (mkLHsPar x') s' undefined (mkLHsPar y') }
+ ; let px = parenthesizeHsExpr opPrec x'
+ py = parenthesizeHsExpr opPrec y'
+ ; wrapParL (HsPar noExt) $
+ OpApp noExt px s' py }
-- Parenthesise both arguments and result,
-- to ensure this operator application does
-- does not get re-associated
-- See Note [Operator association]
cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
- ; wrapParL HsPar $ SectionR s' y' }
+ ; wrapParL (HsPar noExt) $
+ SectionR noExt s' y' }
-- See Note [Sections in HsSyn] in HsExpr
cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
- ; wrapParL HsPar $ SectionL x' s' }
+ ; wrapParL (HsPar noExt) $
+ SectionL noExt x' s' }
- cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s; return $ HsPar s' }
+ cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s
+ ; return $ HsPar noExt s' }
-- Can I indicate this is an infix thing?
-- Note [Dropping constructors]
@@ -851,9 +920,10 @@ cvtl e = wrapL (cvt e)
_ -> mkLHsPar x'
; cvtOpApp x'' s y } -- Note [Converting UInfix]
- cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar e' }
+ cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExt e' }
cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
- ; return $ ExprWithTySig e' (mkLHsSigWcType t') }
+ ; let pe = parenthesizeHsExpr sigPrec e'
+ ; return $ ExprWithTySig (mkLHsSigWcType t') pe }
cvt (RecConE c flds) = do { c' <- cNameL c
; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
@@ -862,9 +932,14 @@ cvtl e = wrapL (cvt e)
<- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
flds
; return $ mkRdrRecordUpd e' flds' }
- cvt (StaticE e) = fmap (HsStatic placeHolderNames) $ cvtl e
- cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
- cvt (LabelE s) = do { return $ HsOverLabel Nothing (fsLit s) }
+ cvt (StaticE e) = fmap (HsStatic noExt) $ cvtl e
+ cvt (UnboundVarE s) = do -- Use of 'vcName' here instead of 'vName' is
+ -- important, because UnboundVarE may contain
+ -- constructor names - see #14627.
+ { s' <- vcName s
+ ; return $ HsVar noExt (noLoc s') }
+ cvt (LabelE s) = do { return $ HsOverLabel noExt Nothing (fsLit s) }
+ cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExt n' }
{- Note [Dropping constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -914,7 +989,7 @@ the trees to reflect the fixities of the underlying operators:
This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and
@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely
right-biased for types and left-biased for everything else. So we left-bias the
-trees of @UInfixP@ and @UInfixE@ and use HsAppsTy for UInfixT.
+trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.
Sample input:
@@ -955,7 +1030,7 @@ cvtOpApp x op1 (UInfixE y op2 z)
cvtOpApp x op y
= do { op' <- cvtl op
; y' <- cvtl y
- ; return (OpApp x op' undefined y') }
+ ; return (OpApp noExt x op' y') }
-------------------------------------
-- Do notation and statements
@@ -969,10 +1044,11 @@ cvtHsDo do_or_lc stmts
; let Just (stmts'', last') = snocView stmts'
; last'' <- case last' of
- L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
+ L loc (BodyStmt _ body _ _)
+ -> return (L loc (mkLastStmt body))
_ -> failWith (bad_last last')
- ; return $ HsDo do_or_lc (noLoc (stmts'' ++ [last''])) placeHolderType }
+ ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) }
where
bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon
, nest 2 $ Outputable.ppr stmt
@@ -985,43 +1061,46 @@ cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))
cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds
- ; returnL $ LetStmt (noLoc ds') }
-cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noExpr noSyntaxExpr placeHolderType }
- where
- cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
+ ; returnL $ LetStmt noExt (noLoc ds') }
+cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss
+ ; returnL $ ParStmt noExt dss' noExpr noSyntaxExpr }
+ where
+ cvt_one ds = do { ds' <- cvtStmts ds
+ ; return (ParStmtBlock noExt ds' undefined noSyntaxExpr) }
+cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') }
cvtMatch :: HsMatchContext RdrName
-> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtMatch ctxt (TH.Match p body decs)
= do { p' <- cvtPat p
- ; lp <- case ctxt of
- CaseAlt -> return p'
- _ -> wrap_conpat p'
+ ; let lp = case p' of
+ L loc SigPat{} -> L loc (ParPat NoExt p') -- #14875
+ _ -> p'
; g' <- cvtGuard body
; decs' <- cvtLocalDecs (text "a where clause") decs
- ; returnL $ Hs.Match ctxt [lp] Nothing
- (GRHSs g' (noLoc decs')) }
+ ; returnL $ Hs.Match noExt ctxt [lp] (GRHSs noExt g' (noLoc decs')) }
cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard (GuardedB pairs) = mapM cvtpair pairs
-cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
+cvtGuard (NormalB e) = do { e' <- cvtl e
+ ; g' <- returnL $ GRHS noExt [] e'; return [g'] }
cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
; g' <- returnL $ mkBodyStmt ge'
- ; returnL $ GRHS [g'] rhs' }
+ ; returnL $ GRHS noExt [g'] rhs' }
cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
- ; returnL $ GRHS gs' rhs' }
+ ; returnL $ GRHS noExt gs' rhs' }
cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)
cvtOverLit (IntegerL i)
- = do { force i; return $ mkHsIntegral (mkIntegralLit i) placeHolderType}
+ = do { force i; return $ mkHsIntegral (mkIntegralLit i) }
cvtOverLit (RationalL r)
- = do { force r; return $ mkHsFractional (mkFractionalLit r) placeHolderType}
+ = do { force r; return $ mkHsFractional (mkFractionalLit r) }
cvtOverLit (StringL s)
= do { let { s' = mkFastString s }
; force s'
- ; return $ mkHsIsString (quotedSourceText s) s' placeHolderType
+ ; return $ mkHsIsString (quotedSourceText s) s'
}
cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
-- An Integer is like an (overloaded) '3' in a Haskell source program
@@ -1052,9 +1131,9 @@ cvtLit :: Lit -> CvtM (HsLit GhcPs)
cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i }
cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w }
cvtLit (FloatPrimL f)
- = do { force f; return $ HsFloatPrim def (mkFractionalLit f) }
+ = do { force f; return $ HsFloatPrim noExt (mkFractionalLit f) }
cvtLit (DoublePrimL f)
- = do { force f; return $ HsDoublePrim def (mkFractionalLit f) }
+ = do { force f; return $ HsDoublePrim noExt (mkFractionalLit f) }
cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c }
cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c }
cvtLit (StringL s) = do { let { s' = mkFastString s }
@@ -1083,40 +1162,48 @@ cvtp (TH.LitP l)
; return (mkNPat (noLoc l') Nothing) }
-- Not right for negative patterns;
-- need to think about that!
- | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
-cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat (noLoc s') }
-cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
-cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] }
-cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }
+ | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExt l' }
+cvtp (TH.VarP s) = do { s' <- vName s
+ ; return $ Hs.VarPat noExt (noLoc s') }
+cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat noExt p' }
+ -- Note [Dropping constructors]
+cvtp (TupP ps) = do { ps' <- cvtPats ps
+ ; return $ TuplePat noExt ps' Boxed }
+cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps
+ ; return $ TuplePat noExt ps' Unboxed }
cvtp (UnboxedSumP p alt arity)
= do { p' <- cvtPat p
; unboxedSumChecks alt arity
- ; return $ SumPat p' alt arity placeHolderType }
+ ; return $ SumPat noExt p' alt arity }
cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps
- ; pps <- mapM wrap_conpat ps'
+ ; let pps = map (parenthesizePat appPrec) ps'
; return $ ConPatIn s' (PrefixCon pps) }
cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
- ; wrapParL ParPat $
- ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) }
+ ; wrapParL (ParPat noExt) $
+ ConPatIn s' $
+ InfixCon (parenthesizePat opPrec p1')
+ (parenthesizePat opPrec p2') }
-- See Note [Operator association]
cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
cvtp (ParensP p) = do { p' <- cvtPat p;
; case p' of -- may be wrapped ConPatIn
(L _ (ParPat {})) -> return $ unLoc p'
- _ -> return $ ParPat p' }
-cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' }
-cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' }
-cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
-cvtp TH.WildP = return $ WildPat placeHolderType
+ _ -> return $ ParPat noExt p' }
+cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noExt p' }
+cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noExt p' }
+cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p
+ ; return $ AsPat noExt s' p' }
+cvtp TH.WildP = return $ WildPat noExt
cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
; return $ ConPatIn c'
$ Hs.RecCon (HsRecFields fs' Nothing) }
cvtp (ListP ps) = do { ps' <- cvtPats ps
- ; return $ ListPat ps' placeHolderType Nothing }
+ ; return
+ $ ListPat noExt ps'}
cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
- ; return $ SigPatIn p' (mkLHsSigWcType t') }
+ ; return $ SigPat (mkLHsSigWcType t') p' }
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
- ; return $ ViewPat e' p' placeHolderType }
+ ; return $ ViewPat noExt e' p'}
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld (s,p)
@@ -1126,12 +1213,6 @@ cvtPatFld (s,p)
, hsRecFieldArg = p'
, hsRecPun = False}) }
-wrap_conpat :: Hs.LPat GhcPs -> CvtM (Hs.LPat GhcPs)
-wrap_conpat p@(L _ (ConPatIn _ (InfixCon{}))) = returnL $ ParPat p
-wrap_conpat p@(L _ (ConPatIn _ (PrefixCon []))) = return p
-wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _))) = returnL $ ParPat p
-wrap_conpat p = return p
-
{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
The produced tree of infix patterns will be left-biased, provided @x@ is.
@@ -1155,11 +1236,11 @@ cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)
cvt_tv (TH.PlainTV nm)
= do { nm' <- tNameL nm
- ; returnL $ UserTyVar nm' }
+ ; returnL $ UserTyVar noExt nm' }
cvt_tv (TH.KindedTV nm ki)
= do { nm' <- tNameL nm
; ki' <- cvtKind ki
- ; returnL $ KindedTyVar nm' ki' }
+ ; returnL $ KindedTyVar noExt nm' ki' }
cvtRole :: TH.Role -> Maybe Coercion.Role
cvtRole TH.NominalR = Just Coercion.Nominal
@@ -1176,14 +1257,17 @@ cvtPred = cvtType
cvtDerivClause :: TH.DerivClause
-> CvtM (LHsDerivingClause GhcPs)
cvtDerivClause (TH.DerivClause ds ctxt)
- = do { ctxt'@(L loc _) <- fmap (map mkLHsSigType) <$> cvtContext ctxt
- ; let ds' = fmap (L loc . cvtDerivStrategy) ds
- ; returnL $ HsDerivingClause ds' ctxt' }
-
-cvtDerivStrategy :: TH.DerivStrategy -> Hs.DerivStrategy
-cvtDerivStrategy TH.StockStrategy = Hs.StockStrategy
-cvtDerivStrategy TH.AnyclassStrategy = Hs.AnyclassStrategy
-cvtDerivStrategy TH.NewtypeStrategy = Hs.NewtypeStrategy
+ = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext ctxt
+ ; ds' <- traverse cvtDerivStrategy ds
+ ; returnL $ HsDerivingClause noExt ds' ctxt' }
+
+cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)
+cvtDerivStrategy TH.StockStrategy = returnL Hs.StockStrategy
+cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy
+cvtDerivStrategy TH.NewtypeStrategy = returnL Hs.NewtypeStrategy
+cvtDerivStrategy (TH.ViaStrategy ty) = do
+ ty' <- cvtType ty
+ returnL $ Hs.ViaStrategy (mkLHsSigType ty')
cvtType :: TH.Type -> CvtM (LHsType GhcPs)
cvtType = cvtTypeKind "type"
@@ -1196,17 +1280,18 @@ cvtTypeKind ty_str ty
| tys' `lengthIs` n -- Saturated
-> if n==1 then return (head tys') -- Singleton tuples treated
-- like nothing (ie just parens)
- else returnL (HsTupleTy HsBoxedOrConstraintTuple tys')
+ else returnL (HsTupleTy noExt
+ HsBoxedOrConstraintTuple tys')
| n == 1
-> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
| otherwise
- -> mk_apps (HsTyVar NotPromoted
+ -> mk_apps (HsTyVar noExt NotPromoted
(noLoc (getRdrName (tupleTyCon Boxed n)))) tys'
UnboxedTupleT n
| tys' `lengthIs` n -- Saturated
- -> returnL (HsTupleTy HsUnboxedTuple tys')
+ -> returnL (HsTupleTy noExt HsUnboxedTuple tys')
| otherwise
- -> mk_apps (HsTyVar NotPromoted
+ -> mk_apps (HsTyVar noExt NotPromoted
(noLoc (getRdrName (tupleTyCon Unboxed n)))) tys'
UnboxedSumT n
| n < 2
@@ -1215,28 +1300,42 @@ cvtTypeKind ty_str ty
, nest 2 $
text "Sums must have an arity of at least 2" ]
| tys' `lengthIs` n -- Saturated
- -> returnL (HsSumTy tys')
+ -> returnL (HsSumTy noExt tys')
| otherwise
- -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n))))
+ -> mk_apps (HsTyVar noExt NotPromoted
+ (noLoc (getRdrName (sumTyCon n))))
tys'
ArrowT
| [x',y'] <- tys' -> do
- case x' of
- (L _ HsFunTy{}) -> do { x'' <- returnL (HsParTy x')
- ; returnL (HsFunTy x'' y') }
- _ -> returnL (HsFunTy x' y')
+ x'' <- case x' of
+ L _ HsFunTy{} -> returnL (HsParTy noExt x')
+ L _ HsForAllTy{} -> returnL (HsParTy noExt x')
+ -- #14646
+ L _ HsQualTy{} -> returnL (HsParTy noExt x')
+ -- #15324
+ _ -> return x'
+ returnL (HsFunTy noExt x'' y')
| otherwise ->
- mk_apps (HsTyVar NotPromoted (noLoc (getRdrName funTyCon)))
+ mk_apps (HsTyVar noExt NotPromoted
+ (noLoc (getRdrName funTyCon)))
tys'
ListT
- | [x'] <- tys' -> returnL (HsListTy x')
+ | [x'] <- tys' -> returnL (HsListTy noExt x')
| otherwise ->
- mk_apps (HsTyVar NotPromoted (noLoc (getRdrName listTyCon)))
+ mk_apps (HsTyVar noExt NotPromoted
+ (noLoc (getRdrName listTyCon)))
tys'
VarT nm -> do { nm' <- tNameL nm
- ; mk_apps (HsTyVar NotPromoted nm') tys' }
+ ; mk_apps (HsTyVar noExt NotPromoted nm') tys' }
ConT nm -> do { nm' <- tconName nm
- ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }
+ ; -- ConT can contain both data constructor (i.e.,
+ -- promoted) names and other (i.e, unpromoted)
+ -- names, as opposed to PromotedT, which can only
+ -- contain data constructor names. See #15572.
+ let prom = if isRdrDataCon nm'
+ then Promoted
+ else NotPromoted
+ ; mk_apps (HsTyVar noExt prom (noLoc nm')) tys'}
ForallT tvs cxt ty
| null tys'
@@ -1252,11 +1351,11 @@ cvtTypeKind ty_str ty
SigT ty ki
-> do { ty' <- cvtType ty
; ki' <- cvtKind ki
- ; mk_apps (HsKindSig ty' ki') tys'
+ ; mk_apps (HsKindSig noExt ty' ki') tys'
}
LitT lit
- -> returnL (HsTyLit (cvtTyLit lit))
+ -> returnL (HsTyLit noExt (cvtTyLit lit))
WildCardT
-> mk_apps mkAnonWildCardTy tys'
@@ -1265,59 +1364,66 @@ cvtTypeKind ty_str ty
-> do { s' <- tconName s
; t1' <- cvtType t1
; t2' <- cvtType t2
- ; mk_apps (HsTyVar NotPromoted (noLoc s')) [t1', t2']
+ ; mk_apps (HsTyVar noExt NotPromoted (noLoc s')) [t1', t2']
}
UInfixT t1 s t2
- -> do { t1' <- cvtType t1
- ; t2' <- cvtType t2
- ; s' <- tconName s
- ; return $ cvtOpAppT t1' s' t2'
+ -> do { t2' <- cvtType t2
+ ; cvtOpAppT t1 s t2'
} -- Note [Converting UInfix]
ParensT t
-> do { t' <- cvtType t
- ; returnL $ HsParTy t'
+ ; returnL $ HsParTy noExt t'
}
PromotedT nm -> do { nm' <- cName nm
- ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }
+ ; mk_apps (HsTyVar noExt Promoted
+ (noLoc nm')) tys' }
-- Promoted data constructor; hence cName
PromotedTupleT n
| n == 1
-> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
| m == n -- Saturated
- -> do { let kis = replicate m placeHolderKind
- ; returnL (HsExplicitTupleTy kis tys')
- }
+ -> returnL (HsExplicitTupleTy noExt tys')
+ | otherwise
+ -> mk_apps (HsTyVar noExt Promoted
+ (noLoc (getRdrName (tupleDataCon Boxed n)))) tys'
where
m = length tys'
PromotedNilT
- -> returnL (HsExplicitListTy Promoted placeHolderKind [])
+ -> returnL (HsExplicitListTy noExt Promoted [])
PromotedConsT -- See Note [Representing concrete syntax in types]
-- in Language.Haskell.TH.Syntax
- | [ty1, L _ (HsExplicitListTy ip _ tys2)] <- tys'
- -> returnL (HsExplicitListTy ip placeHolderKind (ty1:tys2))
+ | [ty1, L _ (HsExplicitListTy _ ip tys2)] <- tys'
+ -> returnL (HsExplicitListTy noExt ip (ty1:tys2))
| otherwise
- -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName consDataCon)))
+ -> mk_apps (HsTyVar noExt Promoted
+ (noLoc (getRdrName consDataCon)))
tys'
StarT
- -> returnL (HsTyVar NotPromoted (noLoc
+ -> returnL (HsTyVar noExt NotPromoted (noLoc
(getRdrName liftedTypeKindTyCon)))
ConstraintT
- -> returnL (HsTyVar NotPromoted
+ -> returnL (HsTyVar noExt NotPromoted
(noLoc (getRdrName constraintKindTyCon)))
EqualityT
- | [x',y'] <- tys' -> returnL (HsEqTy x' y')
+ | [x',y'] <- tys' ->
+ returnL (HsOpTy noExt x' (noLoc eqTyCon_RDR) y')
| otherwise ->
- mk_apps (HsTyVar NotPromoted
- (noLoc (getRdrName eqPrimTyCon))) tys'
+ mk_apps (HsTyVar noExt NotPromoted
+ (noLoc eqTyCon_RDR)) tys'
+ ImplicitParamT n t
+ -> do { n' <- wrapL $ ipName n
+ ; t' <- cvtType t
+ ; returnL (HsIParamTy noExt n' t')
+ }
_ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
}
@@ -1328,22 +1434,46 @@ mk_apps head_ty [] = returnL head_ty
mk_apps head_ty (ty:tys) =
do { head_ty' <- returnL head_ty
; p_ty <- add_parens ty
- ; mk_apps (HsAppTy head_ty' p_ty) tys }
+ ; mk_apps (HsAppTy noExt head_ty' p_ty) tys }
where
- add_parens t@(L _ HsAppTy{}) = returnL (HsParTy t)
- add_parens t@(L _ HsFunTy{}) = returnL (HsParTy t)
- add_parens t = return t
+ -- See Note [Adding parens for splices]
+ add_parens lt@(L _ t)
+ | hsTypeNeedsParens appPrec t = returnL (HsParTy noExt lt)
+ | otherwise = return lt
wrap_apps :: LHsType GhcPs -> CvtM (LHsType GhcPs)
-wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t)
+wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy noExt t)
wrap_apps t = return t
+-- ---------------------------------------------------------------------
+-- Note [Adding parens for splices]
+{-
+The hsSyn representation of parsed source explicitly contains all the original
+parens, as written in the source.
+
+When a Template Haskell (TH) splice is evaluated, the original splice is first
+renamed and type checked and then finally converted to core in DsMeta. This core
+is then run in the TH engine, and the result comes back as a TH AST.
+
+In the process, all parens are stripped out, as they are not needed.
+
+This Convert module then converts the TH AST back to hsSyn AST.
+
+In order to pretty-print this hsSyn AST, parens need to be adde back at certain
+points so that the code is readable with its original meaning.
+
+So scattered through Convert.hs are various points where parens are added.
+
+See (among other closed issued) https://ghc.haskell.org/trac/ghc/ticket/14289
+-}
+-- ---------------------------------------------------------------------
+
-- | Constructs an arrow type with a specified return type
mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)
mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL
where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)
go arg ret_ty = do { ret_ty_l <- returnL ret_ty
- ; return (HsFunTy arg ret_ty_l) }
+ ; return (HsFunTy noExt arg ret_ty_l) }
split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType GhcPs])
split_ty_app ty = go ty []
@@ -1355,23 +1485,20 @@ cvtTyLit :: TH.TyLit -> HsTyLit
cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i
cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)
-{- | @cvtOpAppT x op y@ takes converted arguments and flattens any HsAppsTy
- structure in them.
--}
-cvtOpAppT :: LHsType GhcPs -> RdrName -> LHsType GhcPs -> LHsType GhcPs
-cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _)
- = L (combineSrcSpans loc1 loc2) $
- HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2')
- where
- t1' | L _ (HsAppsTy t1s) <- t1
- = t1s
- | otherwise
- = [noLoc $ HsAppPrefix t1]
+{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator
+application @x `op` y@. The produced tree of infix types will be right-biased,
+provided @y@ is.
- t2' | L _ (HsAppsTy t2s) <- t2
- = t2s
- | otherwise
- = [noLoc $ HsAppPrefix t2]
+See the @cvtOpApp@ documentation for how this function works.
+-}
+cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)
+cvtOpAppT (UInfixT x op2 y) op1 z
+ = do { l <- cvtOpAppT y op1 z
+ ; cvtOpAppT x op2 l }
+cvtOpAppT x op y
+ = do { op' <- tconNameL op
+ ; x' <- cvtType x
+ ; returnL (mkHsOpTy x' op' y) }
cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
cvtKind = cvtTypeKind "kind"
@@ -1381,18 +1508,18 @@ cvtKind = cvtTypeKind "kind"
-- signature is possible).
cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind
-> CvtM (LFamilyResultSig GhcPs)
-cvtMaybeKindToFamilyResultSig Nothing = returnL Hs.NoSig
+cvtMaybeKindToFamilyResultSig Nothing = returnL (Hs.NoSig noExt)
cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki
- ; returnL (Hs.KindSig ki') }
+ ; returnL (Hs.KindSig noExt ki') }
-- | Convert type family result signature. Used with both open and closed type
-- families.
cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)
-cvtFamilyResultSig TH.NoSig = returnL Hs.NoSig
+cvtFamilyResultSig TH.NoSig = returnL (Hs.NoSig noExt)
cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki
- ; returnL (Hs.KindSig ki') }
+ ; returnL (Hs.KindSig noExt ki') }
cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr
- ; returnL (Hs.TyVarSig tv) }
+ ; returnL (Hs.TyVarSig noExt tv) }
-- | Convert injectivity annotation of a type family.
cvtInjectivityAnnotation :: TH.InjectivityAnn
@@ -1411,13 +1538,16 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
| null univs, null reqs = do { l <- getL
; ty' <- cvtType (ForallT exis provs ty)
; return $ L l (HsQualTy { hst_ctxt = L l []
+ , hst_xqual = noExt
, hst_body = ty' }) }
| null reqs = do { l <- getL
; univs' <- hsQTvExplicit <$> cvtTvs univs
; ty' <- cvtType (ForallT exis provs ty)
; let forTy = HsForAllTy { hst_bndrs = univs'
+ , hst_xforall = noExt
, hst_body = L l cxtTy }
cxtTy = HsQualTy { hst_ctxt = L l []
+ , hst_xqual = noExt
, hst_body = ty' }
; return $ L l forTy }
| otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty))
@@ -1467,15 +1597,16 @@ mkHsForAllTy :: [TH.TyVarBndr]
-> SrcSpan
-- ^ The location of the returned 'LHsType' if it needs an
-- explicit forall
- -> LHsQTyVars name
+ -> LHsQTyVars GhcPs
-- ^ The converted type variable binders
- -> LHsType name
+ -> LHsType GhcPs
-- ^ The converted rho type
- -> LHsType name
+ -> LHsType GhcPs
-- ^ The complete type, quantified with a forall if necessary
mkHsForAllTy tvs loc tvs' rho_ty
| null tvs = rho_ty
| otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
+ , hst_xforall = noExt
, hst_body = rho_ty }
-- | If passed an empty 'TH.Cxt', this simply returns the third argument
@@ -1490,15 +1621,16 @@ mkHsQualTy :: TH.Cxt
-> SrcSpan
-- ^ The location of the returned 'LHsType' if it needs an
-- explicit context
- -> LHsContext name
+ -> LHsContext GhcPs
-- ^ The converted context
- -> LHsType name
+ -> LHsType GhcPs
-- ^ The converted tau type
- -> LHsType name
+ -> LHsType GhcPs
-- ^ The complete type, qualified with a context if necessary
mkHsQualTy ctxt loc ctxt' ty
| null ctxt = ty
- | otherwise = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = ty }
+ | otherwise = L loc $ HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'
+ , hst_body = ty }
--------------------------------------------------------------------
-- Turning Name back into RdrName
@@ -1528,6 +1660,11 @@ tName n = cvtName OccName.tvName n
tconNameL n = wrapL (tconName n)
tconName n = cvtName OccName.tcClsName n
+ipName :: String -> CvtM HsIPName
+ipName n
+ = do { unless (okVarOcc n) (failWith (badOcc OccName.varName n))
+ ; return (HsIPName (fsLit n)) }
+
cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
cvtName ctxt_ns (TH.Name occ flavour)
| not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
@@ -1588,8 +1725,14 @@ thRdrName loc ctxt_ns th_occ th_name
occ :: OccName.OccName
occ = mk_occ ctxt_ns th_occ
+-- Return an unqualified exact RdrName if we're dealing with built-in syntax.
+-- See Trac #13776.
thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
-thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
+thOrigRdrName occ th_ns pkg mod =
+ let occ' = mk_occ (mk_ghc_ns th_ns) occ
+ in case isBuiltInOcc_maybe occ' of
+ Just name -> nameRdrName name
+ Nothing -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ'
thRdrNameGuesses :: TH.Name -> [RdrName]
thRdrNameGuesses (TH.Name occ flavour)
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index f08a6af700..98f503b0d9 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -14,9 +14,12 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
module HsBinds where
+import GhcPrelude
+
import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
MatchGroup, pprFunBind,
GRHSs, pprPatBind )
@@ -54,7 +57,7 @@ Global bindings (where clauses)
-}
-- During renaming, we need bindings where the left-hand sides
--- have been renamed but the the right-hand sides have not.
+-- have been renamed but the right-hand sides have not.
-- the ...LR datatypes are parametrized by two id types,
-- one for the left and one for the right.
-- Other than during renaming, these will be the same.
@@ -70,23 +73,34 @@ type LHsLocalBinds id = Located (HsLocalBinds id)
-- Bindings in a 'let' expression
-- or a 'where' clause
data HsLocalBindsLR idL idR
- = HsValBinds (HsValBindsLR idL idR)
+ = HsValBinds
+ (XHsValBinds idL idR)
+ (HsValBindsLR idL idR)
-- ^ Haskell Value Bindings
-- There should be no pattern synonyms in the HsValBindsLR
-- These are *local* (not top level) bindings
- -- The parser accepts them, however, leaving the the
+ -- The parser accepts them, however, leaving the
-- renamer to report them
- | HsIPBinds (HsIPBinds idR)
+ | HsIPBinds
+ (XHsIPBinds idL idR)
+ (HsIPBinds idR)
-- ^ Haskell Implicit Parameter Bindings
- | EmptyLocalBinds
+ | EmptyLocalBinds (XEmptyLocalBinds idL idR)
-- ^ Empty Local Bindings
+ | XHsLocalBindsLR
+ (XXHsLocalBindsLR idL idR)
+
+type instance XHsValBinds (GhcPass pL) (GhcPass pR) = NoExt
+type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = NoExt
+type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExt
+type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExt
+
type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR)
-deriving instance (DataId idL, DataId idR) => Data (HsLocalBindsLR idL idR)
-- | Haskell Value Bindings
type HsValBinds id = HsValBindsLR id id
@@ -101,18 +115,31 @@ data HsValBindsLR idL idR
-- Before renaming RHS; idR is always RdrName
-- Not dependency analysed
-- Recursive by default
- ValBindsIn
+ ValBinds
+ (XValBinds idL idR)
(LHsBindsLR idL idR) [LSig idR]
-- | Value Bindings Out
--
-- After renaming RHS; idR can be Name or Id Dependency analysed,
-- later bindings in the list may depend on earlier ones.
- | ValBindsOut
- [(RecFlag, LHsBinds idL)]
- [LSig GhcRn] -- AZ: how to do this?
+ | XValBindsLR
+ (XXValBindsLR idL idR)
+
+-- ---------------------------------------------------------------------
+-- Deal with ValBindsOut
+
+-- TODO: make this the only type for ValBinds
+data NHsValBindsLR idL
+ = NValBinds
+ [(RecFlag, LHsBinds idL)]
+ [LSig GhcRn]
-deriving instance (DataId idL, DataId idR) => Data (HsValBindsLR idL idR)
+type instance XValBinds (GhcPass pL) (GhcPass pR) = NoExt
+type instance XXValBindsLR (GhcPass pL) (GhcPass pR)
+ = NHsValBindsLR (GhcPass pL)
+
+-- ---------------------------------------------------------------------
-- | Located Haskell Binding
type LHsBind id = LHsBindLR id id
@@ -129,9 +156,8 @@ type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
-- | Located Haskell Binding with separate Left and Right identifier types
type LHsBindLR idL idR = Located (HsBindLR idL idR)
-{- Note [Varieties of binding pattern matches]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
+{- Note [FunBind vs PatBind]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~
The distinction between FunBind and PatBind is a bit subtle. FunBind covers
patterns which resemble function bindings and simple variable bindings.
@@ -142,12 +168,17 @@ patterns which resemble function bindings and simple variable bindings.
x `f` y = e -- FunRhs has Infix
The actual patterns and RHSs of a FunBind are encoding in fun_matches.
-The m_ctxt field of Match will be FunRhs and carries two bits of information
-about the match,
+The m_ctxt field of each Match in fun_matches will be FunRhs and carries
+two bits of information about the match,
- * the mc_strictness field describes whether the match is decorated with a bang
- (e.g. `!x = e`)
- * the mc_fixity field describes the fixity of the function binder
+ * The mc_fixity field on each Match describes the fixity of the
+ function binder in that match. E.g. this is legal:
+ f True False = e1
+ True `f` True = e2
+
+ * The mc_strictness field is used /only/ for nullary FunBinds: ones
+ with one Match, which has no pats. For these, it describes whether
+ the match is decorated with a bang (e.g. `!x = e`).
By contrast, PatBind represents data constructor patterns, as well as a few
other interesting cases. Namely,
@@ -175,7 +206,7 @@ data HsBindLR idL idR
-- @(f :: a -> a) = ... @
--
-- Strict bindings have their strictness recorded in the 'SrcStrictness' of their
- -- 'MatchContext'. See Note [Varieties of binding pattern matches] for
+ -- 'MatchContext'. See Note [FunBind vs PatBind] for
-- details about the relationship between FunBind and PatBind.
--
-- 'ApiAnnotation.AnnKeywordId's
@@ -188,6 +219,11 @@ data HsBindLR idL idR
-- For details on above see note [Api annotations] in ApiAnnotation
FunBind {
+ fun_ext :: XFunBind idL idR, -- ^ After the renamer, this contains
+ -- the locally-bound
+ -- free variables of this defn.
+ -- See Note [Bind free vars]
+
fun_id :: Located (IdP idL), -- Note [fun_id in Match] in HsExpr
fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload
@@ -206,12 +242,6 @@ data HsBindLR idL idR
-- type Int -> forall a'. a' -> a'
-- Notice that the coercion captures the free a'.
- bind_fvs :: PostRn idL NameSet, -- ^ After the renamer, this contains
- -- the locally-bound
- -- free variables of this defn.
- -- See Note [Bind free vars]
-
-
fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any
}
@@ -219,7 +249,7 @@ data HsBindLR idL idR
--
-- The pattern is never a simple variable;
-- That case is done by FunBind.
- -- See Note [Varieties of binding pattern matches] for details about the
+ -- See Note [FunBind vs PatBind] for details about the
-- relationship between FunBind and PatBind.
--
@@ -229,10 +259,9 @@ data HsBindLR idL idR
-- For details on above see note [Api annotations] in ApiAnnotation
| PatBind {
+ pat_ext :: XPatBind idL idR, -- ^ See Note [Bind free vars]
pat_lhs :: LPat idL,
pat_rhs :: GRHSs idR (LHsExpr idR),
- pat_rhs_ty :: PostTc idR Type, -- ^ Type of the GRHSs
- bind_fvs :: PostRn idL NameSet, -- ^ See Note [Bind free vars]
pat_ticks :: ([Tickish Id], [[Tickish Id]])
-- ^ Ticks to put on the rhs, if any, and ticks to put on
-- the bound variables.
@@ -243,6 +272,7 @@ data HsBindLR idL idR
-- Dictionary binding and suchlike.
-- All VarBinds are introduced by the type checker
| VarBind {
+ var_ext :: XVarBind idL idR,
var_id :: IdP idL,
var_rhs :: LHsExpr idR, -- ^ Located only for consistency
var_inline :: Bool -- ^ True <=> inline this binding regardless
@@ -251,6 +281,7 @@ data HsBindLR idL idR
-- | Abstraction Bindings
| AbsBinds { -- Binds abstraction; TRANSLATION
+ abs_ext :: XAbsBinds idL idR,
abs_tvs :: [TyVar],
abs_ev_vars :: [EvVar], -- ^ Includes equality constraints
@@ -265,26 +296,15 @@ data HsBindLR idL idR
abs_ev_binds :: [TcEvBinds],
-- | Typechecked user bindings
- abs_binds :: LHsBinds idL
- }
+ abs_binds :: LHsBinds idL,
- -- | Abstraction Bindings Signature
- | AbsBindsSig { -- Simpler form of AbsBinds, used with a type sig
- -- in tcPolyCheck. Produces simpler desugaring and
- -- is necessary to avoid #11405, comment:3.
- abs_tvs :: [TyVar],
- abs_ev_vars :: [EvVar],
-
- abs_sig_export :: IdP idL, -- like abe_poly
- abs_sig_prags :: TcSpecPrags,
-
- abs_sig_ev_bind :: TcEvBinds, -- no list needed here
- abs_sig_bind :: LHsBind idL -- always only one, and it's always a
- -- FunBind
+ abs_sig :: Bool -- See Note [The abs_sig field of AbsBinds]
}
-- | Patterns Synonym Binding
- | PatSynBind (PatSynBind idL idR)
+ | PatSynBind
+ (XPatSynBind idL idR)
+ (PatSynBind idL idR)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
-- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual',
-- 'ApiAnnotation.AnnWhere'
@@ -292,7 +312,26 @@ data HsBindLR idL idR
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId idL, DataId idR) => Data (HsBindLR idL idR)
+ | XHsBindsLR (XXHsBindsLR idL idR)
+
+data NPatBindTc = NPatBindTc {
+ pat_fvs :: NameSet, -- ^ Free variables
+ pat_rhs_ty :: Type -- ^ Type of the GRHSs
+ } deriving Data
+
+type instance XFunBind (GhcPass pL) GhcPs = NoExt
+type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables
+type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables
+
+type instance XPatBind GhcPs (GhcPass pR) = NoExt
+type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables
+type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc
+
+type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExt
+type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExt
+type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExt
+type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExt
+
-- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
--
@@ -308,13 +347,18 @@ deriving instance (DataId idL, DataId idR) => Data (HsBindLR idL idR)
-- | Abtraction Bindings Export
data ABExport p
- = ABE { abe_poly :: IdP p -- ^ Any INLINE pragmas is attached to this Id
+ = ABE { abe_ext :: XABE p
+ , abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id
, abe_mono :: IdP p
, abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper]
-- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
, abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas
- }
-deriving instance (DataId p) => Data (ABExport p)
+ }
+ | XABExport (XXABExport p)
+
+type instance XABE (GhcPass p) = NoExt
+type instance XXABExport (GhcPass p) = NoExt
+
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow'
@@ -325,14 +369,21 @@ deriving instance (DataId p) => Data (ABExport p)
-- | Pattern Synonym binding
data PatSynBind idL idR
- = PSB { psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym
- psb_fvs :: PostRn idR NameSet, -- ^ See Note [Bind free vars]
+ = PSB { psb_ext :: XPSB idL idR, -- ^ Post renaming, FVs.
+ -- See Note [Bind free vars]
+ psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym
psb_args :: HsPatSynDetails (Located (IdP idR)),
-- ^ Formal parameter names
psb_def :: LPat idR, -- ^ Right-hand side
psb_dir :: HsPatSynDir idR -- ^ Directionality
- }
-deriving instance (DataId idL, DataId idR) => Data (PatSynBind idL idR)
+ }
+ | XPatSynBind (XXPatSynBind idL idR)
+
+type instance XPSB (GhcPass idL) GhcPs = NoExt
+type instance XPSB (GhcPass idL) GhcRn = NameSet
+type instance XPSB (GhcPass idL) GhcTc = NameSet
+
+type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExt
{-
Note [AbsBinds]
@@ -477,6 +528,53 @@ bindings only when
lacks a user type signature
* The group forms a strongly connected component
+
+Note [The abs_sig field of AbsBinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The abs_sig field supports a couple of special cases for bindings.
+Consider
+
+ x :: Num a => (# a, a #)
+ x = (# 3, 4 #)
+
+The general desugaring for AbsBinds would give
+
+ x = /\a. \ ($dNum :: Num a) ->
+ letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in
+ xm
+
+But that has an illegal let-binding for an unboxed tuple. In this
+case we'd prefer to generate the (more direct)
+
+ x = /\ a. \ ($dNum :: Num a) ->
+ (# fromInteger $dNum 3, fromInteger $dNum 4 #)
+
+A similar thing happens with representation-polymorphic defns
+(Trac #11405):
+
+ undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a
+ undef = error "undef"
+
+Again, the vanilla desugaring gives a local let-binding for a
+representation-polymorphic (undefm :: a), which is illegal. But
+again we can desugar without a let:
+
+ undef = /\ a. \ (d:HasCallStack) -> error a d "undef"
+
+The abs_sig field supports this direct desugaring, with no local
+let-bining. When abs_sig = True
+
+ * the abs_binds is single FunBind
+
+ * the abs_exports is a singleton
+
+ * we have a complete type sig for binder
+ and hence the abs_binds is non-recursive
+ (it binds the mono_id but refers to the poly_id
+
+These properties are exploited in DsBinds.dsAbsBinds to
+generate code without a let-binding.
+
Note [ABExport wrapper]
~~~~~~~~~~~~~~~~~~~~~~~
Consider
@@ -520,20 +618,21 @@ Specifically,
it's just an error thunk
-}
-instance (SourceTextX idL, SourceTextX idR,
+instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsLocalBindsLR idL idR) where
- ppr (HsValBinds bs) = ppr bs
- ppr (HsIPBinds bs) = ppr bs
- ppr EmptyLocalBinds = empty
+ ppr (HsValBinds _ bs) = ppr bs
+ ppr (HsIPBinds _ bs) = ppr bs
+ ppr (EmptyLocalBinds _) = empty
+ ppr (XHsLocalBindsLR x) = ppr x
-instance (SourceTextX idL, SourceTextX idR,
+instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsValBindsLR idL idR) where
- ppr (ValBindsIn binds sigs)
+ ppr (ValBinds _ binds sigs)
= pprDeclList (pprLHsBindsForUser binds sigs)
- ppr (ValBindsOut sccs sigs)
+ ppr (XValBindsLR (NValBinds sccs sigs))
= getPprStyle $ \ sty ->
if debugStyle sty then -- Print with sccs showing
vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
@@ -544,17 +643,16 @@ instance (SourceTextX idL, SourceTextX idR,
pp_rec Recursive = text "rec"
pp_rec NonRecursive = text "nonrec"
-pprLHsBinds :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => LHsBindsLR idL idR -> SDoc
+pprLHsBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprLHsBinds binds
| isEmptyLHsBinds binds = empty
| otherwise = pprDeclList (map ppr (bagToList binds))
-pprLHsBindsForUser :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR,
- SourceTextX id2, OutputableBndrId id2)
- => LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
+pprLHsBindsForUser :: (OutputableBndrId (GhcPass idL),
+ OutputableBndrId (GhcPass idR),
+ OutputableBndrId (GhcPass id2))
+ => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc]
-- pprLHsBindsForUser is different to pprLHsBinds because
-- a) No braces: 'let' and 'where' include a list of HsBindGroups
-- and we don't want several groups of bindings each
@@ -583,25 +681,33 @@ pprDeclList :: [SDoc] -> SDoc -- Braces with a space
pprDeclList ds = pprDeeperList vcat ds
------------
-emptyLocalBinds :: HsLocalBindsLR a b
-emptyLocalBinds = EmptyLocalBinds
-
-isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
-isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
-isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds
-isEmptyLocalBinds EmptyLocalBinds = True
+emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b)
+emptyLocalBinds = EmptyLocalBinds noExt
+
+-- AZ:These functions do not seem to be used at all?
+isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool
+isEmptyLocalBindsTc (HsValBinds _ ds) = isEmptyValBinds ds
+isEmptyLocalBindsTc (HsIPBinds _ ds) = isEmptyIPBindsTc ds
+isEmptyLocalBindsTc (EmptyLocalBinds _) = True
+isEmptyLocalBindsTc (XHsLocalBindsLR _) = True
+
+isEmptyLocalBindsPR :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool
+isEmptyLocalBindsPR (HsValBinds _ ds) = isEmptyValBinds ds
+isEmptyLocalBindsPR (HsIPBinds _ ds) = isEmptyIPBindsPR ds
+isEmptyLocalBindsPR (EmptyLocalBinds _) = True
+isEmptyLocalBindsPR (XHsLocalBindsLR _) = True
eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
-eqEmptyLocalBinds EmptyLocalBinds = True
-eqEmptyLocalBinds _ = False
+eqEmptyLocalBinds (EmptyLocalBinds _) = True
+eqEmptyLocalBinds _ = False
-isEmptyValBinds :: HsValBindsLR a b -> Bool
-isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
-isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
+isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool
+isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs
+isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs
-emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
-emptyValBindsIn = ValBindsIn emptyBag []
-emptyValBindsOut = ValBindsOut [] []
+emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b)
+emptyValBindsIn = ValBinds noExt emptyBag []
+emptyValBindsOut = XValBindsLR (NValBinds [] [])
emptyLHsBinds :: LHsBindsLR idL idR
emptyLHsBinds = emptyBag
@@ -610,22 +716,23 @@ isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
isEmptyLHsBinds = isEmptyBag
------------
-plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
-plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
- = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
-plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
- = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
+plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
+ -> HsValBinds(GhcPass a)
+plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2)
+ = ValBinds noExt (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
+plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1))
+ (XValBindsLR (NValBinds ds2 sigs2))
+ = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2))
plusHsValBinds _ _
= panic "HsBinds.plusHsValBinds"
-instance (SourceTextX idL, SourceTextX idR,
+instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsBindLR idL idR) where
ppr mbind = ppr_monobind mbind
-ppr_monobind :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => HsBindLR idL idR -> SDoc
+ppr_monobind :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
= pprPatBind pat grhss
@@ -637,10 +744,10 @@ ppr_monobind (FunBind { fun_id = fun,
fun_tick = ticks })
= pprTicks empty (if null ticks then empty
else text "-- ticks = " <> ppr ticks)
- $$ ifPprDebug (pprBndr LetBind (unLoc fun))
+ $$ whenPprDebug (pprBndr LetBind (unLoc fun))
$$ pprFunBind matches
- $$ ifPprDebug (ppr wrap)
-ppr_monobind (PatSynBind psb) = ppr psb
+ $$ whenPprDebug (ppr wrap)
+ppr_monobind (PatSynBind _ psb) = ppr psb
ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
, abs_exports = exports, abs_binds = val_binds
, abs_ev_binds = ev_binds })
@@ -658,30 +765,17 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
, text "Evidence:" <+> ppr ev_binds ]
else
pprLHsBinds val_binds
-ppr_monobind (AbsBindsSig { abs_tvs = tyvars
- , abs_ev_vars = dictvars
- , abs_sig_export = poly_id
- , abs_sig_ev_bind = ev_bind
- , abs_sig_bind = bind })
- = sdocWithDynFlags $ \ dflags ->
- if gopt Opt_PrintTypecheckerElaboration dflags then
- hang (text "AbsBindsSig" <+> brackets (interpp'SP tyvars)
- <+> brackets (interpp'SP dictvars))
- 2 $ braces $ vcat
- [ text "Exported type:" <+> pprBndr LetBind poly_id
- , text "Bind:" <+> ppr bind
- , text "Evidence:" <+> ppr ev_bind ]
- else
- ppr bind
+ppr_monobind (XHsBindsLR x) = ppr x
-instance (OutputableBndrId p) => Outputable (ABExport p) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ABExport p) where
ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
= vcat [ ppr gbl <+> text "<=" <+> ppr lcl
, nest 2 (pprTcSpecPrags prags)
, nest 2 (text "wrap:" <+> ppr wrap)]
+ ppr (XABExport x) = ppr x
-instance (SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
+instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR,
+ Outputable (XXPatSynBind idL idR))
=> Outputable (PatSynBind idL idR) where
ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,
psb_dir = dir })
@@ -691,17 +785,17 @@ instance (SourceTextX idR,
ppr_simple syntax = syntax <+> ppr pat
ppr_details = case details of
- InfixPatSyn v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
- PrefixPatSyn vs -> hsep (pprPrefixOcc psyn : map ppr vs)
- RecordPatSyn vs ->
- pprPrefixOcc psyn
- <> braces (sep (punctuate comma (map ppr vs)))
+ InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
+ PrefixCon vs -> hsep (pprPrefixOcc psyn : map ppr vs)
+ RecCon vs -> pprPrefixOcc psyn
+ <> braces (sep (punctuate comma (map ppr vs)))
ppr_rhs = case dir of
Unidirectional -> ppr_simple (text "<-")
ImplicitBidirectional -> ppr_simple equals
ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$
(nest 2 $ pprFunBind mg)
+ ppr (XPatSynBind x) = ppr x
pprTicks :: SDoc -> SDoc -> SDoc
-- Print stuff about ticks only when -dppr-debug is on, to avoid
@@ -724,13 +818,27 @@ pprTicks pp_no_debug pp_when_debug
-- | Haskell Implicit Parameter Bindings
data HsIPBinds id
= IPBinds
+ (XIPBinds id)
[LIPBind id]
- TcEvBinds -- Only in typechecker output; binds
- -- uses of the implicit parameters
-deriving instance (DataId id) => Data (HsIPBinds id)
+ -- TcEvBinds -- Only in typechecker output; binds
+ -- -- uses of the implicit parameters
+ | XHsIPBinds (XXHsIPBinds id)
+
+type instance XIPBinds GhcPs = NoExt
+type instance XIPBinds GhcRn = NoExt
+type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the
+ -- implicit parameters
-isEmptyIPBinds :: HsIPBinds id -> Bool
-isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
+
+type instance XXHsIPBinds (GhcPass p) = NoExt
+
+isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool
+isEmptyIPBindsPR (IPBinds _ is) = null is
+isEmptyIPBindsPR (XHsIPBinds _) = True
+
+isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool
+isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds
+isEmptyIPBindsTc (XHsIPBinds _) = True
-- | Located Implicit Parameter Binding
type LIPBind id = Located (IPBind id)
@@ -750,18 +858,27 @@ type LIPBind id = Located (IPBind id)
-- For details on above see note [Api annotations] in ApiAnnotation
data IPBind id
- = IPBind (Either (Located HsIPName) (IdP id)) (LHsExpr id)
-deriving instance (DataId name) => Data (IPBind name)
-
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsIPBinds p) where
- ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
- $$ ifPprDebug (ppr ds)
-
-instance (SourceTextX p, OutputableBndrId p ) => Outputable (IPBind p) where
- ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
+ = IPBind
+ (XCIPBind id)
+ (Either (Located HsIPName) (IdP id))
+ (LHsExpr id)
+ | XIPBind (XXIPBind id)
+
+type instance XCIPBind (GhcPass p) = NoExt
+type instance XXIPBind (GhcPass p) = NoExt
+
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (HsIPBinds p) where
+ ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs)
+ $$ whenPprDebug (ppr ds)
+ ppr (XHsIPBinds x) = ppr x
+
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (IPBind p) where
+ ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
where name = case lr of
Left (L _ ip) -> pprBndr LetBind ip
Right id -> pprBndr LetBind id
+ ppr (XIPBind x) = ppr x
{-
************************************************************************
@@ -798,6 +915,7 @@ data Sig pass
-- For details on above see note [Api annotations] in ApiAnnotation
TypeSig
+ (XTypeSig pass)
[Located (IdP pass)] -- LHS of the signature; e.g. f,g,h :: blah
(LHsSigWcType pass) -- RHS of the signature; can have wildcards
@@ -810,7 +928,7 @@ data Sig pass
-- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
- | PatSynSig [Located (IdP pass)] (LHsSigType pass)
+ | PatSynSig (XPatSynSig pass) [Located (IdP pass)] (LHsSigType pass)
-- P :: forall a b. Req => Prov => ty
-- | A signature for a class method
@@ -823,14 +941,14 @@ data Sig pass
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
-- 'ApiAnnotation.AnnDcolon'
- | ClassOpSig Bool [Located (IdP pass)] (LHsSigType pass)
+ | ClassOpSig (XClassOpSig pass) Bool [Located (IdP pass)] (LHsSigType pass)
-- | A type signature in generated code, notably the code
-- generated for record selectors. We simply record
-- the desired Id itself, replete with its name, type
-- and IdDetails. Otherwise it's just like a type
-- signature: there should be an accompanying binding
- | IdSig Id
+ | IdSig (XIdSig pass) Id
-- | An ordinary fixity declaration
--
@@ -841,7 +959,7 @@ data Sig pass
-- 'ApiAnnotation.AnnVal'
-- For details on above see note [Api annotations] in ApiAnnotation
- | FixSig (FixitySig pass)
+ | FixSig (XFixSig pass) (FixitySig pass)
-- | An inline pragma
--
@@ -854,7 +972,8 @@ data Sig pass
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
- | InlineSig (Located (IdP pass)) -- Function name
+ | InlineSig (XInlineSig pass)
+ (Located (IdP pass)) -- Function name
InlinePragma -- Never defaultInlinePragma
-- | A specialisation pragma
@@ -869,7 +988,8 @@ data Sig pass
-- 'ApiAnnotation.AnnDcolon'
-- For details on above see note [Api annotations] in ApiAnnotation
- | SpecSig (Located (IdP pass)) -- Specialise a function or datatype ...
+ | SpecSig (XSpecSig pass)
+ (Located (IdP pass)) -- Specialise a function or datatype ...
[LHsSigType pass] -- ... to these types
InlinePragma -- The pragma on SPECIALISE_INLINE form.
-- If it's just defaultInlinePragma, then we said
@@ -886,7 +1006,7 @@ data Sig pass
-- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
- | SpecInstSig SourceText (LHsSigType pass)
+ | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass)
-- Note [Pragma source text] in BasicTypes
-- | A minimal complete definition pragma
@@ -898,7 +1018,8 @@ data Sig pass
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
- | MinimalSig SourceText (LBooleanFormula (Located (IdP pass)))
+ | MinimalSig (XMinimalSig pass)
+ SourceText (LBooleanFormula (Located (IdP pass)))
-- Note [Pragma source text] in BasicTypes
-- | A "set cost centre" pragma for declarations
@@ -909,7 +1030,8 @@ data Sig pass
--
-- > {-# SCC funName "cost_centre_name" #-}
- | SCCFunSig SourceText -- Note [Pragma source text] in BasicTypes
+ | SCCFunSig (XSCCFunSig pass)
+ SourceText -- Note [Pragma source text] in BasicTypes
(Located (IdP pass)) -- Function name
(Maybe (Located StringLiteral))
-- | A complete match pragma
@@ -919,18 +1041,34 @@ data Sig pass
-- Used to inform the pattern match checker about additional
-- complete matchings which, for example, arise from pattern
-- synonym definitions.
- | CompleteMatchSig SourceText
+ | CompleteMatchSig (XCompleteMatchSig pass)
+ SourceText
(Located [Located (IdP pass)])
(Maybe (Located (IdP pass)))
-
-deriving instance (DataId pass) => Data (Sig pass)
+ | XSig (XXSig pass)
+
+type instance XTypeSig (GhcPass p) = NoExt
+type instance XPatSynSig (GhcPass p) = NoExt
+type instance XClassOpSig (GhcPass p) = NoExt
+type instance XIdSig (GhcPass p) = NoExt
+type instance XFixSig (GhcPass p) = NoExt
+type instance XInlineSig (GhcPass p) = NoExt
+type instance XSpecSig (GhcPass p) = NoExt
+type instance XSpecInstSig (GhcPass p) = NoExt
+type instance XMinimalSig (GhcPass p) = NoExt
+type instance XSCCFunSig (GhcPass p) = NoExt
+type instance XCompleteMatchSig (GhcPass p) = NoExt
+type instance XXSig (GhcPass p) = NoExt
-- | Located Fixity Signature
type LFixitySig pass = Located (FixitySig pass)
-- | Fixity Signature
-data FixitySig pass = FixitySig [Located (IdP pass)] Fixity
-deriving instance (DataId pass) => Data (FixitySig pass)
+data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity
+ | XFixitySig (XXFixitySig pass)
+
+type instance XFixitySig (GhcPass p) = NoExt
+type instance XXFixitySig (GhcPass p) = NoExt
-- | Type checker Specialisation Pragmas
--
@@ -950,7 +1088,7 @@ data TcSpecPrag
Id
HsWrapper
InlinePragma
- -- ^ The Id to be specialised, an wrapper that specialises the
+ -- ^ The Id to be specialised, a wrapper that specialises the
-- polymorphic function, and inlining spec for the specialised function
deriving Data
@@ -1012,17 +1150,18 @@ isCompleteMatchSig _ = False
hsSigDoc :: Sig name -> SDoc
hsSigDoc (TypeSig {}) = text "type signature"
hsSigDoc (PatSynSig {}) = text "pattern synonym signature"
-hsSigDoc (ClassOpSig is_deflt _ _)
+hsSigDoc (ClassOpSig _ is_deflt _ _)
| is_deflt = text "default type signature"
| otherwise = text "class method signature"
hsSigDoc (IdSig {}) = text "id signature"
hsSigDoc (SpecSig {}) = text "SPECIALISE pragma"
-hsSigDoc (InlineSig _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma"
+hsSigDoc (InlineSig _ _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma"
hsSigDoc (SpecInstSig {}) = text "SPECIALISE instance pragma"
hsSigDoc (FixSig {}) = text "fixity declaration"
hsSigDoc (MinimalSig {}) = text "MINIMAL pragma"
hsSigDoc (SCCFunSig {}) = text "SCC pragma"
hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma"
+hsSigDoc (XSig {}) = text "XSIG TTG extension"
{-
Check if signatures overlap; this is used when checking for duplicate
@@ -1030,46 +1169,48 @@ signatures. Since some of the signatures contain a list of names, testing for
equality is not enough -- we have to check if they overlap.
-}
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (Sig pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Sig p) where
ppr sig = ppr_sig sig
-ppr_sig :: (SourceTextX pass, OutputableBndrId pass ) => Sig pass -> SDoc
-ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty)
-ppr_sig (ClassOpSig is_deflt vars ty)
+ppr_sig :: (OutputableBndrId (GhcPass p)) => Sig (GhcPass p) -> SDoc
+ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty)
+ppr_sig (ClassOpSig _ is_deflt vars ty)
| is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
| otherwise = pprVarSig (map unLoc vars) (ppr ty)
-ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id))
-ppr_sig (FixSig fix_sig) = ppr fix_sig
-ppr_sig (SpecSig var ty inl@(InlinePragma { inl_inline = spec }))
+ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id))
+ppr_sig (FixSig _ fix_sig) = ppr fix_sig
+ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec }))
= pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var)
(interpp'SP ty) inl)
where
pragmaSrc = case spec of
- EmptyInlineSpec -> "{-# SPECIALISE"
- _ -> "{-# SPECIALISE_INLINE"
-ppr_sig (InlineSig var inl)
+ NoUserInline -> "{-# SPECIALISE"
+ _ -> "{-# SPECIALISE_INLINE"
+ppr_sig (InlineSig _ var inl)
= pragSrcBrackets (inl_src inl) "{-# INLINE" (pprInline inl
<+> pprPrefixOcc (unLoc var))
-ppr_sig (SpecInstSig src ty)
+ppr_sig (SpecInstSig _ src ty)
= pragSrcBrackets src "{-# SPECIALISE" (text "instance" <+> ppr ty)
-ppr_sig (MinimalSig src bf)
+ppr_sig (MinimalSig _ src bf)
= pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf)
-ppr_sig (PatSynSig names sig_ty)
+ppr_sig (PatSynSig _ names sig_ty)
= text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)
-ppr_sig (SCCFunSig src fn mlabel)
+ppr_sig (SCCFunSig _ src fn mlabel)
= pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel )
-ppr_sig (CompleteMatchSig src cs mty)
+ppr_sig (CompleteMatchSig _ src cs mty)
= pragSrcBrackets src "{-# COMPLETE"
((hsep (punctuate comma (map ppr (unLoc cs))))
<+> opt_sig)
where
opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty
+ppr_sig (XSig x) = ppr x
-instance OutputableBndrId pass => Outputable (FixitySig pass) where
- ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (FixitySig p) where
+ ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops]
where
pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
+ ppr (XFixitySig x) = ppr x
pragBrackets :: SDoc -> SDoc
pragBrackets doc = text "{-#" <+> doc <+> text "#-}"
@@ -1112,12 +1253,7 @@ pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
-}
-- | Haskell Pattern Synonym Details
-data HsPatSynDetails a
- = InfixPatSyn a a -- ^ Infix Pattern Synonym
- | PrefixPatSyn [a] -- ^ Prefix Pattern Synonym
- | RecordPatSyn [RecordPatSynField a] -- ^ Record Pattern Synonym
- deriving Data
-
+type HsPatSynDetails arg = HsConDetails arg [RecordPatSynField arg]
-- See Note [Record PatSyn Fields]
-- | Record Pattern Synonym Field
@@ -1174,46 +1310,8 @@ instance Traversable RecordPatSynField where
<$> f visible <*> f hidden
-instance Functor HsPatSynDetails where
- fmap f (InfixPatSyn left right) = InfixPatSyn (f left) (f right)
- fmap f (PrefixPatSyn args) = PrefixPatSyn (fmap f args)
- fmap f (RecordPatSyn args) = RecordPatSyn (map (fmap f) args)
-
-instance Foldable HsPatSynDetails where
- foldMap f (InfixPatSyn left right) = f left `mappend` f right
- foldMap f (PrefixPatSyn args) = foldMap f args
- foldMap f (RecordPatSyn args) = foldMap (foldMap f) args
-
- foldl1 f (InfixPatSyn left right) = left `f` right
- foldl1 f (PrefixPatSyn args) = Data.List.foldl1 f args
- foldl1 f (RecordPatSyn args) =
- Data.List.foldl1 f (map (Data.Foldable.foldl1 f) args)
-
- foldr1 f (InfixPatSyn left right) = left `f` right
- foldr1 f (PrefixPatSyn args) = Data.List.foldr1 f args
- foldr1 f (RecordPatSyn args) =
- Data.List.foldr1 f (map (Data.Foldable.foldr1 f) args)
-
- length (InfixPatSyn _ _) = 2
- length (PrefixPatSyn args) = Data.List.length args
- length (RecordPatSyn args) = Data.List.length args
-
- null (InfixPatSyn _ _) = False
- null (PrefixPatSyn args) = Data.List.null args
- null (RecordPatSyn args) = Data.List.null args
-
- toList (InfixPatSyn left right) = [left, right]
- toList (PrefixPatSyn args) = args
- toList (RecordPatSyn args) = foldMap toList args
-
-instance Traversable HsPatSynDetails where
- traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right
- traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args
- traverse f (RecordPatSyn args) = RecordPatSyn <$> traverse (traverse f) args
-
-- | Haskell Pattern Synonym Direction
data HsPatSynDir id
= Unidirectional
| ImplicitBidirectional
| ExplicitBidirectional (MatchGroup id (LHsExpr id))
-deriving instance (DataId id) => Data (HsPatSynDir id)
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 8b7d9c6a40..2d2e911645 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -10,7 +10,7 @@
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
-- | Abstract syntax of global declarations.
--
@@ -18,11 +18,11 @@
-- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
module HsDecls (
-- * Toplevel declarations
- HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving,
- HsDerivingClause(..), LHsDerivingClause,
+ HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep,
+ HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour,
-- ** Class or type declarations
- TyClDecl(..), LTyClDecl,
+ TyClDecl(..), LTyClDecl, DataDeclRn(..),
TyClGroup(..), mkTyClGroup, emptyTyClGroup,
tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,
isClassDecl, isDataDecl, isSynDecl, tcdName,
@@ -35,22 +35,23 @@ module HsDecls (
FamilyDecl(..), LFamilyDecl,
-- ** Instance declarations
- InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..),
+ InstDecl(..), LInstDecl, FamilyInfo(..),
TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
- DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
- TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
+ DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, pprFamInstLHS,
+ FamInstEqn, LFamInstEqn, FamEqn(..),
+ TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
HsTyPats,
LClsInstDecl, ClsInstDecl(..),
-- ** Standalone deriving declarations
DerivDecl(..), LDerivDecl,
+ -- ** Deriving strategies
+ DerivStrategy(..), LDerivStrategy, derivStrategyName,
-- ** @RULE@ declarations
- LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr,
+ LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, HsRuleRn(..),
+ RuleBndr(..),LRuleBndr,
collectRuleBndrSigTys,
flattenRuleDecls, pprFullRuleName,
- -- ** @VECTORISE@ declarations
- VectDecl(..), LVectDecl,
- lvectDeclName, lvectInstDecl,
-- ** @default@ declarations
DefaultDecl(..), LDefaultDecl,
-- ** Template haskell declaration splice
@@ -58,14 +59,11 @@ module HsDecls (
SpliceDecl(..), LSpliceDecl,
-- ** Foreign function interface declarations
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
- noForeignImportCoercionYet, noForeignExportCoercionYet,
CImportSpec(..),
-- ** Data-constructor declarations
ConDecl(..), LConDecl,
- HsConDeclDetails, hsConDeclArgTys,
- getConNames,
- getConDetails,
- gadtDeclDetails,
+ HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta,
+ getConNames, getConArgs,
-- ** Document comments
DocDecl(..), LDocDecl, docDeclDoc,
-- ** Deprecations
@@ -86,7 +84,9 @@ module HsDecls (
) where
-- friends:
-import {-# SOURCE #-} HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr,
+import GhcPrelude
+
+import {-# SOURCE #-} HsExpr( HsExpr, HsSplice, pprExpr,
pprSpliceDecl )
-- Because Expr imports Decls via HsBracket
@@ -94,20 +94,18 @@ import HsBinds
import HsTypes
import HsDoc
import TyCon
-import Name
import BasicTypes
import Coercion
import ForeignCall
-import PlaceHolder ( PlaceHolder(..) )
import HsExtension
import NameSet
-- others:
-import InstEnv
import Class
import Outputable
import Util
import SrcLoc
+import Type
import Bag
import Maybes
@@ -121,7 +119,7 @@ import Data.Data hiding (TyCon,Fixity, Infix)
************************************************************************
-}
-type LHsDecl id = Located (HsDecl id)
+type LHsDecl p = Located (HsDecl p)
-- ^ When in a list this may have
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
@@ -130,24 +128,37 @@ type LHsDecl id = Located (HsDecl id)
-- For details on above see note [Api annotations] in ApiAnnotation
-- | A Haskell Declaration
-data HsDecl id
- = TyClD (TyClDecl id) -- ^ Type or Class Declaration
- | InstD (InstDecl id) -- ^ Instance declaration
- | DerivD (DerivDecl id) -- ^ Deriving declaration
- | ValD (HsBind id) -- ^ Value declaration
- | SigD (Sig id) -- ^ Signature declaration
- | DefD (DefaultDecl id) -- ^ 'default' declaration
- | ForD (ForeignDecl id) -- ^ Foreign declaration
- | WarningD (WarnDecls id) -- ^ Warning declaration
- | AnnD (AnnDecl id) -- ^ Annotation declaration
- | RuleD (RuleDecls id) -- ^ Rule declaration
- | VectD (VectDecl id) -- ^ Vectorise declaration
- | SpliceD (SpliceDecl id) -- ^ Splice declaration
- -- (Includes quasi-quotes)
- | DocD (DocDecl) -- ^ Documentation comment declaration
- | RoleAnnotD (RoleAnnotDecl id) -- ^ Role annotation declaration
-deriving instance (DataId id) => Data (HsDecl id)
-
+data HsDecl p
+ = TyClD (XTyClD p) (TyClDecl p) -- ^ Type or Class Declaration
+ | InstD (XInstD p) (InstDecl p) -- ^ Instance declaration
+ | DerivD (XDerivD p) (DerivDecl p) -- ^ Deriving declaration
+ | ValD (XValD p) (HsBind p) -- ^ Value declaration
+ | SigD (XSigD p) (Sig p) -- ^ Signature declaration
+ | DefD (XDefD p) (DefaultDecl p) -- ^ 'default' declaration
+ | ForD (XForD p) (ForeignDecl p) -- ^ Foreign declaration
+ | WarningD (XWarningD p) (WarnDecls p) -- ^ Warning declaration
+ | AnnD (XAnnD p) (AnnDecl p) -- ^ Annotation declaration
+ | RuleD (XRuleD p) (RuleDecls p) -- ^ Rule declaration
+ | SpliceD (XSpliceD p) (SpliceDecl p) -- ^ Splice declaration
+ -- (Includes quasi-quotes)
+ | DocD (XDocD p) (DocDecl) -- ^ Documentation comment declaration
+ | RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration
+ | XHsDecl (XXHsDecl p)
+
+type instance XTyClD (GhcPass _) = NoExt
+type instance XInstD (GhcPass _) = NoExt
+type instance XDerivD (GhcPass _) = NoExt
+type instance XValD (GhcPass _) = NoExt
+type instance XSigD (GhcPass _) = NoExt
+type instance XDefD (GhcPass _) = NoExt
+type instance XForD (GhcPass _) = NoExt
+type instance XWarningD (GhcPass _) = NoExt
+type instance XAnnD (GhcPass _) = NoExt
+type instance XRuleD (GhcPass _) = NoExt
+type instance XSpliceD (GhcPass _) = NoExt
+type instance XDocD (GhcPass _) = NoExt
+type instance XRoleAnnotD (GhcPass _) = NoExt
+type instance XXHsDecl (GhcPass _) = NoExt
-- NB: all top-level fixity decls are contained EITHER
-- EITHER SigDs
@@ -166,50 +177,56 @@ deriving instance (DataId id) => Data (HsDecl id)
--
-- A 'HsDecl' is categorised into a 'HsGroup' before being
-- fed to the renamer.
-data HsGroup id
+data HsGroup p
= HsGroup {
- hs_valds :: HsValBinds id,
- hs_splcds :: [LSpliceDecl id],
+ hs_ext :: XCHsGroup p,
+ hs_valds :: HsValBinds p,
+ hs_splcds :: [LSpliceDecl p],
- hs_tyclds :: [TyClGroup id],
+ hs_tyclds :: [TyClGroup p],
-- A list of mutually-recursive groups;
-- This includes `InstDecl`s as well;
-- Parser generates a singleton list;
-- renamer does dependency analysis
- hs_derivds :: [LDerivDecl id],
+ hs_derivds :: [LDerivDecl p],
- hs_fixds :: [LFixitySig id],
+ hs_fixds :: [LFixitySig p],
-- Snaffled out of both top-level fixity signatures,
-- and those in class declarations
- hs_defds :: [LDefaultDecl id],
- hs_fords :: [LForeignDecl id],
- hs_warnds :: [LWarnDecls id],
- hs_annds :: [LAnnDecl id],
- hs_ruleds :: [LRuleDecls id],
- hs_vects :: [LVectDecl id],
+ hs_defds :: [LDefaultDecl p],
+ hs_fords :: [LForeignDecl p],
+ hs_warnds :: [LWarnDecls p],
+ hs_annds :: [LAnnDecl p],
+ hs_ruleds :: [LRuleDecls p],
hs_docs :: [LDocDecl]
- }
-deriving instance (DataId id) => Data (HsGroup id)
+ }
+ | XHsGroup (XXHsGroup p)
-emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
+type instance XCHsGroup (GhcPass _) = NoExt
+type instance XXHsGroup (GhcPass _) = NoExt
+
+
+emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p)
emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut }
hsGroupInstDecls :: HsGroup id -> [LInstDecl id]
hsGroupInstDecls = (=<<) group_instds . hs_tyclds
-emptyGroup = HsGroup { hs_tyclds = [],
+emptyGroup = HsGroup { hs_ext = noExt,
+ hs_tyclds = [],
hs_derivds = [],
hs_fixds = [], hs_defds = [], hs_annds = [],
- hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [],
+ hs_fords = [], hs_warnds = [], hs_ruleds = [],
hs_valds = error "emptyGroup hs_valds: Can't happen",
hs_splcds = [],
hs_docs = [] }
-appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
+appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p)
+ -> HsGroup (GhcPass p)
appendGroups
HsGroup {
hs_valds = val_groups1,
@@ -222,8 +239,7 @@ appendGroups
hs_fords = fords1,
hs_warnds = warnds1,
hs_ruleds = rulds1,
- hs_vects = vects1,
- hs_docs = docs1 }
+ hs_docs = docs1 }
HsGroup {
hs_valds = val_groups2,
hs_splcds = spliceds2,
@@ -235,10 +251,10 @@ appendGroups
hs_fords = fords2,
hs_warnds = warnds2,
hs_ruleds = rulds2,
- hs_vects = vects2,
hs_docs = docs2 }
=
HsGroup {
+ hs_ext = noExt,
hs_valds = val_groups1 `plusHsValBinds` val_groups2,
hs_splcds = spliceds1 ++ spliceds2,
hs_tyclds = tyclds1 ++ tyclds2,
@@ -249,28 +265,26 @@ appendGroups
hs_fords = fords1 ++ fords2,
hs_warnds = warnds1 ++ warnds2,
hs_ruleds = rulds1 ++ rulds2,
- hs_vects = vects1 ++ vects2,
hs_docs = docs1 ++ docs2 }
-
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsDecl pass) where
- ppr (TyClD dcl) = ppr dcl
- ppr (ValD binds) = ppr binds
- ppr (DefD def) = ppr def
- ppr (InstD inst) = ppr inst
- ppr (DerivD deriv) = ppr deriv
- ppr (ForD fd) = ppr fd
- ppr (SigD sd) = ppr sd
- ppr (RuleD rd) = ppr rd
- ppr (VectD vect) = ppr vect
- ppr (WarningD wd) = ppr wd
- ppr (AnnD ad) = ppr ad
- ppr (SpliceD dd) = ppr dd
- ppr (DocD doc) = ppr doc
- ppr (RoleAnnotD ra) = ppr ra
-
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsGroup pass) where
+appendGroups _ _ = panic "appendGroups"
+
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDecl p) where
+ ppr (TyClD _ dcl) = ppr dcl
+ ppr (ValD _ binds) = ppr binds
+ ppr (DefD _ def) = ppr def
+ ppr (InstD _ inst) = ppr inst
+ ppr (DerivD _ deriv) = ppr deriv
+ ppr (ForD _ fd) = ppr fd
+ ppr (SigD _ sd) = ppr sd
+ ppr (RuleD _ rd) = ppr rd
+ ppr (WarningD _ wd) = ppr wd
+ ppr (AnnD _ ad) = ppr ad
+ ppr (SpliceD _ dd) = ppr dd
+ ppr (DocD _ doc) = ppr doc
+ ppr (RoleAnnotD _ ra) = ppr ra
+ ppr (XHsDecl x) = ppr x
+
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsGroup p) where
ppr (HsGroup { hs_valds = val_decls,
hs_tyclds = tycl_decls,
hs_derivds = deriv_decls,
@@ -279,13 +293,11 @@ instance (SourceTextX pass, OutputableBndrId pass)
hs_annds = ann_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
- hs_ruleds = rule_decls,
- hs_vects = vect_decls })
+ hs_ruleds = rule_decls })
= vcat_mb empty
[ppr_ds fix_decls, ppr_ds default_decls,
ppr_ds deprec_decls, ppr_ds ann_decls,
ppr_ds rule_decls,
- ppr_ds vect_decls,
if isEmptyValBinds val_decls
then Nothing
else Just (ppr val_decls),
@@ -303,20 +315,26 @@ instance (SourceTextX pass, OutputableBndrId pass)
vcat_mb _ [] = empty
vcat_mb gap (Nothing : ds) = vcat_mb gap ds
vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds
+ ppr (XHsGroup x) = ppr x
-- | Located Splice Declaration
type LSpliceDecl pass = Located (SpliceDecl pass)
-- | Splice Declaration
-data SpliceDecl id
+data SpliceDecl p
= SpliceDecl -- Top level splice
- (Located (HsSplice id))
+ (XSpliceDecl p)
+ (Located (HsSplice p))
SpliceExplicitFlag
-deriving instance (DataId id) => Data (SpliceDecl id)
+ | XSpliceDecl (XXSpliceDecl p)
+
+type instance XSpliceDecl (GhcPass _) = NoExt
+type instance XXSpliceDecl (GhcPass _) = NoExt
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (SpliceDecl pass) where
- ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (SpliceDecl p) where
+ ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f
+ ppr (XSpliceDecl x) = ppr x
{-
************************************************************************
@@ -473,7 +491,7 @@ data TyClDecl pass
-- 'ApiAnnotation.AnnVbar'
-- For details on above see note [Api annotations] in ApiAnnotation
- FamDecl { tcdFam :: FamilyDecl pass }
+ FamDecl { tcdFExt :: XFamDecl pass, tcdFam :: FamilyDecl pass }
| -- | @type@ declaration
--
@@ -481,13 +499,13 @@ data TyClDecl pass
-- 'ApiAnnotation.AnnEqual',
-- For details on above see note [Api annotations] in ApiAnnotation
- SynDecl { tcdLName :: Located (IdP pass) -- ^ Type constructor
+ SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs
+ , tcdLName :: Located (IdP pass) -- ^ Type constructor
, tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an
-- associated type these
-- include outer binders
, tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration
- , tcdRhs :: LHsType pass -- ^ RHS of type declaration
- , tcdFVs :: PostRn pass NameSet }
+ , tcdRhs :: LHsType pass } -- ^ RHS of type declaration
| -- | @data@ declaration
--
@@ -498,33 +516,24 @@ data TyClDecl pass
-- 'ApiAnnotation.AnnWhere',
-- For details on above see note [Api annotations] in ApiAnnotation
- DataDecl { tcdLName :: Located (IdP pass) -- ^ Type constructor
- , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an
- -- associated type
- -- these include outer binders
- -- Eg class T a where
- -- type F a :: *
- -- type F a = a -> a
- -- Here the type decl for 'f'
- -- includes 'a' in its tcdTyVars
- , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration
- , tcdDataDefn :: HsDataDefn pass
- , tcdDataCusk :: PostRn pass Bool -- ^ does this have a CUSK?
- , tcdFVs :: PostRn pass NameSet }
-
- | ClassDecl { tcdCtxt :: LHsContext pass, -- ^ Context...
+ DataDecl { tcdDExt :: XDataDecl pass -- ^ Post renamer, CUSK flag, FVs
+ , tcdLName :: Located (IdP pass) -- ^ Type constructor
+ , tcdTyVars :: LHsQTyVars pass -- ^ Type variables
+ -- See Note [TyVar binders for associated declarations]
+ , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration
+ , tcdDataDefn :: HsDataDefn pass }
+
+ | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs
+ tcdCtxt :: LHsContext pass, -- ^ Context...
tcdLName :: Located (IdP pass), -- ^ Name of the class
tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables
tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration
- tcdFDs :: [Located (FunDep (Located (IdP pass)))],
- -- ^ Functional deps
+ tcdFDs :: [LHsFunDep pass], -- ^ Functional deps
tcdSigs :: [LSig pass], -- ^ Methods' signatures
tcdMeths :: LHsBinds pass, -- ^ Default methods
tcdATs :: [LFamilyDecl pass], -- ^ Associated types;
- tcdATDefs :: [LTyFamDefltEqn pass],
- -- ^ Associated type defaults
- tcdDocs :: [LDocDecl], -- ^ Haddock docs
- tcdFVs :: PostRn pass NameSet
+ tcdATDefs :: [LTyFamDefltEqn pass], -- ^ Associated type defaults
+ tcdDocs :: [LDocDecl] -- ^ Haddock docs
}
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass',
-- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen',
@@ -534,9 +543,51 @@ data TyClDecl pass
-- 'ApiAnnotation.AnnRarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
+ | XTyClDecl (XXTyClDecl pass)
+
+type LHsFunDep pass = Located (FunDep (Located (IdP pass)))
+
+data DataDeclRn = DataDeclRn
+ { tcdDataCusk :: Bool -- ^ does this have a CUSK?
+ , tcdFVs :: NameSet }
+ deriving Data
+
+{- Note [TyVar binders for associated decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For an /associated/ data, newtype, or type-family decl, the LHsQTyVars
+/includes/ outer binders. For example
+ class T a where
+ data D a c
+ type F a b :: *
+ type F a b = a -> a
+Here the data decl for 'D', and type-family decl for 'F', both include 'a'
+in their LHsQTyVars (tcdTyVars and fdTyVars resp).
+
+Ditto any implicit binders in the hsq_implicit field of the LHSQTyVars.
+
+The idea is that the associated type is really a top-level decl in its
+own right. However we are careful to use the same name 'a', so that
+we can match things up.
+
+c.f. Note [Associated type tyvar names] in Class.hs
+ Note [Family instance declaration binders]
+-}
+
+type instance XFamDecl (GhcPass _) = NoExt
-deriving instance (DataId id) => Data (TyClDecl id)
+type instance XSynDecl GhcPs = NoExt
+type instance XSynDecl GhcRn = NameSet -- FVs
+type instance XSynDecl GhcTc = NameSet -- FVs
+type instance XDataDecl GhcPs = NoExt
+type instance XDataDecl GhcRn = DataDeclRn
+type instance XDataDecl GhcTc = DataDeclRn
+
+type instance XClassDecl GhcPs = NoExt
+type instance XClassDecl GhcRn = NameSet -- FVs
+type instance XClassDecl GhcTc = NameSet -- FVs
+
+type instance XXTyClDecl (GhcPass _) = NoExt
-- Simple classifiers for TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -564,7 +615,7 @@ isFamilyDecl _other = False
-- | type family declaration
isTypeFamilyDecl :: TyClDecl pass -> Bool
-isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of
+isTypeFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = info })) = case info of
OpenTypeFamily -> True
ClosedTypeFamily {} -> True
_ -> False
@@ -582,7 +633,7 @@ isClosedTypeFamilyInfo _ = False
-- | data family declaration
isDataFamilyDecl :: TyClDecl pass -> Bool
-isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True
+isDataFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = DataFamily })) = True
isDataFamilyDecl _other = False
-- Dealing with names
@@ -592,8 +643,12 @@ tyFamInstDeclName = unLoc . tyFamInstDeclLName
tyFamInstDeclLName :: TyFamInstDecl pass -> Located (IdP pass)
tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
- (L _ (TyFamEqn { tfe_tycon = ln })) })
+ (HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) })
= ln
+tyFamInstDeclLName (TyFamInstDecl (HsIB _ (XFamEqn _)))
+ = panic "tyFamInstDeclLName"
+tyFamInstDeclLName (TyFamInstDecl (XHsImplicitBndrs _))
+ = panic "tyFamInstDeclLName"
tyClDeclLName :: TyClDecl pass -> Located (IdP pass)
tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln
@@ -622,7 +677,7 @@ countTyClDecls decls
isNewTy _ = False
-- | Does this declaration have a complete, user-supplied kind signature?
--- See Note [Complete user-supplied kind signatures]
+-- See Note [CUSKs: complete user-supplied kind signatures]
hsDeclHasCusk :: TyClDecl GhcRn -> Bool
hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk Nothing fam_decl
hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
@@ -630,17 +685,17 @@ hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
= hsTvbAllKinded tyvars && rhs_annotated rhs
where
rhs_annotated (L _ ty) = case ty of
- HsParTy lty -> rhs_annotated lty
- HsKindSig {} -> True
- _ -> False
-hsDeclHasCusk (DataDecl { tcdDataCusk = cusk }) = cusk
+ HsParTy _ lty -> rhs_annotated lty
+ HsKindSig {} -> True
+ _ -> False
+hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk
hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
+hsDeclHasCusk (XTyClDecl _) = panic "hsDeclHasCusk"
-- Pretty-printing TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (TyClDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where
ppr (FamDecl { tcdFam = decl }) = ppr decl
ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
@@ -670,9 +725,10 @@ instance (SourceTextX pass, OutputableBndrId pass)
top_matter = text "class"
<+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context)
<+> pprFundeps (map unLoc fds)
+ ppr (XTyClDecl x) = ppr x
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (TyClGroup pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (TyClGroup p) where
ppr (TyClGroup { group_tyclds = tyclds
, group_roles = roles
, group_instds = instds
@@ -681,62 +737,121 @@ instance (SourceTextX pass, OutputableBndrId pass)
= ppr tyclds $$
ppr roles $$
ppr instds
+ ppr (XTyClGroup x) = ppr x
-pp_vanilla_decl_head :: (SourceTextX pass, OutputableBndrId pass)
- => Located (IdP pass)
- -> LHsQTyVars pass
+pp_vanilla_decl_head :: (OutputableBndrId (GhcPass p))
+ => Located (IdP (GhcPass p))
+ -> LHsQTyVars (GhcPass p)
-> LexicalFixity
- -> HsContext pass
+ -> HsContext (GhcPass p)
-> SDoc
pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context
= hsep [pprHsContext context, pp_tyvars tyvars]
where
pp_tyvars (varl:varsr)
+ | fixity == Infix && length varsr > 1
+ = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing)
+ , (ppr.unLoc) (head varsr), char ')'
+ , hsep (map (ppr.unLoc) (tail varsr))]
| fixity == Infix
= hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing)
, hsep (map (ppr.unLoc) varsr)]
| otherwise = hsep [ pprPrefixOcc (unLoc thing)
, hsep (map (ppr.unLoc) (varl:varsr))]
- pp_tyvars [] = ppr thing
+ pp_tyvars [] = pprPrefixOcc (unLoc thing)
+pp_vanilla_decl_head _ (XLHsQTyVars x) _ _ = ppr x
-pprTyClDeclFlavour :: TyClDecl a -> SDoc
+pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc
pprTyClDeclFlavour (ClassDecl {}) = text "class"
pprTyClDeclFlavour (SynDecl {}) = text "type"
pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})
= pprFlavour info <+> text "family"
+pprTyClDeclFlavour (FamDecl { tcdFam = XFamilyDecl x})
+ = ppr x
pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
= ppr nd
+pprTyClDeclFlavour (DataDecl { tcdDataDefn = XHsDataDefn x })
+ = ppr x
+pprTyClDeclFlavour (XTyClDecl x) = ppr x
-{- Note [Complete user-supplied kind signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [CUSKs: complete user-supplied kind signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We kind-check declarations differently if they have a complete, user-supplied
kind signature (CUSK). This is because we can safely generalise a CUSKed
declaration before checking all of the others, supporting polymorphic recursion.
See ghc.haskell.org/trac/ghc/wiki/GhcKinds/KindInference#Proposednewstrategy
and #9200 for lots of discussion of how we got here.
-A declaration has a CUSK if we can know its complete kind without doing any
-inference, at all. Here are the rules:
-
- - A class or datatype is said to have a CUSK if and only if all of its type
-variables are annotated. Its result kind is, by construction, Constraint or *
-respectively.
-
- - A type synonym has a CUSK if and only if all of its type variables and its
-RHS are annotated with kinds.
-
- - A closed type family is said to have a CUSK if and only if all of its type
-variables and its return type are annotated.
-
- - An open type family always has a CUSK -- unannotated type variables (and
-return type) default to *.
-
- - Additionally, if -XTypeInType is on, then a data definition with a top-level
- :: must explicitly bind all kind variables to the right of the ::.
- See test dependent/should_compile/KindLevels, which requires this case.
- (Naturally, any kind variable mentioned before the :: should not be bound
- after it.)
+PRINCIPLE:
+ a type declaration has a CUSK iff we could produce a separate kind signature
+ for it, just like a type signature for a function,
+ looking only at the header of the declaration.
+
+Examples:
+ * data T1 (a :: *->*) (b :: *) = ....
+ -- Has CUSK; equivalant to T1 :: (*->*) -> * -> *
+
+ * data T2 a b = ...
+ -- No CUSK; we do not want to guess T2 :: * -> * -> *
+ -- becuase the full decl might be data T a b = MkT (a b)
+
+ * data T3 (a :: k -> *) (b :: *) = ...
+ -- CUSK; equivalent to T3 :: (k -> *) -> * -> *
+ -- We lexically generalise over k to get
+ -- T3 :: forall k. (k -> *) -> * -> *
+ -- The generalisation is here is purely lexical, just like
+ -- f3 :: a -> a
+ -- means
+ -- f3 :: forall a. a -> a
+
+ * data T4 (a :: j k) = ...
+ -- CUSK; equivalent to T4 :: j k -> *
+ -- which we lexically generalise to T4 :: forall j k. j k -> *
+ -- and then, if PolyKinds is on, we further generalise to
+ -- T4 :: forall kk (j :: kk -> *) (k :: kk). j k -> *
+ -- Again this is exactly like what happens as the term level
+ -- when you write
+ -- f4 :: forall a b. a b -> Int
+
+NOTE THAT
+ * A CUSK does /not/ mean that everything about the kind signature is
+ fully specified by the user. Look at T4 and f4: we had do do kind
+ inference to figure out the kind-quantification. But in both cases
+ (T4 and f4) that inference is done looking /only/ at the header of T4
+ (or signature for f4), not at the definition thereof.
+
+ * The CUSK completely fixes the kind of the type constructor, forever.
+
+ * The precise rules, for each declaration form, for whethher a declaration
+ has a CUSK are given in the user manual section "Complete user-supplied
+ kind signatures and polymorphic recursion". BUt they simply implement
+ PRINCIPLE above.
+
+ * Open type families are interesting:
+ type family T5 a b :: *
+ There simply /is/ no accompanying declaration, so that info is all
+ we'll ever get. So we it has a CUSK by definition, and we default
+ any un-fixed kind variables to *.
+
+ * Associated types are a bit tricker:
+ class C6 a where
+ type family T6 a b :: *
+ op :: a Int -> Int
+ Here C6 does not have a CUSK (in fact we ultimately discover that
+ a :: * -> *). And hence neither does T6, the associated family,
+ because we can't fix its kind until we have settled C6. Another
+ way to say it: unlike a top-level, we /may/ discover more about
+ a's kind from C6's definition.
+
+ * A data definition with a top-level :: must explicitly bind all
+ kind variables to the right of the ::. See test
+ dependent/should_compile/KindLevels, which requires this
+ case. (Naturally, any kind variable mentioned before the :: should
+ not be bound after it.)
+
+ This last point is much more debatable than the others; see
+ Trac #15142 comment:22
-}
@@ -773,13 +888,18 @@ in RnSource for more info.
-- | Type or Class Group
data TyClGroup pass -- See Note [TyClGroups and dependency analysis]
- = TyClGroup { group_tyclds :: [LTyClDecl pass]
+ = TyClGroup { group_ext :: XCTyClGroup pass
+ , group_tyclds :: [LTyClDecl pass]
, group_roles :: [LRoleAnnotDecl pass]
, group_instds :: [LInstDecl pass] }
-deriving instance (DataId id) => Data (TyClGroup id)
+ | XTyClGroup (XXTyClGroup pass)
-emptyTyClGroup :: TyClGroup pass
-emptyTyClGroup = TyClGroup [] [] []
+type instance XCTyClGroup (GhcPass _) = NoExt
+type instance XXTyClGroup (GhcPass _) = NoExt
+
+
+emptyTyClGroup :: TyClGroup (GhcPass p)
+emptyTyClGroup = TyClGroup noExt [] [] []
tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass]
tyClGroupTyClDecls = concatMap group_tyclds
@@ -790,9 +910,11 @@ tyClGroupInstDecls = concatMap group_instds
tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass]
tyClGroupRoleDecls = concatMap group_roles
-mkTyClGroup :: [LTyClDecl pass] -> [LInstDecl pass] -> TyClGroup pass
+mkTyClGroup :: [LTyClDecl (GhcPass p)] -> [LInstDecl (GhcPass p)]
+ -> TyClGroup (GhcPass p)
mkTyClGroup decls instds = TyClGroup
- { group_tyclds = decls
+ { group_ext = noExt
+ , group_tyclds = decls
, group_roles = []
, group_instds = instds
}
@@ -873,39 +995,47 @@ type LFamilyResultSig pass = Located (FamilyResultSig pass)
-- | type Family Result Signature
data FamilyResultSig pass = -- see Note [FamilyResultSig]
- NoSig
+ NoSig (XNoSig pass)
-- ^ - 'ApiAnnotation.AnnKeywordId' :
-- For details on above see note [Api annotations] in ApiAnnotation
- | KindSig (LHsKind pass)
+ | KindSig (XCKindSig pass) (LHsKind pass)
-- ^ - 'ApiAnnotation.AnnKeywordId' :
-- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon',
-- 'ApiAnnotation.AnnCloseP'
-- For details on above see note [Api annotations] in ApiAnnotation
- | TyVarSig (LHsTyVarBndr pass)
+ | TyVarSig (XTyVarSig pass) (LHsTyVarBndr pass)
-- ^ - 'ApiAnnotation.AnnKeywordId' :
-- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon',
-- 'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual'
+ | XFamilyResultSig (XXFamilyResultSig pass)
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (FamilyResultSig pass)
+type instance XNoSig (GhcPass _) = NoExt
+type instance XCKindSig (GhcPass _) = NoExt
+type instance XTyVarSig (GhcPass _) = NoExt
+type instance XXFamilyResultSig (GhcPass _) = NoExt
+
-- | Located type Family Declaration
type LFamilyDecl pass = Located (FamilyDecl pass)
-- | type Family Declaration
data FamilyDecl pass = FamilyDecl
- { fdInfo :: FamilyInfo pass -- type/data, closed/open
+ { fdExt :: XCFamilyDecl pass
+ , fdInfo :: FamilyInfo pass -- type/data, closed/open
, fdLName :: Located (IdP pass) -- type constructor
, fdTyVars :: LHsQTyVars pass -- type variables
- , fdFixity :: LexicalFixity -- Fixity used in the declaration
+ -- See Note [TyVar binders for associated declarations]
+ , fdFixity :: LexicalFixity -- Fixity used in the declaration
, fdResultSig :: LFamilyResultSig pass -- result signature
, fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann
}
+ | XFamilyDecl (XXFamilyDecl pass)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
-- 'ApiAnnotation.AnnData', 'ApiAnnotation.AnnFamily',
-- 'ApiAnnotation.AnnWhere', 'ApiAnnotation.AnnOpenP',
@@ -915,7 +1045,9 @@ data FamilyDecl pass = FamilyDecl
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId id) => Data (FamilyDecl id)
+type instance XCFamilyDecl (GhcPass _) = NoExt
+type instance XXFamilyDecl (GhcPass _) = NoExt
+
-- | Located Injectivity Annotation
type LInjectivityAnn pass = Located (InjectivityAnn pass)
@@ -934,7 +1066,6 @@ data InjectivityAnn pass
-- 'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (InjectivityAnn pass)
data FamilyInfo pass
= DataFamily
@@ -942,9 +1073,9 @@ data FamilyInfo pass
-- | 'Nothing' if we're in an hs-boot file and the user
-- said "type family Foo x where .."
| ClosedTypeFamily (Maybe [LTyFamInstEqn pass])
-deriving instance (DataId pass) => Data (FamilyInfo pass)
-- | Does this family declaration have a complete, user-supplied kind signature?
+-- See Note [CUSKs: complete user-supplied kind signatures]
famDeclHasCusk :: Maybe Bool
-- ^ if associated, does the enclosing class have a CUSK?
-> FamilyDecl pass -> Bool
@@ -953,25 +1084,25 @@ famDeclHasCusk _ (FamilyDecl { fdInfo = ClosedTypeFamily _
, fdResultSig = L _ resultSig })
= hsTvbAllKinded tyvars && hasReturnKindSignature resultSig
famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True
- -- all un-associated open families have CUSKs!
+ -- all un-associated open families have CUSKs
-- | Does this family declaration have user-supplied return kind signature?
hasReturnKindSignature :: FamilyResultSig a -> Bool
-hasReturnKindSignature NoSig = False
-hasReturnKindSignature (TyVarSig (L _ (UserTyVar _))) = False
-hasReturnKindSignature _ = True
+hasReturnKindSignature (NoSig _) = False
+hasReturnKindSignature (TyVarSig _ (L _ (UserTyVar{}))) = False
+hasReturnKindSignature _ = True
-- | Maybe return name of the result type variable
resultVariableName :: FamilyResultSig a -> Maybe (IdP a)
-resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig
-resultVariableName _ = Nothing
+resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig
+resultVariableName _ = Nothing
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (FamilyDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (FamilyDecl p) where
ppr = pprFamilyDecl TopLevel
-pprFamilyDecl :: (SourceTextX pass, OutputableBndrId pass)
- => TopLevelFlag -> FamilyDecl pass -> SDoc
+pprFamilyDecl :: (OutputableBndrId (GhcPass p))
+ => TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc
pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
, fdTyVars = tyvars
, fdFixity = fixity
@@ -987,9 +1118,10 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
NotTopLevel -> empty
pp_kind = case result of
- NoSig -> empty
- KindSig kind -> dcolon <+> ppr kind
- TyVarSig tv_bndr -> text "=" <+> ppr tv_bndr
+ NoSig _ -> empty
+ KindSig _ kind -> dcolon <+> ppr kind
+ TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr
+ XFamilyResultSig x -> ppr x
pp_inj = case mb_inj of
Just (L _ (InjectivityAnn lhs rhs)) ->
hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]
@@ -999,8 +1131,9 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
( text "where"
, case mb_eqns of
Nothing -> text ".."
- Just eqns -> vcat $ map ppr_fam_inst_eqn eqns )
+ Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns )
_ -> (empty, empty)
+pprFamilyDecl _ (XFamilyDecl x) = ppr x
pprFlavour :: FamilyInfo pass -> SDoc
pprFlavour DataFamily = text "data"
@@ -1027,7 +1160,8 @@ data HsDataDefn pass -- The payload of a data type defn
-- data/newtype T a = <constrs>
-- data/newtype instance T [a] = <constrs>
-- @
- HsDataDefn { dd_ND :: NewOrData,
+ HsDataDefn { dd_ext :: XCHsDataDefn pass,
+ dd_ND :: NewOrData,
dd_ctxt :: LHsContext pass, -- ^ Context
dd_cType :: Maybe (Located CType),
dd_kindSig:: Maybe (LHsKind pass),
@@ -1050,7 +1184,10 @@ data HsDataDefn pass -- The payload of a data type defn
-- For details on above see note [Api annotations] in ApiAnnotation
}
-deriving instance (DataId id) => Data (HsDataDefn id)
+ | XHsDataDefn (XXHsDataDefn pass)
+
+type instance XCHsDataDefn (GhcPass _) = NoExt
+type instance XXHsDataDefn (GhcPass _) = NoExt
-- | Haskell Deriving clause
type HsDeriving pass = Located [LHsDerivingClause pass]
@@ -1073,7 +1210,8 @@ type LHsDerivingClause pass = Located (HsDerivingClause pass)
data HsDerivingClause pass
-- See Note [Deriving strategies] in TcDeriv
= HsDerivingClause
- { deriv_clause_strategy :: Maybe (Located DerivStrategy)
+ { deriv_clause_ext :: XCHsDerivingClause pass
+ , deriv_clause_strategy :: Maybe (LDerivStrategy pass)
-- ^ The user-specified strategy (if any) to use when deriving
-- 'deriv_clause_tys'.
, deriv_clause_tys :: Located [LHsSigType pass]
@@ -1086,28 +1224,45 @@ data HsDerivingClause pass
--
-- should produce a derived instance for @C [a] (T b)@.
}
-deriving instance (DataId id) => Data (HsDerivingClause id)
+ | XHsDerivingClause (XXHsDerivingClause pass)
+
+type instance XCHsDerivingClause (GhcPass _) = NoExt
+type instance XXHsDerivingClause (GhcPass _) = NoExt
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsDerivingClause pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (HsDerivingClause p) where
ppr (HsDerivingClause { deriv_clause_strategy = dcs
, deriv_clause_tys = L _ dct })
= hsep [ text "deriving"
- , ppDerivStrategy dcs
- , pp_dct dct ]
+ , pp_strat_before
+ , pp_dct dct
+ , pp_strat_after ]
where
-- This complexity is to distinguish between
-- deriving Show
-- deriving (Show)
- pp_dct [a@(HsIB { hsib_body = L _ HsAppsTy{} })] = parens (ppr a)
- pp_dct [a] = ppr a
- pp_dct _ = parens (interpp'SP dct)
+ pp_dct [HsIB { hsib_body = ty }]
+ = ppr (parenthesizeHsType appPrec ty)
+ pp_dct _ = parens (interpp'SP dct)
+
+ -- @via@ is unique in that in comes /after/ the class being derived,
+ -- so we must special-case it.
+ (pp_strat_before, pp_strat_after) =
+ case dcs of
+ Just (L _ via@ViaStrategy{}) -> (empty, ppr via)
+ _ -> (ppDerivStrategy dcs, empty)
+ ppr (XHsDerivingClause x) = ppr x
data NewOrData
= NewType -- ^ @newtype Blah ...@
| DataType -- ^ @data Blah ...@
deriving( Eq, Data ) -- Needed because Demand derives Eq
+-- | Convert a 'NewOrData' to a 'TyConFlavour'
+newOrDataToFlavour :: NewOrData -> TyConFlavour
+newOrDataToFlavour NewType = NewtypeFlavour
+newOrDataToFlavour DataType = DataTypeFlavour
+
-- | Located data Constructor Declaration
type LConDecl pass = Located (ConDecl pass)
-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when
@@ -1142,33 +1297,85 @@ type LConDecl pass = Located (ConDecl pass)
-- | data Constructor Declaration
data ConDecl pass
= ConDeclGADT
- { con_names :: [Located (IdP pass)]
- , con_type :: LHsSigType pass
- -- ^ The type after the ‘::’
+ { con_g_ext :: XConDeclGADT pass
+ , con_names :: [Located (IdP pass)]
+
+ -- The next four fields describe the type after the '::'
+ -- See Note [GADT abstract syntax]
+ -- The following field is Located to anchor API Annotations,
+ -- AnnForall and AnnDot.
+ , con_forall :: Located 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.
}
| ConDeclH98
- { con_name :: Located (IdP pass)
-
- , con_qvars :: Maybe (LHsQTyVars pass)
- -- 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}
-
- , con_cxt :: Maybe (LHsContext pass)
- -- ^ User-written context (if any)
-
- , con_details :: HsConDeclDetails pass
- -- ^ Arguments
+ { con_ext :: XConDeclH98 pass
+ , con_name :: Located (IdP pass)
+
+ , con_forall :: Located Bool
+ -- ^ True <=> explicit user-written forall
+ -- e.g. data T a = forall b. MkT b (b->a)
+ -- 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)
+ | XConDecl (XXConDecl pass)
+
+type instance XConDeclGADT (GhcPass _) = NoExt
+type instance XConDeclH98 (GhcPass _) = NoExt
+type instance XXConDecl (GhcPass _) = NoExt
+
+{- 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
@@ -1177,37 +1384,23 @@ type HsConDeclDetails pass
getConNames :: ConDecl pass -> [Located (IdP pass)]
getConNames ConDeclH98 {con_name = name} = [name]
getConNames ConDeclGADT {con_names = names} = names
+getConNames XConDecl {} = panic "getConNames"
--- 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 :: (OutputableBndrId (GhcPass p))
+ => (HsContext (GhcPass p) -> SDoc) -- Printing the header
+ -> HsDataDefn (GhcPass p)
-> SDoc
pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
, dd_cType = mb_ct
@@ -1228,48 +1421,57 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
Nothing -> empty
Just kind -> dcolon <+> ppr kind
pp_derivings (L _ ds) = vcat (map ppr ds)
+pp_data_defn _ (XHsDataDefn x) = ppr x
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsDataDefn pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (HsDataDefn p) where
ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d
instance Outputable NewOrData where
ppr NewType = text "newtype"
ppr DataType = text "data"
-pp_condecls :: (SourceTextX pass, OutputableBndrId pass)
- => [LConDecl pass] -> SDoc
+pp_condecls :: (OutputableBndrId (GhcPass p)) => [LConDecl (GhcPass p)] -> SDoc
pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax
= hang (text "where") 2 (vcat (map ppr cs))
pp_condecls cs -- In H98 syntax
= equals <+> sep (punctuate (text " |") (map ppr cs))
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (ConDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ConDecl p) where
ppr = pprConDecl
-pprConDecl :: (SourceTextX pass, OutputableBndrId pass) => ConDecl pass -> SDoc
+pprConDecl :: (OutputableBndrId (GhcPass p)) => ConDecl (GhcPass p) -> 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
+
+pprConDecl (XConDecl x) = ppr x
ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc
ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
@@ -1283,27 +1485,35 @@ ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
Note [Type family instance declarations in HsSyn]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The data type TyFamEqn represents one equation of a type family instance.
-It is parameterised over its tfe_pats field:
+The data type FamEqn represents one equation of a type family instance.
+Aside from the pass, it is also parameterised over two fields:
+feqn_pats and feqn_rhs.
+
+feqn_pats is either LHsTypes (for ordinary data/type family instances) or
+LHsQTyVars (for associated type family default instances). In particular:
* An ordinary type family instance declaration looks like this in source Haskell
type instance T [a] Int = a -> a
(or something similar for a closed family)
- It is represented by a TyFamInstEqn, with *type* in the tfe_pats field.
+ It is represented by a FamInstEqn, with a *type* (LHsType) in the feqn_pats
+ field.
* On the other hand, the *default instance* of an associated type looks like
this in source Haskell
class C a where
type T a b
type T a b = a -> b -- The default instance
- It is represented by a TyFamDefltEqn, with *type variables* in the tfe_pats
- field.
+ It is represented by a TyFamDefltEqn, with *type variables* (LHsQTyVars) in
+ the feqn_pats field.
+
+feqn_rhs is either an HsDataDefn (for data family instances) or an LHsType
+(for type family instances).
-}
----------------- Type synonym family instances -------------
-- | Located Type Family Instance Equation
-type LTyFamInstEqn pass = Located (TyFamInstEqn pass)
+type LTyFamInstEqn pass = Located (TyFamInstEqn pass)
-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
-- when in a list
@@ -1313,16 +1523,14 @@ type LTyFamInstEqn pass = Located (TyFamInstEqn pass)
type LTyFamDefltEqn pass = Located (TyFamDefltEqn pass)
-- | Haskell Type Patterns
-type HsTyPats pass = HsImplicitBndrs pass [LHsType pass]
- -- ^ Type patterns (with kind and type bndrs)
- -- See Note [Family instance declaration binders]
+type HsTyPats pass = [LHsType pass]
{- Note [Family instance declaration binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The HsTyPats field is LHS patterns or a type/data family instance.
-
-The hsib_vars of the HsImplicitBndrs are the template variables of the
-type patterns, i.e. fv(pat_tys). Note in particular
+For ordinary data/type family instances, the feqn_pats field of FamEqn stores
+the LHS type (and kind) patterns. These type patterns can of course contain
+type (and kind) variables, which are bound in the hsib_vars field of the
+HsImplicitBndrs in FamInstEqn. Note in particular
* The hsib_vars *includes* any anonymous wildcards. For example
type instance F a _ = a
@@ -1330,7 +1538,7 @@ type patterns, i.e. fv(pat_tys). Note in particular
'_' gets its own unique. In this context wildcards behave just like
an ordinary type variable, only anonymous.
-* The hsib_vars *including* type variables that are already in scope
+* The hsib_vars *includes* type variables that are already in scope
Eg class C s t where
type F t p :: *
@@ -1344,45 +1552,31 @@ type patterns, i.e. fv(pat_tys). Note in particular
type F (a8,b9) x10 = x10->a8
so that we can compare the type pattern in the 'instance' decl and
in the associated 'type' decl
+
+For associated type family default instances (TyFamDefltEqn), instead of using
+type patterns with binders in a surrounding HsImplicitBndrs, we use raw type
+variables (LHsQTyVars) in the feqn_pats field of FamEqn.
+
+c.f. Note [TyVar binders for associated declarations]
-}
-- | Type Family Instance Equation
-type TyFamInstEqn pass = TyFamEqn pass (HsTyPats pass)
+type TyFamInstEqn pass = FamInstEqn pass (LHsType pass)
-- | Type Family Default Equation
-type TyFamDefltEqn pass = TyFamEqn pass (LHsQTyVars pass)
+type TyFamDefltEqn pass = FamEqn pass (LHsQTyVars pass) (LHsType pass)
-- See Note [Type family instance declarations in HsSyn]
--- | Type Family Equation
---
--- One equation in a type family instance declaration
--- See Note [Type family instance declarations in HsSyn]
-data TyFamEqn pass pats
- = TyFamEqn
- { tfe_tycon :: Located (IdP pass)
- , tfe_pats :: pats
- , tfe_fixity :: LexicalFixity -- ^ Fixity used in the declaration
- , tfe_rhs :: LHsType pass }
- -- ^
- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
-
- -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass, Data pats) => Data (TyFamEqn pass pats)
-
-- | Located Type Family Instance Declaration
type LTyFamInstDecl pass = Located (TyFamInstDecl pass)
-- | Type Family Instance Declaration
-data TyFamInstDecl pass
- = TyFamInstDecl
- { tfid_eqn :: LTyFamInstEqn pass
- , tfid_fvs :: PostRn pass NameSet }
+newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
-- ^
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
-- 'ApiAnnotation.AnnInstance',
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (TyFamInstDecl pass)
----------------- Data family instances -------------
@@ -1390,14 +1584,8 @@ deriving instance (DataId pass) => Data (TyFamInstDecl pass)
type LDataFamInstDecl pass = Located (DataFamInstDecl pass)
-- | Data Family Instance Declaration
-data DataFamInstDecl pass
- = DataFamInstDecl
- { dfid_tycon :: Located (IdP pass)
- , dfid_pats :: HsTyPats pass -- LHS
- , dfid_fixity :: LexicalFixity -- ^ Fixity used in the declaration
- , dfid_defn :: HsDataDefn pass -- RHS
- , dfid_fvs :: PostRn pass NameSet }
- -- Free vars for dependency analysis
+newtype DataFamInstDecl pass
+ = DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) }
-- ^
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
-- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance',
@@ -1406,8 +1594,40 @@ data DataFamInstDecl pass
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (DataFamInstDecl pass)
+----------------- Family instances (common types) -------------
+
+-- | Located Family Instance Equation
+type LFamInstEqn pass rhs = Located (FamInstEqn pass rhs)
+
+-- | Family Instance Equation
+type FamInstEqn pass rhs
+ = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs)
+ -- ^ Here, the @pats@ are type patterns (with kind and type bndrs).
+ -- See Note [Family instance declaration binders]
+
+-- | Family Equation
+--
+-- One equation in a type family instance declaration, data family instance
+-- declaration, or type family default.
+-- See Note [Type family instance declarations in HsSyn]
+-- See Note [Family instance declaration binders]
+data FamEqn pass pats rhs
+ = FamEqn
+ { feqn_ext :: XCFamEqn pass pats rhs
+ , feqn_tycon :: Located (IdP pass)
+ , feqn_pats :: pats
+ , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration
+ , feqn_rhs :: rhs
+ }
+ -- ^
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
+ | XFamEqn (XXFamEqn pass pats rhs)
+
+ -- For details on above see note [Api annotations] in ApiAnnotation
+
+type instance XCFamEqn (GhcPass _) p r = NoExt
+type instance XXFamEqn (GhcPass _) p r = NoExt
----------------- Class instances -------------
@@ -1417,7 +1637,8 @@ type LClsInstDecl pass = Located (ClsInstDecl pass)
-- | Class Instance Declaration
data ClsInstDecl pass
= ClsInstDecl
- { cid_poly_ty :: LHsSigType pass -- Context => Class Instance-type
+ { cid_ext :: XCClsInstDecl pass
+ , cid_poly_ty :: LHsSigType pass -- Context => Class Instance-type
-- Using a polytype means that the renamer conveniently
-- figures out the quantified type variables for us.
, cid_binds :: LHsBinds pass -- Class methods
@@ -1436,8 +1657,10 @@ data ClsInstDecl pass
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId id) => Data (ClsInstDecl id)
+ | XClsInstDecl (XXClsInstDecl pass)
+type instance XCClsInstDecl (GhcPass _) = NoExt
+type instance XXClsInstDecl (GhcPass _) = NoExt
----------------- Instances of all kinds -------------
@@ -1447,19 +1670,27 @@ type LInstDecl pass = Located (InstDecl pass)
-- | Instance Declaration
data InstDecl pass -- Both class and family instances
= ClsInstD
- { cid_inst :: ClsInstDecl pass }
+ { cid_d_ext :: XClsInstD pass
+ , cid_inst :: ClsInstDecl pass }
| DataFamInstD -- data family instance
- { dfid_inst :: DataFamInstDecl pass }
+ { dfid_ext :: XDataFamInstD pass
+ , dfid_inst :: DataFamInstDecl pass }
| TyFamInstD -- type family instance
- { tfid_inst :: TyFamInstDecl pass }
-deriving instance (DataId id) => Data (InstDecl id)
+ { tfid_ext :: XTyFamInstD pass
+ , tfid_inst :: TyFamInstDecl pass }
+ | XInstDecl (XXInstDecl pass)
+
+type instance XClsInstD (GhcPass _) = NoExt
+type instance XDataFamInstD (GhcPass _) = NoExt
+type instance XTyFamInstD (GhcPass _) = NoExt
+type instance XXInstDecl (GhcPass _) = NoExt
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (TyFamInstDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (TyFamInstDecl p) where
ppr = pprTyFamInstDecl TopLevel
-pprTyFamInstDecl :: (SourceTextX pass, OutputableBndrId pass)
- => TopLevelFlag -> TyFamInstDecl pass -> SDoc
+pprTyFamInstDecl :: (OutputableBndrId (GhcPass p))
+ => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc
pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })
= text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn
@@ -1467,51 +1698,71 @@ ppr_instance_keyword :: TopLevelFlag -> SDoc
ppr_instance_keyword TopLevel = text "instance"
ppr_instance_keyword NotTopLevel = empty
-ppr_fam_inst_eqn :: (SourceTextX pass, OutputableBndrId pass)
- => LTyFamInstEqn pass -> SDoc
-ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon
- , tfe_pats = pats
- , tfe_fixity = fixity
- , tfe_rhs = rhs }))
- = pp_fam_inst_lhs tycon pats fixity [] <+> equals <+> ppr rhs
-
-ppr_fam_deflt_eqn :: (SourceTextX pass, OutputableBndrId pass)
- => LTyFamDefltEqn pass -> SDoc
-ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon
- , tfe_pats = tvs
- , tfe_fixity = fixity
- , tfe_rhs = rhs }))
+ppr_fam_inst_eqn :: (OutputableBndrId (GhcPass p))
+ => TyFamInstEqn (GhcPass p) -> SDoc
+ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = tycon
+ , feqn_pats = pats
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs }})
+ = pprFamInstLHS tycon pats fixity [] Nothing <+> equals <+> ppr rhs
+ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x
+ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x
+
+ppr_fam_deflt_eqn :: (OutputableBndrId (GhcPass p))
+ => LTyFamDefltEqn (GhcPass p) -> SDoc
+ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon
+ , feqn_pats = tvs
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs }))
= text "type" <+> pp_vanilla_decl_head tycon tvs fixity []
<+> equals <+> ppr rhs
+ppr_fam_deflt_eqn (L _ (XFamEqn x)) = ppr x
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (DataFamInstDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (DataFamInstDecl p) where
ppr = pprDataFamInstDecl TopLevel
-pprDataFamInstDecl :: (SourceTextX pass, OutputableBndrId pass)
- => TopLevelFlag -> DataFamInstDecl pass -> SDoc
-pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_tycon = tycon
- , dfid_pats = pats
- , dfid_fixity = fixity
- , dfid_defn = defn })
+pprDataFamInstDecl :: (OutputableBndrId (GhcPass p))
+ => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc
+pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+ FamEqn { feqn_tycon = tycon
+ , feqn_pats = pats
+ , feqn_fixity = fixity
+ , feqn_rhs = defn }}})
= pp_data_defn pp_hdr defn
where
pp_hdr ctxt = ppr_instance_keyword top_lvl
- <+> pp_fam_inst_lhs tycon pats fixity ctxt
-
-pprDataFamInstFlavour :: DataFamInstDecl pass -> SDoc
-pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) })
+ <+> pprFamInstLHS tycon pats fixity ctxt Nothing
+ -- No need to pass an explicit kind signature to
+ -- pprFamInstLHS here, since pp_data_defn already
+ -- pretty-prints that. See #14817.
+pprDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn x)))
+ = ppr x
+pprDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs x))
+ = ppr x
+
+pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc
+pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+ FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}})
= ppr nd
-
-pp_fam_inst_lhs :: (SourceTextX pass, OutputableBndrId pass)
- => Located (IdP pass)
- -> HsTyPats pass
+pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+ FamEqn { feqn_rhs = XHsDataDefn x}}})
+ = ppr x
+pprDataFamInstFlavour (DataFamInstDecl (HsIB _ (XFamEqn x)))
+ = ppr x
+pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x))
+ = ppr x
+
+pprFamInstLHS :: (OutputableBndrId (GhcPass p))
+ => Located (IdP (GhcPass p))
+ -> HsTyPats (GhcPass p)
-> LexicalFixity
- -> HsContext pass
+ -> HsContext (GhcPass p)
+ -> Maybe (LHsKind (GhcPass p))
-> SDoc
-pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) fixity context
+pprFamInstLHS thing typats fixity context mb_kind_sig
-- explicit type patterns
- = hsep [ pprHsContext context, pp_pats typats]
+ = hsep [ pprHsContext context, pp_pats typats, pp_kind_sig ]
where
pp_pats (patl:patsr)
| fixity == Infix
@@ -1519,10 +1770,16 @@ pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) fixity context
, hsep (map (pprHsType.unLoc) patsr)]
| otherwise = hsep [ pprPrefixOcc (unLoc thing)
, hsep (map (pprHsType.unLoc) (patl:patsr))]
- pp_pats [] = empty
+ pp_pats [] = pprPrefixOcc (unLoc thing)
+
+ pp_kind_sig
+ | Just k <- mb_kind_sig
+ = dcolon <+> ppr k
+ | otherwise
+ = empty
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (ClsInstDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (ClsInstDecl p) where
ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
, cid_sigs = sigs, cid_tyfam_insts = ats
, cid_overlap_mode = mbOverlap
@@ -1539,8 +1796,10 @@ instance (SourceTextX pass, OutputableBndrId pass)
where
top_matter = text "instance" <+> ppOverlapPragma mbOverlap
<+> ppr inst_ty
+ ppr (XClsInstDecl x) = ppr x
-ppDerivStrategy :: Maybe (Located DerivStrategy) -> SDoc
+ppDerivStrategy :: (p ~ GhcPass pass, OutputableBndrId p)
+ => Maybe (LDerivStrategy p) -> SDoc
ppDerivStrategy mb =
case mb of
Nothing -> empty
@@ -1560,11 +1819,11 @@ ppOverlapPragma mb =
maybe_stext (SourceText src) _ = text src <+> text "#-}"
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (InstDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (InstDecl p) where
ppr (ClsInstD { cid_inst = decl }) = ppr decl
ppr (TyFamInstD { tfid_inst = decl }) = ppr decl
ppr (DataFamInstD { dfid_inst = decl }) = ppr decl
+ ppr (XInstDecl x) = ppr x
-- Extract the declarations of associated data types from an instance
@@ -1576,6 +1835,8 @@ instDeclDataFamInsts inst_decls
= map unLoc fam_insts
do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst]
do_one (L _ (TyFamInstD {})) = []
+ do_one (L _ (ClsInstD _ (XClsInstDecl _))) = panic "instDeclDataFamInsts"
+ do_one (L _ (XInstDecl _)) = panic "instDeclDataFamInsts"
{-
************************************************************************
@@ -1585,13 +1846,25 @@ instDeclDataFamInsts inst_decls
************************************************************************
-}
--- | Located Deriving Declaration
+-- | Located stand-alone 'deriving instance' declaration
type LDerivDecl pass = Located (DerivDecl pass)
--- | Deriving Declaration
+-- | Stand-alone 'deriving instance' declaration
data DerivDecl pass = DerivDecl
- { deriv_type :: LHsSigType pass
- , deriv_strategy :: Maybe (Located DerivStrategy)
+ { deriv_ext :: XCDerivDecl pass
+ , deriv_type :: LHsSigWcType pass
+ -- ^ The instance type to derive.
+ --
+ -- It uses an 'LHsSigWcType' because the context is allowed to be a
+ -- single wildcard:
+ --
+ -- > deriving instance _ => Eq (Foo a)
+ --
+ -- Which signifies that the context should be inferred.
+
+ -- See Note [Inferring the instance context] in TcDerivInfer.
+
+ , deriv_strategy :: Maybe (LDerivStrategy pass)
, deriv_overlap_mode :: Maybe (Located OverlapMode)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving',
-- 'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock',
@@ -1600,10 +1873,13 @@ data DerivDecl pass = DerivDecl
-- For details on above see note [Api annotations] in ApiAnnotation
}
-deriving instance (DataId pass) => Data (DerivDecl pass)
+ | XDerivDecl (XXDerivDecl pass)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (DerivDecl pass) where
+type instance XCDerivDecl (GhcPass _) = NoExt
+type instance XXDerivDecl (GhcPass _) = NoExt
+
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (DerivDecl p) where
ppr (DerivDecl { deriv_type = ty
, deriv_strategy = ds
, deriv_overlap_mode = o })
@@ -1612,6 +1888,51 @@ instance (SourceTextX pass, OutputableBndrId pass)
, text "instance"
, ppOverlapPragma o
, ppr ty ]
+ ppr (XDerivDecl x) = ppr x
+
+{-
+************************************************************************
+* *
+ Deriving strategies
+* *
+************************************************************************
+-}
+
+-- | A 'Located' 'DerivStrategy'.
+type LDerivStrategy pass = Located (DerivStrategy pass)
+
+-- | Which technique the user explicitly requested when deriving an instance.
+data DerivStrategy pass
+ -- See Note [Deriving strategies] in TcDeriv
+ = StockStrategy -- ^ GHC's \"standard\" strategy, which is to implement a
+ -- custom instance for the data type. This only works
+ -- for certain types that GHC knows about (e.g., 'Eq',
+ -- 'Show', 'Functor' when @-XDeriveFunctor@ is enabled,
+ -- etc.)
+ | AnyclassStrategy -- ^ @-XDeriveAnyClass@
+ | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@
+ | ViaStrategy (XViaStrategy pass)
+ -- ^ @-XDerivingVia@
+
+type instance XViaStrategy GhcPs = LHsSigType GhcPs
+type instance XViaStrategy GhcRn = LHsSigType GhcRn
+type instance XViaStrategy GhcTc = Type
+
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (DerivStrategy p) where
+ ppr StockStrategy = text "stock"
+ ppr AnyclassStrategy = text "anyclass"
+ ppr NewtypeStrategy = text "newtype"
+ ppr (ViaStrategy ty) = text "via" <+> ppr ty
+
+-- | A short description of a @DerivStrategy'@.
+derivStrategyName :: DerivStrategy a -> SDoc
+derivStrategyName = text . go
+ where
+ go StockStrategy = "stock"
+ go AnyclassStrategy = "anyclass"
+ go NewtypeStrategy = "newtype"
+ go (ViaStrategy {}) = "via"
{-
************************************************************************
@@ -1630,18 +1951,21 @@ type LDefaultDecl pass = Located (DefaultDecl pass)
-- | Default Declaration
data DefaultDecl pass
- = DefaultDecl [LHsType pass]
+ = DefaultDecl (XCDefaultDecl pass) [LHsType pass]
-- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault',
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (DefaultDecl pass)
+ | XDefaultDecl (XXDefaultDecl pass)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (DefaultDecl pass) where
+type instance XCDefaultDecl (GhcPass _) = NoExt
+type instance XXDefaultDecl (GhcPass _) = NoExt
- ppr (DefaultDecl tys)
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (DefaultDecl p) where
+ ppr (DefaultDecl _ tys)
= text "default" <+> parens (interpp'SP tys)
+ ppr (XDefaultDecl x) = ppr x
{-
************************************************************************
@@ -1663,15 +1987,15 @@ type LForeignDecl pass = Located (ForeignDecl pass)
-- | Foreign Declaration
data ForeignDecl pass
= ForeignImport
- { fd_name :: Located (IdP pass) -- defines this name
+ { fd_i_ext :: XForeignImport pass -- Post typechecker, rep_ty ~ sig_ty
+ , fd_name :: Located (IdP pass) -- defines this name
, fd_sig_ty :: LHsSigType pass -- sig_ty
- , fd_co :: PostTc pass Coercion -- rep_ty ~ sig_ty
, fd_fi :: ForeignImport }
| ForeignExport
- { fd_name :: Located (IdP pass) -- uses this name
+ { fd_e_ext :: XForeignExport pass -- Post typechecker, rep_ty ~ sig_ty
+ , fd_name :: Located (IdP pass) -- uses this name
, fd_sig_ty :: LHsSigType pass -- sig_ty
- , fd_co :: PostTc pass Coercion -- rep_ty ~ sig_ty
, fd_fe :: ForeignExport }
-- ^
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign',
@@ -1679,8 +2003,8 @@ data ForeignDecl pass
-- 'ApiAnnotation.AnnDcolon'
-- For details on above see note [Api annotations] in ApiAnnotation
+ | XForeignDecl (XXForeignDecl pass)
-deriving instance (DataId pass) => Data (ForeignDecl pass)
{-
In both ForeignImport and ForeignExport:
sig_ty is the type given in the Haskell code
@@ -1690,11 +2014,15 @@ deriving instance (DataId pass) => Data (ForeignDecl pass)
such as Int and IO that we know how to make foreign calls with.
-}
-noForeignImportCoercionYet :: PlaceHolder
-noForeignImportCoercionYet = PlaceHolder
+type instance XForeignImport GhcPs = NoExt
+type instance XForeignImport GhcRn = NoExt
+type instance XForeignImport GhcTc = Coercion
+
+type instance XForeignExport GhcPs = NoExt
+type instance XForeignExport GhcRn = NoExt
+type instance XForeignExport GhcTc = Coercion
-noForeignExportCoercionYet :: PlaceHolder
-noForeignExportCoercionYet = PlaceHolder
+type instance XXForeignDecl (GhcPass _) = NoExt
-- Specification Of an imported external entity in dependence on the calling
-- convention
@@ -1741,14 +2069,15 @@ data ForeignExport = CExport (Located CExportSpec) -- contains the calling
-- pretty printing of foreign declarations
--
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (ForeignDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (ForeignDecl p) where
ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport })
= hang (text "foreign import" <+> ppr fimport <+> ppr n)
2 (dcolon <+> ppr ty)
ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) =
hang (text "foreign export" <+> ppr fexport <+> ppr n)
2 (dcolon <+> ppr ty)
+ ppr (XForeignDecl x) = ppr x
instance Outputable ForeignImport where
ppr (CImport cconv safety mHeader spec (L _ srcText)) =
@@ -1795,9 +2124,13 @@ type LRuleDecls pass = Located (RuleDecls pass)
-- Note [Pragma source text] in BasicTypes
-- | Rule Declarations
-data RuleDecls pass = HsRules { rds_src :: SourceText
+data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass
+ , rds_src :: SourceText
, rds_rules :: [LRuleDecl pass] }
-deriving instance (DataId pass) => Data (RuleDecls pass)
+ | XRuleDecls (XXRuleDecls pass)
+
+type instance XCRuleDecls (GhcPass _) = NoExt
+type instance XXRuleDecls (GhcPass _) = NoExt
-- | Located Rule Declaration
type LRuleDecl pass = Located (RuleDecl pass)
@@ -1805,15 +2138,14 @@ type LRuleDecl pass = Located (RuleDecl pass)
-- | Rule Declaration
data RuleDecl pass
= HsRule -- Source rule
+ (XHsRule pass) -- After renamer, free-vars from the LHS and RHS
(Located (SourceText,RuleName)) -- Rule name
-- Note [Pragma source text] in BasicTypes
Activation
[LRuleBndr pass] -- Forall'd vars; after typechecking this
-- includes tyvars
(Located (HsExpr pass)) -- LHS
- (PostRn pass NameSet) -- Free-vars from the LHS
(Located (HsExpr pass)) -- RHS
- (PostRn pass NameSet) -- Free-vars from the RHS
-- ^
-- - 'ApiAnnotation.AnnKeywordId' :
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde',
@@ -1823,7 +2155,16 @@ data RuleDecl pass
-- 'ApiAnnotation.AnnEqual',
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (RuleDecl pass)
+ | XRuleDecl (XXRuleDecl pass)
+
+data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS
+ deriving Data
+
+type instance XHsRule GhcPs = NoExt
+type instance XHsRule GhcRn = HsRuleRn
+type instance XHsRule GhcTc = HsRuleRn
+
+type instance XXRuleDecl (GhcPass _) = NoExt
flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass]
flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
@@ -1833,157 +2174,46 @@ type LRuleBndr pass = Located (RuleBndr pass)
-- | Rule Binder
data RuleBndr pass
- = RuleBndr (Located (IdP pass))
- | RuleBndrSig (Located (IdP pass)) (LHsSigWcType pass)
+ = RuleBndr (XCRuleBndr pass) (Located (IdP pass))
+ | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (LHsSigWcType pass)
+ | XRuleBndr (XXRuleBndr pass)
-- ^
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (RuleBndr pass)
+
+type instance XCRuleBndr (GhcPass _) = NoExt
+type instance XRuleBndrSig (GhcPass _) = NoExt
+type instance XXRuleBndr (GhcPass _) = NoExt
collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass]
-collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
+collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs]
pprFullRuleName :: Located (SourceText, RuleName) -> SDoc
pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (RuleDecls pass) where
- ppr (HsRules st rules)
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (RuleDecls p) where
+ ppr (HsRules _ st rules)
= pprWithSourceText st (text "{-# RULES")
<+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"
+ ppr (XRuleDecls x) = ppr x
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (RuleDecl pass) where
- ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecl p) where
+ ppr (HsRule _ name act ns lhs rhs)
= sep [pprFullRuleName name <+> ppr act,
nest 4 (pp_forall <+> pprExpr (unLoc lhs)),
nest 6 (equals <+> pprExpr (unLoc rhs)) ]
where
pp_forall | null ns = empty
| otherwise = forAllLit <+> fsep (map ppr ns) <> dot
+ ppr (XRuleDecl x) = ppr x
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (RuleBndr pass) where
- ppr (RuleBndr name) = ppr name
- ppr (RuleBndrSig name ty) = parens (ppr name <> dcolon <> ppr ty)
-
-{-
-************************************************************************
-* *
-\subsection{Vectorisation declarations}
-* *
-************************************************************************
-
-A vectorisation pragma, one of
-
- {-# VECTORISE f = closure1 g (scalar_map g) #-}
- {-# VECTORISE SCALAR f #-}
- {-# NOVECTORISE f #-}
-
- {-# VECTORISE type T = ty #-}
- {-# VECTORISE SCALAR type T #-}
--}
-
--- | Located Vectorise Declaration
-type LVectDecl pass = Located (VectDecl pass)
-
--- | Vectorise Declaration
-data VectDecl pass
- = HsVect
- SourceText -- Note [Pragma source text] in BasicTypes
- (Located (IdP pass))
- (LHsExpr pass)
- -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
- -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnClose'
-
- -- For details on above see note [Api annotations] in ApiAnnotation
- | HsNoVect
- SourceText -- Note [Pragma source text] in BasicTypes
- (Located (IdP pass))
- -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
- -- 'ApiAnnotation.AnnClose'
-
- -- For details on above see note [Api annotations] in ApiAnnotation
- | HsVectTypeIn -- pre type-checking
- SourceText -- Note [Pragma source text] in BasicTypes
- Bool -- 'TRUE' => SCALAR declaration
- (Located (IdP pass))
- (Maybe (Located (IdP pass))) -- 'Nothing' => no right-hand side
- -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
- -- 'ApiAnnotation.AnnType','ApiAnnotation.AnnClose',
- -- 'ApiAnnotation.AnnEqual'
-
- -- For details on above see note [Api annotations] in ApiAnnotation
- | HsVectTypeOut -- post type-checking
- Bool -- 'TRUE' => SCALAR declaration
- TyCon
- (Maybe TyCon) -- 'Nothing' => no right-hand side
- | HsVectClassIn -- pre type-checking
- SourceText -- Note [Pragma source text] in BasicTypes
- (Located (IdP pass))
- -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
- -- 'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose',
-
- -- For details on above see note [Api annotations] in ApiAnnotation
- | HsVectClassOut -- post type-checking
- Class
- | HsVectInstIn -- pre type-checking (always SCALAR) !!!FIXME: should be superfluous now
- (LHsSigType pass)
- | HsVectInstOut -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now
- ClsInst
-deriving instance (DataId pass) => Data (VectDecl pass)
-
-lvectDeclName :: NamedThing (IdP pass) => LVectDecl pass -> 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"
-
-lvectInstDecl :: LVectDecl pass -> Bool
-lvectInstDecl (L _ (HsVectInstIn _)) = True
-lvectInstDecl (L _ (HsVectInstOut _)) = True
-lvectInstDecl _ = False
-
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (VectDecl pass) where
- ppr (HsVect _ v rhs)
- = sep [text "{-# VECTORISE" <+> ppr v,
- nest 4 $
- pprExpr (unLoc rhs) <+> text "#-}" ]
- ppr (HsNoVect _ v)
- = sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ]
- ppr (HsVectTypeIn _ False t Nothing)
- = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ]
- ppr (HsVectTypeIn _ False t (Just t'))
- = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ]
- ppr (HsVectTypeIn _ True t Nothing)
- = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
- 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 "#-}" ]
- ppr (HsVectTypeOut False t (Just t'))
- = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ]
- ppr (HsVectTypeOut True t Nothing)
- = 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)
- = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
- ppr (HsVectClassOut c)
- = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
- ppr (HsVectInstIn ty)
- = sep [text "{-# VECTORISE SCALAR instance" <+> ppr ty <+> text "#-}" ]
- ppr (HsVectInstOut i)
- = sep [text "{-# VECTORISE SCALAR instance" <+> ppr i <+> text "#-}" ]
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleBndr p) where
+ ppr (RuleBndr _ name) = ppr name
+ ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)
+ ppr (XRuleBndr x) = ppr x
{-
************************************************************************
@@ -2029,27 +2259,39 @@ type LWarnDecls pass = Located (WarnDecls pass)
-- Note [Pragma source text] in BasicTypes
-- | Warning pragma Declarations
-data WarnDecls pass = Warnings { wd_src :: SourceText
+data WarnDecls pass = Warnings { wd_ext :: XWarnings pass
+ , wd_src :: SourceText
, wd_warnings :: [LWarnDecl pass]
}
-deriving instance (DataId pass) => Data (WarnDecls pass)
+ | XWarnDecls (XXWarnDecls pass)
+
+type instance XWarnings (GhcPass _) = NoExt
+type instance XXWarnDecls (GhcPass _) = NoExt
-- | Located Warning pragma Declaration
type LWarnDecl pass = Located (WarnDecl pass)
-- | Warning pragma Declaration
-data WarnDecl pass = Warning [Located (IdP pass)] WarningTxt
-deriving instance (DataId pass) => Data (WarnDecl pass)
+data WarnDecl pass = Warning (XWarning pass) [Located (IdP pass)] WarningTxt
+ | XWarnDecl (XXWarnDecl pass)
+
+type instance XWarning (GhcPass _) = NoExt
+type instance XXWarnDecl (GhcPass _) = NoExt
-instance OutputableBndr (IdP pass) => Outputable (WarnDecls pass) where
- ppr (Warnings (SourceText src) decls)
+
+instance (p ~ GhcPass pass,OutputableBndr (IdP p))
+ => Outputable (WarnDecls p) where
+ ppr (Warnings _ (SourceText src) decls)
= text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
- ppr (Warnings NoSourceText _decls) = panic "WarnDecls"
+ ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls"
+ ppr (XWarnDecls x) = ppr x
-instance OutputableBndr (IdP pass) => Outputable (WarnDecl pass) where
- ppr (Warning thing txt)
+instance (p ~ GhcPass pass, OutputableBndr (IdP p))
+ => Outputable (WarnDecl p) where
+ ppr (Warning _ thing txt)
= hsep ( punctuate comma (map ppr thing))
<+> ppr txt
+ ppr (XWarnDecl x) = ppr x
{-
************************************************************************
@@ -2064,6 +2306,7 @@ type LAnnDecl pass = Located (AnnDecl pass)
-- | Annotation Declaration
data AnnDecl pass = HsAnnotation
+ (XHsAnnotation pass)
SourceText -- Note [Pragma source text] in BasicTypes
(AnnProvenance (IdP pass)) (Located (HsExpr pass))
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
@@ -2072,12 +2315,15 @@ data AnnDecl pass = HsAnnotation
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (AnnDecl pass)
+ | XAnnDecl (XXAnnDecl pass)
+
+type instance XHsAnnotation (GhcPass _) = NoExt
+type instance XXAnnDecl (GhcPass _) = NoExt
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (AnnDecl pass) where
- ppr (HsAnnotation _ provenance expr)
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (AnnDecl p) where
+ ppr (HsAnnotation _ _ provenance expr)
= hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
+ ppr (XAnnDecl x) = ppr x
-- | Annotation Provenance
data AnnProvenance name = ValueAnnProvenance (Located name)
@@ -2115,21 +2361,28 @@ type LRoleAnnotDecl pass = Located (RoleAnnotDecl pass)
-- top-level declarations
-- | Role Annotation Declaration
data RoleAnnotDecl pass
- = RoleAnnotDecl (Located (IdP pass)) -- type constructor
+ = RoleAnnotDecl (XCRoleAnnotDecl pass)
+ (Located (IdP pass)) -- type constructor
[Located (Maybe Role)] -- optional annotations
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
-- 'ApiAnnotation.AnnRole'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (RoleAnnotDecl pass)
+ | XRoleAnnotDecl (XXRoleAnnotDecl pass)
+
+type instance XCRoleAnnotDecl (GhcPass _) = NoExt
+type instance XXRoleAnnotDecl (GhcPass _) = NoExt
-instance OutputableBndr (IdP pass) => Outputable (RoleAnnotDecl pass) where
- ppr (RoleAnnotDecl ltycon roles)
- = text "type role" <+> ppr ltycon <+>
+instance (p ~ GhcPass pass, OutputableBndr (IdP p))
+ => Outputable (RoleAnnotDecl p) where
+ ppr (RoleAnnotDecl _ ltycon roles)
+ = text "type role" <+> pprPrefixOcc (unLoc ltycon) <+>
hsep (map (pp_role . unLoc) roles)
where
pp_role Nothing = underscore
pp_role (Just r) = ppr r
+ ppr (XRoleAnnotDecl x) = ppr x
roleAnnotDeclName :: RoleAnnotDecl pass -> (IdP pass)
-roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = name
+roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name
+roleAnnotDeclName (XRoleAnnotDecl _) = panic "roleAnnotDeclName"
diff --git a/compiler/hsSyn/HsDoc.hs b/compiler/hsSyn/HsDoc.hs
index d9c5dba296..affbf1bac0 100644
--- a/compiler/hsSyn/HsDoc.hs
+++ b/compiler/hsSyn/HsDoc.hs
@@ -1,30 +1,152 @@
-{-# LANGUAGE CPP, DeriveDataTypeable #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module HsDoc (
- HsDocString(..),
- LHsDocString,
- ppr_mbDoc
+module HsDoc
+ ( HsDocString
+ , LHsDocString
+ , mkHsDocString
+ , mkHsDocStringUtf8ByteString
+ , unpackHDS
+ , hsDocStringToByteString
+ , ppr_mbDoc
+
+ , appendDocs
+ , concatDocs
+
+ , DeclDocMap(..)
+ , emptyDeclDocMap
+
+ , ArgDocMap(..)
+ , emptyArgDocMap
) where
#include "HsVersions.h"
+import GhcPrelude
+
+import Binary
+import Encoding
+import FastFunctions
+import Name
import Outputable
import SrcLoc
-import FastString
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Internal as BS
import Data.Data
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
+import Foreign
-- | Haskell Documentation String
-newtype HsDocString = HsDocString FastString
+--
+-- Internally this is a UTF8-Encoded 'ByteString'.
+newtype HsDocString = HsDocString ByteString
+ -- There are at least two plausible Semigroup instances for this type:
+ --
+ -- 1. Simple string concatenation.
+ -- 2. Concatenation as documentation paragraphs with newlines in between.
+ --
+ -- To avoid confusion, we pass on defining an instance at all.
deriving (Eq, Show, Data)
-- | Located Haskell Documentation String
type LHsDocString = Located HsDocString
+instance Binary HsDocString where
+ put_ bh (HsDocString bs) = put_ bh bs
+ get bh = HsDocString <$> get bh
+
instance Outputable HsDocString where
- ppr (HsDocString fs) = ftext fs
+ ppr = doubleQuotes . text . unpackHDS
+
+mkHsDocString :: String -> HsDocString
+mkHsDocString s =
+ inlinePerformIO $ do
+ let len = utf8EncodedLength s
+ buf <- mallocForeignPtrBytes len
+ withForeignPtr buf $ \ptr -> do
+ utf8EncodeString ptr s
+ pure (HsDocString (BS.fromForeignPtr buf 0 len))
+
+-- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'.
+mkHsDocStringUtf8ByteString :: ByteString -> HsDocString
+mkHsDocStringUtf8ByteString = HsDocString
+
+unpackHDS :: HsDocString -> String
+unpackHDS = utf8DecodeByteString . hsDocStringToByteString
+
+-- | Return the contents of a 'HsDocString' as a UTF8-encoded 'ByteString'.
+hsDocStringToByteString :: HsDocString -> ByteString
+hsDocStringToByteString (HsDocString bs) = bs
ppr_mbDoc :: Maybe LHsDocString -> SDoc
ppr_mbDoc (Just doc) = ppr doc
ppr_mbDoc Nothing = empty
+-- | Join two docstrings.
+--
+-- Non-empty docstrings are joined with two newlines in between,
+-- resulting in separate paragraphs.
+appendDocs :: HsDocString -> HsDocString -> HsDocString
+appendDocs x y =
+ fromMaybe
+ (HsDocString BS.empty)
+ (concatDocs [x, y])
+
+-- | Concat docstrings with two newlines in between.
+--
+-- Empty docstrings are skipped.
+--
+-- If all inputs are empty, 'Nothing' is returned.
+concatDocs :: [HsDocString] -> Maybe HsDocString
+concatDocs xs =
+ if BS.null b
+ then Nothing
+ else Just (HsDocString b)
+ where
+ b = BS.intercalate (C8.pack "\n\n")
+ . filter (not . BS.null)
+ . map hsDocStringToByteString
+ $ xs
+
+-- | Docs for declarations: functions, data types, instances, methods etc.
+newtype DeclDocMap = DeclDocMap (Map Name HsDocString)
+
+instance Binary DeclDocMap where
+ put_ bh (DeclDocMap m) = put_ bh (Map.toList m)
+ -- We can't rely on a deterministic ordering of the `Name`s here.
+ -- See the comments on `Name`'s `Ord` instance for context.
+ get bh = DeclDocMap . Map.fromList <$> get bh
+
+instance Outputable DeclDocMap where
+ ppr (DeclDocMap m) = vcat (map pprPair (Map.toAscList m))
+ where
+ pprPair (name, doc) = ppr name Outputable.<> colon $$ nest 2 (ppr doc)
+
+emptyDeclDocMap :: DeclDocMap
+emptyDeclDocMap = DeclDocMap Map.empty
+
+-- | Docs for arguments. E.g. function arguments, method arguments.
+newtype ArgDocMap = ArgDocMap (Map Name (Map Int HsDocString))
+
+instance Binary ArgDocMap where
+ put_ bh (ArgDocMap m) = put_ bh (Map.toList (Map.toAscList <$> m))
+ -- We can't rely on a deterministic ordering of the `Name`s here.
+ -- See the comments on `Name`'s `Ord` instance for context.
+ get bh = ArgDocMap . fmap Map.fromDistinctAscList . Map.fromList <$> get bh
+
+instance Outputable ArgDocMap where
+ ppr (ArgDocMap m) = vcat (map pprPair (Map.toAscList m))
+ where
+ pprPair (name, int_map) =
+ ppr name Outputable.<> colon $$ nest 2 (pprIntMap int_map)
+ pprIntMap im = vcat (map pprIPair (Map.toAscList im))
+ pprIPair (i, doc) = ppr i Outputable.<> colon $$ nest 2 (ppr doc)
+
+emptyArgDocMap :: ArgDocMap
+emptyArgDocMap = ArgDocMap Map.empty
diff --git a/compiler/hsSyn/HsDumpAst.hs b/compiler/hsSyn/HsDumpAst.hs
index e2244312d0..1a1c259c01 100644
--- a/compiler/hsSyn/HsDumpAst.hs
+++ b/compiler/hsSyn/HsDumpAst.hs
@@ -15,8 +15,9 @@ module HsDumpAst (
BlankSrcSpan(..),
) where
+import GhcPrelude
+
import Data.Data hiding (Fixity)
-import Data.List
import Bag
import BasicTypes
import FastString
@@ -28,8 +29,7 @@ import HsSyn
import OccName hiding (occName)
import Var
import Module
-import DynFlags
-import Outputable hiding (space)
+import Outputable
import qualified Data.ByteString as B
@@ -39,11 +39,11 @@ data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan
-- | Show a GHC syntax tree. This parameterised because it is also used for
-- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked
-- out, to avoid comparing locations, only structure
-showAstData :: Data a => BlankSrcSpan -> a -> String
-showAstData b = showAstData' 0
+showAstData :: Data a => BlankSrcSpan -> a -> SDoc
+showAstData b a0 = blankLine $$ showAstData' a0
where
- showAstData' :: Data a => Int -> a -> String
- showAstData' n =
+ showAstData' :: Data a => a -> SDoc
+ showAstData' =
generic
`ext1Q` list
`extQ` string `extQ` fastString `extQ` srcSpan
@@ -54,118 +54,118 @@ showAstData b = showAstData' 0
`extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
`extQ` fixity
`ext2Q` located
- where generic :: Data a => a -> String
- generic t = indent n ++ "(" ++ showConstr (toConstr t)
- ++ space (unwords (gmapQ (showAstData' (n+1)) t)) ++ ")"
-
- space "" = ""
- space s = ' ':s
- indent i = "\n" ++ replicate i ' '
+ where generic :: Data a => a -> SDoc
+ generic t = parens $ text (showConstr (toConstr t))
+ $$ vcat (gmapQ showAstData' t)
- string :: String -> String
- string = normalize_newlines . show
+ string :: String -> SDoc
+ string = text . normalize_newlines . show
- fastString :: FastString -> String
- fastString = ("{FastString: "++) . (++"}") . normalize_newlines
- . show
+ fastString :: FastString -> SDoc
+ fastString s = braces $
+ text "FastString: "
+ <> text (normalize_newlines . show $ s)
- bytestring :: B.ByteString -> String
- bytestring = normalize_newlines . show
+ bytestring :: B.ByteString -> SDoc
+ bytestring = text . normalize_newlines . show
- list l = indent n ++ "["
- ++ intercalate "," (map (showAstData' (n+1)) l)
- ++ "]"
+ list [] = brackets empty
+ list [x] = brackets (showAstData' x)
+ list (x1 : x2 : xs) = (text "[" <> showAstData' x1)
+ $$ go x2 xs
+ where
+ go y [] = text "," <> showAstData' y <> text "]"
+ go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys
-- Eliminate word-size dependence
- lit :: HsLit GhcPs -> String
+ lit :: HsLit GhcPs -> SDoc
lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s
lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s
lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s
lit l = generic l
- litr :: HsLit GhcRn -> String
+ litr :: HsLit GhcRn -> SDoc
litr (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s
litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
litr (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s
litr (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s
litr l = generic l
- litt :: HsLit GhcTc -> String
+ litt :: HsLit GhcTc -> SDoc
litt (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s
litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
litt (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s
litt (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s
litt l = generic l
- numericLit :: String -> Integer -> SourceText -> String
- numericLit tag x s = indent n ++ unwords [ "{" ++ tag
- , generic x
- , generic s ++ "}" ]
+ numericLit :: String -> Integer -> SourceText -> SDoc
+ numericLit tag x s = braces $ hsep [ text tag
+ , generic x
+ , generic s ]
- name :: Name -> String
- name = ("{Name: "++) . (++"}") . showSDocDebug_ . ppr
+ name :: Name -> SDoc
+ name nm = braces $ text "Name: " <> ppr nm
- occName = ("{OccName: "++) . (++"}") . OccName.occNameString
+ occName n = braces $
+ text "OccName: "
+ <> text (OccName.occNameString n)
- moduleName :: ModuleName -> String
- moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . ppr
+ moduleName :: ModuleName -> SDoc
+ moduleName m = braces $ text "ModuleName: " <> ppr m
- srcSpan :: SrcSpan -> String
+ srcSpan :: SrcSpan -> SDoc
srcSpan ss = case b of
- BlankSrcSpan -> "{ "++ "ss" ++"}"
- NoBlankSrcSpan ->
- "{ "++ showSDoc_ (hang (ppr ss) (n+2)
- -- TODO: show annotations here
- (text "")
- )
- ++"}"
-
- var :: Var -> String
- var = ("{Var: "++) . (++"}") . showSDocDebug_ . ppr
-
- dataCon :: DataCon -> String
- dataCon = ("{DataCon: "++) . (++"}") . showSDoc_ . ppr
-
- bagRdrName:: Bag (Located (HsBind GhcPs)) -> String
- bagRdrName = ("{Bag(Located (HsBind GhcPs)): "++) . (++"}")
- . list . bagToList
-
- bagName :: Bag (Located (HsBind GhcRn)) -> String
- bagName = ("{Bag(Located (HsBind Name)): "++) . (++"}")
- . list . bagToList
-
- bagVar :: Bag (Located (HsBind GhcTc)) -> String
- bagVar = ("{Bag(Located (HsBind Var)): "++) . (++"}")
- . list . bagToList
-
- nameSet = ("{NameSet: "++) . (++"}") . list . nameSetElemsStable
-
- fixity :: Fixity -> String
- fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . ppr
-
- located :: (Data b,Data loc) => GenLocated loc b -> String
- located (L ss a) =
- indent n ++ "("
- ++ case cast ss of
+ BlankSrcSpan -> text "{ ss }"
+ NoBlankSrcSpan -> braces $ char ' ' <>
+ (hang (ppr ss) 1
+ -- TODO: show annotations here
+ (text ""))
+
+ var :: Var -> SDoc
+ var v = braces $ text "Var: " <> ppr v
+
+ dataCon :: DataCon -> SDoc
+ dataCon c = braces $ text "DataCon: " <> ppr c
+
+ bagRdrName:: Bag (Located (HsBind GhcPs)) -> SDoc
+ bagRdrName bg = braces $
+ text "Bag(Located (HsBind GhcPs)):"
+ $$ (list . bagToList $ bg)
+
+ bagName :: Bag (Located (HsBind GhcRn)) -> SDoc
+ bagName bg = braces $
+ text "Bag(Located (HsBind Name)):"
+ $$ (list . bagToList $ bg)
+
+ bagVar :: Bag (Located (HsBind GhcTc)) -> SDoc
+ bagVar bg = braces $
+ text "Bag(Located (HsBind Var)):"
+ $$ (list . bagToList $ bg)
+
+ nameSet ns = braces $
+ text "NameSet:"
+ $$ (list . nameSetElemsStable $ ns)
+
+ fixity :: Fixity -> SDoc
+ fixity fx = braces $
+ text "Fixity: "
+ <> ppr fx
+
+ located :: (Data b,Data loc) => GenLocated loc b -> SDoc
+ located (L ss a) = parens $
+ case cast ss of
Just (s :: SrcSpan) ->
srcSpan s
- Nothing -> "nnnnnnnn"
- ++ showAstData' (n+1) a
- ++ ")"
+ Nothing -> text "nnnnnnnn"
+ $$ showAstData' a
normalize_newlines :: String -> String
normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs
normalize_newlines (x:xs) = x:normalize_newlines xs
normalize_newlines [] = []
-showSDoc_ :: SDoc -> String
-showSDoc_ = normalize_newlines . showSDoc unsafeGlobalDynFlags
-
-showSDocDebug_ :: SDoc -> String
-showSDocDebug_ = normalize_newlines . showSDocDebug unsafeGlobalDynFlags
-
{-
************************************************************************
* *
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 016b02fe2f..45b1b07d73 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -11,6 +11,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE TypeFamilies #-}
-- | Abstract Haskell syntax for expressions.
module HsExpr where
@@ -18,6 +19,8 @@ module HsExpr where
#include "HsVersions.h"
-- friends:
+import GhcPrelude
+
import HsDecls
import HsPat
import HsLit
@@ -79,12 +82,6 @@ type PostTcExpr = HsExpr GhcTc
-- than is convenient to keep individually.
type PostTcTable = [(Name, PostTcExpr)]
-noPostTcExpr :: PostTcExpr
-noPostTcExpr = HsLit (HsString noSourceText (fsLit "noPostTcExpr"))
-
-noPostTcTable :: PostTcTable
-noPostTcTable = []
-
-------------------------
-- | Syntax Expression
--
@@ -101,23 +98,22 @@ noPostTcTable = []
-- > (syn_arg_wraps[1] arg1) ...
--
-- where the actual arguments come from elsewhere in the AST.
--- This could be defined using @PostRn@ and @PostTc@ and such, but it's
+-- This could be defined using @GhcPass p@ and such, but it's
-- harder to get it all to work out that way. ('noSyntaxExpr' is hard to
-- write, for example.)
data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p
, syn_arg_wraps :: [HsWrapper]
, syn_res_wrap :: HsWrapper }
-deriving instance (DataId p) => Data (SyntaxExpr p)
-- | This is used for rebindable-syntax pieces that are too polymorphic
-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)
-noExpr :: SourceTextX p => HsExpr p
-noExpr = HsLit (HsString (sourceText "noExpr") (fsLit "noExpr"))
+noExpr :: HsExpr (GhcPass p)
+noExpr = HsLit noExt (HsString (SourceText "noExpr") (fsLit "noExpr"))
-noSyntaxExpr :: SourceTextX p => SyntaxExpr p
+noSyntaxExpr :: SyntaxExpr (GhcPass p)
-- Before renaming, and sometimes after,
-- (if the syntax slot makes no sense)
-noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString noSourceText
+noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExt (HsString NoSourceText
(fsLit "noSyntaxExpr"))
, syn_arg_wraps = []
, syn_res_wrap = WpHole }
@@ -125,13 +121,14 @@ noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString noSourceText
-- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the
-- renamer), missing its HsWrappers.
mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn
-mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc name
+mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar noExt $ noLoc name
, syn_arg_wraps = []
, syn_res_wrap = WpHole }
-- don't care about filling in syn_arg_wraps because we're clearly
-- not past the typechecker
-instance (SourceTextX p, OutputableBndrId p) => Outputable (SyntaxExpr p) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (SyntaxExpr p) where
ppr (SyntaxExpr { syn_expr = expr
, syn_arg_wraps = arg_wraps
, syn_res_wrap = res_wrap })
@@ -182,8 +179,15 @@ is Less Cool because
typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)
-}
--- | An unbound variable; used for treating out-of-scope variables as
--- expression holes
+-- | An unbound variable; used for treating
+-- out-of-scope variables as expression holes
+--
+-- Either "x", "y" Plain OutOfScope
+-- or "_", "_x" A TrueExprHole
+--
+-- Both forms indicate an out-of-scope variable, but the latter
+-- indicates that the user /expects/ it to be out of scope, and
+-- just wants GHC to report its type
data UnboundVar
= OutOfScope OccName GlobalRdrEnv -- ^ An (unqualified) out-of-scope
-- variable, together with the GlobalRdrEnv
@@ -196,7 +200,8 @@ data UnboundVar
deriving Data
instance Outputable UnboundVar where
- ppr = ppr . unboundVarOcc
+ ppr (OutOfScope occ _) = text "OutOfScope" <> parens (ppr occ)
+ ppr (TrueExprHole occ) = text "ExprHole" <> parens (ppr occ)
unboundVarOcc :: UnboundVar -> OccName
unboundVarOcc (OutOfScope occ _) = occ
@@ -274,11 +279,13 @@ information to use is the GlobalRdrEnv itself.
-- | A Haskell expression.
data HsExpr p
- = HsVar (Located (IdP p)) -- ^ Variable
+ = HsVar (XVar p)
+ (Located (IdP p)) -- ^ Variable
-- See Note [Located RdrNames]
- | HsUnboundVar UnboundVar -- ^ Unbound variable; also used for "holes"
+ | HsUnboundVar (XUnboundVar p)
+ UnboundVar -- ^ Unbound variable; also used for "holes"
-- (_ or _x).
-- Turned from HsVar to HsUnboundVar by the
-- renamer, when it finds an out-of-scope
@@ -286,24 +293,31 @@ data HsExpr p
-- Turned into HsVar by type checker, to support
-- deferred type errors.
- | HsConLikeOut ConLike -- ^ After typechecker only; must be different
+ | HsConLikeOut (XConLikeOut p)
+ ConLike -- ^ After typechecker only; must be different
-- HsVar for pretty printing
- | HsRecFld (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector
+ | HsRecFld (XRecFld p)
+ (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector
-- Not in use after typechecking
- | HsOverLabel (Maybe (IdP p)) FastString
+ | HsOverLabel (XOverLabel p)
+ (Maybe (IdP p)) FastString
-- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)
-- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the
-- in-scope 'fromLabel'.
-- NB: Not in use after typechecking
- | HsIPVar HsIPName -- ^ Implicit parameter (not in use after typechecking)
- | HsOverLit (HsOverLit p) -- ^ Overloaded literals
+ | HsIPVar (XIPVar p)
+ HsIPName -- ^ Implicit parameter (not in use after typechecking)
+ | HsOverLit (XOverLitE p)
+ (HsOverLit p) -- ^ Overloaded literals
- | HsLit (HsLit p) -- ^ Simple (non-overloaded) literals
+ | HsLit (XLitE p)
+ (HsLit p) -- ^ Simple (non-overloaded) literals
- | HsLam (MatchGroup p (LHsExpr p))
+ | HsLam (XLam p)
+ (MatchGroup p (LHsExpr p))
-- ^ Lambda abstraction. Currently always a single match
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
@@ -311,7 +325,7 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsLamCase (MatchGroup p (LHsExpr p)) -- ^ Lambda-case
+ | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
-- 'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen',
@@ -319,28 +333,24 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsApp (LHsExpr p) (LHsExpr p) -- ^ Application
+ | HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application
- | HsAppType (LHsExpr p) (LHsWcType p) -- ^ Visible type application
+ | HsAppType (XAppTypeE p) (LHsExpr p) -- ^ Visible type application
--
-- Explicit type argument; e.g f @Int x y
-- NB: Has wildcards, but no implicit quantification
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt',
- -- TODO:AZ: Sort out Name
- | HsAppTypeOut (LHsExpr p) (LHsWcType GhcRn) -- just for pretty-printing
-
-
-- | Operator applications:
-- NB Bracketed ops such as (+) come out as Vars.
-- NB We need an expr for the operator in an OpApp/Section since
-- the typechecker may need to apply the operator to a few types.
- | OpApp (LHsExpr p) -- left operand
+ | OpApp (XOpApp p)
+ (LHsExpr p) -- left operand
(LHsExpr p) -- operator
- (PostRn p Fixity) -- Renamer adds fixity; bottom until then
(LHsExpr p) -- right operand
-- | Negation operator. Contains the negated expression and the name
@@ -349,18 +359,22 @@ data HsExpr p
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus'
-- For details on above see note [Api annotations] in ApiAnnotation
- | NegApp (LHsExpr p)
+ | NegApp (XNegApp p)
+ (LHsExpr p)
(SyntaxExpr p)
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
-- 'ApiAnnotation.AnnClose' @')'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsPar (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn]
+ | HsPar (XPar p)
+ (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn]
- | SectionL (LHsExpr p) -- operand; see Note [Sections in HsSyn]
+ | SectionL (XSectionL p)
+ (LHsExpr p) -- operand; see Note [Sections in HsSyn]
(LHsExpr p) -- operator
- | SectionR (LHsExpr p) -- operator; see Note [Sections in HsSyn]
+ | SectionR (XSectionR p)
+ (LHsExpr p) -- operator; see Note [Sections in HsSyn]
(LHsExpr p) -- operand
-- | Used for explicit tuples and sections thereof
@@ -370,6 +384,7 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| ExplicitTuple
+ (XExplicitTuple p)
[LHsTupArg p]
Boxity
@@ -381,17 +396,18 @@ data HsExpr p
-- There will be multiple 'ApiAnnotation.AnnVbar', (1 - alternative) before
-- the expression, (arity - alternative) after it
| ExplicitSum
+ (XExplicitSum p)
ConTag -- Alternative (one-based)
Arity -- Sum arity
(LHsExpr p)
- (PostTc p [Type]) -- the type arguments
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',
-- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,
-- 'ApiAnnotation.AnnClose' @'}'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCase (LHsExpr p)
+ | HsCase (XCase p)
+ (LHsExpr p)
(MatchGroup p (LHsExpr p))
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf',
@@ -400,7 +416,8 @@ data HsExpr p
-- 'ApiAnnotation.AnnElse',
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsIf (Maybe (SyntaxExpr p)) -- cond function
+ | HsIf (XIf p)
+ (Maybe (SyntaxExpr p)) -- cond function
-- Nothing => use the built-in 'if'
-- See Note [Rebindable if]
(LHsExpr p) -- predicate
@@ -413,7 +430,7 @@ data HsExpr p
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsMultiIf (PostTc p Type) [LGRHS p (LHsExpr p)]
+ | HsMultiIf (XMultiIf p) [LGRHS p (LHsExpr p)]
-- | let(rec)
--
@@ -422,7 +439,8 @@ data HsExpr p
-- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn'
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsLet (LHsLocalBinds p)
+ | HsLet (XLet p)
+ (LHsLocalBinds p)
(LHsExpr p)
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',
@@ -431,11 +449,11 @@ data HsExpr p
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsDo (HsStmtContext Name) -- The parameterisation is unimportant
+ | HsDo (XDo p) -- Type of the whole expression
+ (HsStmtContext Name) -- The parameterisation is unimportant
-- because in this context we never use
-- the PatGuard or ParStmt variant
(Located [ExprLStmt p]) -- "do":one or more stmts
- (PostTc p Type) -- Type of the whole expression
-- | Syntactic list: [a,b,c,...]
--
@@ -444,23 +462,11 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| ExplicitList
- (PostTc p Type) -- Gives type of components of list
+ (XExplicitList p) -- Gives type of components of list
(Maybe (SyntaxExpr p))
-- For OverloadedLists, the fromListN witness
[LHsExpr p]
- -- | Syntactic parallel array: [:e1, ..., en:]
- --
- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
- -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnComma',
- -- 'ApiAnnotation.AnnVbar'
- -- 'ApiAnnotation.AnnClose' @':]'@
-
- -- For details on above see note [Api annotations] in ApiAnnotation
- | ExplicitPArr
- (PostTc p Type) -- type of elements of the parallel array
- [LHsExpr p]
-
-- | Record construction
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,
@@ -468,11 +474,9 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| RecordCon
- { rcon_con_name :: Located (IdP p) -- The constructor name;
+ { rcon_ext :: XRecordCon p
+ , rcon_con_name :: Located (IdP p) -- The constructor name;
-- not used after type checking
- , rcon_con_like :: PostTc p ConLike
- -- The data constructor or pattern synonym
- , rcon_con_expr :: PostTcExpr -- Instantiated constructor function
, rcon_flds :: HsRecordBinds p } -- The fields
-- | Record update
@@ -482,18 +486,9 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| RecordUpd
- { rupd_expr :: LHsExpr p
+ { rupd_ext :: XRecordUpd p
+ , rupd_expr :: LHsExpr p
, rupd_flds :: [LHsRecUpdField p]
- , rupd_cons :: PostTc p [ConLike]
- -- Filled in by the type checker to the
- -- _non-empty_ list of DataCons that have
- -- all the upd'd fields
-
- , rupd_in_tys :: PostTc p [Type] -- Argument types of *input* record type
- , rupd_out_tys :: PostTc p [Type] -- and *output* record type
- -- The original type can be reconstructed
- -- with conLikeResTy
- , rupd_wrap :: PostTc p HsWrapper -- See note [Record Update HsWrapper]
}
-- For a type family, the arg types are of the *instance* tycon,
-- not the family tycon
@@ -504,14 +499,10 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| ExprWithTySig
- (LHsExpr p)
- (LHsSigWcType p)
-
- | ExprWithTySigOut -- Post typechecking
- (LHsExpr p)
- (LHsSigWcType GhcRn) -- Retain the signature,
+ (XExprWithTySig p) -- Retain the signature,
-- as HsSigType Name, for
-- round-tripping purposes
+ (LHsExpr p)
-- | Arithmetic sequence
--
@@ -521,31 +512,14 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| ArithSeq
- PostTcExpr
+ (XArithSeq p)
(Maybe (SyntaxExpr p))
-- For OverloadedLists, the fromList witness
(ArithSeqInfo p)
- -- | Arithmetic sequence for parallel array
- --
- -- > [:e1..e2:] or [:e1, e2..e3:]
- --
- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
- -- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot',
- -- 'ApiAnnotation.AnnVbar',
- -- 'ApiAnnotation.AnnClose' @':]'@
-
- -- For details on above see note [Api annotations] in ApiAnnotation
- | PArrSeq
- PostTcExpr
- (ArithSeqInfo p)
-
- -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# SCC'@,
- -- 'ApiAnnotation.AnnVal' or 'ApiAnnotation.AnnValStr',
- -- 'ApiAnnotation.AnnClose' @'\#-}'@
-
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsSCC SourceText -- Note [Pragma source text] in BasicTypes
+ | HsSCC (XSCC p)
+ SourceText -- Note [Pragma source text] in BasicTypes
StringLiteral -- "set cost centre" SCC pragma
(LHsExpr p) -- expr whose cost is to be measured
@@ -553,7 +527,8 @@ data HsExpr p
-- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCoreAnn SourceText -- Note [Pragma source text] in BasicTypes
+ | HsCoreAnn (XCoreAnn p)
+ SourceText -- Note [Pragma source text] in BasicTypes
StringLiteral -- hdaume: core annotation
(LHsExpr p)
@@ -565,15 +540,17 @@ data HsExpr p
-- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnCloseQ'
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsBracket (HsBracket p)
+ | HsBracket (XBracket p) (HsBracket p)
-- See Note [Pending Splices]
| HsRnBracketOut
+ (XRnBracketOut p)
(HsBracket GhcRn) -- Output of the renamer is the *original* renamed
-- expression, plus
[PendingRnSplice] -- _renamed_ splices to be type checked
| HsTcBracketOut
+ (XTcBracketOut p)
(HsBracket GhcRn) -- Output of the type checker is the *original*
-- renamed expression, plus
[PendingTcSplice] -- _typechecked_ splices to be
@@ -583,7 +560,7 @@ data HsExpr p
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsSpliceE (HsSplice p)
+ | HsSpliceE (XSpliceE p) (HsSplice p)
-----------------------------------------------------------
-- Arrow notation extension
@@ -594,7 +571,8 @@ data HsExpr p
-- 'ApiAnnotation.AnnRarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsProc (LPat p) -- arrow abstraction, proc
+ | HsProc (XProc p)
+ (LPat p) -- arrow abstraction, proc
(LHsCmdTop p) -- body of the abstraction
-- always has an empty stack
@@ -603,7 +581,7 @@ data HsExpr p
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic',
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsStatic (PostRn p NameSet) -- Free variables of the body
+ | HsStatic (XStatic p) -- Free variables of the body
(LHsExpr p) -- Body
---------------------------------------
@@ -617,10 +595,10 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| HsArrApp -- Arrow tail, or arrow application (f -< arg)
+ (XArrApp p) -- type of the arrow expressions f,
+ -- of the form a t t', where arg :: t
(LHsExpr p) -- arrow expression, f
(LHsExpr p) -- input expression, arg
- (PostTc p Type) -- type of the arrow expressions f,
- -- of the form a t t', where arg :: t
HsArrAppType -- higher-order (-<<) or first-order (-<)
Bool -- True => right-to-left (f -< arg)
-- False => left-to-right (arg >- f)
@@ -630,6 +608,7 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| HsArrForm -- Command formation, (| e cmd1 .. cmdn |)
+ (XArrForm p)
(LHsExpr p) -- the operator
-- after type-checking, a type abstraction to be
-- applied to the type of the local environment tuple
@@ -641,10 +620,12 @@ data HsExpr p
-- Haskell program coverage (Hpc) Support
| HsTick
+ (XTick p)
(Tickish (IdP p))
(LHsExpr p) -- sub-expression
| HsBinTick
+ (XBinTick p)
Int -- module-local tick number for True
Int -- module-local tick number for False
(LHsExpr p) -- sub-expression
@@ -660,6 +641,7 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| HsTickPragma -- A pragma introduced tick
+ (XTickPragma p)
SourceText -- Note [Pragma source text] in BasicTypes
(StringLiteral,(Int,Int),(Int,Int))
-- external span for this tick
@@ -672,24 +654,26 @@ data HsExpr p
-- These constructors only appear temporarily in the parser.
-- The renamer translates them into the Right Thing.
- | EWildPat -- wildcard
+ | EWildPat (XEWildPat p) -- wildcard
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
-- For details on above see note [Api annotations] in ApiAnnotation
- | EAsPat (Located (IdP p)) -- as pattern
+ | EAsPat (XEAsPat p)
+ (Located (IdP p)) -- as pattern
(LHsExpr p)
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
- | EViewPat (LHsExpr p) -- view pattern
+ | EViewPat (XEViewPat p)
+ (LHsExpr p) -- view pattern
(LHsExpr p)
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
-- For details on above see note [Api annotations] in ApiAnnotation
- | ELazyPat (LHsExpr p) -- ~ pattern
+ | ELazyPat (XELazyPat p) (LHsExpr p) -- ~ pattern
---------------------------------------
@@ -698,10 +682,128 @@ data HsExpr p
-- See Note [Detecting forced eta expansion] in DsExpr. This invariant
-- is maintained by HsUtils.mkHsWrap.
- | HsWrap HsWrapper -- TRANSLATION
+ | HsWrap (XWrap p)
+ HsWrapper -- TRANSLATION
(HsExpr p)
-deriving instance (DataId p) => Data (HsExpr p)
+ | XExpr (XXExpr p) -- Note [Trees that Grow] extension constructor
+
+
+-- | Extra data fields for a 'RecordCon', added by the type checker
+data RecordConTc = RecordConTc
+ { rcon_con_like :: ConLike -- The data constructor or pattern synonym
+ , rcon_con_expr :: PostTcExpr -- Instantiated constructor function
+ }
+
+-- | Extra data fields for a 'RecordUpd', added by the type checker
+data RecordUpdTc = RecordUpdTc
+ { rupd_cons :: [ConLike]
+ -- Filled in by the type checker to the
+ -- _non-empty_ list of DataCons that have
+ -- all the upd'd fields
+
+ , rupd_in_tys :: [Type] -- Argument types of *input* record type
+ , rupd_out_tys :: [Type] -- and *output* record type
+ -- The original type can be reconstructed
+ -- with conLikeResTy
+ , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper]
+ } deriving Data
+
+-- ---------------------------------------------------------------------
+
+type instance XVar (GhcPass _) = NoExt
+type instance XUnboundVar (GhcPass _) = NoExt
+type instance XConLikeOut (GhcPass _) = NoExt
+type instance XRecFld (GhcPass _) = NoExt
+type instance XOverLabel (GhcPass _) = NoExt
+type instance XIPVar (GhcPass _) = NoExt
+type instance XOverLitE (GhcPass _) = NoExt
+type instance XLitE (GhcPass _) = NoExt
+type instance XLam (GhcPass _) = NoExt
+type instance XLamCase (GhcPass _) = NoExt
+type instance XApp (GhcPass _) = NoExt
+
+type instance XAppTypeE GhcPs = LHsWcType GhcPs
+type instance XAppTypeE GhcRn = LHsWcType GhcRn
+type instance XAppTypeE GhcTc = LHsWcType GhcRn
+
+type instance XOpApp GhcPs = NoExt
+type instance XOpApp GhcRn = Fixity
+type instance XOpApp GhcTc = Fixity
+
+type instance XNegApp (GhcPass _) = NoExt
+type instance XPar (GhcPass _) = NoExt
+type instance XSectionL (GhcPass _) = NoExt
+type instance XSectionR (GhcPass _) = NoExt
+type instance XExplicitTuple (GhcPass _) = NoExt
+
+type instance XExplicitSum GhcPs = NoExt
+type instance XExplicitSum GhcRn = NoExt
+type instance XExplicitSum GhcTc = [Type]
+
+type instance XCase (GhcPass _) = NoExt
+type instance XIf (GhcPass _) = NoExt
+
+type instance XMultiIf GhcPs = NoExt
+type instance XMultiIf GhcRn = NoExt
+type instance XMultiIf GhcTc = Type
+
+type instance XLet (GhcPass _) = NoExt
+
+type instance XDo GhcPs = NoExt
+type instance XDo GhcRn = NoExt
+type instance XDo GhcTc = Type
+
+type instance XExplicitList GhcPs = NoExt
+type instance XExplicitList GhcRn = NoExt
+type instance XExplicitList GhcTc = Type
+
+type instance XRecordCon GhcPs = NoExt
+type instance XRecordCon GhcRn = NoExt
+type instance XRecordCon GhcTc = RecordConTc
+
+type instance XRecordUpd GhcPs = NoExt
+type instance XRecordUpd GhcRn = NoExt
+type instance XRecordUpd GhcTc = RecordUpdTc
+
+type instance XExprWithTySig GhcPs = (LHsSigWcType GhcPs)
+type instance XExprWithTySig GhcRn = (LHsSigWcType GhcRn)
+type instance XExprWithTySig GhcTc = (LHsSigWcType GhcRn)
+
+type instance XArithSeq GhcPs = NoExt
+type instance XArithSeq GhcRn = NoExt
+type instance XArithSeq GhcTc = PostTcExpr
+
+type instance XSCC (GhcPass _) = NoExt
+type instance XCoreAnn (GhcPass _) = NoExt
+type instance XBracket (GhcPass _) = NoExt
+
+type instance XRnBracketOut (GhcPass _) = NoExt
+type instance XTcBracketOut (GhcPass _) = NoExt
+
+type instance XSpliceE (GhcPass _) = NoExt
+type instance XProc (GhcPass _) = NoExt
+
+type instance XStatic GhcPs = NoExt
+type instance XStatic GhcRn = NameSet
+type instance XStatic GhcTc = NameSet
+
+type instance XArrApp GhcPs = NoExt
+type instance XArrApp GhcRn = NoExt
+type instance XArrApp GhcTc = Type
+
+type instance XArrForm (GhcPass _) = NoExt
+type instance XTick (GhcPass _) = NoExt
+type instance XBinTick (GhcPass _) = NoExt
+type instance XTickPragma (GhcPass _) = NoExt
+type instance XEWildPat (GhcPass _) = NoExt
+type instance XEAsPat (GhcPass _) = NoExt
+type instance XEViewPat (GhcPass _) = NoExt
+type instance XELazyPat (GhcPass _) = NoExt
+type instance XWrap (GhcPass _) = NoExt
+type instance XXExpr (GhcPass _) = NoExt
+
+-- ---------------------------------------------------------------------
-- | Located Haskell Tuple Argument
--
@@ -716,13 +818,22 @@ type LHsTupArg id = Located (HsTupArg id)
-- | Haskell Tuple Argument
data HsTupArg id
- = Present (LHsExpr id) -- ^ The argument
- | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type
-deriving instance (DataId id) => Data (HsTupArg id)
+ = Present (XPresent id) (LHsExpr id) -- ^ The argument
+ | Missing (XMissing id) -- ^ The argument is missing, but this is its type
+ | XTupArg (XXTupArg id) -- ^ Note [Trees that Grow] extension point
+
+type instance XPresent (GhcPass _) = NoExt
+
+type instance XMissing GhcPs = NoExt
+type instance XMissing GhcRn = NoExt
+type instance XMissing GhcTc = Type
+
+type instance XXTupArg (GhcPass _) = NoExt
tupArgPresent :: LHsTupArg id -> Bool
tupArgPresent (L _ (Present {})) = True
tupArgPresent (L _ (Missing {})) = False
+tupArgPresent (L _ (XTupArg {})) = False
{-
Note [Parens in HsSyn]
@@ -740,7 +851,7 @@ HsPar (and ParPat in patterns, HsParTy in types) is used as follows
https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c
* ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or
- not they are strictly necssary. This should be addressed when #13238 is
+ not they are strictly necessary. This should be addressed when #13238 is
completed, to be treated the same as HsPar.
@@ -796,16 +907,16 @@ RenamedSource that the API Annotations cannot be used directly with
RenamedSource, so this allows a simple mapping to be used based on the location.
-}
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p) where
ppr expr = pprExpr expr
-----------------------
-- pprExpr, pprLExpr, pprBinds call pprDeeper;
-- the underscore versions do not
-pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc
pprLExpr (L _ e) = pprExpr e
-pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
+pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc
pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e
| otherwise = pprDeeper (ppr_expr e)
@@ -813,60 +924,58 @@ isQuietHsExpr :: HsExpr id -> Bool
-- Parentheses do display something, but it gives little info and
-- if we go deeper when we go inside them then we get ugly things
-- like (...)
-isQuietHsExpr (HsPar _) = True
+isQuietHsExpr (HsPar {}) = True
-- applications don't display anything themselves
-isQuietHsExpr (HsApp _ _) = True
-isQuietHsExpr (HsAppType _ _) = True
-isQuietHsExpr (HsAppTypeOut _ _) = True
-isQuietHsExpr (OpApp _ _ _ _) = True
+isQuietHsExpr (HsApp {}) = True
+isQuietHsExpr (HsAppType {}) = True
+isQuietHsExpr (OpApp {}) = True
isQuietHsExpr _ = False
-pprBinds :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => HsLocalBindsLR idL idR -> SDoc
+pprBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprBinds b = pprDeeper (ppr b)
-----------------------
-ppr_lexpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+ppr_lexpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
-ppr_expr :: forall p. (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
-ppr_expr (HsVar (L _ v)) = pprPrefixOcc v
-ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv)
-ppr_expr (HsConLikeOut c) = pprPrefixOcc c
-ppr_expr (HsIPVar v) = ppr v
-ppr_expr (HsOverLabel _ l)= char '#' <> ppr l
-ppr_expr (HsLit lit) = ppr lit
-ppr_expr (HsOverLit lit) = ppr lit
-ppr_expr (HsPar e) = parens (ppr_lexpr e)
-
-ppr_expr (HsCoreAnn stc (StringLiteral sta s) e)
+ppr_expr :: forall p. (OutputableBndrId (GhcPass p))
+ => HsExpr (GhcPass p) -> SDoc
+ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v
+ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc (unboundVarOcc uv)
+ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c
+ppr_expr (HsIPVar _ v) = ppr v
+ppr_expr (HsOverLabel _ _ l)= char '#' <> ppr l
+ppr_expr (HsLit _ lit) = ppr lit
+ppr_expr (HsOverLit _ lit) = ppr lit
+ppr_expr (HsPar _ e) = parens (ppr_lexpr e)
+
+ppr_expr (HsCoreAnn _ stc (StringLiteral sta s) e)
= vcat [pprWithSourceText stc (text "{-# CORE")
<+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}"
, ppr_lexpr e]
ppr_expr e@(HsApp {}) = ppr_apps e []
ppr_expr e@(HsAppType {}) = ppr_apps e []
-ppr_expr e@(HsAppTypeOut {}) = ppr_apps e []
-ppr_expr (OpApp e1 op _ e2)
+ppr_expr (OpApp _ e1 op e2)
| Just pp_op <- should_print_infix (unLoc op)
= pp_infixly pp_op
| otherwise
= pp_prefixly
where
- should_print_infix (HsVar (L _ v)) = Just (pprInfixOcc v)
- should_print_infix (HsConLikeOut c)= Just (pprInfixOcc (conLikeName c))
- should_print_infix (HsRecFld f) = Just (pprInfixOcc f)
- should_print_infix (HsUnboundVar h@TrueExprHole{})
+ should_print_infix (HsVar _ (L _ v)) = Just (pprInfixOcc v)
+ should_print_infix (HsConLikeOut _ c)= Just (pprInfixOcc (conLikeName c))
+ should_print_infix (HsRecFld _ f) = Just (pprInfixOcc f)
+ should_print_infix (HsUnboundVar _ h@TrueExprHole{})
= Just (pprInfixOcc (unboundVarOcc h))
- should_print_infix EWildPat = Just (text "`_`")
- should_print_infix (HsWrap _ e) = should_print_infix e
+ should_print_infix (EWildPat _) = Just (text "`_`")
+ should_print_infix (HsWrap _ _ e) = should_print_infix e
should_print_infix _ = Nothing
- pp_e1 = pprDebugParendExpr e1 -- In debug mode, add parens
- pp_e2 = pprDebugParendExpr e2 -- to make precedence clear
+ pp_e1 = pprDebugParendExpr opPrec e1 -- In debug mode, add parens
+ pp_e2 = pprDebugParendExpr opPrec e2 -- to make precedence clear
pp_prefixly
= hang (ppr op) 2 (sep [pp_e1, pp_e2])
@@ -874,63 +983,73 @@ ppr_expr (OpApp e1 op _ e2)
pp_infixly pp_op
= hang pp_e1 2 (sep [pp_op, nest 2 pp_e2])
-ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
+ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e
-ppr_expr (SectionL expr op)
+ppr_expr (SectionL _ expr op)
= case unLoc op of
- HsVar (L _ v) -> pp_infixly v
- HsConLikeOut c -> pp_infixly (conLikeName c)
- _ -> pp_prefixly
+ HsVar _ (L _ v) -> pp_infixly v
+ HsConLikeOut _ c -> pp_infixly (conLikeName c)
+ HsUnboundVar _ h@TrueExprHole{}
+ -> pp_infixly (unboundVarOcc h)
+ _ -> pp_prefixly
where
- pp_expr = pprDebugParendExpr expr
+ pp_expr = pprDebugParendExpr opPrec expr
pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
4 (hsep [pp_expr, text "x_ )"])
+
+ pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc
pp_infixly v = (sep [pp_expr, pprInfixOcc v])
-ppr_expr (SectionR op expr)
+ppr_expr (SectionR _ op expr)
= case unLoc op of
- HsVar (L _ v) -> pp_infixly v
- HsConLikeOut c -> pp_infixly (conLikeName c)
- _ -> pp_prefixly
+ HsVar _ (L _ v) -> pp_infixly v
+ HsConLikeOut _ c -> pp_infixly (conLikeName c)
+ HsUnboundVar _ h@TrueExprHole{}
+ -> pp_infixly (unboundVarOcc h)
+ _ -> pp_prefixly
where
- pp_expr = pprDebugParendExpr expr
+ pp_expr = pprDebugParendExpr opPrec expr
pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])
4 (pp_expr <> rparen)
+
+ pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc
pp_infixly v = sep [pprInfixOcc v, pp_expr]
-ppr_expr (ExplicitTuple exprs boxity)
+ppr_expr (ExplicitTuple _ exprs boxity)
= tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs))
where
ppr_tup_args [] = []
- ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
- ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es
+ ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
+ ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es
+ ppr_tup_args (XTupArg x : es) = (ppr x <> punc es) : ppr_tup_args es
punc (Present {} : _) = comma <> space
punc (Missing {} : _) = comma
+ punc (XTupArg {} : _) = comma <> space
punc [] = empty
-ppr_expr (ExplicitSum alt arity expr _)
+ppr_expr (ExplicitSum _ alt arity expr)
= text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)"
where
ppr_bars n = hsep (replicate n (char '|'))
-ppr_expr (HsLam matches)
+ppr_expr (HsLam _ matches)
= pprMatches matches
-ppr_expr (HsLamCase matches)
+ppr_expr (HsLamCase _ matches)
= sep [ sep [text "\\case"],
nest 2 (pprMatches matches) ]
-ppr_expr (HsCase expr matches@(MG { mg_alts = L _ [_] }))
+ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ [_] }))
= sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")],
nest 2 (pprMatches matches) <+> char '}']
-ppr_expr (HsCase expr matches)
+ppr_expr (HsCase _ expr matches)
= sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],
nest 2 (pprMatches matches) ]
-ppr_expr (HsIf _ e1 e2 e3)
+ppr_expr (HsIf _ _ e1 e2 e3)
= sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")],
nest 4 (ppr e2),
text "else",
@@ -938,80 +1057,76 @@ ppr_expr (HsIf _ e1 e2 e3)
ppr_expr (HsMultiIf _ alts)
= hang (text "if") 3 (vcat (map ppr_alt alts))
- where ppr_alt (L _ (GRHS guards expr)) =
+ where ppr_alt (L _ (GRHS _ guards expr)) =
hang vbar 2 (ppr_one one_alt)
where
ppr_one [] = panic "ppr_exp HsMultiIf"
ppr_one (h:t) = hang h 2 (sep t)
one_alt = [ interpp'SP guards
, text "->" <+> pprDeeper (ppr expr) ]
+ ppr_alt (L _ (XGRHS x)) = ppr x
-- special case: let ... in let ...
-ppr_expr (HsLet (L _ binds) expr@(L _ (HsLet _ _)))
+ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _)))
= sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),
ppr_lexpr expr]
-ppr_expr (HsLet (L _ binds) expr)
+ppr_expr (HsLet _ (L _ binds) expr)
= sep [hang (text "let") 2 (pprBinds binds),
hang (text "in") 2 (ppr expr)]
-ppr_expr (HsDo do_or_list_comp (L _ stmts) _) = pprDo do_or_list_comp stmts
+ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts
ppr_expr (ExplicitList _ _ exprs)
= brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
-ppr_expr (ExplicitPArr _ exprs)
- = paBrackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
-
ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })
= hang (ppr con_id) 2 (ppr rbinds)
ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds })
= hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
-ppr_expr (ExprWithTySig expr sig)
- = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
- 4 (ppr sig)
-ppr_expr (ExprWithTySigOut expr sig)
+ppr_expr (ExprWithTySig sig expr)
= hang (nest 2 (ppr_lexpr expr) <+> dcolon)
4 (ppr sig)
ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
-ppr_expr (PArrSeq _ info) = paBrackets (ppr info)
-ppr_expr EWildPat = char '_'
-ppr_expr (ELazyPat e) = char '~' <> ppr e
-ppr_expr (EAsPat v e) = ppr v <> char '@' <> ppr e
-ppr_expr (EViewPat p e) = ppr p <+> text "->" <+> ppr e
+ppr_expr (EWildPat _) = char '_'
+ppr_expr (ELazyPat _ e) = char '~' <> ppr e
+ppr_expr (EAsPat _ (L _ v) e) = pprPrefixOcc v <> char '@' <> ppr e
+ppr_expr (EViewPat _ p e) = ppr p <+> text "->" <+> ppr e
-ppr_expr (HsSCC st (StringLiteral stl lbl) expr)
+ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr)
= sep [ pprWithSourceText st (text "{-# SCC")
-- no doublequotes if stl empty, for the case where the SCC was written
-- without quotes.
<+> pprWithSourceText stl (ftext lbl) <+> text "#-}",
ppr expr ]
-ppr_expr (HsWrap co_fn e)
+ppr_expr (HsWrap _ co_fn e)
= pprHsWrapper co_fn (\parens -> if parens then pprExpr e
else pprExpr e)
-ppr_expr (HsSpliceE s) = pprSplice s
-ppr_expr (HsBracket b) = pprHsBracket b
-ppr_expr (HsRnBracketOut e []) = ppr e
-ppr_expr (HsRnBracketOut e ps) = ppr e $$ text "pending(rn)" <+> ppr ps
-ppr_expr (HsTcBracketOut e []) = ppr e
-ppr_expr (HsTcBracketOut e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
+ppr_expr (HsSpliceE _ s) = pprSplice s
+ppr_expr (HsBracket _ b) = pprHsBracket b
+ppr_expr (HsRnBracketOut _ e []) = ppr e
+ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps
+ppr_expr (HsTcBracketOut _ e []) = ppr e
+ppr_expr (HsTcBracketOut _ e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
-ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
+ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
= hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]
+ppr_expr (HsProc _ pat (L _ (XCmdTop x)))
+ = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr x]
ppr_expr (HsStatic _ e)
= hsep [text "static", ppr e]
-ppr_expr (HsTick tickish exp)
+ppr_expr (HsTick _ tickish exp)
= pprTicks (ppr exp) $
ppr tickish <+> ppr_lexpr exp
-ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
+ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp)
= pprTicks (ppr exp) $
hcat [text "bintick<",
ppr tickIdTrue,
@@ -1019,7 +1134,7 @@ ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
ppr tickIdFalse,
text ">(",
ppr exp, text ")"]
-ppr_expr (HsTickPragma _ externalSrcLoc _ exp)
+ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp)
= pprTicks (ppr exp) $
hcat [text "tickpragma<",
pprExternalSrcLoc externalSrcLoc,
@@ -1027,44 +1142,40 @@ ppr_expr (HsTickPragma _ externalSrcLoc _ exp)
ppr exp,
text ")"]
-ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
+ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp True)
= hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
-ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)
+ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp False)
= hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
-ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True)
+ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp True)
= hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
-ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
+ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp False)
= hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
-ppr_expr (HsArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2])
+ppr_expr (HsArrForm _ (L _ (HsVar _ (L _ v))) (Just _) [arg1, arg2])
= sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
-ppr_expr (HsArrForm (L _ (HsConLikeOut c)) (Just _) [arg1, arg2])
+ppr_expr (HsArrForm _ (L _ (HsConLikeOut _ c)) (Just _) [arg1, arg2])
= sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc (conLikeName c), pprCmdArg (unLoc arg2)]]
-ppr_expr (HsArrForm op _ args)
+ppr_expr (HsArrForm _ op _ args)
= hang (text "(|" <+> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")
-ppr_expr (HsRecFld f) = ppr f
-
--- We must tiresomely make the "id" parameter to the LHsWcType existential
--- because it's different in the HsAppType case and the HsAppTypeOut case
--- | Located Haskell Wildcard Type Expression
-data LHsWcTypeX = forall p. (SourceTextX p, OutputableBndrId p)
- => LHsWcTypeX (LHsWcType p)
+ppr_expr (HsRecFld _ f) = ppr f
+ppr_expr (XExpr x) = ppr x
-ppr_apps :: (SourceTextX p, OutputableBndrId p) => HsExpr p
- -> [Either (LHsExpr p) LHsWcTypeX]
+ppr_apps :: (OutputableBndrId (GhcPass p))
+ => HsExpr (GhcPass p)
+ -> [Either (LHsExpr (GhcPass p)) (XAppTypeE (GhcPass p))]
-> SDoc
-ppr_apps (HsApp (L _ fun) arg) args
+ppr_apps (HsApp _ (L _ fun) arg) args
= ppr_apps fun (Left arg : args)
-ppr_apps (HsAppType (L _ fun) arg) args
- = ppr_apps fun (Right (LHsWcTypeX arg) : args)
-ppr_apps (HsAppTypeOut (L _ fun) arg) args
- = ppr_apps fun (Right (LHsWcTypeX arg) : args)
+ppr_apps (HsAppType arg (L _ fun)) args
+ = ppr_apps fun (Right arg : args)
ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args))
where
pp (Left arg) = ppr arg
- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
- = char '@' <> pprHsType arg
+ -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
+ -- = char '@' <> pprHsType arg
+ pp (Right arg)
+ = char '@' <> ppr arg
pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
@@ -1082,50 +1193,87 @@ fixities should do the job, except in debug mode (-dppr-debug) so we
can see the structure of the parse tree.
-}
-pprDebugParendExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
-pprDebugParendExpr expr
+pprDebugParendExpr :: (OutputableBndrId (GhcPass p))
+ => PprPrec -> LHsExpr (GhcPass p) -> SDoc
+pprDebugParendExpr p expr
= getPprStyle (\sty ->
- if debugStyle sty then pprParendLExpr expr
+ if debugStyle sty then pprParendLExpr p expr
else pprLExpr expr)
-pprParendLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
-pprParendLExpr (L _ e) = pprParendExpr e
+pprParendLExpr :: (OutputableBndrId (GhcPass p))
+ => PprPrec -> LHsExpr (GhcPass p) -> SDoc
+pprParendLExpr p (L _ e) = pprParendExpr p e
-pprParendExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
-pprParendExpr expr
- | hsExprNeedsParens expr = parens (pprExpr expr)
- | otherwise = pprExpr expr
+pprParendExpr :: (OutputableBndrId (GhcPass p))
+ => PprPrec -> HsExpr (GhcPass p) -> SDoc
+pprParendExpr p expr
+ | hsExprNeedsParens p expr = parens (pprExpr expr)
+ | otherwise = pprExpr expr
-- Using pprLExpr makes sure that we go 'deeper'
-- I think that is usually (always?) right
-hsExprNeedsParens :: HsExpr id -> Bool
--- True of expressions for which '(e)' and 'e'
--- mean the same thing
-hsExprNeedsParens (ArithSeq {}) = False
-hsExprNeedsParens (PArrSeq {}) = False
-hsExprNeedsParens (HsLit {}) = False
-hsExprNeedsParens (HsOverLit {}) = False
-hsExprNeedsParens (HsVar {}) = False
-hsExprNeedsParens (HsUnboundVar {}) = False
-hsExprNeedsParens (HsConLikeOut {}) = False
-hsExprNeedsParens (HsIPVar {}) = False
-hsExprNeedsParens (HsOverLabel {}) = False
-hsExprNeedsParens (ExplicitTuple {}) = False
-hsExprNeedsParens (ExplicitList {}) = False
-hsExprNeedsParens (ExplicitPArr {}) = False
-hsExprNeedsParens (HsPar {}) = False
-hsExprNeedsParens (HsBracket {}) = False
-hsExprNeedsParens (HsRnBracketOut {}) = False
-hsExprNeedsParens (HsTcBracketOut {}) = False
-hsExprNeedsParens (HsDo sc _ _)
- | isListCompExpr sc = False
-hsExprNeedsParens (HsRecFld{}) = False
-hsExprNeedsParens (RecordCon{}) = False
-hsExprNeedsParens (HsSpliceE{}) = False
-hsExprNeedsParens (RecordUpd{}) = False
-hsExprNeedsParens (HsWrap _ e) = hsExprNeedsParens e
-hsExprNeedsParens _ = True
-
+-- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs
+-- parentheses under precedence @p@.
+hsExprNeedsParens :: PprPrec -> HsExpr p -> Bool
+hsExprNeedsParens p = go
+ where
+ go (HsVar{}) = False
+ go (HsUnboundVar{}) = False
+ go (HsConLikeOut{}) = False
+ go (HsIPVar{}) = False
+ go (HsOverLabel{}) = False
+ go (HsLit _ l) = hsLitNeedsParens p l
+ go (HsOverLit _ ol) = hsOverLitNeedsParens p ol
+ go (HsPar{}) = False
+ go (HsCoreAnn _ _ _ (L _ e)) = go e
+ go (HsApp{}) = p >= appPrec
+ go (HsAppType {}) = p >= appPrec
+ go (OpApp{}) = p >= opPrec
+ go (NegApp{}) = p > topPrec
+ go (SectionL{}) = True
+ go (SectionR{}) = True
+ go (ExplicitTuple{}) = False
+ go (ExplicitSum{}) = False
+ go (HsLam{}) = p > topPrec
+ go (HsLamCase{}) = p > topPrec
+ go (HsCase{}) = p > topPrec
+ go (HsIf{}) = p > topPrec
+ go (HsMultiIf{}) = p > topPrec
+ go (HsLet{}) = p > topPrec
+ go (HsDo _ sc _)
+ | isComprehensionContext sc = False
+ | otherwise = p > topPrec
+ go (ExplicitList{}) = False
+ go (RecordUpd{}) = False
+ go (ExprWithTySig{}) = p > topPrec
+ go (ArithSeq{}) = False
+ go (EWildPat{}) = False
+ go (ELazyPat{}) = False
+ go (EAsPat{}) = False
+ go (EViewPat{}) = True
+ go (HsSCC{}) = p >= appPrec
+ go (HsWrap _ _ e) = go e
+ go (HsSpliceE{}) = False
+ go (HsBracket{}) = False
+ go (HsRnBracketOut{}) = False
+ go (HsTcBracketOut{}) = False
+ go (HsProc{}) = p > topPrec
+ go (HsStatic{}) = p >= appPrec
+ go (HsTick _ _ (L _ e)) = go e
+ go (HsBinTick _ _ _ (L _ e)) = go e
+ go (HsTickPragma _ _ _ _ (L _ e)) = go e
+ go (HsArrApp{}) = True
+ go (HsArrForm{}) = True
+ go (RecordCon{}) = False
+ go (HsRecFld{}) = False
+ go (XExpr{}) = True
+
+-- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true,
+-- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@.
+parenthesizeHsExpr :: PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
+parenthesizeHsExpr p le@(L loc e)
+ | hsExprNeedsParens p e = L loc (HsPar NoExt le)
+ | otherwise = le
isAtomicHsExpr :: HsExpr id -> Bool
-- True of a single token
@@ -1136,8 +1284,8 @@ isAtomicHsExpr (HsOverLit {}) = True
isAtomicHsExpr (HsIPVar {}) = True
isAtomicHsExpr (HsOverLabel {}) = True
isAtomicHsExpr (HsUnboundVar {}) = True
-isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e
-isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e)
+isAtomicHsExpr (HsWrap _ _ e) = isAtomicHsExpr e
+isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e)
isAtomicHsExpr (HsRecFld{}) = True
isAtomicHsExpr _ = False
@@ -1162,10 +1310,10 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
= HsCmdArrApp -- Arrow tail, or arrow application (f -< arg)
+ (XCmdArrApp id) -- type of the arrow expressions f,
+ -- of the form a t t', where arg :: t
(LHsExpr id) -- arrow expression, f
(LHsExpr id) -- input expression, arg
- (PostTc id Type) -- type of the arrow expressions f,
- -- of the form a t t', where arg :: t
HsArrAppType -- higher-order (-<<) or first-order (-<)
Bool -- True => right-to-left (f -< arg)
-- False => left-to-right (arg >- f)
@@ -1175,6 +1323,7 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
| HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |)
+ (XCmdArrForm id)
(LHsExpr id) -- The operator.
-- After type-checking, a type abstraction to be
-- applied to the type of the local environment tuple
@@ -1184,22 +1333,26 @@ data HsCmd id
-- were converted from OpApp's by the renamer
[LHsCmdTop id] -- argument commands
- | HsCmdApp (LHsCmd id)
+ | HsCmdApp (XCmdApp id)
+ (LHsCmd id)
(LHsExpr id)
- | HsCmdLam (MatchGroup id (LHsCmd id)) -- kappa
+ | HsCmdLam (XCmdLam id)
+ (MatchGroup id (LHsCmd id)) -- kappa
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
-- 'ApiAnnotation.AnnRarrow',
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCmdPar (LHsCmd id) -- parenthesised command
+ | HsCmdPar (XCmdPar id)
+ (LHsCmd id) -- parenthesised command
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
-- 'ApiAnnotation.AnnClose' @')'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCmdCase (LHsExpr id)
+ | HsCmdCase (XCmdCase id)
+ (LHsExpr id)
(MatchGroup id (LHsCmd id)) -- bodies are HsCmd's
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',
-- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,
@@ -1207,7 +1360,8 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCmdIf (Maybe (SyntaxExpr id)) -- cond function
+ | HsCmdIf (XCmdIf id)
+ (Maybe (SyntaxExpr id)) -- cond function
(LHsExpr id) -- predicate
(LHsCmd id) -- then part
(LHsCmd id) -- else part
@@ -1218,7 +1372,8 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCmdLet (LHsLocalBinds id) -- let(rec)
+ | HsCmdLet (XCmdLet id)
+ (LHsLocalBinds id) -- let(rec)
(LHsCmd id)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',
-- 'ApiAnnotation.AnnOpen' @'{'@,
@@ -1226,8 +1381,8 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCmdDo (Located [CmdLStmt id])
- (PostTc id Type) -- Type of the whole expression
+ | HsCmdDo (XCmdDo id) -- Type of the whole expression
+ (Located [CmdLStmt id])
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',
-- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi',
-- 'ApiAnnotation.AnnVbar',
@@ -1235,11 +1390,31 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCmdWrap HsWrapper
+ | HsCmdWrap (XCmdWrap id)
+ HsWrapper
(HsCmd id) -- If cmd :: arg1 --> res
-- wrap :: arg1 "->" arg2
-- Then (HsCmdWrap wrap cmd) :: arg2 --> res
-deriving instance (DataId id) => Data (HsCmd id)
+ | XCmd (XXCmd id) -- Note [Trees that Grow] extension point
+
+type instance XCmdArrApp GhcPs = NoExt
+type instance XCmdArrApp GhcRn = NoExt
+type instance XCmdArrApp GhcTc = Type
+
+type instance XCmdArrForm (GhcPass _) = NoExt
+type instance XCmdApp (GhcPass _) = NoExt
+type instance XCmdLam (GhcPass _) = NoExt
+type instance XCmdPar (GhcPass _) = NoExt
+type instance XCmdCase (GhcPass _) = NoExt
+type instance XCmdIf (GhcPass _) = NoExt
+type instance XCmdLet (GhcPass _) = NoExt
+
+type instance XCmdDo GhcPs = NoExt
+type instance XCmdDo GhcRn = NoExt
+type instance XCmdDo GhcTc = Type
+
+type instance XCmdWrap (GhcPass _) = NoExt
+type instance XXCmd (GhcPass _) = NoExt
-- | Haskell Array Application Type
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
@@ -1256,22 +1431,31 @@ type LHsCmdTop p = Located (HsCmdTop p)
-- | Haskell Top-level Command
data HsCmdTop p
- = HsCmdTop (LHsCmd p)
- (PostTc p Type) -- Nested tuple of inputs on the command's stack
- (PostTc p Type) -- return type of the command
- (CmdSyntaxTable p) -- See Note [CmdSyntaxTable]
-deriving instance (DataId p) => Data (HsCmdTop p)
+ = HsCmdTop (XCmdTop p)
+ (LHsCmd p)
+ | XCmdTop (XXCmdTop p) -- Note [Trees that Grow] extension point
+
+data CmdTopTc
+ = CmdTopTc Type -- Nested tuple of inputs on the command's stack
+ Type -- return type of the command
+ (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable]
+
+type instance XCmdTop GhcPs = NoExt
+type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable]
+type instance XCmdTop GhcTc = CmdTopTc
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p) where
+type instance XXCmdTop (GhcPass _) = NoExt
+
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) where
ppr cmd = pprCmd cmd
-----------------------
-- pprCmd and pprLCmd call pprDeeper;
-- the underscore versions do not
-pprLCmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc
+pprLCmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc
pprLCmd (L _ c) = pprCmd c
-pprCmd :: (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc
+pprCmd :: (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc
pprCmd c | isQuietHsCmd c = ppr_cmd c
| otherwise = pprDeeper (ppr_cmd c)
@@ -1279,81 +1463,83 @@ isQuietHsCmd :: HsCmd id -> Bool
-- Parentheses do display something, but it gives little info and
-- if we go deeper when we go inside them then we get ugly things
-- like (...)
-isQuietHsCmd (HsCmdPar _) = True
+isQuietHsCmd (HsCmdPar {}) = True
-- applications don't display anything themselves
-isQuietHsCmd (HsCmdApp _ _) = True
+isQuietHsCmd (HsCmdApp {}) = True
isQuietHsCmd _ = False
-----------------------
-ppr_lcmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc
+ppr_lcmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc
ppr_lcmd c = ppr_cmd (unLoc c)
-ppr_cmd :: forall p. (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc
-ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c)
+ppr_cmd :: forall p. (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc
+ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c)
-ppr_cmd (HsCmdApp c e)
+ppr_cmd (HsCmdApp _ c e)
= let (fun, args) = collect_args c [e] in
hang (ppr_lcmd fun) 2 (sep (map ppr args))
where
- collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args)
+ collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args)
collect_args fun args = (fun, args)
-ppr_cmd (HsCmdLam matches)
+ppr_cmd (HsCmdLam _ matches)
= pprMatches matches
-ppr_cmd (HsCmdCase expr matches)
+ppr_cmd (HsCmdCase _ expr matches)
= sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],
nest 2 (pprMatches matches) ]
-ppr_cmd (HsCmdIf _ e ct ce)
+ppr_cmd (HsCmdIf _ _ e ct ce)
= sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")],
nest 4 (ppr ct),
text "else",
nest 4 (ppr ce)]
-- special case: let ... in let ...
-ppr_cmd (HsCmdLet (L _ binds) cmd@(L _ (HsCmdLet _ _)))
+ppr_cmd (HsCmdLet _ (L _ binds) cmd@(L _ (HsCmdLet {})))
= sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),
ppr_lcmd cmd]
-ppr_cmd (HsCmdLet (L _ binds) cmd)
+ppr_cmd (HsCmdLet _ (L _ binds) cmd)
= sep [hang (text "let") 2 (pprBinds binds),
hang (text "in") 2 (ppr cmd)]
-ppr_cmd (HsCmdDo (L _ stmts) _) = pprDo ArrowExpr stmts
+ppr_cmd (HsCmdDo _ (L _ stmts)) = pprDo ArrowExpr stmts
-ppr_cmd (HsCmdWrap w cmd)
+ppr_cmd (HsCmdWrap _ w cmd)
= pprHsWrapper w (\_ -> parens (ppr_cmd cmd))
-ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True)
+ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)
= hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
-ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False)
+ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False)
= hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
-ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True)
+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True)
= hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
-ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False)
+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False)
= hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
-ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) _ (Just _) [arg1, arg2])
+ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2])
= hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
, pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) Infix _ [arg1, arg2])
+ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _ [arg1, arg2])
= hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
, pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) _ (Just _) [arg1, arg2])
+ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2])
= hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
, pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) Infix _ [arg1, arg2])
+ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2])
= hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
, pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm op _ _ args)
+ppr_cmd (HsCmdArrForm _ op _ _ args)
= hang (text "(|" <> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <> text "|)")
+ppr_cmd (XCmd x) = ppr x
-pprCmdArg :: (SourceTextX p, OutputableBndrId p) => HsCmdTop p -> SDoc
-pprCmdArg (HsCmdTop cmd _ _ _)
+pprCmdArg :: (OutputableBndrId (GhcPass p)) => HsCmdTop (GhcPass p) -> SDoc
+pprCmdArg (HsCmdTop _ cmd)
= ppr_lcmd cmd
+pprCmdArg (XCmdTop x) = ppr x
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmdTop p) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmdTop p) where
ppr = pprCmdArg
{-
@@ -1390,14 +1576,25 @@ patterns in each equation.
-}
data MatchGroup p body
- = MG { mg_alts :: Located [LMatch p body] -- The alternatives
- , mg_arg_tys :: [PostTc p Type] -- Types of the arguments, t1..tn
- , mg_res_ty :: PostTc p Type -- Type of the result, tr
+ = MG { mg_ext :: XMG p body -- Posr typechecker, types of args and result
+ , mg_alts :: Located [LMatch p body] -- The alternatives
, mg_origin :: Origin }
-- The type is the type of the entire group
-- t1 -> ... -> tn -> tr
-- where there are n patterns
-deriving instance (Data body,DataId p) => Data (MatchGroup p body)
+ | XMatchGroup (XXMatchGroup p body)
+
+data MatchGroupTc
+ = MatchGroupTc
+ { mg_arg_tys :: [Type] -- Types of the arguments, t1..tn
+ , mg_res_ty :: Type -- Type of the result, tr
+ } deriving Data
+
+type instance XMG GhcPs b = NoExt
+type instance XMG GhcRn b = NoExt
+type instance XMG GhcTc b = MatchGroupTc
+
+type instance XXMatchGroup (GhcPass _) b = NoExt
-- | Located Match
type LMatch id body = Located (Match id body)
@@ -1407,18 +1604,18 @@ type LMatch id body = Located (Match id body)
-- For details on above see note [Api annotations] in ApiAnnotation
data Match p body
= Match {
+ m_ext :: XCMatch p body,
m_ctxt :: HsMatchContext (NameOrRdrName (IdP p)),
-- See note [m_ctxt in Match]
m_pats :: [LPat p], -- The patterns
- m_type :: (Maybe (LHsType p)),
- -- A type signature for the result of the match
- -- Nothing after typechecking
- -- NB: No longer supported
m_grhss :: (GRHSs p body)
}
-deriving instance (Data body,DataId p) => Data (Match p body)
+ | XMatch (XXMatch p body)
+
+type instance XCMatch (GhcPass _) b = NoExt
+type instance XXMatch (GhcPass _) b = NoExt
-instance (SourceTextX idR, OutputableBndrId idR, Outputable body)
+instance (idR ~ GhcPass pr, OutputableBndrId idR, Outputable body)
=> Outputable (Match idR body) where
ppr = pprMatch
@@ -1466,6 +1663,7 @@ isInfixMatch match = case m_ctxt match of
isEmptyMatchGroup :: MatchGroup id body -> Bool
isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms
+isEmptyMatchGroup (XMatchGroup{}) = panic "isEmptyMatchGroup"
-- | Is there only one RHS in this list of matches?
isSingletonMatchGroup :: [LMatch id body] -> Bool
@@ -1482,9 +1680,11 @@ matchGroupArity :: MatchGroup id body -> Arity
matchGroupArity (MG { mg_alts = alts })
| L _ (alt1:_) <- alts = length (hsLMatchPats alt1)
| otherwise = panic "matchGroupArity"
+matchGroupArity (XMatchGroup{}) = panic "matchGroupArity"
hsLMatchPats :: LMatch id body -> [LPat id]
-hsLMatchPats (L _ (Match _ pats _ _)) = pats
+hsLMatchPats (L _ (Match { m_pats = pats })) = pats
+hsLMatchPats (L _ (XMatch _)) = panic "hsLMatchPats"
-- | Guarded Right-Hand Sides
--
@@ -1498,46 +1698,54 @@ hsLMatchPats (L _ (Match _ pats _ _)) = pats
-- For details on above see note [Api annotations] in ApiAnnotation
data GRHSs p body
= GRHSs {
+ grhssExt :: XCGRHSs p body,
grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs
grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause
}
-deriving instance (Data body,DataId p) => Data (GRHSs p body)
+ | XGRHSs (XXGRHSs p body)
+
+type instance XCGRHSs (GhcPass _) b = NoExt
+type instance XXGRHSs (GhcPass _) b = NoExt
-- | Located Guarded Right-Hand Side
type LGRHS id body = Located (GRHS id body)
-- | Guarded Right Hand Side.
-data GRHS id body = GRHS [GuardLStmt id] -- Guards
- body -- Right hand side
-deriving instance (Data body,DataId id) => Data (GRHS id body)
+data GRHS p body = GRHS (XCGRHS p body)
+ [GuardLStmt p] -- Guards
+ body -- Right hand side
+ | XGRHS (XXGRHS p body)
+
+type instance XCGRHS (GhcPass _) b = NoExt
+type instance XXGRHS (GhcPass _) b = NoExt
-- We know the list must have at least one @Match@ in it.
-pprMatches :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => MatchGroup idR body -> SDoc
+pprMatches :: (OutputableBndrId (GhcPass idR), Outputable body)
+ => MatchGroup (GhcPass idR) body -> SDoc
pprMatches MG { mg_alts = matches }
= vcat (map pprMatch (map unLoc (unLoc matches)))
-- Don't print the type; it's only a place-holder before typechecking
+pprMatches (XMatchGroup x) = ppr x
-- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => MatchGroup idR body -> SDoc
+pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body)
+ => MatchGroup (GhcPass idR) body -> SDoc
pprFunBind matches = pprMatches matches
-- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr,
- OutputableBndrId bndr,
- OutputableBndrId p,
+pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr),
+ OutputableBndrId (GhcPass p),
Outputable body)
- => LPat bndr -> GRHSs p body -> SDoc
+ => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
pprPatBind pat (grhss)
- = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP p)) grhss)]
+ = sep [ppr pat,
+ nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)]
-pprMatch :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => Match idR body -> SDoc
+pprMatch :: (OutputableBndrId (GhcPass idR), Outputable body)
+ => Match (GhcPass idR) body -> SDoc
pprMatch match
- = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
- , nest 2 ppr_maybe_ty
+ = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)
, nest 2 (pprGRHSs ctxt (m_grhss match)) ]
where
ctxt = m_ctxt match
@@ -1558,37 +1766,40 @@ pprMatch match
| otherwise -> (parens pp_infix, pats2)
-- (x &&& y) z = e
where
- pp_infix = pprParendLPat pat1 <+> pprInfixOcc fun <+> pprParendLPat pat2
+ pp_infix = pprParendLPat opPrec pat1
+ <+> pprInfixOcc fun
+ <+> pprParendLPat opPrec pat2
LambdaExpr -> (char '\\', m_pats match)
- _ -> ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 )
- (ppr pat1, []) -- No parens around the single pat
+ _ -> if null (m_pats match)
+ then (empty, [])
+ else ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 )
+ (ppr pat1, []) -- No parens around the single pat
(pat1:pats1) = m_pats match
(pat2:pats2) = pats1
- ppr_maybe_ty = case m_type match of
- Just ty -> dcolon <+> ppr ty
- Nothing -> empty
-
-pprGRHSs :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => HsMatchContext idL -> GRHSs idR body -> SDoc
-pprGRHSs ctxt (GRHSs grhss (L _ binds))
+pprGRHSs :: (OutputableBndrId (GhcPass idR), Outputable body)
+ => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc
+pprGRHSs ctxt (GRHSs _ grhss (L _ binds))
= vcat (map (pprGRHS ctxt . unLoc) grhss)
-- Print the "where" even if the contents of the binds is empty. Only
-- EmptyLocalBinds means no "where" keyword
$$ ppUnless (eqEmptyLocalBinds binds)
(text "where" $$ nest 4 (pprBinds binds))
+pprGRHSs _ (XGRHSs x) = ppr x
-pprGRHS :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => HsMatchContext idL -> GRHS idR body -> SDoc
-pprGRHS ctxt (GRHS [] body)
+pprGRHS :: (OutputableBndrId (GhcPass idR), Outputable body)
+ => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc
+pprGRHS ctxt (GRHS _ [] body)
= pp_rhs ctxt body
-pprGRHS ctxt (GRHS guards body)
+pprGRHS ctxt (GRHS _ guards body)
= sep [vbar <+> interpp'SP guards, pp_rhs ctxt body]
+pprGRHS _ (XGRHS x) = ppr x
+
pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
@@ -1643,30 +1854,30 @@ type GhciStmt id = Stmt id (LHsExpr id)
-- For details on above see note [Api annotations] in ApiAnnotation
data StmtLR idL idR body -- body should always be (LHs**** idR)
- = LastStmt -- Always the last Stmt in ListComp, MonadComp, PArrComp,
- -- and (after the renamer) DoExpr, MDoExpr
+ = LastStmt -- Always the last Stmt in ListComp, MonadComp,
+ -- and (after the renamer, see RnExpr.checkLastStmt) DoExpr, MDoExpr
-- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff
+ (XLastStmt idL idR body)
body
Bool -- True <=> return was stripped by ApplicativeDo
- (SyntaxExpr idR) -- The return operator, used only for
- -- MonadComp For ListComp, PArrComp, we
- -- use the baked-in 'return' For DoExpr,
- -- MDoExpr, we don't apply a 'return' at
- -- all See Note [Monad Comprehensions] |
- -- - 'ApiAnnotation.AnnKeywordId' :
- -- 'ApiAnnotation.AnnLarrow'
+ (SyntaxExpr idR) -- The return operator
+ -- The return operator is used only for MonadComp
+ -- For ListComp we use the baked-in 'return'
+ -- For DoExpr, MDoExpr, we don't apply a 'return' at all
+ -- See Note [Monad Comprehensions]
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
- | BindStmt (LPat idL)
+ | BindStmt (XBindStmt idL idR body) -- Post typechecking,
+ -- result type of the function passed to bind;
+ -- that is, S in (>>=) :: Q -> (R -> S) -> T
+ (LPat idL)
body
(SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts]
(SyntaxExpr idR) -- The fail operator
-- The fail operator is noSyntaxExpr
-- if the pattern match can't fail
- (PostTc idR Type) -- result type of the function passed to bind;
- -- that is, S in (>>=) :: Q -> (R -> S) -> T
-
-- | 'ApplicativeStmt' represents an applicative expression built with
-- <$> and <*>. It is generated by the renamer, and is desugared into the
-- appropriate applicative expression by the desugarer, but it is intended
@@ -1675,34 +1886,38 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
-- For full details, see Note [ApplicativeDo] in RnExpr
--
| ApplicativeStmt
+ (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body
[ ( SyntaxExpr idR
- , ApplicativeArg idL idR) ]
+ , ApplicativeArg idL) ]
-- [(<$>, e1), (<*>, e2), ..., (<*>, en)]
(Maybe (SyntaxExpr idR)) -- 'join', if necessary
- (PostTc idR Type) -- Type of the body
- | BodyStmt body -- See Note [BodyStmt]
+ | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type
+ -- of the RHS (used for arrows)
+ body -- See Note [BodyStmt]
(SyntaxExpr idR) -- The (>>) operator
(SyntaxExpr idR) -- The `guard` operator; used only in MonadComp
-- See notes [Monad Comprehensions]
- (PostTc idR Type) -- Element type of the RHS (used for arrows)
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet'
-- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@,
-- For details on above see note [Api annotations] in ApiAnnotation
- | LetStmt (LHsLocalBindsLR idL idR)
+ | LetStmt (XLetStmt idL idR body) (LHsLocalBindsLR idL idR)
-- ParStmts only occur in a list/monad comprehension
- | ParStmt [ParStmtBlock idL idR]
+ | ParStmt (XParStmt idL idR body) -- Post typecheck,
+ -- S in (>>=) :: Q -> (R -> S) -> T
+ [ParStmtBlock idL idR]
(HsExpr idR) -- Polymorphic `mzip` for monad comprehensions
(SyntaxExpr idR) -- The `>>=` operator
-- See notes [Monad Comprehensions]
- (PostTc idR Type) -- S in (>>=) :: Q -> (R -> S) -> T
-- After renaming, the ids are the binders
-- bound by the stmts and used after themp
| TransStmt {
+ trS_ext :: XTransStmt idL idR body, -- Post typecheck,
+ -- R in (>>=) :: Q -> (R -> S) -> T
trS_form :: TransForm,
trS_stmts :: [ExprLStmt idL], -- Stmts to the *left* of the 'group'
-- which generates the tuples to be grouped
@@ -1716,7 +1931,6 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for
-- the inner monad comprehensions
trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator
- trS_bind_arg_ty :: PostTc idR Type, -- R in (>>=) :: Q -> (R -> S) -> T
trS_fmap :: HsExpr idR -- The polymorphic 'fmap' function for desugaring
-- Only for 'group' forms
-- Just a simple HsExpr, because it's
@@ -1728,7 +1942,8 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
-- For details on above see note [Api annotations] in ApiAnnotation
| RecStmt
- { recS_stmts :: [LStmtLR idL idR body]
+ { recS_ext :: XRecStmt idL idR body
+ , recS_stmts :: [LStmtLR idL idR body]
-- The next two fields are only valid after renaming
, recS_later_ids :: [IdP idR]
@@ -1747,26 +1962,59 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
, recS_bind_fn :: SyntaxExpr idR -- The bind function
, recS_ret_fn :: SyntaxExpr idR -- The return function
, recS_mfix_fn :: SyntaxExpr idR -- The mfix function
- , recS_bind_ty :: PostTc idR Type -- S in (>>=) :: Q -> (R -> S) -> T
+ }
+ | XStmtLR (XXStmtLR idL idR body)
- -- These fields are only valid after typechecking
+-- Extra fields available post typechecking for RecStmt.
+data RecStmtTc =
+ RecStmtTc
+ { recS_bind_ty :: Type -- S in (>>=) :: Q -> (R -> S) -> T
, recS_later_rets :: [PostTcExpr] -- (only used in the arrow version)
, recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1
- -- with recS_later_ids and recS_rec_ids,
- -- and are the expressions that should be
- -- returned by the recursion.
- -- They may not quite be the Ids themselves,
- -- because the Id may be *polymorphic*, but
- -- the returned thing has to be *monomorphic*,
- -- so they may be type applications
-
- , recS_ret_ty :: PostTc idR Type -- The type of
- -- do { stmts; return (a,b,c) }
+ -- with recS_later_ids and recS_rec_ids,
+ -- and are the expressions that should be
+ -- returned by the recursion.
+ -- They may not quite be the Ids themselves,
+ -- because the Id may be *polymorphic*, but
+ -- the returned thing has to be *monomorphic*,
+ -- so they may be type applications
+
+ , recS_ret_ty :: Type -- The type of
+ -- do { stmts; return (a,b,c) }
-- With rebindable syntax the type might not
-- be quite as simple as (m (tya, tyb, tyc)).
}
-deriving instance (Data body, DataId idL, DataId idR)
- => Data (StmtLR idL idR body)
+
+
+type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExt
+
+type instance XBindStmt (GhcPass _) GhcPs b = NoExt
+type instance XBindStmt (GhcPass _) GhcRn b = NoExt
+type instance XBindStmt (GhcPass _) GhcTc b = Type
+
+type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExt
+type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExt
+type instance XApplicativeStmt (GhcPass _) GhcTc b = Type
+
+type instance XBodyStmt (GhcPass _) GhcPs b = NoExt
+type instance XBodyStmt (GhcPass _) GhcRn b = NoExt
+type instance XBodyStmt (GhcPass _) GhcTc b = Type
+
+type instance XLetStmt (GhcPass _) (GhcPass _) b = NoExt
+
+type instance XParStmt (GhcPass _) GhcPs b = NoExt
+type instance XParStmt (GhcPass _) GhcRn b = NoExt
+type instance XParStmt (GhcPass _) GhcTc b = Type
+
+type instance XTransStmt (GhcPass _) GhcPs b = NoExt
+type instance XTransStmt (GhcPass _) GhcRn b = NoExt
+type instance XTransStmt (GhcPass _) GhcTc b = Type
+
+type instance XRecStmt (GhcPass _) GhcPs b = NoExt
+type instance XRecStmt (GhcPass _) GhcRn b = NoExt
+type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc
+
+type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExt
data TransForm -- The 'f' below is the 'using' function, 'e' is the by function
= ThenForm -- then f or then f by e (depending on trS_by)
@@ -1776,21 +2024,35 @@ data TransForm -- The 'f' below is the 'using' function, 'e' is the by functio
-- | Parenthesised Statement Block
data ParStmtBlock idL idR
= ParStmtBlock
+ (XParStmtBlock idL idR)
[ExprLStmt idL]
[IdP idR] -- The variables to be returned
(SyntaxExpr idR) -- The return operator
-deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR)
+ | XParStmtBlock (XXParStmtBlock idL idR)
+
+type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExt
+type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExt
-- | Applicative Argument
-data ApplicativeArg idL idR
- = ApplicativeArgOne -- pat <- expr (pat must be irrefutable)
- (LPat idL)
+data ApplicativeArg idL
+ = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt)
+ (XApplicativeArgOne idL)
+ (LPat idL) -- WildPat if it was a BodyStmt (see below)
(LHsExpr idL)
- | ApplicativeArgMany -- do { stmts; return vars }
- [ExprLStmt idL] -- stmts
- (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn)
- (LPat idL) -- (v1,...,vn)
-deriving instance (DataId idL, DataId idR) => Data (ApplicativeArg idL idR)
+ Bool -- True <=> was a BodyStmt
+ -- False <=> was a BindStmt
+ -- See Note [Applicative BodyStmt]
+
+ | ApplicativeArgMany -- do { stmts; return vars }
+ (XApplicativeArgMany idL)
+ [ExprLStmt idL] -- stmts
+ (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn)
+ (LPat idL) -- (v1,...,vn)
+ | XApplicativeArg (XXApplicativeArg idL)
+
+type instance XApplicativeArgOne (GhcPass _) = NoExt
+type instance XApplicativeArgMany (GhcPass _) = NoExt
+type instance XXApplicativeArg (GhcPass _) = NoExt
{-
Note [The type of bind in Stmts]
@@ -1927,41 +2189,73 @@ Parallel statements require the 'Control.Monad.Zip.mzip' function:
In any other context than 'MonadComp', the fields for most of these
'SyntaxExpr's stay bottom.
+
+
+Note [Applicative BodyStmt]
+
+(#12143) For the purposes of ApplicativeDo, we treat any BodyStmt
+as if it was a BindStmt with a wildcard pattern. For example,
+
+ do
+ x <- A
+ B
+ return x
+
+is transformed as if it were
+
+ do
+ x <- A
+ _ <- B
+ return x
+
+so it transforms to
+
+ (\(x,_) -> x) <$> A <*> B
+
+But we have to remember when we treat a BodyStmt like a BindStmt,
+because in error messages we want to emit the original syntax the user
+wrote, not our internal representation. So ApplicativeArgOne has a
+Bool flag that is True when the original statement was a BodyStmt, so
+that we can pretty-print it correctly.
-}
-instance (SourceTextX idL, OutputableBndrId idL)
- => Outputable (ParStmtBlock idL idR) where
- ppr (ParStmtBlock stmts _ _) = interpp'SP stmts
+instance (Outputable (StmtLR idL idL (LHsExpr idL)),
+ Outputable (XXParStmtBlock idL idR))
+ => Outputable (ParStmtBlock idL idR) where
+ ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts
+ ppr (XParStmtBlock x) = ppr x
-instance (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR, Outputable body)
+instance (idL ~ GhcPass pl,idR ~ GhcPass pr,
+ OutputableBndrId idL, OutputableBndrId idR,
+ Outputable body)
=> Outputable (StmtLR idL idR body) where
ppr stmt = pprStmt stmt
-pprStmt :: forall idL idR body . (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR,
+pprStmt :: forall idL idR body . (OutputableBndrId (GhcPass idL),
+ OutputableBndrId (GhcPass idR),
Outputable body)
- => (StmtLR idL idR body) -> SDoc
-pprStmt (LastStmt expr ret_stripped _)
- = ifPprDebug (text "[last]") <+>
+ => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc
+pprStmt (LastStmt _ expr ret_stripped _)
+ = whenPprDebug (text "[last]") <+>
(if ret_stripped then text "return" else empty) <+>
ppr expr
-pprStmt (BindStmt pat expr _ _ _) = hsep [ppr pat, larrow, ppr expr]
-pprStmt (LetStmt (L _ binds)) = hsep [text "let", pprBinds binds]
-pprStmt (BodyStmt expr _ _ _) = ppr expr
-pprStmt (ParStmt stmtss _ _ _) = sep (punctuate (text " | ") (map ppr stmtss))
+pprStmt (BindStmt _ pat expr _ _) = hsep [ppr pat, larrow, ppr expr]
+pprStmt (LetStmt _ (L _ binds)) = hsep [text "let", pprBinds binds]
+pprStmt (BodyStmt _ expr _ _) = ppr expr
+pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss))
-pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form })
+pprStmt (TransStmt { trS_stmts = stmts, trS_by = by
+ , trS_using = using, trS_form = form })
= sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form])
pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
, recS_later_ids = later_ids })
= text "rec" <+>
vcat [ ppr_do_stmts segment
- , ifPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids
+ , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids
, text "later_ids=" <> ppr later_ids])]
-pprStmt (ApplicativeStmt args mb_join _)
+pprStmt (ApplicativeStmt _ args mb_join)
= getPprStyle $ \style ->
if userStyle style
then pp_for_user
@@ -1975,15 +2269,21 @@ pprStmt (ApplicativeStmt args mb_join _)
-- ppr directly rather than transforming here, because we need to
-- inject a "return" which is hard when we're polymorphic in the id
-- type.
- flattenStmt :: ExprLStmt idL -> [SDoc]
- flattenStmt (L _ (ApplicativeStmt args _ _)) = concatMap flattenArg args
+ flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]
+ flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args
flattenStmt stmt = [ppr stmt]
- flattenArg (_, ApplicativeArgOne pat expr) =
- [ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
- :: ExprStmt idL)]
- flattenArg (_, ApplicativeArgMany stmts _ _) =
+ flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc]
+ flattenArg (_, ApplicativeArgOne _ pat expr isBody)
+ | isBody = -- See Note [Applicative BodyStmt]
+ [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
+ :: ExprStmt (GhcPass idL))]
+ | otherwise =
+ [ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
+ :: ExprStmt (GhcPass idL))]
+ flattenArg (_, ApplicativeArgMany _ stmts _ _) =
concatMap flattenStmt stmts
+ flattenArg (_, XApplicativeArg _) = panic "flattenArg"
pp_debug =
let
@@ -1993,20 +2293,29 @@ pprStmt (ApplicativeStmt args mb_join _)
then ap_expr
else text "join" <+> parens ap_expr
- pp_arg (_, ApplicativeArgOne pat expr) =
- ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
- :: ExprStmt idL)
- pp_arg (_, ApplicativeArgMany stmts return pat) =
+ pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc
+ pp_arg (_, ApplicativeArgOne _ pat expr isBody)
+ | isBody = -- See Note [Applicative BodyStmt]
+ ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
+ :: ExprStmt (GhcPass idL))
+ | otherwise =
+ ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
+ :: ExprStmt (GhcPass idL))
+ pp_arg (_, ApplicativeArgMany _ stmts return pat) =
ppr pat <+>
text "<-" <+>
- ppr (HsDo DoExpr (noLoc
- (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)]))
- (error "pprStmt"))
+ ppr (HsDo (panic "pprStmt") DoExpr (noLoc
+ (stmts ++
+ [noLoc (LastStmt noExt (noLoc return) False noSyntaxExpr)])))
+ pp_arg (_, XApplicativeArg x) = ppr x
+
+pprStmt (XStmtLR x) = ppr x
-pprTransformStmt :: (SourceTextX p, OutputableBndrId p)
- => [IdP p] -> LHsExpr p -> Maybe (LHsExpr p) -> SDoc
+pprTransformStmt :: (OutputableBndrId (GhcPass p))
+ => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
+ -> Maybe (LHsExpr (GhcPass p)) -> SDoc
pprTransformStmt bndrs using by
- = sep [ text "then" <+> ifPprDebug (braces (ppr bndrs))
+ = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs))
, nest 2 (ppr using)
, nest 2 (pprBy by)]
@@ -2020,27 +2329,26 @@ pprBy :: Outputable body => Maybe body -> SDoc
pprBy Nothing = empty
pprBy (Just e) = text "by" <+> ppr e
-pprDo :: (SourceTextX p, OutputableBndrId p, Outputable body)
- => HsStmtContext any -> [LStmt p body] -> SDoc
+pprDo :: (OutputableBndrId (GhcPass p), Outputable body)
+ => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc
pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts
pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts
pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts
pprDo MDoExpr stmts = text "mdo" <+> ppr_do_stmts stmts
pprDo ListComp stmts = brackets $ pprComp stmts
-pprDo PArrComp stmts = paBrackets $ pprComp stmts
pprDo MonadComp stmts = brackets $ pprComp stmts
pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
-ppr_do_stmts :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR, Outputable body)
- => [LStmtLR idL idR body] -> SDoc
+ppr_do_stmts :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc
-- Print a bunch of do stmts
ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)
-pprComp :: (SourceTextX p, OutputableBndrId p, Outputable body)
- => [LStmt p body] -> SDoc
+pprComp :: (OutputableBndrId (GhcPass p), Outputable body)
+ => [LStmt (GhcPass p) body] -> SDoc
pprComp quals -- Prints: body | qual1, ..., qualn
- | Just (initStmts, L _ (LastStmt body _ _)) <- snocView quals
+ | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals
= if null initStmts
-- If there are no statements in a list comprehension besides the last
-- one, we simply treat it like a normal list. This does arise
@@ -2052,8 +2360,8 @@ pprComp quals -- Prints: body | qual1, ..., qualn
| otherwise
= pprPanic "pprComp" (pprQuals quals)
-pprQuals :: (SourceTextX p, OutputableBndrId p, Outputable body)
- => [LStmt p body] -> SDoc
+pprQuals :: (OutputableBndrId (GhcPass p), Outputable body)
+ => [LStmt (GhcPass p) body] -> SDoc
-- Show list comprehension qualifiers separated by commas
pprQuals quals = interpp'SP quals
@@ -2068,30 +2376,40 @@ pprQuals quals = interpp'SP quals
-- | Haskell Splice
data HsSplice id
= HsTypedSplice -- $$z or $$(f 4)
+ (XTypedSplice id)
SpliceDecoration -- Whether $$( ) variant found, for pretty printing
(IdP id) -- A unique name to identify this splice point
(LHsExpr id) -- See Note [Pending Splices]
| HsUntypedSplice -- $z or $(f 4)
+ (XUntypedSplice id)
SpliceDecoration -- Whether $( ) variant found, for pretty printing
(IdP id) -- A unique name to identify this splice point
(LHsExpr id) -- See Note [Pending Splices]
| HsQuasiQuote -- See Note [Quasi-quote overview] in TcSplice
+ (XQuasiQuote id)
(IdP id) -- Splice point
(IdP id) -- Quoter
SrcSpan -- The span of the enclosed string
FastString -- The enclosed string
+ -- AZ:TODO: use XSplice instead of HsSpliced
| HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in
-- RnSplice.
-- This is the result of splicing a splice. It is produced by
-- the renamer and consumed by the typechecker. It lives only
-- between the two.
+ (XSpliced id)
ThModFinalizers -- TH finalizers produced by the splice.
(HsSplicedThing id) -- The result of splicing
- deriving Typeable
-deriving instance (DataId id) => Data (HsSplice id)
+ | XSplice (XXSplice id) -- Note [Trees that Grow] extension point
+
+type instance XTypedSplice (GhcPass _) = NoExt
+type instance XUntypedSplice (GhcPass _) = NoExt
+type instance XQuasiQuote (GhcPass _) = NoExt
+type instance XSpliced (GhcPass _) = NoExt
+type instance XXSplice (GhcPass _) = NoExt
-- | A splice can appear with various decorations wrapped around it. This data
-- type captures explicitly how it was originally written, for use in the pretty
@@ -2131,18 +2449,14 @@ data HsSplicedThing id
= HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression
| HsSplicedTy (HsType id) -- ^ Haskell Spliced Type
| HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern
- deriving Typeable
-deriving instance (DataId id) => Data (HsSplicedThing id)
-- See Note [Pending Splices]
type SplicePointName = Name
-- | Pending Renamer Splice
data PendingRnSplice
- -- AZ:TODO: The hard-coded GhcRn feels wrong. How to force the PostRn?
= PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn)
- deriving Data
data UntypedSpliceFlavour
= UntypedExpSplice
@@ -2153,10 +2467,8 @@ data UntypedSpliceFlavour
-- | Pending Type-checker Splice
data PendingTcSplice
- -- AZ:TODO: The hard-coded GhcTc feels wrong. How to force the PostTc?
+ -- AZ:TODO: The hard-coded GhcTc feels wrong.
= PendingTcSplice SplicePointName (LHsExpr GhcTc)
- deriving Data
-
{-
Note [Pending Splices]
@@ -2222,85 +2534,99 @@ splices. In contrast, when pretty printing the output of the type checker, we
sense, although I hate to add another constructor to HsExpr.
-}
-instance (SourceTextX p, OutputableBndrId p)
+instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsSplicedThing p) where
ppr (HsSplicedExpr e) = ppr_expr e
ppr (HsSplicedTy t) = ppr t
ppr (HsSplicedPat p) = ppr p
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsSplice p) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsSplice p) where
ppr s = pprSplice s
-pprPendingSplice :: (SourceTextX p, OutputableBndrId p)
- => SplicePointName -> LHsExpr p -> SDoc
+pprPendingSplice :: (OutputableBndrId (GhcPass p))
+ => SplicePointName -> LHsExpr (GhcPass p) -> SDoc
pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e)
-pprSpliceDecl :: (SourceTextX p, OutputableBndrId p)
- => HsSplice p -> SpliceExplicitFlag -> SDoc
+pprSpliceDecl :: (OutputableBndrId (GhcPass p))
+ => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e
pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")"
pprSpliceDecl e ImplicitSplice = ppr_splice_decl e
-ppr_splice_decl :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc
-ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty
+ppr_splice_decl :: (OutputableBndrId (GhcPass p))
+ => HsSplice (GhcPass p) -> SDoc
+ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty
ppr_splice_decl e = pprSplice e
-pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc
-pprSplice (HsTypedSplice HasParens n e)
+pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc
+pprSplice (HsTypedSplice _ HasParens n e)
= ppr_splice (text "$$(") n e (text ")")
-pprSplice (HsTypedSplice HasDollar n e)
+pprSplice (HsTypedSplice _ HasDollar n e)
= ppr_splice (text "$$") n e empty
-pprSplice (HsTypedSplice NoParens n e)
+pprSplice (HsTypedSplice _ NoParens n e)
= ppr_splice empty n e empty
-pprSplice (HsUntypedSplice HasParens n e)
+pprSplice (HsUntypedSplice _ HasParens n e)
= ppr_splice (text "$(") n e (text ")")
-pprSplice (HsUntypedSplice HasDollar n e)
+pprSplice (HsUntypedSplice _ HasDollar n e)
= ppr_splice (text "$") n e empty
-pprSplice (HsUntypedSplice NoParens n e)
+pprSplice (HsUntypedSplice _ NoParens n e)
= ppr_splice empty n e empty
-pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s
-pprSplice (HsSpliced _ thing) = ppr thing
+pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s
+pprSplice (HsSpliced _ _ thing) = ppr thing
+pprSplice (XSplice x) = ppr x
ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc
-ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <>
+ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <>
char '[' <> ppr quoter <> vbar <>
ppr quote <> text "|]"
-ppr_splice :: (SourceTextX p, OutputableBndrId p)
- => SDoc -> (IdP p) -> LHsExpr p -> SDoc -> SDoc
+ppr_splice :: (OutputableBndrId (GhcPass p))
+ => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc
ppr_splice herald n e trail
- = herald <> ifPprDebug (brackets (ppr n)) <> ppr e <> trail
+ = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail
-- | Haskell Bracket
-data HsBracket p = ExpBr (LHsExpr p) -- [| expr |]
- | PatBr (LPat p) -- [p| pat |]
- | DecBrL [LHsDecl p] -- [d| decls |]; result of parser
- | DecBrG (HsGroup p) -- [d| decls |]; result of renamer
- | TypBr (LHsType p) -- [t| type |]
- | VarBr Bool (IdP p) -- True: 'x, False: ''T
- -- (The Bool flag is used only in pprHsBracket)
- | TExpBr (LHsExpr p) -- [|| expr ||]
-deriving instance (DataId p) => Data (HsBracket p)
+data HsBracket p
+ = ExpBr (XExpBr p) (LHsExpr p) -- [| expr |]
+ | PatBr (XPatBr p) (LPat p) -- [p| pat |]
+ | DecBrL (XDecBrL p) [LHsDecl p] -- [d| decls |]; result of parser
+ | DecBrG (XDecBrG p) (HsGroup p) -- [d| decls |]; result of renamer
+ | TypBr (XTypBr p) (LHsType p) -- [t| type |]
+ | VarBr (XVarBr p) Bool (IdP p) -- True: 'x, False: ''T
+ -- (The Bool flag is used only in pprHsBracket)
+ | TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||]
+ | XBracket (XXBracket p) -- Note [Trees that Grow] extension point
+
+type instance XExpBr (GhcPass _) = NoExt
+type instance XPatBr (GhcPass _) = NoExt
+type instance XDecBrL (GhcPass _) = NoExt
+type instance XDecBrG (GhcPass _) = NoExt
+type instance XTypBr (GhcPass _) = NoExt
+type instance XVarBr (GhcPass _) = NoExt
+type instance XTExpBr (GhcPass _) = NoExt
+type instance XXBracket (GhcPass _) = NoExt
isTypedBracket :: HsBracket id -> Bool
isTypedBracket (TExpBr {}) = True
isTypedBracket _ = False
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsBracket p) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (HsBracket p) where
ppr = pprHsBracket
-pprHsBracket :: (SourceTextX p, OutputableBndrId p) => HsBracket p -> SDoc
-pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
-pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
-pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp)
-pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds))
-pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
-pprHsBracket (VarBr True n)
+pprHsBracket :: (OutputableBndrId (GhcPass p)) => HsBracket (GhcPass p) -> SDoc
+pprHsBracket (ExpBr _ e) = thBrackets empty (ppr e)
+pprHsBracket (PatBr _ p) = thBrackets (char 'p') (ppr p)
+pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)
+pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds))
+pprHsBracket (TypBr _ t) = thBrackets (char 't') (ppr t)
+pprHsBracket (VarBr _ True n)
= char '\'' <> pprPrefixOcc n
-pprHsBracket (VarBr False n)
+pprHsBracket (VarBr _ False n)
= text "''" <> pprPrefixOcc n
-pprHsBracket (TExpBr e) = thTyBrackets (ppr e)
+pprHsBracket (TExpBr _ e) = thTyBrackets (ppr e)
+pprHsBracket (XBracket e) = ppr e
thBrackets :: SDoc -> SDoc -> SDoc
thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>
@@ -2333,9 +2659,9 @@ data ArithSeqInfo id
| FromThenTo (LHsExpr id)
(LHsExpr id)
(LHsExpr id)
-deriving instance (DataId id) => Data (ArithSeqInfo id)
+-- AZ: Sould ArithSeqInfo have a TTG extension?
-instance (SourceTextX p, OutputableBndrId p)
+instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (ArithSeqInfo p) where
ppr (From e1) = hcat [ppr e1, pp_dotdot]
ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]
@@ -2359,11 +2685,10 @@ pp_dotdot = text " .. "
-- Context of a pattern match. This is more subtle than it would seem. See Note
-- [Varieties of pattern matches].
data HsMatchContext id -- Not an extensible tag
- = FunRhs { mc_fun :: Located id -- ^ function binder of @f@
- , mc_fixity :: LexicalFixity -- ^ fixing of @f@
- , mc_strictness :: SrcStrictness
- -- ^ was the pattern banged? See
- -- Note [Varieties of binding pattern matches]
+ = FunRhs { mc_fun :: Located id -- ^ function binder of @f@
+ , mc_fixity :: LexicalFixity -- ^ fixing of @f@
+ , mc_strictness :: SrcStrictness -- ^ was @f@ banged?
+ -- See Note [FunBind vs PatBind]
}
-- ^A pattern matching on an argument of a
-- function binding
@@ -2372,6 +2697,9 @@ data HsMatchContext id -- Not an extensible tag
| IfAlt -- ^Guards of a multi-way if alternative
| ProcExpr -- ^Patterns of a proc
| PatBindRhs -- ^A pattern binding eg [y] <- e = e
+ | PatBindGuards -- ^Guards of pattern bindings, e.g.,
+ -- (Just b) | Just _ <- x = e
+ -- | otherwise = e'
| RecUpd -- ^Record update [used only in DsExpr to
-- tell matchWrapper what sort of
@@ -2393,6 +2721,7 @@ instance OutputableBndr id => Outputable (HsMatchContext id) where
ppr IfAlt = text "IfAlt"
ppr ProcExpr = text "ProcExpr"
ppr PatBindRhs = text "PatBindRhs"
+ ppr PatBindGuards = text "PatBindGuards"
ppr RecUpd = text "RecUpd"
ppr (StmtCtxt _) = text "StmtCtxt _"
ppr ThPatSplice = text "ThPatSplice"
@@ -2410,7 +2739,6 @@ isPatSynCtxt ctxt =
data HsStmtContext id
= ListComp
| MonadComp
- | PArrComp -- ^Parallel array comprehension
| DoExpr -- ^do { ... }
| MDoExpr -- ^mdo { ... } ie recursive do-expression
@@ -2423,39 +2751,39 @@ data HsStmtContext id
deriving Functor
deriving instance (Data id) => Data (HsStmtContext id)
-isListCompExpr :: HsStmtContext id -> Bool
--- Uses syntax [ e | quals ]
-isListCompExpr ListComp = True
-isListCompExpr PArrComp = True
-isListCompExpr MonadComp = True
-isListCompExpr (ParStmtCtxt c) = isListCompExpr c
-isListCompExpr (TransStmtCtxt c) = isListCompExpr c
-isListCompExpr _ = False
-
-isMonadCompExpr :: HsStmtContext id -> Bool
-isMonadCompExpr MonadComp = True
-isMonadCompExpr (ParStmtCtxt ctxt) = isMonadCompExpr ctxt
-isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt
-isMonadCompExpr _ = False
+isComprehensionContext :: HsStmtContext id -> Bool
+-- Uses comprehension syntax [ e | quals ]
+isComprehensionContext ListComp = True
+isComprehensionContext MonadComp = True
+isComprehensionContext (ParStmtCtxt c) = isComprehensionContext c
+isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c
+isComprehensionContext _ = False
-- | Should pattern match failure in a 'HsStmtContext' be desugared using
-- 'MonadFail'?
isMonadFailStmtContext :: HsStmtContext id -> Bool
-isMonadFailStmtContext MonadComp = True
-isMonadFailStmtContext DoExpr = True
-isMonadFailStmtContext MDoExpr = True
-isMonadFailStmtContext GhciStmtCtxt = True
-isMonadFailStmtContext _ = False
+isMonadFailStmtContext MonadComp = True
+isMonadFailStmtContext DoExpr = True
+isMonadFailStmtContext MDoExpr = True
+isMonadFailStmtContext GhciStmtCtxt = True
+isMonadFailStmtContext (ParStmtCtxt ctxt) = isMonadFailStmtContext ctxt
+isMonadFailStmtContext (TransStmtCtxt ctxt) = isMonadFailStmtContext ctxt
+isMonadFailStmtContext _ = False -- ListComp, PatGuard, ArrowExpr
+
+isMonadCompContext :: HsStmtContext id -> Bool
+isMonadCompContext MonadComp = True
+isMonadCompContext _ = False
matchSeparator :: HsMatchContext id -> SDoc
-matchSeparator (FunRhs {}) = text "="
-matchSeparator CaseAlt = text "->"
-matchSeparator IfAlt = text "->"
-matchSeparator LambdaExpr = text "->"
-matchSeparator ProcExpr = text "->"
-matchSeparator PatBindRhs = text "="
-matchSeparator (StmtCtxt _) = text "<-"
-matchSeparator RecUpd = text "=" -- This can be printed by the pattern
+matchSeparator (FunRhs {}) = text "="
+matchSeparator CaseAlt = text "->"
+matchSeparator IfAlt = text "->"
+matchSeparator LambdaExpr = text "->"
+matchSeparator ProcExpr = text "->"
+matchSeparator PatBindRhs = text "="
+matchSeparator PatBindGuards = text "="
+matchSeparator (StmtCtxt _) = text "<-"
+matchSeparator RecUpd = text "=" -- This can be printed by the pattern
-- match checker trace
matchSeparator ThPatSplice = panic "unused"
matchSeparator ThPatQuote = panic "unused"
@@ -2482,10 +2810,11 @@ pprMatchContextNoun RecUpd = text "record-update construct"
pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice"
pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation"
pprMatchContextNoun PatBindRhs = text "pattern binding"
+pprMatchContextNoun PatBindGuards = text "pattern binding guards"
pprMatchContextNoun LambdaExpr = text "lambda abstraction"
pprMatchContextNoun ProcExpr = text "arrow abstraction"
pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
- $$ pprStmtContext ctxt
+ $$ pprAStmtContext ctxt
pprMatchContextNoun PatSyn = text "pattern synonym declaration"
-----------------
@@ -2498,7 +2827,6 @@ pprAStmtContext ctxt = article <+> pprStmtContext ctxt
pp_a = text "a"
article = case ctxt of
MDoExpr -> pp_an
- PArrComp -> pp_an
GhciStmtCtxt -> pp_an
_ -> pp_a
@@ -2510,7 +2838,6 @@ pprStmtContext MDoExpr = text "'mdo' block"
pprStmtContext ArrowExpr = text "'do' block in an arrow command"
pprStmtContext ListComp = text "list comprehension"
pprStmtContext MonadComp = text "monad comprehension"
-pprStmtContext PArrComp = text "array comprehension"
pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt
-- Drop the inner contexts when reporting errors, else we get
@@ -2519,13 +2846,11 @@ pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctx
-- transformed branch of
-- transformed branch of monad comprehension
pprStmtContext (ParStmtCtxt c) =
- sdocWithPprDebug $ \dbg -> if dbg
- then sep [text "parallel branch of", pprAStmtContext c]
- else pprStmtContext c
+ ifPprDebug (sep [text "parallel branch of", pprAStmtContext c])
+ (pprStmtContext c)
pprStmtContext (TransStmtCtxt c) =
- sdocWithPprDebug $ \dbg -> if dbg
- then sep [text "transformed branch of", pprAStmtContext c]
- else pprStmtContext c
+ ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])
+ (pprStmtContext c)
instance (Outputable p, Outputable (NameOrRdrName p))
=> Outputable (HsStmtContext p) where
@@ -2538,6 +2863,7 @@ matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun
matchContextErrString CaseAlt = text "case"
matchContextErrString IfAlt = text "multi-way if"
matchContextErrString PatBindRhs = text "pattern binding"
+matchContextErrString PatBindGuards = text "pattern binding guards"
matchContextErrString RecUpd = text "record update"
matchContextErrString LambdaExpr = text "lambda"
matchContextErrString ProcExpr = text "proc"
@@ -2553,23 +2879,24 @@ matchContextErrString (StmtCtxt ArrowExpr) = text "'do' block"
matchContextErrString (StmtCtxt MDoExpr) = text "'mdo' block"
matchContextErrString (StmtCtxt ListComp) = text "list comprehension"
matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension"
-matchContextErrString (StmtCtxt PArrComp) = text "array comprehension"
-pprMatchInCtxt :: (SourceTextX idR, OutputableBndrId idR,
+pprMatchInCtxt :: (OutputableBndrId (GhcPass idR),
-- TODO:AZ these constraints do not make sense
- Outputable (NameOrRdrName (NameOrRdrName (IdP idR))),
- Outputable body)
- => Match idR body -> SDoc
+ Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))),
+ Outputable body)
+ => Match (GhcPass idR) body -> SDoc
pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match)
<> colon)
4 (pprMatch match)
-pprStmtInCtxt :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR,
+pprStmtInCtxt :: (OutputableBndrId (GhcPass idL),
+ OutputableBndrId (GhcPass idR),
Outputable body)
- => HsStmtContext (IdP idL) -> StmtLR idL idR body -> SDoc
-pprStmtInCtxt ctxt (LastStmt e _ _)
- | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts"
+ => HsStmtContext (IdP (GhcPass idL))
+ -> StmtLR (GhcPass idL) (GhcPass idR) body
+ -> SDoc
+pprStmtInCtxt ctxt (LastStmt _ e _ _)
+ | isComprehensionContext ctxt -- For [ e | .. ], do not mutter about "stmts"
= hang (text "In the expression:") 2 (ppr e)
pprStmtInCtxt ctxt stmt
diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot
index bac8a5a183..109e9814e5 100644
--- a/compiler/hsSyn/HsExpr.hs-boot
+++ b/compiler/hsSyn/HsExpr.hs-boot
@@ -5,6 +5,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE TypeFamilies #-}
module HsExpr where
@@ -12,13 +13,12 @@ import SrcLoc ( Located )
import Outputable ( SDoc, Outputable )
import {-# SOURCE #-} HsPat ( LPat )
import BasicTypes ( SpliceExplicitFlag(..))
-import HsExtension ( OutputableBndrId, DataId, SourceTextX )
-import Data.Data hiding ( Fixity )
+import HsExtension ( OutputableBndrId, GhcPass )
type role HsExpr nominal
type role HsCmd nominal
-type role MatchGroup nominal representational
-type role GRHSs nominal representational
+type role MatchGroup nominal nominal
+type role GRHSs nominal nominal
type role HsSplice nominal
type role SyntaxExpr nominal
data HsExpr (i :: *)
@@ -28,32 +28,24 @@ data MatchGroup (a :: *) (body :: *)
data GRHSs (a :: *) (body :: *)
data SyntaxExpr (i :: *)
-instance (DataId p) => Data (HsSplice p)
-instance (DataId p) => Data (HsExpr p)
-instance (DataId p) => Data (HsCmd p)
-instance (Data body,DataId p) => Data (MatchGroup p body)
-instance (Data body,DataId p) => Data (GRHSs p body)
-instance (DataId p) => Data (SyntaxExpr p)
-
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p)
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p)
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p)
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p)
type LHsExpr a = Located (HsExpr a)
-pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc
-pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
+pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc
-pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc
+pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc
-pprSpliceDecl :: (SourceTextX p, OutputableBndrId p)
- => HsSplice p -> SpliceExplicitFlag -> SDoc
+pprSpliceDecl :: (OutputableBndrId (GhcPass p))
+ => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
-pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr,
- OutputableBndrId bndr,
- OutputableBndrId p,
+pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr),
+ OutputableBndrId (GhcPass p),
Outputable body)
- => LPat bndr -> GRHSs p body -> SDoc
+ => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
-pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => MatchGroup idR body -> SDoc
+pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body)
+ => MatchGroup (GhcPass idR) body -> SDoc
diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs
index 880f7096c6..a7c467dce4 100644
--- a/compiler/hsSyn/HsExtension.hs
+++ b/compiler/hsSyn/HsExtension.hs
@@ -7,26 +7,25 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+ -- in module PlaceHolder
module HsExtension where
-- This module captures the type families to precisely identify the extension
-- points for HsSyn
+import GhcPrelude
+
import GHC.Exts (Constraint)
import Data.Data hiding ( Fixity )
import PlaceHolder
-import BasicTypes
-import ConLike
-import NameSet
import Name
import RdrName
import Var
-import Type ( Type )
import Outputable
import SrcLoc (Located)
-import Coercion
-import TcEvidence
{-
Note [Trees that grow]
@@ -53,6 +52,17 @@ haskell-src-exts ASTs as well.
-}
+-- | used as place holder in TTG values
+data NoExt = NoExt
+ deriving (Data,Eq,Ord)
+
+instance Outputable NoExt where
+ ppr _ = text "NoExt"
+
+-- | Used when constructing a term with an unused extension point.
+noExt :: NoExt
+noExt = NoExt
+
-- | Used as a data type index for the hsSyn AST
data GhcPass (c :: Pass)
deriving instance Eq (GhcPass c)
@@ -67,25 +77,707 @@ type GhcRn = GhcPass 'Renamed -- Old 'Name' type param
type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para,
type GhcTcId = GhcTc -- Old 'TcId' type param
-
--- | Types that are not defined until after type checking
-type family PostTc x ty -- Note [Pass sensitive types] in PlaceHolder
-type instance PostTc GhcPs ty = PlaceHolder
-type instance PostTc GhcRn ty = PlaceHolder
-type instance PostTc GhcTc ty = 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
-type instance PostRn GhcRn ty = ty
-type instance PostRn GhcTc ty = ty
-
-- | Maps the "normal" id type for a given pass
type family IdP p
type instance IdP GhcPs = RdrName
type instance IdP GhcRn = Name
type instance IdP GhcTc = Id
+type LIdP p = Located (IdP p)
+
+-- =====================================================================
+-- Type families for the HsBinds extension points
+
+-- HsLocalBindsLR type families
+type family XHsValBinds x x'
+type family XHsIPBinds x x'
+type family XEmptyLocalBinds x x'
+type family XXHsLocalBindsLR x x'
+
+type ForallXHsLocalBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
+ ( c (XHsValBinds x x')
+ , c (XHsIPBinds x x')
+ , c (XEmptyLocalBinds x x')
+ , c (XXHsLocalBindsLR x x')
+ )
+
+-- ValBindsLR type families
+type family XValBinds x x'
+type family XXValBindsLR x x'
+
+type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
+ ( c (XValBinds x x')
+ , c (XXValBindsLR x x')
+ )
+
+
+-- HsBindsLR type families
+type family XFunBind x x'
+type family XPatBind x x'
+type family XVarBind x x'
+type family XAbsBinds x x'
+type family XPatSynBind x x'
+type family XXHsBindsLR x x'
+
+type ForallXHsBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
+ ( c (XFunBind x x')
+ , c (XPatBind x x')
+ , c (XVarBind x x')
+ , c (XAbsBinds x x')
+ , c (XPatSynBind x x')
+ , c (XXHsBindsLR x x')
+ )
+
+-- ABExport type families
+type family XABE x
+type family XXABExport x
+
+type ForallXABExport (c :: * -> Constraint) (x :: *) =
+ ( c (XABE x)
+ , c (XXABExport x)
+ )
+
+-- PatSynBind type families
+type family XPSB x x'
+type family XXPatSynBind x x'
+
+type ForallXPatSynBind (c :: * -> Constraint) (x :: *) (x' :: *) =
+ ( c (XPSB x x')
+ , c (XXPatSynBind x x')
+ )
+
+-- HsIPBinds type families
+type family XIPBinds x
+type family XXHsIPBinds x
+
+type ForallXHsIPBinds (c :: * -> Constraint) (x :: *) =
+ ( c (XIPBinds x)
+ , c (XXHsIPBinds x)
+ )
+
+-- IPBind type families
+type family XCIPBind x
+type family XXIPBind x
+
+type ForallXIPBind (c :: * -> Constraint) (x :: *) =
+ ( c (XCIPBind x)
+ , c (XXIPBind x)
+ )
+
+-- Sig type families
+type family XTypeSig x
+type family XPatSynSig x
+type family XClassOpSig x
+type family XIdSig x
+type family XFixSig x
+type family XInlineSig x
+type family XSpecSig x
+type family XSpecInstSig x
+type family XMinimalSig x
+type family XSCCFunSig x
+type family XCompleteMatchSig x
+type family XXSig x
+
+type ForallXSig (c :: * -> Constraint) (x :: *) =
+ ( c (XTypeSig x)
+ , c (XPatSynSig x)
+ , c (XClassOpSig x)
+ , c (XIdSig x)
+ , c (XFixSig x)
+ , c (XInlineSig x)
+ , c (XSpecSig x)
+ , c (XSpecInstSig x)
+ , c (XMinimalSig x)
+ , c (XSCCFunSig x)
+ , c (XCompleteMatchSig x)
+ , c (XXSig x)
+ )
+
+-- FixitySig type families
+type family XFixitySig x
+type family XXFixitySig x
+
+type ForallXFixitySig (c :: * -> Constraint) (x :: *) =
+ ( c (XFixitySig x)
+ , c (XXFixitySig x)
+ )
+
+-- =====================================================================
+-- Type families for the HsDecls extension points
+
+-- HsDecl type families
+type family XTyClD x
+type family XInstD x
+type family XDerivD x
+type family XValD x
+type family XSigD x
+type family XDefD x
+type family XForD x
+type family XWarningD x
+type family XAnnD x
+type family XRuleD x
+type family XSpliceD x
+type family XDocD x
+type family XRoleAnnotD x
+type family XXHsDecl x
+
+type ForallXHsDecl (c :: * -> Constraint) (x :: *) =
+ ( c (XTyClD x)
+ , c (XInstD x)
+ , c (XDerivD x)
+ , c (XValD x)
+ , c (XSigD x)
+ , c (XDefD x)
+ , c (XForD x)
+ , c (XWarningD x)
+ , c (XAnnD x)
+ , c (XRuleD x)
+ , c (XSpliceD x)
+ , c (XDocD x)
+ , c (XRoleAnnotD x)
+ , c (XXHsDecl x)
+ )
+
+-- -------------------------------------
+-- HsGroup type families
+type family XCHsGroup x
+type family XXHsGroup x
+
+type ForallXHsGroup (c :: * -> Constraint) (x :: *) =
+ ( c (XCHsGroup x)
+ , c (XXHsGroup x)
+ )
+
+-- -------------------------------------
+-- SpliceDecl type families
+type family XSpliceDecl x
+type family XXSpliceDecl x
+
+type ForallXSpliceDecl (c :: * -> Constraint) (x :: *) =
+ ( c (XSpliceDecl x)
+ , c (XXSpliceDecl x)
+ )
+
+-- -------------------------------------
+-- TyClDecl type families
+type family XFamDecl x
+type family XSynDecl x
+type family XDataDecl x
+type family XClassDecl x
+type family XXTyClDecl x
+
+type ForallXTyClDecl (c :: * -> Constraint) (x :: *) =
+ ( c (XFamDecl x)
+ , c (XSynDecl x)
+ , c (XDataDecl x)
+ , c (XClassDecl x)
+ , c (XXTyClDecl x)
+ )
+
+-- -------------------------------------
+-- TyClGroup type families
+type family XCTyClGroup x
+type family XXTyClGroup x
+
+type ForallXTyClGroup (c :: * -> Constraint) (x :: *) =
+ ( c (XCTyClGroup x)
+ , c (XXTyClGroup x)
+ )
+
+-- -------------------------------------
+-- FamilyResultSig type families
+type family XNoSig x
+type family XCKindSig x -- Clashes with XKindSig above
+type family XTyVarSig x
+type family XXFamilyResultSig x
+
+type ForallXFamilyResultSig (c :: * -> Constraint) (x :: *) =
+ ( c (XNoSig x)
+ , c (XCKindSig x)
+ , c (XTyVarSig x)
+ , c (XXFamilyResultSig x)
+ )
+
+-- -------------------------------------
+-- FamilyDecl type families
+type family XCFamilyDecl x
+type family XXFamilyDecl x
+
+type ForallXFamilyDecl (c :: * -> Constraint) (x :: *) =
+ ( c (XCFamilyDecl x)
+ , c (XXFamilyDecl x)
+ )
+
+-- -------------------------------------
+-- HsDataDefn type families
+type family XCHsDataDefn x
+type family XXHsDataDefn x
+
+type ForallXHsDataDefn (c :: * -> Constraint) (x :: *) =
+ ( c (XCHsDataDefn x)
+ , c (XXHsDataDefn x)
+ )
+
+-- -------------------------------------
+-- HsDerivingClause type families
+type family XCHsDerivingClause x
+type family XXHsDerivingClause x
+
+type ForallXHsDerivingClause (c :: * -> Constraint) (x :: *) =
+ ( c (XCHsDerivingClause x)
+ , c (XXHsDerivingClause x)
+ )
+
+-- -------------------------------------
+-- ConDecl type families
+type family XConDeclGADT x
+type family XConDeclH98 x
+type family XXConDecl x
+
+type ForallXConDecl (c :: * -> Constraint) (x :: *) =
+ ( c (XConDeclGADT x)
+ , c (XConDeclH98 x)
+ , c (XXConDecl x)
+ )
+
+-- -------------------------------------
+-- FamEqn type families
+type family XCFamEqn x p r
+type family XXFamEqn x p r
+
+type ForallXFamEqn (c :: * -> Constraint) (x :: *) (p :: *) (r :: *) =
+ ( c (XCFamEqn x p r)
+ , c (XXFamEqn x p r)
+ )
+
+-- -------------------------------------
+-- ClsInstDecl type families
+type family XCClsInstDecl x
+type family XXClsInstDecl x
+
+type ForallXClsInstDecl (c :: * -> Constraint) (x :: *) =
+ ( c (XCClsInstDecl x)
+ , c (XXClsInstDecl x)
+ )
+
+-- -------------------------------------
+-- ClsInstDecl type families
+type family XClsInstD x
+type family XDataFamInstD x
+type family XTyFamInstD x
+type family XXInstDecl x
+
+type ForallXInstDecl (c :: * -> Constraint) (x :: *) =
+ ( c (XClsInstD x)
+ , c (XDataFamInstD x)
+ , c (XTyFamInstD x)
+ , c (XXInstDecl x)
+ )
+
+-- -------------------------------------
+-- DerivDecl type families
+type family XCDerivDecl x
+type family XXDerivDecl x
+
+type ForallXDerivDecl (c :: * -> Constraint) (x :: *) =
+ ( c (XCDerivDecl x)
+ , c (XXDerivDecl x)
+ )
+
+-- -------------------------------------
+-- DerivStrategy type family
+type family XViaStrategy x
+
+-- -------------------------------------
+-- DefaultDecl type families
+type family XCDefaultDecl x
+type family XXDefaultDecl x
+
+type ForallXDefaultDecl (c :: * -> Constraint) (x :: *) =
+ ( c (XCDefaultDecl x)
+ , c (XXDefaultDecl x)
+ )
+
+-- -------------------------------------
+-- DefaultDecl type families
+type family XForeignImport x
+type family XForeignExport x
+type family XXForeignDecl x
+
+type ForallXForeignDecl (c :: * -> Constraint) (x :: *) =
+ ( c (XForeignImport x)
+ , c (XForeignExport x)
+ , c (XXForeignDecl x)
+ )
+
+-- -------------------------------------
+-- RuleDecls type families
+type family XCRuleDecls x
+type family XXRuleDecls x
+
+type ForallXRuleDecls (c :: * -> Constraint) (x :: *) =
+ ( c (XCRuleDecls x)
+ , c (XXRuleDecls x)
+ )
+
+
+-- -------------------------------------
+-- RuleDecl type families
+type family XHsRule x
+type family XXRuleDecl x
+
+type ForallXRuleDecl (c :: * -> Constraint) (x :: *) =
+ ( c (XHsRule x)
+ , c (XXRuleDecl x)
+ )
+
+-- -------------------------------------
+-- RuleBndr type families
+type family XCRuleBndr x
+type family XRuleBndrSig x
+type family XXRuleBndr x
+
+type ForallXRuleBndr (c :: * -> Constraint) (x :: *) =
+ ( c (XCRuleBndr x)
+ , c (XRuleBndrSig x)
+ , c (XXRuleBndr x)
+ )
+
+-- -------------------------------------
+-- WarnDecls type families
+type family XWarnings x
+type family XXWarnDecls x
+
+type ForallXWarnDecls (c :: * -> Constraint) (x :: *) =
+ ( c (XWarnings x)
+ , c (XXWarnDecls x)
+ )
+
+-- -------------------------------------
+-- AnnDecl type families
+type family XWarning x
+type family XXWarnDecl x
+
+type ForallXWarnDecl (c :: * -> Constraint) (x :: *) =
+ ( c (XWarning x)
+ , c (XXWarnDecl x)
+ )
+
+-- -------------------------------------
+-- AnnDecl type families
+type family XHsAnnotation x
+type family XXAnnDecl x
+
+type ForallXAnnDecl (c :: * -> Constraint) (x :: *) =
+ ( c (XHsAnnotation x)
+ , c (XXAnnDecl x)
+ )
+
+-- -------------------------------------
+-- RoleAnnotDecl type families
+type family XCRoleAnnotDecl x
+type family XXRoleAnnotDecl x
+
+type ForallXRoleAnnotDecl (c :: * -> Constraint) (x :: *) =
+ ( c (XCRoleAnnotDecl x)
+ , c (XXRoleAnnotDecl x)
+ )
+
+-- =====================================================================
+-- Type families for the HsExpr extension points
+
+type family XVar x
+type family XUnboundVar x
+type family XConLikeOut x
+type family XRecFld x
+type family XOverLabel x
+type family XIPVar x
+type family XOverLitE x
+type family XLitE x
+type family XLam x
+type family XLamCase x
+type family XApp x
+type family XAppTypeE x
+type family XOpApp x
+type family XNegApp x
+type family XPar x
+type family XSectionL x
+type family XSectionR x
+type family XExplicitTuple x
+type family XExplicitSum x
+type family XCase x
+type family XIf x
+type family XMultiIf x
+type family XLet x
+type family XDo x
+type family XExplicitList x
+type family XRecordCon x
+type family XRecordUpd x
+type family XExprWithTySig x
+type family XArithSeq x
+type family XSCC x
+type family XCoreAnn x
+type family XBracket x
+type family XRnBracketOut x
+type family XTcBracketOut x
+type family XSpliceE x
+type family XProc x
+type family XStatic x
+type family XArrApp x
+type family XArrForm x
+type family XTick x
+type family XBinTick x
+type family XTickPragma x
+type family XEWildPat x
+type family XEAsPat x
+type family XEViewPat x
+type family XELazyPat x
+type family XWrap x
+type family XXExpr x
+
+type ForallXExpr (c :: * -> Constraint) (x :: *) =
+ ( c (XVar x)
+ , c (XUnboundVar x)
+ , c (XConLikeOut x)
+ , c (XRecFld x)
+ , c (XOverLabel x)
+ , c (XIPVar x)
+ , c (XOverLitE x)
+ , c (XLitE x)
+ , c (XLam x)
+ , c (XLamCase x)
+ , c (XApp x)
+ , c (XAppTypeE x)
+ , c (XOpApp x)
+ , c (XNegApp x)
+ , c (XPar x)
+ , c (XSectionL x)
+ , c (XSectionR x)
+ , c (XExplicitTuple x)
+ , c (XExplicitSum x)
+ , c (XCase x)
+ , c (XIf x)
+ , c (XMultiIf x)
+ , c (XLet x)
+ , c (XDo x)
+ , c (XExplicitList x)
+ , c (XRecordCon x)
+ , c (XRecordUpd x)
+ , c (XExprWithTySig x)
+ , c (XArithSeq x)
+ , c (XSCC x)
+ , c (XCoreAnn x)
+ , c (XBracket x)
+ , c (XRnBracketOut x)
+ , c (XTcBracketOut x)
+ , c (XSpliceE x)
+ , c (XProc x)
+ , c (XStatic x)
+ , c (XArrApp x)
+ , c (XArrForm x)
+ , c (XTick x)
+ , c (XBinTick x)
+ , c (XTickPragma x)
+ , c (XEWildPat x)
+ , c (XEAsPat x)
+ , c (XEViewPat x)
+ , c (XELazyPat x)
+ , c (XWrap x)
+ , c (XXExpr 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)
+ )
+
+-- ----------------------------------------------------------------------
+
+type family XPresent x
+type family XMissing x
+type family XXTupArg x
+
+type ForallXTupArg (c :: * -> Constraint) (x :: *) =
+ ( c (XPresent x)
+ , c (XMissing x)
+ , c (XXTupArg x)
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XTypedSplice x
+type family XUntypedSplice x
+type family XQuasiQuote x
+type family XSpliced x
+type family XXSplice x
+
+type ForallXSplice (c :: * -> Constraint) (x :: *) =
+ ( c (XTypedSplice x)
+ , c (XUntypedSplice x)
+ , c (XQuasiQuote x)
+ , c (XSpliced x)
+ , c (XXSplice x)
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XExpBr x
+type family XPatBr x
+type family XDecBrL x
+type family XDecBrG x
+type family XTypBr x
+type family XVarBr x
+type family XTExpBr x
+type family XXBracket x
+
+type ForallXBracket (c :: * -> Constraint) (x :: *) =
+ ( c (XExpBr x)
+ , c (XPatBr x)
+ , c (XDecBrL x)
+ , c (XDecBrG x)
+ , c (XTypBr x)
+ , c (XVarBr x)
+ , c (XTExpBr x)
+ , c (XXBracket x)
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XCmdTop x
+type family XXCmdTop x
+
+type ForallXCmdTop (c :: * -> Constraint) (x :: *) =
+ ( c (XCmdTop x)
+ , c (XXCmdTop x)
+ )
+
+-- -------------------------------------
+
+type family XMG x b
+type family XXMatchGroup x b
+
+type ForallXMatchGroup (c :: * -> Constraint) (x :: *) (b :: *) =
+ ( c (XMG x b)
+ , c (XXMatchGroup x b)
+ )
+
+-- -------------------------------------
+
+type family XCMatch x b
+type family XXMatch x b
+
+type ForallXMatch (c :: * -> Constraint) (x :: *) (b :: *) =
+ ( c (XCMatch x b)
+ , c (XXMatch x b)
+ )
+
+-- -------------------------------------
+
+type family XCGRHSs x b
+type family XXGRHSs x b
+
+type ForallXGRHSs (c :: * -> Constraint) (x :: *) (b :: *) =
+ ( c (XCGRHSs x b)
+ , c (XXGRHSs x b)
+ )
+
+-- -------------------------------------
+
+type family XCGRHS x b
+type family XXGRHS x b
+
+type ForallXGRHS (c :: * -> Constraint) (x :: *) (b :: *) =
+ ( c (XCGRHS x b)
+ , c (XXGRHS x b)
+ )
+
+-- -------------------------------------
+
+type family XLastStmt x x' b
+type family XBindStmt x x' b
+type family XApplicativeStmt x x' b
+type family XBodyStmt x x' b
+type family XLetStmt x x' b
+type family XParStmt x x' b
+type family XTransStmt x x' b
+type family XRecStmt x x' b
+type family XXStmtLR x x' b
+
+type ForallXStmtLR (c :: * -> Constraint) (x :: *) (x' :: *) (b :: *) =
+ ( c (XLastStmt x x' b)
+ , c (XBindStmt x x' b)
+ , c (XApplicativeStmt x x' b)
+ , c (XBodyStmt x x' b)
+ , c (XLetStmt x x' b)
+ , c (XParStmt x x' b)
+ , c (XTransStmt x x' b)
+ , c (XRecStmt x x' b)
+ , c (XXStmtLR x x' b)
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XCmdArrApp x
+type family XCmdArrForm x
+type family XCmdApp x
+type family XCmdLam x
+type family XCmdPar x
+type family XCmdCase x
+type family XCmdIf x
+type family XCmdLet x
+type family XCmdDo x
+type family XCmdWrap x
+type family XXCmd x
+
+type ForallXCmd (c :: * -> Constraint) (x :: *) =
+ ( c (XCmdArrApp x)
+ , c (XCmdArrForm x)
+ , c (XCmdApp x)
+ , c (XCmdLam x)
+ , c (XCmdPar x)
+ , c (XCmdCase x)
+ , c (XCmdIf x)
+ , c (XCmdLet x)
+ , c (XCmdDo x)
+ , c (XCmdWrap x)
+ , c (XXCmd x)
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XParStmtBlock x x'
+type family XXParStmtBlock x x'
+
+type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) =
+ ( c (XParStmtBlock x x')
+ , c (XXParStmtBlock x x')
+ )
+
+-- ---------------------------------------------------------------------
+
+type family XApplicativeArgOne x
+type family XApplicativeArgMany x
+type family XXApplicativeArg x
+
+type ForallXApplicativeArg (c :: * -> Constraint) (x :: *) =
+ ( c (XApplicativeArgOne x)
+ , c (XApplicativeArgMany x)
+ , c (XXApplicativeArg x)
+ )
+
+-- =====================================================================
+-- Type families for the HsImpExp extension points
+
+-- TODO
+
+-- =====================================================================
+-- Type families for the HsLit extension points
-- We define a type family for each extension point. This is based on prepending
-- 'X' to the constructor name, for ease of reference.
@@ -102,128 +794,235 @@ 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
-- 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 (XHsDoublePrim x)
+ , c (XHsFloatPrim x)
+ , c (XHsInt x)
+ , c (XHsInt64Prim x)
+ , c (XHsIntPrim x)
+ , c (XHsInteger x)
+ , c (XHsRat x)
+ , c (XHsString x)
, c (XHsStringPrim 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 (XHsDoublePrim x)
+ , c (XHsWordPrim x)
+ , c (XXLit x)
)
+type family XOverLit x
+type family XXOverLit x
+
+type ForallXOverLit (c :: * -> Constraint) (x :: *) =
+ ( c (XOverLit x)
+ , c (XXOverLit x)
+ )
+
+-- =====================================================================
+-- Type families for the HsPat extension points
--- 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 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 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 (XViewPat x)
+ , c (XSplicePat x)
+ , c (XLitPat x)
+ , c (XNPat x)
+ , c (XNPlusKPat x)
+ , c (XSigPat x)
+ , c (XCoPat x)
+ , c (XXPat x)
+ )
+
+-- =====================================================================
+-- Type families for the HsTypes type families
+
+type family XHsQTvs x
+type family XXLHsQTyVars x
+
+type ForallXLHsQTyVars (c :: * -> Constraint) (x :: *) =
+ ( c (XHsQTvs x)
+ , c (XXLHsQTyVars x)
+ )
+
+-- -------------------------------------
+
+type family XHsIB x b
+type family XXHsImplicitBndrs x b
+
+type ForallXHsImplicitBndrs (c :: * -> Constraint) (x :: *) (b :: *) =
+ ( c (XHsIB x b)
+ , c (XXHsImplicitBndrs x b)
+ )
+
+-- -------------------------------------
+
+type family XHsWC x b
+type family XXHsWildCardBndrs x b
+
+type ForallXHsWildCardBndrs(c :: * -> Constraint) (x :: *) (b :: *) =
+ ( c (XHsWC x b)
+ , c (XXHsWildCardBndrs x b)
+ )
+
+-- -------------------------------------
+
+type family XForAllTy x
+type family XQualTy x
+type family XTyVar x
+type family XAppTy x
+type family XFunTy x
+type family XListTy x
+type family XTupleTy x
+type family XSumTy x
+type family XOpTy x
+type family XParTy x
+type family XIParamTy x
+type family XStarTy 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 (XAppTy x)
+ , c (XFunTy x)
+ , c (XListTy x)
+ , c (XTupleTy x)
+ , c (XSumTy x)
+ , c (XOpTy x)
+ , c (XParTy x)
+ , c (XIParamTy x)
+ , c (XStarTy 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)
+ )
+
-- ---------------------------------------------------------------------
--- | The 'SourceText' fields have been moved into the extension fields, thus
--- placing a requirement in the extension field to contain a 'SourceText' so
--- that the pretty printing and round tripping of source can continue to
--- operate.
---
--- The 'HasSourceText' class captures this requirement for the relevant fields.
-class HasSourceText a where
- -- Provide setters to mimic existing constructors
- noSourceText :: a
- sourceText :: String -> a
-
- setSourceText :: SourceText -> a
- getSourceText :: a -> SourceText
-
--- | Provide a summary constraint that lists all the extension points requiring
--- the 'HasSourceText' class, so that it can be changed in one place as the
--- named extensions change throughout the AST.
-type SourceTextX x =
- ( HasSourceText (XHsChar x)
- , HasSourceText (XHsCharPrim x)
- , HasSourceText (XHsString x)
- , HasSourceText (XHsStringPrim x)
- , HasSourceText (XHsIntPrim x)
- , HasSourceText (XHsWordPrim x)
- , HasSourceText (XHsInt64Prim x)
- , HasSourceText (XHsWord64Prim x)
- , HasSourceText (XHsInteger 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)
+ )
--- | 'SourceText' trivially implements 'HasSourceText'
-instance HasSourceText SourceText where
- noSourceText = NoSourceText
- sourceText s = SourceText s
+-- ---------------------------------------------------------------------
- setSourceText s = s
- getSourceText a = a
+type family XConDeclField x
+type family XXConDeclField x
+type ForallXConDeclField (c :: * -> Constraint) (x :: *) =
+ ( c (XConDeclField x)
+ , c (XXConDeclField x)
+ )
--- ----------------------------------------------------------------------
--- | Defaults for each annotation, used to simplify creation in arbitrary
--- contexts
-class HasDefault a where
- def :: a
+-- ---------------------------------------------------------------------
+
+type family XCFieldOcc x
+type family XXFieldOcc x
+
+type ForallXFieldOcc (c :: * -> Constraint) (x :: *) =
+ ( c (XCFieldOcc x)
+ , c (XXFieldOcc x)
+ )
-instance HasDefault () where
- def = ()
-instance HasDefault SourceText where
- def = NoSourceText
+-- =====================================================================
+-- Type families for the HsImpExp type families
--- | Provide a single constraint that captures the requirement for a default
--- across all the extension points.
-type HasDefaultX x = ForallX HasDefault x
+type family XCImportDecl x
+type family XXImportDecl x
+
+type ForallXImportDecl (c :: * -> Constraint) (x :: *) =
+ ( c (XCImportDecl x)
+ , c (XXImportDecl x)
+ )
+
+-- -------------------------------------
+
+type family XIEVar x
+type family XIEThingAbs x
+type family XIEThingAll x
+type family XIEThingWith x
+type family XIEModuleContents x
+type family XIEGroup x
+type family XIEDoc x
+type family XIEDocNamed x
+type family XXIE x
+
+type ForallXIE (c :: * -> Constraint) (x :: *) =
+ ( c (XIEVar x)
+ , c (XIEThingAbs x)
+ , c (XIEThingAll x)
+ , c (XIEThingWith x)
+ , c (XIEModuleContents x)
+ , c (XIEGroup x)
+ , c (XIEDoc x)
+ , c (XIEDocNamed x)
+ , c (XXIE x)
+ )
+
+-- -------------------------------------
+
+
+-- =====================================================================
+-- End of Type family definitions
+-- =====================================================================
-- ----------------------------------------------------------------------
-- | Conversion of annotations from one type index to another. This is required
@@ -252,38 +1051,58 @@ 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)
-- ----------------------------------------------------------------------
+-- Note [OutputableX]
+-- ~~~~~~~~~~~~~~~~~~
+--
+-- is required because the type family resolution
+-- process cannot determine that all cases are handled for a `GhcPass p`
+-- case where the cases are listed separately.
+--
+-- So
+--
+-- type instance XXHsIPBinds (GhcPass p) = NoExt
--
-type DataId p =
- ( Data p
- , ForallX Data p
- , Data (NameOrRdrName (IdP p))
-
- , Data (IdP p)
- , Data (PostRn p (IdP p))
- , Data (PostRn p (Located Name))
- , Data (PostRn p Bool)
- , Data (PostRn p Fixity)
- , Data (PostRn p NameSet)
- , Data (PostRn p [Name])
-
- , Data (PostTc p (IdP p))
- , Data (PostTc p Coercion)
- , Data (PostTc p ConLike)
- , Data (PostTc p HsWrapper)
- , Data (PostTc p Type)
- , Data (PostTc p [ConLike])
- , Data (PostTc p [Type])
+-- will correctly deduce Outputable for (GhcPass p), but
+--
+-- type instance XIPBinds GhcPs = NoExt
+-- type instance XIPBinds GhcRn = NoExt
+-- type instance XIPBinds GhcTc = TcEvBinds
+--
+-- will not.
+
+
+-- | Provide a summary constraint that gives all am Outputable constraint to
+-- extension points needing one
+type OutputableX p = -- See Note [OutputableX]
+ (
+ Outputable (XSigPat p)
+ , Outputable (XSigPat GhcRn)
+
+ , Outputable (XIPBinds p)
+
+ , Outputable (XExprWithTySig p)
+ , Outputable (XExprWithTySig GhcRn)
+
+ , Outputable (XAppTypeE p)
+ , Outputable (XAppTypeE GhcRn)
+
+ , Outputable (XViaStrategy p)
+ , Outputable (XViaStrategy GhcRn)
+
)
+-- TODO: Should OutputableX be included in OutputableBndrId?
+-- ----------------------------------------------------------------------
-- |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
)
diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs
index 79ff2876aa..39bd9b7e18 100644
--- a/compiler/hsSyn/HsImpExp.hs
+++ b/compiler/hsSyn/HsImpExp.hs
@@ -9,11 +9,14 @@ HsImpExp: Abstract syntax: imports, exports, interfaces
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
module HsImpExp where
+import GhcPrelude
+
import Module ( ModuleName )
import HsDoc ( HsDocString )
import OccName ( HasOccName(..), isTcOcc, isSymOcc )
@@ -38,7 +41,7 @@ One per \tr{import} declaration in a module.
-}
-- | Located Import Declaration
-type LImportDecl name = Located (ImportDecl name)
+type LImportDecl pass = Located (ImportDecl pass)
-- ^ When in a list this may have
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
@@ -48,8 +51,9 @@ type LImportDecl name = Located (ImportDecl name)
-- | Import Declaration
--
-- A single Haskell @import@ declaration.
-data ImportDecl name
+data ImportDecl pass
= ImportDecl {
+ ideclExt :: XCImportDecl pass,
ideclSourceSrc :: SourceText,
-- Note [Pragma source text] in BasicTypes
ideclName :: Located ModuleName, -- ^ Module name.
@@ -59,9 +63,10 @@ data ImportDecl name
ideclQualified :: Bool, -- ^ True => qualified
ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude)
ideclAs :: Maybe (Located ModuleName), -- ^ as Module
- ideclHiding :: Maybe (Bool, Located [LIE name])
+ ideclHiding :: Maybe (Bool, Located [LIE pass])
-- ^ (True => hiding, names)
}
+ | XImportDecl (XXImportDecl pass)
-- ^
-- 'ApiAnnotation.AnnKeywordId's
--
@@ -78,10 +83,13 @@ data ImportDecl name
-- to location in ideclHiding
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId name) => Data (ImportDecl name)
-simpleImportDecl :: ModuleName -> ImportDecl name
+type instance XCImportDecl (GhcPass _) = NoExt
+type instance XXImportDecl (GhcPass _) = NoExt
+
+simpleImportDecl :: ModuleName -> ImportDecl (GhcPass p)
simpleImportDecl mn = ImportDecl {
+ ideclExt = noExt,
ideclSourceSrc = NoSourceText,
ideclName = noLoc mn,
ideclPkgQual = Nothing,
@@ -93,7 +101,8 @@ simpleImportDecl mn = ImportDecl {
ideclHiding = Nothing
}
-instance (OutputableBndrId pass) => Outputable (ImportDecl pass) where
+instance (p ~ GhcPass pass,OutputableBndrId p)
+ => Outputable (ImportDecl p) where
ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod'
, ideclPkgQual = pkg
, ideclSource = from, ideclSafe = safe
@@ -130,6 +139,7 @@ instance (OutputableBndrId pass) => Outputable (ImportDecl pass) where
ppr_ies [] = text "()"
ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')'
+ ppr (XImportDecl x) = ppr x
{-
************************************************************************
@@ -156,7 +166,7 @@ type LIEWrappedName name = Located (IEWrappedName name)
-- | Located Import or Export
-type LIE name = Located (IE name)
+type LIE pass = Located (IE pass)
-- ^ When in a list this may have
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma'
@@ -164,11 +174,11 @@ type LIE name = Located (IE name)
-- For details on above see note [Api annotations] in ApiAnnotation
-- | Imported or exported entity.
-data IE name
- = IEVar (LIEWrappedName (IdP name))
+data IE pass
+ = IEVar (XIEVar pass) (LIEWrappedName (IdP pass))
-- ^ Imported or Exported Variable
- | IEThingAbs (LIEWrappedName (IdP name))
+ | IEThingAbs (XIEThingAbs pass) (LIEWrappedName (IdP pass))
-- ^ Imported or exported Thing with Absent list
--
-- The thing is a Class/Type (can't tell)
@@ -177,7 +187,7 @@ data IE name
-- For details on above see note [Api annotations] in ApiAnnotation
-- See Note [Located RdrNames] in HsExpr
- | IEThingAll (LIEWrappedName (IdP name))
+ | IEThingAll (XIEThingAll pass) (LIEWrappedName (IdP pass))
-- ^ Imported or exported Thing with All imported or exported
--
-- The thing is a Class/Type and the All refers to methods/constructors
@@ -189,10 +199,11 @@ data IE name
-- For details on above see note [Api annotations] in ApiAnnotation
-- See Note [Located RdrNames] in HsExpr
- | IEThingWith (LIEWrappedName (IdP name))
+ | IEThingWith (XIEThingWith pass)
+ (LIEWrappedName (IdP pass))
IEWildcard
- [LIEWrappedName (IdP name)]
- [Located (FieldLbl (IdP name))]
+ [LIEWrappedName (IdP pass)]
+ [Located (FieldLbl (IdP pass))]
-- ^ Imported or exported Thing With given imported or exported
--
-- The thing is a Class/Type and the imported or exported things are
@@ -203,7 +214,7 @@ data IE name
-- 'ApiAnnotation.AnnType'
-- For details on above see note [Api annotations] in ApiAnnotation
- | IEModuleContents (Located ModuleName)
+ | IEModuleContents (XIEModuleContents pass) (Located ModuleName)
-- ^ Imported or exported module contents
--
-- (Export Only)
@@ -211,12 +222,20 @@ data IE name
-- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnModule'
-- For details on above see note [Api annotations] in ApiAnnotation
- | IEGroup Int HsDocString -- ^ Doc section heading
- | IEDoc HsDocString -- ^ Some documentation
- | IEDocNamed String -- ^ Reference to named doc
- -- deriving (Eq, Data)
-deriving instance (Eq name, Eq (IdP name)) => Eq (IE name)
-deriving instance (DataId name) => Data (IE name)
+ | IEGroup (XIEGroup pass) Int HsDocString -- ^ Doc section heading
+ | IEDoc (XIEDoc pass) HsDocString -- ^ Some documentation
+ | IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc
+ | XIE (XXIE pass)
+
+type instance XIEVar (GhcPass _) = NoExt
+type instance XIEThingAbs (GhcPass _) = NoExt
+type instance XIEThingAll (GhcPass _) = NoExt
+type instance XIEThingWith (GhcPass _) = NoExt
+type instance XIEModuleContents (GhcPass _) = NoExt
+type instance XIEGroup (GhcPass _) = NoExt
+type instance XIEDoc (GhcPass _) = NoExt
+type instance XIEDocNamed (GhcPass _) = NoExt
+type instance XXIE (GhcPass _) = NoExt
-- | Imported or Exported Wildcard
data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data)
@@ -239,22 +258,23 @@ See Note [Representing fields in AvailInfo] in Avail for more details.
-}
ieName :: IE pass -> IdP pass
-ieName (IEVar (L _ n)) = ieWrappedName n
-ieName (IEThingAbs (L _ n)) = ieWrappedName n
-ieName (IEThingWith (L _ n) _ _ _) = ieWrappedName n
-ieName (IEThingAll (L _ n)) = ieWrappedName n
+ieName (IEVar _ (L _ n)) = ieWrappedName n
+ieName (IEThingAbs _ (L _ n)) = ieWrappedName n
+ieName (IEThingWith _ (L _ n) _ _ _) = ieWrappedName n
+ieName (IEThingAll _ (L _ n)) = ieWrappedName n
ieName _ = panic "ieName failed pattern match!"
ieNames :: IE pass -> [IdP pass]
-ieNames (IEVar (L _ n) ) = [ieWrappedName n]
-ieNames (IEThingAbs (L _ n) ) = [ieWrappedName n]
-ieNames (IEThingAll (L _ n) ) = [ieWrappedName n]
-ieNames (IEThingWith (L _ n) _ ns _) = ieWrappedName n
+ieNames (IEVar _ (L _ n) ) = [ieWrappedName n]
+ieNames (IEThingAbs _ (L _ n) ) = [ieWrappedName n]
+ieNames (IEThingAll _ (L _ n) ) = [ieWrappedName n]
+ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n
: map (ieWrappedName . unLoc) ns
-ieNames (IEModuleContents _ ) = []
-ieNames (IEGroup _ _ ) = []
-ieNames (IEDoc _ ) = []
-ieNames (IEDocNamed _ ) = []
+ieNames (IEModuleContents {}) = []
+ieNames (IEGroup {}) = []
+ieNames (IEDoc {}) = []
+ieNames (IEDocNamed {}) = []
+ieNames (XIE {}) = panic "ieNames"
ieWrappedName :: IEWrappedName name -> name
ieWrappedName (IEName (L _ n)) = n
@@ -272,11 +292,11 @@ replaceWrappedName (IEType (L l _)) n = IEType (L l n)
replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2
replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n')
-instance (OutputableBndrId pass) => Outputable (IE pass) where
- ppr (IEVar var) = ppr (unLoc var)
- ppr (IEThingAbs thing) = ppr (unLoc thing)
- ppr (IEThingAll thing) = hcat [ppr (unLoc thing), text "(..)"]
- ppr (IEThingWith thing wc withs flds)
+instance (p ~ GhcPass pass,OutputableBndrId p) => Outputable (IE p) where
+ ppr (IEVar _ var) = ppr (unLoc var)
+ ppr (IEThingAbs _ thing) = ppr (unLoc thing)
+ ppr (IEThingAll _ thing) = hcat [ppr (unLoc thing), text "(..)"]
+ ppr (IEThingWith _ thing wc withs flds)
= ppr (unLoc thing) <> parens (fsep (punctuate comma
(ppWiths ++
map (ppr . flLabel . unLoc) flds)))
@@ -288,11 +308,12 @@ instance (OutputableBndrId pass) => Outputable (IE pass) where
IEWildcard pos ->
let (bs, as) = splitAt pos (map (ppr . unLoc) withs)
in bs ++ [text ".."] ++ as
- ppr (IEModuleContents mod')
+ ppr (IEModuleContents _ mod')
= text "module" <+> ppr mod'
- ppr (IEGroup n _) = text ("<IEGroup: " ++ show n ++ ">")
- ppr (IEDoc doc) = ppr doc
- ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">")
+ ppr (IEGroup _ n _) = text ("<IEGroup: " ++ show n ++ ">")
+ ppr (IEDoc _ doc) = ppr doc
+ ppr (IEDocNamed _ string) = text ("<IEDocNamed: " ++ string ++ ">")
+ ppr (XIE x) = ppr x
instance (HasOccName name) => HasOccName (IEWrappedName name) where
occName w = occName (ieWrappedName w)
diff --git a/compiler/hsSyn/HsInstances.hs b/compiler/hsSyn/HsInstances.hs
new file mode 100644
index 0000000000..9a9f21d046
--- /dev/null
+++ b/compiler/hsSyn/HsInstances.hs
@@ -0,0 +1,416 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module HsInstances where
+
+-- This module defines the Data instances for the hsSyn AST.
+
+-- It happens here to avoid massive constraint types on the AST with concomitant
+-- slow GHC bootstrap times.
+
+-- UndecidableInstances ?
+
+import Data.Data hiding ( Fixity )
+
+import GhcPrelude
+import HsExtension
+import HsBinds
+import HsDecls
+import HsExpr
+import HsLit
+import HsTypes
+import HsPat
+import HsImpExp
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsSyn -----------------------------------------
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsBinds ---------------------------------------
+
+-- deriving instance (DataIdLR pL pR) => Data (HsLocalBindsLR pL pR)
+deriving instance Data (HsLocalBindsLR GhcPs GhcPs)
+deriving instance Data (HsLocalBindsLR GhcPs GhcRn)
+deriving instance Data (HsLocalBindsLR GhcRn GhcRn)
+deriving instance Data (HsLocalBindsLR GhcTc GhcTc)
+
+-- deriving instance (DataIdLR pL pR) => Data (HsValBindsLR pL pR)
+deriving instance Data (HsValBindsLR GhcPs GhcPs)
+deriving instance Data (HsValBindsLR GhcPs GhcRn)
+deriving instance Data (HsValBindsLR GhcRn GhcRn)
+deriving instance Data (HsValBindsLR GhcTc GhcTc)
+
+-- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL)
+deriving instance Data (NHsValBindsLR GhcPs)
+deriving instance Data (NHsValBindsLR GhcRn)
+deriving instance Data (NHsValBindsLR GhcTc)
+
+-- deriving instance (DataIdLR pL pR) => Data (HsBindLR pL pR)
+deriving instance Data (HsBindLR GhcPs GhcPs)
+deriving instance Data (HsBindLR GhcPs GhcRn)
+deriving instance Data (HsBindLR GhcRn GhcRn)
+deriving instance Data (HsBindLR GhcTc GhcTc)
+
+-- deriving instance (DataId p) => Data (ABExport p)
+deriving instance Data (ABExport GhcPs)
+deriving instance Data (ABExport GhcRn)
+deriving instance Data (ABExport GhcTc)
+
+-- deriving instance (DataIdLR pL pR) => Data (PatSynBind pL pR)
+deriving instance Data (PatSynBind GhcPs GhcPs)
+deriving instance Data (PatSynBind GhcPs GhcRn)
+deriving instance Data (PatSynBind GhcRn GhcRn)
+deriving instance Data (PatSynBind GhcTc GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsIPBinds p)
+deriving instance Data (HsIPBinds GhcPs)
+deriving instance Data (HsIPBinds GhcRn)
+deriving instance Data (HsIPBinds GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (IPBind p)
+deriving instance Data (IPBind GhcPs)
+deriving instance Data (IPBind GhcRn)
+deriving instance Data (IPBind GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (Sig p)
+deriving instance Data (Sig GhcPs)
+deriving instance Data (Sig GhcRn)
+deriving instance Data (Sig GhcTc)
+
+-- deriving instance (DataId p) => Data (FixitySig p)
+deriving instance Data (FixitySig GhcPs)
+deriving instance Data (FixitySig GhcRn)
+deriving instance Data (FixitySig GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsPatSynDir p)
+deriving instance Data (HsPatSynDir GhcPs)
+deriving instance Data (HsPatSynDir GhcRn)
+deriving instance Data (HsPatSynDir GhcTc)
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsDecls ---------------------------------------
+
+-- deriving instance (DataIdLR p p) => Data (HsDecl p)
+deriving instance Data (HsDecl GhcPs)
+deriving instance Data (HsDecl GhcRn)
+deriving instance Data (HsDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsGroup p)
+deriving instance Data (HsGroup GhcPs)
+deriving instance Data (HsGroup GhcRn)
+deriving instance Data (HsGroup GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (SpliceDecl p)
+deriving instance Data (SpliceDecl GhcPs)
+deriving instance Data (SpliceDecl GhcRn)
+deriving instance Data (SpliceDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (TyClDecl p)
+deriving instance Data (TyClDecl GhcPs)
+deriving instance Data (TyClDecl GhcRn)
+deriving instance Data (TyClDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (TyClGroup p)
+deriving instance Data (TyClGroup GhcPs)
+deriving instance Data (TyClGroup GhcRn)
+deriving instance Data (TyClGroup GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (FamilyResultSig p)
+deriving instance Data (FamilyResultSig GhcPs)
+deriving instance Data (FamilyResultSig GhcRn)
+deriving instance Data (FamilyResultSig GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (FamilyDecl p)
+deriving instance Data (FamilyDecl GhcPs)
+deriving instance Data (FamilyDecl GhcRn)
+deriving instance Data (FamilyDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (InjectivityAnn p)
+deriving instance Data (InjectivityAnn GhcPs)
+deriving instance Data (InjectivityAnn GhcRn)
+deriving instance Data (InjectivityAnn GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (FamilyInfo p)
+deriving instance Data (FamilyInfo GhcPs)
+deriving instance Data (FamilyInfo GhcRn)
+deriving instance Data (FamilyInfo GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsDataDefn p)
+deriving instance Data (HsDataDefn GhcPs)
+deriving instance Data (HsDataDefn GhcRn)
+deriving instance Data (HsDataDefn GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsDerivingClause p)
+deriving instance Data (HsDerivingClause GhcPs)
+deriving instance Data (HsDerivingClause GhcRn)
+deriving instance Data (HsDerivingClause GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (ConDecl p)
+deriving instance Data (ConDecl GhcPs)
+deriving instance Data (ConDecl GhcRn)
+deriving instance Data (ConDecl GhcTc)
+
+-- deriving instance DataIdLR p p => Data (TyFamInstDecl p)
+deriving instance Data (TyFamInstDecl GhcPs)
+deriving instance Data (TyFamInstDecl GhcRn)
+deriving instance Data (TyFamInstDecl GhcTc)
+
+-- deriving instance DataIdLR p p => Data (DataFamInstDecl p)
+deriving instance Data (DataFamInstDecl GhcPs)
+deriving instance Data (DataFamInstDecl GhcRn)
+deriving instance Data (DataFamInstDecl GhcTc)
+
+-- deriving instance (DataIdLR p p,Data pats,Data rhs)=>Data (FamEqn p pats rhs)
+deriving instance (Data pats,Data rhs) => Data (FamEqn GhcPs pats rhs)
+deriving instance (Data pats,Data rhs) => Data (FamEqn GhcRn pats rhs)
+deriving instance (Data pats,Data rhs) => Data (FamEqn GhcTc pats rhs)
+
+-- deriving instance (DataIdLR p p) => Data (ClsInstDecl p)
+deriving instance Data (ClsInstDecl GhcPs)
+deriving instance Data (ClsInstDecl GhcRn)
+deriving instance Data (ClsInstDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (InstDecl p)
+deriving instance Data (InstDecl GhcPs)
+deriving instance Data (InstDecl GhcRn)
+deriving instance Data (InstDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (DerivDecl p)
+deriving instance Data (DerivDecl GhcPs)
+deriving instance Data (DerivDecl GhcRn)
+deriving instance Data (DerivDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (DerivStrategy p)
+deriving instance Data (DerivStrategy GhcPs)
+deriving instance Data (DerivStrategy GhcRn)
+deriving instance Data (DerivStrategy GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (DefaultDecl p)
+deriving instance Data (DefaultDecl GhcPs)
+deriving instance Data (DefaultDecl GhcRn)
+deriving instance Data (DefaultDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (ForeignDecl p)
+deriving instance Data (ForeignDecl GhcPs)
+deriving instance Data (ForeignDecl GhcRn)
+deriving instance Data (ForeignDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (RuleDecls p)
+deriving instance Data (RuleDecls GhcPs)
+deriving instance Data (RuleDecls GhcRn)
+deriving instance Data (RuleDecls GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (RuleDecl p)
+deriving instance Data (RuleDecl GhcPs)
+deriving instance Data (RuleDecl GhcRn)
+deriving instance Data (RuleDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (RuleBndr p)
+deriving instance Data (RuleBndr GhcPs)
+deriving instance Data (RuleBndr GhcRn)
+deriving instance Data (RuleBndr GhcTc)
+
+-- deriving instance (DataId p) => Data (WarnDecls p)
+deriving instance Data (WarnDecls GhcPs)
+deriving instance Data (WarnDecls GhcRn)
+deriving instance Data (WarnDecls GhcTc)
+
+-- deriving instance (DataId p) => Data (WarnDecl p)
+deriving instance Data (WarnDecl GhcPs)
+deriving instance Data (WarnDecl GhcRn)
+deriving instance Data (WarnDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (AnnDecl p)
+deriving instance Data (AnnDecl GhcPs)
+deriving instance Data (AnnDecl GhcRn)
+deriving instance Data (AnnDecl GhcTc)
+
+-- deriving instance (DataId p) => Data (RoleAnnotDecl p)
+deriving instance Data (RoleAnnotDecl GhcPs)
+deriving instance Data (RoleAnnotDecl GhcRn)
+deriving instance Data (RoleAnnotDecl GhcTc)
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsExpr ----------------------------------------
+
+-- deriving instance (DataIdLR p p) => Data (SyntaxExpr p)
+deriving instance Data (SyntaxExpr GhcPs)
+deriving instance Data (SyntaxExpr GhcRn)
+deriving instance Data (SyntaxExpr GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsExpr p)
+deriving instance Data (HsExpr GhcPs)
+deriving instance Data (HsExpr GhcRn)
+deriving instance Data (HsExpr GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsTupArg p)
+deriving instance Data (HsTupArg GhcPs)
+deriving instance Data (HsTupArg GhcRn)
+deriving instance Data (HsTupArg GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsCmd p)
+deriving instance Data (HsCmd GhcPs)
+deriving instance Data (HsCmd GhcRn)
+deriving instance Data (HsCmd GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsCmdTop p)
+deriving instance Data (HsCmdTop GhcPs)
+deriving instance Data (HsCmdTop GhcRn)
+deriving instance Data (HsCmdTop GhcTc)
+
+-- deriving instance (DataIdLR p p,Data body) => Data (MatchGroup p body)
+deriving instance (Data body) => Data (MatchGroup GhcPs body)
+deriving instance (Data body) => Data (MatchGroup GhcRn body)
+deriving instance (Data body) => Data (MatchGroup GhcTc body)
+
+-- deriving instance (DataIdLR p p,Data body) => Data (Match p body)
+deriving instance (Data body) => Data (Match GhcPs body)
+deriving instance (Data body) => Data (Match GhcRn body)
+deriving instance (Data body) => Data (Match GhcTc body)
+
+-- deriving instance (DataIdLR p p,Data body) => Data (GRHSs p body)
+deriving instance (Data body) => Data (GRHSs GhcPs body)
+deriving instance (Data body) => Data (GRHSs GhcRn body)
+deriving instance (Data body) => Data (GRHSs GhcTc body)
+
+-- deriving instance (DataIdLR p p,Data body) => Data (GRHS p body)
+deriving instance (Data body) => Data (GRHS GhcPs body)
+deriving instance (Data body) => Data (GRHS GhcRn body)
+deriving instance (Data body) => Data (GRHS GhcTc body)
+
+-- deriving instance (DataIdLR p p,Data body) => Data (StmtLR p p body)
+deriving instance (Data body) => Data (StmtLR GhcPs GhcPs body)
+deriving instance (Data body) => Data (StmtLR GhcPs GhcRn body)
+deriving instance (Data body) => Data (StmtLR GhcRn GhcRn body)
+deriving instance (Data body) => Data (StmtLR GhcTc GhcTc body)
+
+deriving instance Data RecStmtTc
+
+-- deriving instance (DataIdLR p p) => Data (ParStmtBlock p p)
+deriving instance Data (ParStmtBlock GhcPs GhcPs)
+deriving instance Data (ParStmtBlock GhcPs GhcRn)
+deriving instance Data (ParStmtBlock GhcRn GhcRn)
+deriving instance Data (ParStmtBlock GhcTc GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (ApplicativeArg p)
+deriving instance Data (ApplicativeArg GhcPs)
+deriving instance Data (ApplicativeArg GhcRn)
+deriving instance Data (ApplicativeArg GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsSplice p)
+deriving instance Data (HsSplice GhcPs)
+deriving instance Data (HsSplice GhcRn)
+deriving instance Data (HsSplice GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsSplicedThing p)
+deriving instance Data (HsSplicedThing GhcPs)
+deriving instance Data (HsSplicedThing GhcRn)
+deriving instance Data (HsSplicedThing GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsBracket p)
+deriving instance Data (HsBracket GhcPs)
+deriving instance Data (HsBracket GhcRn)
+deriving instance Data (HsBracket GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (ArithSeqInfo p)
+deriving instance Data (ArithSeqInfo GhcPs)
+deriving instance Data (ArithSeqInfo GhcRn)
+deriving instance Data (ArithSeqInfo GhcTc)
+
+deriving instance Data RecordConTc
+deriving instance Data CmdTopTc
+deriving instance Data PendingRnSplice
+deriving instance Data PendingTcSplice
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsLit ----------------------------------------
+
+-- deriving instance (DataId p) => Data (HsLit p)
+deriving instance Data (HsLit GhcPs)
+deriving instance Data (HsLit GhcRn)
+deriving instance Data (HsLit GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsOverLit p)
+deriving instance Data (HsOverLit GhcPs)
+deriving instance Data (HsOverLit GhcRn)
+deriving instance Data (HsOverLit GhcTc)
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsPat -----------------------------------------
+
+-- deriving instance (DataIdLR p p) => Data (Pat p)
+deriving instance Data (Pat GhcPs)
+deriving instance Data (Pat GhcRn)
+deriving instance Data (Pat GhcTc)
+
+deriving instance Data ListPatTc
+
+-- deriving instance (DataIdLR p p, Data body) => Data (HsRecFields p body)
+deriving instance (Data body) => Data (HsRecFields GhcPs body)
+deriving instance (Data body) => Data (HsRecFields GhcRn body)
+deriving instance (Data body) => Data (HsRecFields GhcTc body)
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsTypes ---------------------------------------
+
+-- deriving instance (DataIdLR p p) => Data (LHsQTyVars p)
+deriving instance Data (LHsQTyVars GhcPs)
+deriving instance Data (LHsQTyVars GhcRn)
+deriving instance Data (LHsQTyVars GhcTc)
+
+-- deriving instance (DataIdLR p p, Data thing) =>Data (HsImplicitBndrs p thing)
+deriving instance (Data thing) => Data (HsImplicitBndrs GhcPs thing)
+deriving instance (Data thing) => Data (HsImplicitBndrs GhcRn thing)
+deriving instance (Data thing) => Data (HsImplicitBndrs GhcTc thing)
+
+-- deriving instance (DataIdLR p p, Data thing) =>Data (HsWildCardBndrs p thing)
+deriving instance (Data thing) => Data (HsWildCardBndrs GhcPs thing)
+deriving instance (Data thing) => Data (HsWildCardBndrs GhcRn thing)
+deriving instance (Data thing) => Data (HsWildCardBndrs GhcTc thing)
+
+-- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p)
+deriving instance Data (HsTyVarBndr GhcPs)
+deriving instance Data (HsTyVarBndr GhcRn)
+deriving instance Data (HsTyVarBndr GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsType p)
+deriving instance Data (HsType GhcPs)
+deriving instance Data (HsType GhcRn)
+deriving instance Data (HsType GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (ConDeclField p)
+deriving instance Data (ConDeclField GhcPs)
+deriving instance Data (ConDeclField GhcRn)
+deriving instance Data (ConDeclField GhcTc)
+
+-- deriving instance (DataId p) => Data (FieldOcc p)
+deriving instance Data (FieldOcc GhcPs)
+deriving instance Data (FieldOcc GhcRn)
+deriving instance Data (FieldOcc GhcTc)
+
+-- deriving instance DataId p => Data (AmbiguousFieldOcc p)
+deriving instance Data (AmbiguousFieldOcc GhcPs)
+deriving instance Data (AmbiguousFieldOcc GhcRn)
+deriving instance Data (AmbiguousFieldOcc GhcTc)
+
+
+-- deriving instance (DataId name) => Data (ImportDecl name)
+deriving instance Data (ImportDecl GhcPs)
+deriving instance Data (ImportDecl GhcRn)
+deriving instance Data (ImportDecl GhcTc)
+
+-- deriving instance (DataId name) => Data (IE name)
+deriving instance Data (IE GhcPs)
+deriving instance Data (IE GhcRn)
+deriving instance Data (IE GhcTc)
+
+-- deriving instance (Eq name, Eq (IdP name)) => Eq (IE name)
+deriving instance Eq (IE GhcPs)
+deriving instance Eq (IE GhcRn)
+deriving instance Eq (IE GhcTc)
+
+-- ---------------------------------------------------------------------
diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs
index 1044f9bca6..d1411bd750 100644
--- a/compiler/hsSyn/HsLit.hs
+++ b/compiler/hsSyn/HsLit.hs
@@ -8,7 +8,6 @@
{-# LANGUAGE CPP, DeriveDataTypeable #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
@@ -19,10 +18,12 @@ module HsLit where
#include "HsVersions.h"
+import GhcPrelude
+
import {-# SOURCE #-} HsExpr( HsExpr, pprExpr )
import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit,
negateFractionalLit,SourceText(..),pprWithSourceText )
-import Type ( Type )
+import Type
import Outputable
import FastString
import HsExtension
@@ -75,8 +76,22 @@ data HsLit x
| HsDoublePrim (XHsDoublePrim x) FractionalLit
-- ^ Unboxed Double
-deriving instance (DataId x) => Data (HsLit x)
+ | XLit (XXLit x)
+type instance XHsChar (GhcPass _) = SourceText
+type instance XHsCharPrim (GhcPass _) = SourceText
+type instance XHsString (GhcPass _) = SourceText
+type instance XHsStringPrim (GhcPass _) = SourceText
+type instance XHsInt (GhcPass _) = NoExt
+type instance XHsIntPrim (GhcPass _) = SourceText
+type instance XHsWordPrim (GhcPass _) = SourceText
+type instance XHsInt64Prim (GhcPass _) = SourceText
+type instance XHsWord64Prim (GhcPass _) = SourceText
+type instance XHsInteger (GhcPass _) = SourceText
+type instance XHsRat (GhcPass _) = NoExt
+type instance XHsFloatPrim (GhcPass _) = NoExt
+type instance XHsDoublePrim (GhcPass _) = NoExt
+type instance XXLit (GhcPass _) = NoExt
instance Eq (HsLit x) where
(HsChar _ x1) == (HsChar _ x2) = x1==x2
@@ -97,11 +112,24 @@ instance Eq (HsLit x) where
-- | Haskell Overloaded Literal
data HsOverLit p
= OverLit {
- ol_val :: OverLitVal,
- ol_rebindable :: PostRn p Bool, -- Note [ol_rebindable]
- ol_witness :: HsExpr p, -- Note [Overloaded literal witnesses]
- ol_type :: PostTc p Type }
-deriving instance (DataId p, DataId p) => Data (HsOverLit p)
+ ol_ext :: (XOverLit p),
+ ol_val :: OverLitVal,
+ ol_witness :: HsExpr p} -- Note [Overloaded literal witnesses]
+
+ | XOverLit
+ (XXOverLit p)
+
+data OverLitTc
+ = OverLitTc {
+ ol_rebindable :: Bool, -- Note [ol_rebindable]
+ ol_type :: Type }
+ deriving Data
+
+type instance XOverLit GhcPs = NoExt
+type instance XOverLit GhcRn = Bool -- Note [ol_rebindable]
+type instance XOverLit GhcTc = OverLitTc
+
+type instance XXOverLit (GhcPass _) = NoExt
-- Note [Literal source text] in BasicTypes for SourceText fields in
-- the following
@@ -117,8 +145,9 @@ negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i)
negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f)
negateOverLitVal _ = panic "negateOverLitVal: argument is not a number"
-overLitType :: HsOverLit p -> PostTc p Type
-overLitType = ol_type
+overLitType :: HsOverLit GhcTc -> Type
+overLitType (OverLit (OverLitTc _ ty) _ _) = ty
+overLitType XOverLit{} = panic "overLitType"
-- | Convert a literal from one index type to another, updating the annotations
-- according to the relevant 'Convertable' instance
@@ -136,6 +165,7 @@ convertLit (HsInteger a x b) = (HsInteger (convert a) x b)
convertLit (HsRat a x b) = (HsRat (convert a) x b)
convertLit (HsFloatPrim a x) = (HsFloatPrim (convert a) x)
convertLit (HsDoublePrim a x) = (HsDoublePrim (convert a) x)
+convertLit (XLit a) = (XLit (convert a))
{-
Note [ol_rebindable]
@@ -169,8 +199,10 @@ found to have.
-- Comparison operations are needed when grouping literals
-- for compiling pattern-matching (module MatchLit)
-instance Eq (HsOverLit p) where
- (OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2
+instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where
+ (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2
+ (XOverLit val1) == (XOverLit val2) = val1 == val2
+ _ == _ = panic "Eq HsOverLit"
instance Eq OverLitVal where
(HsIntegral i1) == (HsIntegral i2) = i1 == i2
@@ -178,8 +210,10 @@ instance Eq OverLitVal where
(HsIsString _ s1) == (HsIsString _ s2) = s1 == s2
_ == _ = False
-instance Ord (HsOverLit p) where
- compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2
+instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where
+ compare (OverLit _ val1 _) (OverLit _ val2 _) = val1 `compare` val2
+ compare (XOverLit val1) (XOverLit val2) = val1 `compare` val2
+ compare _ _ = panic "Ord HsOverLit"
instance Ord OverLitVal where
compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2
@@ -193,38 +227,33 @@ instance Ord OverLitVal where
compare (HsIsString _ _) (HsFractional _) = GT
-- Instance specific to GhcPs, need the SourceText
-instance (SourceTextX x) => Outputable (HsLit x) where
- ppr (HsChar st c) = pprWithSourceText (getSourceText st) (pprHsChar c)
- ppr (HsCharPrim st c)
- = pp_st_suffix (getSourceText st) primCharSuffix (pprPrimChar c)
- ppr (HsString st s)
- = pprWithSourceText (getSourceText st) (pprHsString s)
- ppr (HsStringPrim st s)
- = pprWithSourceText (getSourceText st) (pprHsBytes s)
+instance p ~ GhcPass pass => Outputable (HsLit p) where
+ ppr (HsChar st c) = pprWithSourceText st (pprHsChar c)
+ ppr (HsCharPrim st c) = pp_st_suffix st primCharSuffix (pprPrimChar c)
+ ppr (HsString st s) = pprWithSourceText st (pprHsString s)
+ ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s)
ppr (HsInt _ i)
= pprWithSourceText (il_text i) (integer (il_value i))
- ppr (HsInteger st i _) = pprWithSourceText (getSourceText st) (integer i)
+ ppr (HsInteger st i _) = pprWithSourceText st (integer i)
ppr (HsRat _ f _) = ppr f
ppr (HsFloatPrim _ f) = ppr f <> primFloatSuffix
ppr (HsDoublePrim _ d) = ppr d <> primDoubleSuffix
- ppr (HsIntPrim st i)
- = pprWithSourceText (getSourceText st) (pprPrimInt i)
- ppr (HsWordPrim st w)
- = pprWithSourceText (getSourceText st) (pprPrimWord w)
- ppr (HsInt64Prim st i)
- = pp_st_suffix (getSourceText st) primInt64Suffix (pprPrimInt64 i)
- ppr (HsWord64Prim st w)
- = pp_st_suffix (getSourceText st) primWord64Suffix (pprPrimWord64 w)
+ ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i)
+ ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w)
+ ppr (HsInt64Prim st i) = pp_st_suffix st primInt64Suffix (pprPrimInt64 i)
+ ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w)
+ ppr (XLit x) = ppr x
pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc
pp_st_suffix NoSourceText _ doc = doc
pp_st_suffix (SourceText st) suffix _ = text st <> suffix
-- in debug mode, print the expression that it's resolved to, too
-instance (SourceTextX p, OutputableBndrId p)
+instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsOverLit p) where
ppr (OverLit {ol_val=val, ol_witness=witness})
- = ppr val <+> (ifPprDebug (parens (pprExpr witness)))
+ = ppr val <+> (whenPprDebug (parens (pprExpr witness)))
+ ppr (XOverLit x) = ppr x
instance Outputable OverLitVal where
ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i))
@@ -237,11 +266,10 @@ instance Outputable OverLitVal where
-- mainly for too reasons:
-- * We do not want to expose their internal representation
-- * The warnings become too messy
-pmPprHsLit :: (SourceTextX x) => HsLit x -> SDoc
+pmPprHsLit :: HsLit (GhcPass x) -> SDoc
pmPprHsLit (HsChar _ c) = pprHsChar c
pmPprHsLit (HsCharPrim _ c) = pprHsChar c
-pmPprHsLit (HsString st s) = pprWithSourceText (getSourceText st)
- (pprHsString s)
+pmPprHsLit (HsString st s) = pprWithSourceText st (pprHsString s)
pmPprHsLit (HsStringPrim _ s) = pprHsBytes s
pmPprHsLit (HsInt _ i) = integer (il_value i)
pmPprHsLit (HsIntPrim _ i) = integer i
@@ -252,3 +280,35 @@ pmPprHsLit (HsInteger _ i _) = integer i
pmPprHsLit (HsRat _ f _) = ppr f
pmPprHsLit (HsFloatPrim _ f) = ppr f
pmPprHsLit (HsDoublePrim _ d) = ppr d
+pmPprHsLit (XLit x) = ppr x
+
+-- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs
+-- to be parenthesized under precedence @p@.
+hsLitNeedsParens :: PprPrec -> HsLit x -> Bool
+hsLitNeedsParens p = go
+ where
+ go (HsChar {}) = False
+ go (HsCharPrim {}) = False
+ go (HsString {}) = False
+ go (HsStringPrim {}) = False
+ go (HsInt _ x) = p > topPrec && il_neg x
+ go (HsIntPrim _ x) = p > topPrec && x < 0
+ go (HsWordPrim {}) = False
+ go (HsInt64Prim _ x) = p > topPrec && x < 0
+ go (HsWord64Prim {}) = False
+ go (HsInteger _ x _) = p > topPrec && x < 0
+ go (HsRat _ x _) = p > topPrec && fl_neg x
+ go (HsFloatPrim _ x) = p > topPrec && fl_neg x
+ go (HsDoublePrim _ x) = p > topPrec && fl_neg x
+ go (XLit _) = False
+
+-- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal
+-- @ol@ needs to be parenthesized under precedence @p@.
+hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool
+hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv
+ where
+ go :: OverLitVal -> Bool
+ go (HsIntegral x) = p > topPrec && il_neg x
+ go (HsFractional x) = p > topPrec && fl_neg x
+ go (HsIsString {}) = False
+hsOverLitNeedsParens _ (XOverLit { }) = False
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index f7d18768df..6f65487411 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -18,6 +18,7 @@
module HsPat (
Pat(..), InPat, OutPat, LPat,
+ ListPatTc(..),
HsConPatDetails, hsConPatArgs,
HsRecFields(..), HsRecField'(..), LHsRecField',
@@ -29,15 +30,17 @@ module HsPat (
mkPrefixConPat, mkCharLitPat, mkNilPat,
looksLazyPatBind,
- isBangedLPat, isBangedPatBind,
- hsPatNeedsParens,
+ isBangedLPat,
+ patNeedsParens, parenthesizePat,
isIrrefutableHsPat,
- collectEvVarsPats,
+ collectEvVarsPat, collectEvVarsPats,
pprParendLPat, pprConArgs
) where
+import GhcPrelude
+
import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprSplice)
-- friends:
@@ -76,42 +79,47 @@ type LPat p = Located (Pat p)
-- For details on above see note [Api annotations] in ApiAnnotation
data Pat p
= ------------ Simple patterns ---------------
- WildPat (PostTc p Type) -- ^ Wildcard Pattern
+ WildPat (XWildPat p) -- ^ Wildcard Pattern
-- The sole reason for a type on a WildPat is to
-- support hsPatType :: Pat Id -> Type
-- AZ:TODO above comment needs to be updated
- | VarPat (Located (IdP p)) -- ^ Variable Pattern
+ | VarPat (XVarPat p)
+ (Located (IdP p)) -- ^ Variable Pattern
-- See Note [Located RdrNames] in HsExpr
- | LazyPat (LPat p) -- ^ Lazy Pattern
+ | LazyPat (XLazyPat p)
+ (LPat p) -- ^ Lazy Pattern
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
-- For details on above see note [Api annotations] in ApiAnnotation
- | AsPat (Located (IdP p)) (LPat p) -- ^ As pattern
+ | AsPat (XAsPat p)
+ (Located (IdP p)) (LPat p) -- ^ As pattern
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
-- For details on above see note [Api annotations] in ApiAnnotation
- | ParPat (LPat p) -- ^ Parenthesised pattern
+ | ParPat (XParPat p)
+ (LPat p) -- ^ Parenthesised pattern
-- See Note [Parens in HsSyn] in HsExpr
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
-- 'ApiAnnotation.AnnClose' @')'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | BangPat (LPat p) -- ^ Bang pattern
+ | BangPat (XBangPat p)
+ (LPat p) -- ^ Bang pattern
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
-- For details on above see note [Api annotations] in ApiAnnotation
------------ Lists, tuples, arrays ---------------
- | ListPat [LPat p]
- (PostTc p Type) -- The type of the elements
- (Maybe (PostTc p Type, SyntaxExpr p)) -- For rebindable syntax
+ | ListPat (XListPat p)
+ [LPat p]
-- For OverloadedLists a Just (ty,fn) gives
-- overall type of the pattern, and the toList
- -- function to convert the scrutinee to a list value
+-- function to convert the scrutinee to a list value
+
-- ^ Syntactic List
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
@@ -119,12 +127,13 @@ data Pat p
-- For details on above see note [Api annotations] in ApiAnnotation
- | TuplePat [LPat p] -- Tuple sub-patterns
+ | TuplePat (XTuplePat p)
+ -- after typechecking, holds the types of the tuple components
+ [LPat p] -- Tuple sub-patterns
Boxity -- UnitPat is TuplePat []
- [PostTc p Type] -- [] before typechecker, filled in afterwards
- -- with the types of the tuple components
- -- You might think that the PostTc p Type was redundant, because we can
- -- get the pattern type by getting the types of the sub-patterns.
+ -- You might think that the post typechecking Type was redundant,
+ -- because we can get the pattern type by getting the types of the
+ -- sub-patterns.
-- But it's essential
-- data T a where
-- T1 :: Int -> T Int
@@ -144,12 +153,12 @@ data Pat p
-- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
-- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@
- | SumPat (LPat p) -- Sum sub-pattern
- ConTag -- Alternative (one-based)
- Arity -- Arity
- (PostTc p [Type]) -- PlaceHolder before typechecker, filled in
+ | SumPat (XSumPat p) -- PlaceHolder before typechecker, filled in
-- afterwards with the types of the
-- alternative
+ (LPat p) -- Sum sub-pattern
+ ConTag -- Alternative (one-based)
+ Arity -- Arity (INVARIANT: ≥ 2)
-- ^ Anonymous sum pattern
--
-- - 'ApiAnnotation.AnnKeywordId' :
@@ -157,12 +166,7 @@ data Pat p
-- 'ApiAnnotation.AnnClose' @'#)'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | PArrPat [LPat p] -- Syntactic parallel array
- (PostTc p Type) -- The type of the elements
- -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
- -- 'ApiAnnotation.AnnClose' @':]'@
- -- For details on above see note [Api annotations] in ApiAnnotation
------------ Constructor patterns ---------------
| ConPatIn (Located (IdP p))
(HsConPatDetails p)
@@ -193,11 +197,11 @@ data Pat p
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
- | ViewPat (LHsExpr p)
+ | ViewPat (XViewPat p) -- The overall type of the pattern
+ -- (= the argument type of the view function)
+ -- for hsPatType.
+ (LHsExpr p)
(LPat p)
- (PostTc p Type) -- The overall type of the pattern
- -- (= the argument type of the view function)
- -- for hsPatType.
-- ^ View Pattern
------------ Pattern splices ---------------
@@ -205,31 +209,34 @@ data Pat p
-- 'ApiAnnotation.AnnClose' @')'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | SplicePat (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes)
+ | SplicePat (XSplicePat p)
+ (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes)
------------ Literal and n+k patterns ---------------
- | LitPat (HsLit p) -- ^ Literal Pattern
+ | LitPat (XLitPat p)
+ (HsLit p) -- ^ Literal Pattern
-- Used for *non-overloaded* literal patterns:
-- Int#, Char#, Int, Char, String, etc.
| NPat -- Natural Pattern
-- Used for all overloaded literals,
-- including overloaded strings with -XOverloadedStrings
+ (XNPat p) -- Overall type of pattern. Might be
+ -- different than the literal's type
+ -- if (==) or negate changes the type
(Located (HsOverLit p)) -- ALWAYS positive
(Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for
-- negative patterns, Nothing
-- otherwise
(SyntaxExpr p) -- Equality checker, of type t->t->Bool
- (PostTc p Type) -- Overall type of pattern. Might be
- -- different than the literal's type
- -- if (==) or negate changes the type
-- ^ Natural Pattern
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | NPlusKPat (Located (IdP p)) -- n+k pattern
+ | NPlusKPat (XNPlusKPat p) -- Type of overall pattern
+ (Located (IdP p)) -- n+k pattern
(Located (HsOverLit p)) -- It'll always be an HsIntegral
(HsOverLit p) -- See Note [NPlusK patterns] in TcPat
-- NB: This could be (PostTc ...), but that induced a
@@ -237,24 +244,22 @@ data Pat p
(SyntaxExpr p) -- (>=) function, of type t1->t2->Bool
(SyntaxExpr p) -- Name of '-' (see RnEnv.lookupSyntaxName)
- (PostTc p Type) -- Type of overall pattern
-- ^ n+k pattern
------------ Pattern type signatures ---------------
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
-- For details on above see note [Api annotations] in ApiAnnotation
- | SigPatIn (LPat p) -- Pattern with a type signature
- (LHsSigWcType p) -- Signature can bind both
- -- kind and type vars
- -- ^ Pattern with a type signature
-
- | SigPatOut (LPat p)
- Type
+ | SigPat (XSigPat p) -- Before typechecker
+ -- Signature can bind both
+ -- kind and type vars
+ -- After typechecker: Type
+ (LPat p) -- Pattern with a type signature
-- ^ Pattern with a type signature
------------ Pattern coercions (translation only) ---------------
- | CoPat HsWrapper -- Coercion Pattern
+ | CoPat (XCoPat p)
+ HsWrapper -- Coercion Pattern
-- If co :: t1 ~ t2, p :: t2,
-- then (CoPat co p) :: t1
(Pat p) -- Why not LPat? Ans: existing locn will do
@@ -262,7 +267,67 @@ data Pat p
-- During desugaring a (CoPat co pat) turns into a cast with 'co' on
-- the scrutinee, followed by a match on 'pat'
-- ^ Coercion Pattern
-deriving instance (DataId p) => Data (Pat p)
+
+ -- | Trees that Grow extension point for new constructors
+ | XPat
+ (XXPat p)
+
+-- ---------------------------------------------------------------------
+
+data ListPatTc
+ = ListPatTc
+ Type -- The type of the elements
+ (Maybe (Type, SyntaxExpr GhcTc)) -- For rebindable syntax
+
+type instance XWildPat GhcPs = NoExt
+type instance XWildPat GhcRn = NoExt
+type instance XWildPat GhcTc = Type
+
+type instance XVarPat (GhcPass _) = NoExt
+type instance XLazyPat (GhcPass _) = NoExt
+type instance XAsPat (GhcPass _) = NoExt
+type instance XParPat (GhcPass _) = NoExt
+type instance XBangPat (GhcPass _) = NoExt
+
+-- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap
+-- compiler, as it triggers https://ghc.haskell.org/trac/ghc/ticket/14396 for
+-- `SyntaxExpr`
+type instance XListPat GhcPs = NoExt
+type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn)
+type instance XListPat GhcTc = ListPatTc
+
+type instance XTuplePat GhcPs = NoExt
+type instance XTuplePat GhcRn = NoExt
+type instance XTuplePat GhcTc = [Type]
+
+type instance XSumPat GhcPs = NoExt
+type instance XSumPat GhcRn = NoExt
+type instance XSumPat GhcTc = [Type]
+
+type instance XViewPat GhcPs = NoExt
+type instance XViewPat GhcRn = NoExt
+type instance XViewPat GhcTc = Type
+
+type instance XSplicePat (GhcPass _) = NoExt
+type instance XLitPat (GhcPass _) = NoExt
+
+type instance XNPat GhcPs = NoExt
+type instance XNPat GhcRn = NoExt
+type instance XNPat GhcTc = Type
+
+type instance XNPlusKPat GhcPs = NoExt
+type instance XNPlusKPat GhcRn = NoExt
+type instance XNPlusKPat GhcTc = Type
+
+type instance XSigPat GhcPs = (LHsSigWcType GhcPs)
+type instance XSigPat GhcRn = (LHsSigWcType GhcRn)
+type instance XSigPat GhcTc = Type
+
+type instance XCoPat (GhcPass _) = NoExt
+type instance XXPat (GhcPass _) = NoExt
+
+-- ---------------------------------------------------------------------
+
-- | Haskell Constructor Pattern Details
type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))
@@ -282,7 +347,6 @@ data HsRecFields p arg -- A bunch of record fields
= HsRecFields { rec_flds :: [LHsRecField p arg],
rec_dotdot :: Maybe Int } -- Note [DotDot fields]
deriving (Functor, Foldable, Traversable)
-deriving instance (DataId p, Data arg) => Data (HsRecFields p arg)
-- Note [DotDot fields]
@@ -367,11 +431,11 @@ data HsRecField' id arg = HsRecField {
--
-- The parsed HsRecUpdField corresponding to the record update will have:
--
--- hsRecFieldLbl = Unambiguous "x" PlaceHolder :: AmbiguousFieldOcc RdrName
+-- hsRecFieldLbl = Unambiguous "x" NoExt :: AmbiguousFieldOcc RdrName
--
-- After the renamer, this will become:
--
--- hsRecFieldLbl = Ambiguous "x" PlaceHolder :: AmbiguousFieldOcc Name
+-- hsRecFieldLbl = Ambiguous "x" NoExt :: AmbiguousFieldOcc Name
--
-- (note that the Unambiguous constructor is not type-correct here).
-- The typechecker will determine the particular selector:
@@ -380,24 +444,24 @@ data HsRecField' id arg = HsRecField {
--
-- See also Note [Disambiguating record fields] in TcExpr.
-hsRecFields :: HsRecFields p arg -> [PostRn p (IdP p)]
+hsRecFields :: HsRecFields p arg -> [XCFieldOcc p]
hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)
-- Probably won't typecheck at once, things have changed :/
hsRecFieldsArgs :: HsRecFields p arg -> [arg]
hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds)
-hsRecFieldSel :: HsRecField pass arg -> Located (PostRn pass (IdP pass))
-hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl
+hsRecFieldSel :: HsRecField pass arg -> Located (XCFieldOcc pass)
+hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl
hsRecFieldId :: HsRecField GhcTc arg -> Located Id
hsRecFieldId = hsRecFieldSel
-hsRecUpdFieldRdr :: HsRecUpdField p -> Located RdrName
+hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName
hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl
hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id
-hsRecUpdFieldId = fmap selectorFieldOcc . hsRecUpdFieldOcc
+hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc
hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc
hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
@@ -411,8 +475,7 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
************************************************************************
-}
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (Pat pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) where
ppr = pprPat
pprPatBndr :: OutputableBndr name => name -> SDoc
@@ -424,46 +487,49 @@ pprPatBndr var -- Print with type info if -dppr-debug is on
else
pprPrefixOcc var
-pprParendLPat :: (SourceTextX pass, OutputableBndrId pass) => LPat pass -> SDoc
-pprParendLPat (L _ p) = pprParendPat p
+pprParendLPat :: (OutputableBndrId (GhcPass p))
+ => PprPrec -> LPat (GhcPass p) -> SDoc
+pprParendLPat p (L _ pat) = pprParendPat p pat
-pprParendPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc
-pprParendPat p = sdocWithDynFlags $ \ dflags ->
- if need_parens dflags p
- then parens (pprPat p)
- else pprPat p
+pprParendPat :: (OutputableBndrId (GhcPass p))
+ => PprPrec -> Pat (GhcPass p) -> SDoc
+pprParendPat p pat = sdocWithDynFlags $ \ dflags ->
+ if need_parens dflags pat
+ then parens (pprPat pat)
+ else pprPat pat
where
- need_parens dflags p
- | CoPat {} <- p = gopt Opt_PrintTypecheckerElaboration dflags
- | otherwise = hsPatNeedsParens p
+ need_parens dflags pat
+ | CoPat {} <- pat = gopt Opt_PrintTypecheckerElaboration dflags
+ | otherwise = patNeedsParens p pat
-- For a CoPat we need parens if we are going to show it, which
-- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper)
-- But otherwise the CoPat is discarded, so it
-- is the pattern inside that matters. Sigh.
-pprPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc
-pprPat (VarPat (L _ var)) = pprPatBndr var
-pprPat (WildPat _) = char '_'
-pprPat (LazyPat pat) = char '~' <> pprParendLPat pat
-pprPat (BangPat pat) = char '!' <> pprParendLPat pat
-pprPat (AsPat name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat]
-pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
-pprPat (ParPat pat) = parens (ppr pat)
-pprPat (LitPat s) = ppr s
-pprPat (NPat l Nothing _ _) = ppr l
-pprPat (NPat l (Just _) _ _) = char '-' <> ppr l
-pprPat (NPlusKPat n k _ _ _ _)= hcat [ppr n, char '+', ppr k]
-pprPat (SplicePat splice) = pprSplice splice
-pprPat (CoPat co pat _) = pprHsWrapper co (\parens -> if parens
- then pprParendPat pat
- else pprPat pat)
-pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
-pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty
-pprPat (ListPat pats _ _) = brackets (interpp'SP pats)
-pprPat (PArrPat pats _) = paBrackets (interpp'SP pats)
-pprPat (TuplePat pats bx _) = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
-pprPat (SumPat pat alt arity _) = sumParens (pprAlternative ppr pat alt arity)
-pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
+pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc
+pprPat (VarPat _ (L _ var)) = pprPatBndr var
+pprPat (WildPat _) = char '_'
+pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat
+pprPat (BangPat _ pat) = char '!' <> pprParendLPat appPrec pat
+pprPat (AsPat _ name pat) = hcat [pprPrefixOcc (unLoc name), char '@',
+ pprParendLPat appPrec pat]
+pprPat (ViewPat _ expr pat) = hcat [pprLExpr expr, text " -> ", ppr pat]
+pprPat (ParPat _ pat) = parens (ppr pat)
+pprPat (LitPat _ s) = ppr s
+pprPat (NPat _ l Nothing _) = ppr l
+pprPat (NPat _ l (Just _) _) = char '-' <> ppr l
+pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr n, char '+', ppr k]
+pprPat (SplicePat _ splice) = pprSplice splice
+pprPat (CoPat _ co pat _) = pprHsWrapper co $ \parens
+ -> if parens
+ then pprParendPat appPrec pat
+ else pprPat pat
+pprPat (SigPat ty pat) = ppr pat <+> dcolon <+> ppr ty
+pprPat (ListPat _ pats) = brackets (interpp'SP pats)
+pprPat (TuplePat _ pats bx) = tupleParens (boxityTupleSort bx)
+ (pprWithCommas ppr pats)
+pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity)
+pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
pat_binds = binds, pat_args = details })
= sdocWithDynFlags $ \dflags ->
@@ -476,16 +542,19 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
, ppr binds])
<+> pprConArgs details
else pprUserCon (unLoc con) details
+pprPat (XPat x) = ppr x
-pprUserCon :: (SourceTextX p, OutputableBndr con, OutputableBndrId p)
- => con -> HsConPatDetails p -> SDoc
+pprUserCon :: (OutputableBndr con, OutputableBndrId (GhcPass p))
+ => con -> HsConPatDetails (GhcPass p) -> SDoc
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details = pprPrefixOcc c <+> pprConArgs details
-pprConArgs :: (SourceTextX p, OutputableBndrId p) => HsConPatDetails p -> SDoc
-pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
-pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
+pprConArgs :: (OutputableBndrId (GhcPass p))
+ => HsConPatDetails (GhcPass p) -> SDoc
+pprConArgs (PrefixCon pats) = sep (map (pprParendLPat appPrec) pats)
+pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1
+ , pprParendLPat appPrec p2 ]
pprConArgs (RecCon rpats) = ppr rpats
instance (Outputable arg)
@@ -495,7 +564,7 @@ instance (Outputable arg)
ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
= braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
where
- dotdot = text ".." <+> ifPprDebug (ppr (drop n flds))
+ dotdot = text ".." <+> whenPprDebug (ppr (drop n flds))
instance (Outputable p, Outputable arg)
=> Outputable (HsRecField' p arg) where
@@ -522,9 +591,9 @@ mkPrefixConPat dc pats tys
mkNilPat :: Type -> OutPat p
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
-mkCharLitPat :: (SourceTextX p) => SourceText -> Char -> OutPat p
+mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p)
mkCharLitPat src c = mkPrefixConPat charDataCon
- [noLoc $ LitPat (HsCharPrim (setSourceText src) c)] []
+ [noLoc $ LitPat NoExt (HsCharPrim src c)] []
{-
************************************************************************
@@ -558,12 +627,8 @@ patterns are treated specially, of course.
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
-}
-isBangedPatBind :: HsBind p -> Bool
-isBangedPatBind (PatBind {pat_lhs = pat}) = isBangedLPat pat
-isBangedPatBind _ = False
-
isBangedLPat :: LPat p -> Bool
-isBangedLPat (L _ (ParPat p)) = isBangedLPat p
+isBangedLPat (L _ (ParPat _ p)) = isBangedLPat p
isBangedLPat (L _ (BangPat {})) = True
isBangedLPat _ = False
@@ -577,20 +642,18 @@ looksLazyPatBind (PatBind { pat_lhs = p })
= looksLazyLPat p
looksLazyPatBind (AbsBinds { abs_binds = binds })
= anyBag (looksLazyPatBind . unLoc) binds
-looksLazyPatBind (AbsBindsSig { abs_sig_bind = L _ bind })
- = looksLazyPatBind bind
looksLazyPatBind _
= False
looksLazyLPat :: LPat p -> Bool
-looksLazyLPat (L _ (ParPat p)) = looksLazyLPat p
-looksLazyLPat (L _ (AsPat _ p)) = looksLazyLPat p
+looksLazyLPat (L _ (ParPat _ p)) = looksLazyLPat p
+looksLazyLPat (L _ (AsPat _ _ p)) = looksLazyLPat p
looksLazyLPat (L _ (BangPat {})) = False
looksLazyLPat (L _ (VarPat {})) = False
looksLazyLPat (L _ (WildPat {})) = False
looksLazyLPat _ = True
-isIrrefutableHsPat :: (SourceTextX p, OutputableBndrId p) => LPat p -> Bool
+isIrrefutableHsPat :: (OutputableBndrId p) => LPat p -> Bool
-- (isIrrefutableHsPat p) is true if matching against p cannot fail,
-- in the sense of falling through to the next pattern.
-- (NB: this is not quite the same as the (silly) defn
@@ -611,17 +674,16 @@ isIrrefutableHsPat pat
go1 (WildPat {}) = True
go1 (VarPat {}) = True
go1 (LazyPat {}) = True
- go1 (BangPat pat) = go pat
- go1 (CoPat _ pat _) = go1 pat
- go1 (ParPat pat) = go pat
- go1 (AsPat _ pat) = go pat
- go1 (ViewPat _ pat _) = go pat
- go1 (SigPatIn pat _) = go pat
- go1 (SigPatOut pat _) = go pat
- go1 (TuplePat pats _ _) = all go pats
- go1 (SumPat pat _ _ _) = go pat
+ go1 (BangPat _ pat) = go pat
+ go1 (CoPat _ _ pat _) = go1 pat
+ go1 (ParPat _ pat) = go pat
+ go1 (AsPat _ _ pat) = go pat
+ go1 (ViewPat _ _ pat) = go pat
+ go1 (SigPat _ pat) = go pat
+ go1 (TuplePat _ pats _) = all go pats
+ go1 (SumPat {}) = False
+ -- See Note [Unboxed sum patterns aren't irrefutable]
go1 (ListPat {}) = False
- go1 (PArrPat {}) = False -- ?
go1 (ConPatIn {}) = False -- Conservative
go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details })
@@ -640,62 +702,98 @@ isIrrefutableHsPat pat
-- since we cannot know until the splice is evaluated.
go1 (SplicePat {}) = False
-hsPatNeedsParens :: Pat a -> Bool
-hsPatNeedsParens (NPlusKPat {}) = True
-hsPatNeedsParens (SplicePat {}) = False
-hsPatNeedsParens (ConPatIn _ ds) = conPatNeedsParens ds
-hsPatNeedsParens p@(ConPatOut {}) = conPatNeedsParens (pat_args p)
-hsPatNeedsParens (SigPatIn {}) = True
-hsPatNeedsParens (SigPatOut {}) = True
-hsPatNeedsParens (ViewPat {}) = True
-hsPatNeedsParens (CoPat _ p _) = hsPatNeedsParens p
-hsPatNeedsParens (WildPat {}) = False
-hsPatNeedsParens (VarPat {}) = False
-hsPatNeedsParens (LazyPat {}) = False
-hsPatNeedsParens (BangPat {}) = False
-hsPatNeedsParens (ParPat {}) = False
-hsPatNeedsParens (AsPat {}) = False
-hsPatNeedsParens (TuplePat {}) = False
-hsPatNeedsParens (SumPat {}) = False
-hsPatNeedsParens (ListPat {}) = False
-hsPatNeedsParens (PArrPat {}) = False
-hsPatNeedsParens (LitPat {}) = False
-hsPatNeedsParens (NPat {}) = False
-
-conPatNeedsParens :: HsConDetails a b -> Bool
-conPatNeedsParens (PrefixCon {}) = False
-conPatNeedsParens (InfixCon {}) = True
-conPatNeedsParens (RecCon {}) = False
+ go1 (XPat {}) = False
+
+{- Note [Unboxed sum patterns aren't irrefutable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as
+patterns. A simple example that demonstrates this is from #14228:
+
+ pattern Just' x = (# x | #)
+ pattern Nothing' = (# | () #)
+
+ foo x = case x of
+ Nothing' -> putStrLn "nothing"
+ Just' -> putStrLn "just"
+
+In foo, the pattern Nothing' (that is, (# x | #)) is certainly not irrefutable,
+as does not match an unboxed sum value of the same arity—namely, (# | y #)
+(covered by Just'). In fact, no unboxed sum pattern is irrefutable, since the
+minimum unboxed sum arity is 2.
+
+Failing to mark unboxed sum patterns as non-irrefutable would cause the Just'
+case in foo to be unreachable, as GHC would mistakenly believe that Nothing'
+is the only thing that could possibly be matched!
+-}
+
+-- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs
+-- parentheses under precedence @p@.
+patNeedsParens :: PprPrec -> Pat p -> Bool
+patNeedsParens p = go
+ where
+ go (NPlusKPat {}) = p > opPrec
+ go (SplicePat {}) = False
+ go (ConPatIn _ ds) = conPatNeedsParens p ds
+ go cp@(ConPatOut {}) = conPatNeedsParens p (pat_args cp)
+ go (SigPat {}) = p > topPrec
+ go (ViewPat {}) = True
+ go (CoPat _ _ p _) = go p
+ go (WildPat {}) = False
+ go (VarPat {}) = False
+ go (LazyPat {}) = False
+ go (BangPat {}) = False
+ go (ParPat {}) = False
+ go (AsPat {}) = False
+ go (TuplePat {}) = False
+ go (SumPat {}) = False
+ go (ListPat {}) = False
+ go (LitPat _ l) = hsLitNeedsParens p l
+ go (NPat _ (L _ ol) _ _) = hsOverLitNeedsParens p ol
+ go (XPat {}) = True -- conservative default
+
+-- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@
+-- needs parentheses under precedence @p@.
+conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool
+conPatNeedsParens p = go
+ where
+ go (PrefixCon args) = p >= appPrec && not (null args)
+ go (InfixCon {}) = p >= opPrec
+ go (RecCon {}) = False
+
+-- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and
+-- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.
+parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
+parenthesizePat p lpat@(L loc pat)
+ | patNeedsParens p pat = L loc (ParPat NoExt lpat)
+ | otherwise = lpat
{-
% Collect all EvVars from all constructor patterns
-}
-- May need to add more cases
-collectEvVarsPats :: [Pat p] -> Bag EvVar
+collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar
collectEvVarsPats = unionManyBags . map collectEvVarsPat
-collectEvVarsLPat :: LPat p -> Bag EvVar
+collectEvVarsLPat :: LPat GhcTc -> Bag EvVar
collectEvVarsLPat (L _ pat) = collectEvVarsPat pat
-collectEvVarsPat :: Pat p -> Bag EvVar
+collectEvVarsPat :: Pat GhcTc -> Bag EvVar
collectEvVarsPat pat =
case pat of
- LazyPat p -> collectEvVarsLPat p
- AsPat _ p -> collectEvVarsLPat p
- ParPat p -> collectEvVarsLPat p
- BangPat p -> collectEvVarsLPat p
- ListPat ps _ _ -> unionManyBags $ map collectEvVarsLPat ps
- TuplePat ps _ _ -> unionManyBags $ map collectEvVarsLPat ps
- SumPat p _ _ _ -> collectEvVarsLPat p
- PArrPat ps _ -> unionManyBags $ map collectEvVarsLPat ps
+ LazyPat _ p -> collectEvVarsLPat p
+ AsPat _ _ p -> collectEvVarsLPat p
+ ParPat _ p -> collectEvVarsLPat p
+ BangPat _ p -> collectEvVarsLPat p
+ ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps
+ TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps
+ SumPat _ p _ _ -> collectEvVarsLPat p
ConPatOut {pat_dicts = dicts, pat_args = args}
- -> unionBags (listToBag dicts)
+ -> unionBags (listToBag dicts)
$ unionManyBags
$ map collectEvVarsLPat
$ hsConPatArgs args
- SigPatOut p _ -> collectEvVarsLPat p
- CoPat _ p _ -> collectEvVarsPat p
- ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn"
- SigPatIn _ _ -> panic "foldMapPatBag: SigPatIn"
- _other_pat -> emptyBag
+ SigPat _ p -> collectEvVarsLPat p
+ CoPat _ _ p _ -> collectEvVarsPat p
+ ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn"
+ _other_pat -> emptyBag
diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot
index 8cb82ed22e..b7efb1c28c 100644
--- a/compiler/hsSyn/HsPat.hs-boot
+++ b/compiler/hsSyn/HsPat.hs-boot
@@ -4,17 +4,16 @@
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE TypeFamilies #-}
module HsPat where
import SrcLoc( Located )
-import Data.Data hiding (Fixity)
import Outputable
-import HsExtension ( SourceTextX, DataId, OutputableBndrId )
+import HsExtension ( OutputableBndrId, GhcPass )
type role Pat nominal
data Pat (i :: *)
type LPat i = Located (Pat i)
-instance (DataId p) => Data (Pat p)
-instance (SourceTextX pass, OutputableBndrId pass) => Outputable (Pat pass)
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p)
diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs
index 76afa8b81e..e04abbf70f 100644
--- a/compiler/hsSyn/HsSyn.hs
+++ b/compiler/hsSyn/HsSyn.hs
@@ -15,6 +15,8 @@ therefore, is almost nothing but re-exporting.
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data
module HsSyn (
module HsBinds,
@@ -30,10 +32,12 @@ module HsSyn (
module HsExtension,
Fixity,
- HsModule(..)
+ HsModule(..),
) where
-- friends:
+import GhcPrelude
+
import HsDecls
import HsBinds
import HsExpr
@@ -46,6 +50,7 @@ import HsTypes
import BasicTypes ( Fixity, WarningTxt )
import HsUtils
import HsDoc
+import HsInstances ()
-- others:
import Outputable
@@ -58,12 +63,12 @@ import Data.Data hiding ( Fixity )
-- | Haskell Module
--
-- All we actually declare here is the top-level structure for a module.
-data HsModule name
+data HsModule pass
= HsModule {
hsmodName :: Maybe (Located ModuleName),
-- ^ @Nothing@: \"module X where\" is omitted (in which case the next
-- field is Nothing too)
- hsmodExports :: Maybe (Located [LIE name]),
+ hsmodExports :: Maybe (Located [LIE pass]),
-- ^ Export list
--
-- - @Nothing@: export list omitted, so export everything
@@ -77,11 +82,11 @@ data HsModule name
-- ,'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
- hsmodImports :: [LImportDecl name],
+ hsmodImports :: [LImportDecl pass],
-- ^ We snaffle interesting stuff out of the imported interfaces early
-- on, adding that info to TyDecls/etc; so this list is often empty,
-- downstream.
- hsmodDecls :: [LHsDecl name],
+ hsmodDecls :: [LHsDecl pass],
-- ^ Type, class, value, and interface signature decls
hsmodDeprecMessage :: Maybe (Located WarningTxt),
-- ^ reason\/explanation for warning/deprecation of this module
@@ -108,10 +113,12 @@ data HsModule name
-- hsmodImports,hsmodDecls if this style is used.
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId name) => Data (HsModule name)
+-- deriving instance (DataIdLR name name) => Data (HsModule name)
+deriving instance Data (HsModule GhcPs)
+deriving instance Data (HsModule GhcRn)
+deriving instance Data (HsModule GhcTc)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsModule pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsModule p) where
ppr (HsModule Nothing _ imports decls _ mbDoc)
= pp_mb mbDoc $$ pp_nonnull imports
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 77b1439efb..04260bc0e1 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -8,18 +8,18 @@ HsTypes: Abstract syntax: user-defined types
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
module HsTypes (
- HsType(..), LHsType, HsKind, LHsKind,
+ HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind,
HsTyVarBndr(..), LHsTyVarBndr,
- LHsQTyVars(..),
+ LHsQTyVars(..), HsQTvsRn(..),
HsImplicitBndrs(..),
HsWildCardBndrs(..),
LHsSigType, LHsSigWcType, LHsWcType,
@@ -28,14 +28,13 @@ module HsTypes (
HsContext, LHsContext,
HsTyLit(..),
HsIPName(..), hsIPNameFS,
- HsAppType(..),LHsAppType,
LBangType, BangType,
HsSrcBang(..), HsImplBang(..),
SrcStrictness(..), SrcUnpackedness(..),
getBangType, getBangStrictness,
- ConDeclField(..), LConDeclField, pprConDeclFields, updateGadtResult,
+ ConDeclField(..), LConDeclField, pprConDeclFields,
HsConDetails(..),
@@ -44,34 +43,37 @@ module HsTypes (
rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,
unambiguousFieldOcc, ambiguousFieldOcc,
- HsWildCardInfo(..), mkAnonWildCardTy,
+ HsWildCardInfo(..), mkAnonWildCardTy, pprAnonWildCard,
wildCardName, sameWildCard,
mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs,
- isHsKindedTyVar, hsTvbAllKinded,
+ isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy,
hsScopedTvs, hsWcScopedTvs, dropWildCards,
hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,
hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames,
splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,
splitLHsPatSynTy,
splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy,
- splitHsFunType, splitHsAppsTy,
- splitHsAppTys, getAppsTyHead_maybe, hsTyGetAppHead_maybe,
+ splitHsFunType,
+ splitHsAppTys, hsTyGetAppHead_maybe,
mkHsOpTy, mkHsAppTy, mkHsAppTys,
ignoreParens, hsSigType, hsSigWcType,
hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
-- Printing
pprHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra,
- pprHsContext, pprHsContextNoArrow, pprHsContextMaybe
+ pprHsContext, pprHsContextNoArrow, pprHsContextMaybe,
+ hsTypeNeedsParens, parenthesizeHsType
) where
+import GhcPrelude
+
import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
-import PlaceHolder ( PlaceHolder(..) )
import HsExtension
+import HsLit () -- for instances
import Id ( Id )
import Name( Name )
@@ -89,8 +91,8 @@ import FastString
import Maybes( isJust )
import Data.Data hiding ( Fixity, Prefix, Infix )
+import Data.List ( foldl' )
import Data.Maybe ( fromMaybe )
-import Control.Monad ( unless )
{-
************************************************************************
@@ -107,11 +109,11 @@ type LBangType pass = Located (BangType pass)
type BangType pass = HsType pass -- Bangs are in the HsType data type
getBangType :: LHsType a -> LHsType a
-getBangType (L _ (HsBangTy _ ty)) = ty
-getBangType ty = ty
+getBangType (L _ (HsBangTy _ _ ty)) = ty
+getBangType ty = ty
getBangStrictness :: LHsType a -> HsSrcBang
-getBangStrictness (L _ (HsBangTy s _)) = s
+getBangStrictness (L _ (HsBangTy _ s _)) = s
getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
{-
@@ -216,6 +218,49 @@ Note carefully:
* After type checking is done, we report what types the wildcards
got unified with.
+Note [Ordering of implicit variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Since the advent of -XTypeApplications, GHC makes promises about the ordering
+of implicit variable quantification. Specifically, we offer that implicitly
+quantified variables (such as those in const :: a -> b -> a, without a `forall`)
+will occur in left-to-right order of first occurrence. Here are a few examples:
+
+ const :: a -> b -> a -- forall a b. ...
+ f :: Eq a => b -> a -> a -- forall a b. ... contexts are included
+
+ type a <-< b = b -> a
+ g :: a <-< b -- forall a b. ... type synonyms matter
+
+ class Functor f where
+ fmap :: (a -> b) -> f a -> f b -- forall f a b. ...
+ -- The f is quantified by the class, so only a and b are considered in fmap
+
+This simple story is complicated by the possibility of dependency: all variables
+must come after any variables mentioned in their kinds.
+
+ typeRep :: Typeable a => TypeRep (a :: k) -- forall k a. ...
+
+The k comes first because a depends on k, even though the k appears later than
+the a in the code. Thus, GHC does a *stable topological sort* on the variables.
+By "stable", we mean that any two variables who do not depend on each other
+preserve their existing left-to-right ordering.
+
+Implicitly bound variables are collected by the extract- family of functions
+(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.) in RnTypes.
+These functions thus promise to keep left-to-right ordering.
+Look for pointers to this note to see the places where the action happens.
+
+Note that we also maintain this ordering in kind signatures. Even though
+there's no visible kind application (yet), having implicit variables be
+quantified in left-to-right order in kind signatures is nice since:
+
+* It's consistent with the treatment for type signatures.
+* It can affect how types are displayed with -fprint-explicit-kinds (see
+ #15568 for an example), which is a situation where knowing the order in
+ which implicit variables are quantified can be useful.
+* In the event that visible kind application is implemented, the order in
+ which we would expect implicit variables to be ordered in kinds will have
+ already been established.
-}
-- | Located Haskell Context
@@ -253,65 +298,89 @@ type LHsTyVarBndr pass = Located (HsTyVarBndr pass)
-- | Located Haskell Quantified Type Variables
data LHsQTyVars pass -- See Note [HsType binders]
- = HsQTvs { hsq_implicit :: PostRn pass [Name]
- -- implicit (dependent) variables
- , hsq_explicit :: [LHsTyVarBndr pass] -- explicit variables
- -- See Note [HsForAllTy tyvar binders]
- , hsq_dependent :: PostRn pass NameSet
- -- which explicit vars are dependent
- -- See Note [Dependent LHsQTyVars] in TcHsType
+ = HsQTvs { hsq_ext :: XHsQTvs pass
+
+ , hsq_explicit :: [LHsTyVarBndr pass]
+ -- Explicit variables, written by the user
+ -- See Note [HsForAllTy tyvar binders]
}
+ | XLHsQTyVars (XXLHsQTyVars pass)
-deriving instance (DataId pass) => Data (LHsQTyVars pass)
+data HsQTvsRn
+ = HsQTvsRn
+ { hsq_implicit :: [Name]
+ -- Implicit (dependent) variables
+
+ , hsq_dependent :: NameSet
+ -- Which members of hsq_explicit are dependent; that is,
+ -- mentioned in the kind of a later hsq_explicit,
+ -- or mentioned in a kind in the scope of this HsQTvs
+ -- See Note [Dependent LHsQTyVars] in TcHsType
+ } deriving Data
+
+type instance XHsQTvs GhcPs = NoExt
+type instance XHsQTvs GhcRn = HsQTvsRn
+type instance XHsQTvs GhcTc = HsQTvsRn
+
+type instance XXLHsQTyVars (GhcPass _) = NoExt
mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs
-mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs
- , hsq_dependent = PlaceHolder }
+mkHsQTvs tvs = HsQTvs { hsq_ext = noExt, hsq_explicit = tvs }
hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass]
hsQTvExplicit = hsq_explicit
emptyLHsQTvs :: LHsQTyVars GhcRn
-emptyLHsQTvs = HsQTvs [] [] emptyNameSet
+emptyLHsQTvs = HsQTvs (HsQTvsRn [] emptyNameSet) []
isEmptyLHsQTvs :: LHsQTyVars GhcRn -> Bool
-isEmptyLHsQTvs (HsQTvs [] [] _) = True
+isEmptyLHsQTvs (HsQTvs (HsQTvsRn [] _) []) = True
isEmptyLHsQTvs _ = False
------------------------------------------------
-- HsImplicitBndrs
--- Used to quantify the binders of a type in cases
--- when a HsForAll isn't appropriate:
+-- Used to quantify the implicit binders of a type
+-- * Implicit binders of a type signature (LHsSigType/LHsSigWcType)
-- * Patterns in a type/data family instance (HsTyPats)
--- * Type of a rule binder (RuleBndr)
--- * Pattern type signatures (SigPatIn)
--- In the last of these, wildcards can happen, so we must accommodate them
-- | Haskell Implicit Binders
data HsImplicitBndrs pass thing -- See Note [HsType binders]
- = HsIB { hsib_vars :: PostRn pass [Name] -- Implicitly-bound kind & type vars
- , hsib_body :: thing -- Main payload (type or list of types)
- , hsib_closed :: PostRn pass Bool -- Taking the hsib_vars into account,
- -- is the payload closed? Used in
- -- TcHsType.decideKindGeneralisationPlan
+ = HsIB { hsib_ext :: XHsIB pass thing -- after renamer: [Name]
+ -- Implicitly-bound kind & type vars
+ -- Order is important; see
+ -- Note [Ordering of implicit variables]
+ -- in RnTypes
+
+ , hsib_body :: thing -- Main payload (type or list of types)
}
-deriving instance (DataId pass, Data thing) => Data (HsImplicitBndrs pass thing)
+ | XHsImplicitBndrs (XXHsImplicitBndrs pass thing)
+
+type instance XHsIB GhcPs _ = NoExt
+type instance XHsIB GhcRn _ = [Name]
+type instance XHsIB GhcTc _ = [Name]
+
+type instance XXHsImplicitBndrs (GhcPass _) _ = NoExt
-- | Haskell Wildcard Binders
data HsWildCardBndrs pass thing
-- See Note [HsType binders]
-- See Note [The wildcard story for types]
- = HsWC { hswc_wcs :: PostRn pass [Name]
- -- Wild cards, both named and anonymous
+ = HsWC { hswc_ext :: XHsWC pass thing
-- after the renamer
+ -- Wild cards, both named and anonymous
, hswc_body :: thing
-- Main payload (type or list of types)
-- If there is an extra-constraints wildcard,
-- it's still there in the hsc_body.
}
+ | XHsWildCardBndrs (XXHsWildCardBndrs pass thing)
-deriving instance (DataId pass, Data thing) => Data (HsWildCardBndrs pass thing)
+type instance XHsWC GhcPs b = NoExt
+type instance XHsWC GhcRn b = [Name]
+type instance XHsWC GhcTc b = [Name]
+
+type instance XXHsWildCardBndrs (GhcPass _) b = NoExt
-- | Located Haskell Signature Type
type LHsSigType pass = HsImplicitBndrs pass (LHsType pass) -- Implicit only
@@ -326,6 +395,7 @@ type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both
hsImplicitBody :: HsImplicitBndrs pass thing -> thing
hsImplicitBody (HsIB { hsib_body = body }) = body
+hsImplicitBody (XHsImplicitBndrs _) = panic "hsImplicitBody"
hsSigType :: LHsSigType pass -> LHsType pass
hsSigType = hsImplicitBody
@@ -358,24 +428,22 @@ the explicitly forall'd tyvar 'a' is bound by the HsForAllTy
-}
mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing
-mkHsImplicitBndrs x = HsIB { hsib_body = x
- , hsib_vars = PlaceHolder
- , hsib_closed = PlaceHolder }
+mkHsImplicitBndrs x = HsIB { hsib_ext = noExt
+ , hsib_body = x }
mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs x = HsWC { hswc_body = x
- , hswc_wcs = PlaceHolder }
+ , hswc_ext = noExt }
-- Add empty binders. This is a bit suspicious; what if
-- the wrapped thing had free type variables?
mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs GhcRn thing
-mkEmptyImplicitBndrs x = HsIB { hsib_body = x
- , hsib_vars = []
- , hsib_closed = False }
+mkEmptyImplicitBndrs x = HsIB { hsib_ext = []
+ , hsib_body = x }
mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing
mkEmptyWildCardBndrs x = HsWC { hswc_body = x
- , hswc_wcs = [] }
+ , hswc_ext = [] }
--------------------------------------------------
@@ -400,9 +468,11 @@ instance OutputableBndr HsIPName where
-- | Haskell Type Variable Binder
data HsTyVarBndr pass
= UserTyVar -- no explicit kinding
+ (XUserTyVar pass)
(Located (IdP pass))
-- See Note [Located RdrNames] in HsExpr
| KindedTyVar
+ (XKindedTyVar pass)
(Located (IdP pass))
(LHsKind pass) -- The user-supplied kind signature
-- ^
@@ -410,12 +480,19 @@ data HsTyVarBndr pass
-- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (HsTyVarBndr pass)
+
+ | XTyVarBndr
+ (XXTyVarBndr pass)
+
+type instance XUserTyVar (GhcPass _) = NoExt
+type instance XKindedTyVar (GhcPass _) = NoExt
+type instance XXTyVarBndr (GhcPass _) = NoExt
-- | Does this 'HsTyVarBndr' come with an explicit kind annotation?
isHsKindedTyVar :: HsTyVarBndr pass -> Bool
isHsKindedTyVar (UserTyVar {}) = False
isHsKindedTyVar (KindedTyVar {}) = True
+isHsKindedTyVar (XTyVarBndr{}) = panic "isHsKindedTyVar"
-- | Do all type variables in this 'LHsQTyVars' come with kind annotations?
hsTvbAllKinded :: LHsQTyVars pass -> Bool
@@ -424,19 +501,22 @@ hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit
-- | Haskell Type
data HsType pass
= HsForAllTy -- See Note [HsType binders]
- { hst_bndrs :: [LHsTyVarBndr pass]
+ { hst_xforall :: XForAllTy pass,
+ hst_bndrs :: [LHsTyVarBndr pass]
-- Explicit, user-supplied 'forall a b c'
- , hst_body :: LHsType pass -- body type
+ , hst_body :: LHsType pass -- body type
}
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall',
-- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
| HsQualTy -- See Note [HsType binders]
- { hst_ctxt :: LHsContext pass -- Context C => blah
- , hst_body :: LHsType pass }
+ { hst_xqual :: XQualTy pass
+ , hst_ctxt :: LHsContext pass -- Context C => blah
+ , hst_body :: LHsType pass }
- | HsTyVar Promoted -- whether explicitly promoted, for the pretty
+ | HsTyVar (XTyVar pass)
+ Promoted -- whether explicitly promoted, for the pretty
-- printer
(Located (IdP pass))
-- Type variable, type constructor, or data constructor
@@ -446,53 +526,50 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsAppsTy [LHsAppType pass] -- Used only before renaming,
- -- Note [HsAppsTy]
- -- ^ - 'ApiAnnotation.AnnKeywordId' : None
-
- | HsAppTy (LHsType pass)
+ | HsAppTy (XAppTy pass)
+ (LHsType pass)
(LHsType pass)
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsFunTy (LHsType pass) -- function type
+ | HsFunTy (XFunTy pass)
+ (LHsType pass) -- function type
(LHsType pass)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow',
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsListTy (LHsType pass) -- Element type
+ | HsListTy (XListTy pass)
+ (LHsType pass) -- Element type
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
-- 'ApiAnnotation.AnnClose' @']'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsPArrTy (LHsType pass) -- Elem. type of parallel array: [:t:]
- -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
- -- 'ApiAnnotation.AnnClose' @':]'@
-
- -- For details on above see note [Api annotations] in ApiAnnotation
-
- | HsTupleTy HsTupleSort
+ | HsTupleTy (XTupleTy pass)
+ HsTupleSort
[LHsType pass] -- Element types (length gives arity)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@,
-- 'ApiAnnotation.AnnClose' @')' or '#)'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsSumTy [LHsType pass] -- Element types (length gives arity)
+ | HsSumTy (XSumTy pass)
+ [LHsType pass] -- Element types (length gives arity)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@,
-- 'ApiAnnotation.AnnClose' '#)'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsOpTy (LHsType pass) (Located (IdP pass)) (LHsType pass)
+ | HsOpTy (XOpTy pass)
+ (LHsType pass) (Located (IdP pass)) (LHsType pass)
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsParTy (LHsType pass) -- See Note [Parens in HsSyn] in HsExpr
+ | HsParTy (XParTy pass)
+ (LHsType pass) -- See Note [Parens in HsSyn] in HsExpr
-- Parenthesis preserved for the precedence re-arrangement in RnTypes
-- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
@@ -500,7 +577,8 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsIParamTy (Located HsIPName) -- (?x :: ty)
+ | HsIParamTy (XIParamTy pass)
+ (Located HsIPName) -- (?x :: ty)
(LHsType pass) -- Implicit parameters as they occur in
-- contexts
-- ^
@@ -510,18 +588,13 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsEqTy (LHsType pass) -- ty1 ~ ty2
- (LHsType pass) -- Always allowed even without
- -- TypeOperators, and has special
- -- kinding rule
- -- ^
- -- > ty1 ~ ty2
- --
- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
-
- -- For details on above see note [Api annotations] in ApiAnnotation
+ | HsStarTy (XStarTy pass)
+ Bool -- Is this the Unicode variant?
+ -- Note [HsStarTy]
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : None
- | HsKindSig (LHsType pass) -- (ty :: kind)
+ | HsKindSig (XKindSig pass)
+ (LHsType pass) -- (ty :: kind)
(LHsKind pass) -- A type with a kind signature
-- ^
-- > (ty :: kind)
@@ -531,19 +604,21 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsSpliceTy (HsSplice pass) -- Includes quasi-quotes
- (PostTc pass Kind)
+ | HsSpliceTy (XSpliceTy pass)
+ (HsSplice pass) -- Includes quasi-quotes
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@,
-- 'ApiAnnotation.AnnClose' @')'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsDocTy (LHsType pass) LHsDocString -- A documented type
+ | HsDocTy (XDocTy pass)
+ (LHsType pass) LHsDocString -- A documented type
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsBangTy HsSrcBang (LHsType pass) -- Bang-style type annotations
+ | HsBangTy (XBangTy pass)
+ HsSrcBang (LHsType pass) -- Bang-style type annotations
-- ^ - 'ApiAnnotation.AnnKeywordId' :
-- 'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@,
-- 'ApiAnnotation.AnnClose' @'#-}'@
@@ -551,21 +626,22 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsRecTy [LConDeclField pass] -- Only in data type declarations
+ | HsRecTy (XRecTy pass)
+ [LConDeclField pass] -- Only in data type declarations
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,
-- 'ApiAnnotation.AnnClose' @'}'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCoreTy Type -- An escape hatch for tunnelling a *closed*
- -- Core Type through HsSyn.
- -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+ -- | HsCoreTy (XCoreTy pass) Type -- An escape hatch for tunnelling a *closed*
+ -- -- Core Type through HsSyn.
+ -- -- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
| HsExplicitListTy -- A promoted explicit list
+ (XExplicitListTy pass)
Promoted -- whether explcitly promoted, for pretty printer
- (PostTc pass Kind) -- See Note [Promoted lists and tuples]
[LHsType pass]
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@,
-- 'ApiAnnotation.AnnClose' @']'@
@@ -573,24 +649,77 @@ data HsType pass
-- For details on above see note [Api annotations] in ApiAnnotation
| HsExplicitTupleTy -- A promoted explicit tuple
- [PostTc pass Kind] -- See Note [Promoted lists and tuples]
+ (XExplicitTupleTy pass)
[LHsType pass]
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@,
-- 'ApiAnnotation.AnnClose' @')'@
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsTyLit HsTyLit -- A promoted numeric literal.
+ | HsTyLit (XTyLit pass) HsTyLit -- A promoted numeric literal.
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsWildCardTy (HsWildCardInfo pass) -- A type wildcard
+ | HsWildCardTy (XWildCardTy pass) -- A type wildcard
-- See Note [The wildcard story for types]
+ -- A anonymous wild card ('_'). A fresh Name is generated for
+ -- each individual anonymous wildcard during renaming
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (HsType pass)
+
+ -- For adding new constructors via Trees that Grow
+ | XHsType
+ (XXType pass)
+
+data NewHsTypeX
+ = NHsCoreTy Type -- An escape hatch for tunnelling a *closed*
+ -- Core Type through HsSyn.
+ deriving Data
+ -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+
+instance Outputable NewHsTypeX where
+ ppr (NHsCoreTy ty) = ppr ty
+
+type instance XForAllTy (GhcPass _) = NoExt
+type instance XQualTy (GhcPass _) = NoExt
+type instance XTyVar (GhcPass _) = NoExt
+type instance XAppTy (GhcPass _) = NoExt
+type instance XFunTy (GhcPass _) = NoExt
+type instance XListTy (GhcPass _) = NoExt
+type instance XTupleTy (GhcPass _) = NoExt
+type instance XSumTy (GhcPass _) = NoExt
+type instance XOpTy (GhcPass _) = NoExt
+type instance XParTy (GhcPass _) = NoExt
+type instance XIParamTy (GhcPass _) = NoExt
+type instance XStarTy (GhcPass _) = NoExt
+type instance XKindSig (GhcPass _) = NoExt
+
+type instance XSpliceTy GhcPs = NoExt
+type instance XSpliceTy GhcRn = NoExt
+type instance XSpliceTy GhcTc = Kind
+
+type instance XDocTy (GhcPass _) = NoExt
+type instance XBangTy (GhcPass _) = NoExt
+type instance XRecTy (GhcPass _) = NoExt
+
+type instance XExplicitListTy GhcPs = NoExt
+type instance XExplicitListTy GhcRn = NoExt
+type instance XExplicitListTy GhcTc = Kind
+
+type instance XExplicitTupleTy GhcPs = NoExt
+type instance XExplicitTupleTy GhcRn = NoExt
+type instance XExplicitTupleTy GhcTc = [Kind]
+
+type instance XTyLit (GhcPass _) = NoExt
+
+type instance XWildCardTy GhcPs = NoExt
+type instance XWildCardTy GhcRn = HsWildCardInfo
+type instance XWildCardTy GhcTc = HsWildCardInfo
+
+type instance XXType (GhcPass _) = NewHsTypeX
+
-- Note [Literal source text] in BasicTypes for SourceText fields in
-- the following
@@ -600,25 +729,11 @@ data HsTyLit
| HsStrTy SourceText FastString
deriving Data
-newtype HsWildCardInfo pass -- See Note [The wildcard story for types]
- = AnonWildCard (PostRn pass (Located Name))
+newtype HsWildCardInfo -- See Note [The wildcard story for types]
+ = AnonWildCard (Located Name)
+ deriving Data
-- A anonymous wild card ('_'). A fresh Name is generated for
-- each individual anonymous wildcard during renaming
-deriving instance (DataId pass) => Data (HsWildCardInfo pass)
-
--- | Located Haskell Application Type
-type LHsAppType pass = Located (HsAppType pass)
- -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSimpleQuote'
-
--- | Haskell Application Type
-data HsAppType pass
- = HsAppInfix (Located (IdP pass)) -- either a symbol or an id in backticks
- | HsAppPrefix (LHsType pass) -- anything else, including things like (+)
-deriving instance (DataId pass) => Data (HsAppType pass)
-
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsAppType pass) where
- ppr = ppr_app_ty
{-
Note [HsForAllTy tyvar binders]
@@ -675,16 +790,18 @@ HsTyVar: A name in a type or kind.
The 'Promoted' field in an HsTyVar captures whether the type was promoted in
the source code by prefixing an apostrophe.
-Note [HsAppsTy]
+Note [HsStarTy]
~~~~~~~~~~~~~~~
-How to parse
+When the StarIsType extension is enabled, we want to treat '*' and its Unicode
+variant identically to 'Data.Kind.Type'. Unfortunately, doing so in the parser
+would mean that when we pretty-print it back, we don't know whether the user
+wrote '*' or 'Type', and lose the parse/ppr roundtrip property.
- Foo * Int
+As a workaround, we parse '*' as HsStarTy (if it stands for 'Data.Kind.Type')
+and then desugar it to 'Data.Kind.Type' in the typechecker (see tc_hs_type).
+When '*' is a regular type operator (StarIsType is disabled), HsStarTy is not
+involved.
-? Is it `(*) Foo Int` or `Foo GHC.Types.* Int`? There's no way to know until renaming.
-So we just take type expressions like this and put each component in a list, so be
-sorted out in the renamer. The sorting out is done by RnTypes.mkHsOpTyRn. This means
-that the parser should never produce HsAppTy or HsOpTy.
Note [Promoted lists and tuples]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -752,18 +869,23 @@ type LConDeclField pass = Located (ConDeclField pass)
-- | Constructor Declaration Field
data ConDeclField pass -- Record fields have Haddoc docs on them
- = ConDeclField { cd_fld_names :: [LFieldOcc pass],
+ = ConDeclField { cd_fld_ext :: XConDeclField pass,
+ cd_fld_names :: [LFieldOcc pass],
-- ^ See Note [ConDeclField passs]
cd_fld_type :: LBangType pass,
cd_fld_doc :: Maybe LHsDocString }
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
-- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (ConDeclField pass)
+ | XConDeclField (XXConDeclField pass)
+
+type instance XConDeclField (GhcPass _) = NoExt
+type instance XXConDeclField (GhcPass _) = NoExt
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (ConDeclField pass) where
- ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (ConDeclField p) where
+ ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
+ ppr (XConDeclField x) = ppr x
-- HsConDetails is used for patterns/expressions *and* for data type
-- declarations
@@ -780,30 +902,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]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -836,19 +934,23 @@ hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name]
-- - the named wildcars; see Note [Scoping of named wildcards]
-- because they scope in the same way
hsWcScopedTvs sig_ty
- | HsWC { hswc_wcs = nwcs, hswc_body = sig_ty1 } <- sig_ty
- , HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty1
+ | HsWC { hswc_ext = nwcs, hswc_body = sig_ty1 } <- sig_ty
+ , HsIB { hsib_ext = vars
+ , hsib_body = sig_ty2 } <- sig_ty1
= case sig_ty2 of
L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++
map hsLTyVarName tvs
-- include kind variables only if the type is headed by forall
-- (this is consistent with GHC 7 behaviour)
_ -> nwcs
+hsWcScopedTvs (HsWC _ (XHsImplicitBndrs _)) = panic "hsWcScopedTvs"
+hsWcScopedTvs (XHsWildCardBndrs _) = panic "hsWcScopedTvs"
hsScopedTvs :: LHsSigType GhcRn -> [Name]
-- Same as hsWcScopedTvs, but for a LHsSigType
hsScopedTvs sig_ty
- | HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty
+ | HsIB { hsib_ext = vars
+ , hsib_body = sig_ty2 } <- sig_ty
, L _ (HsForAllTy { hst_bndrs = tvs }) <- sig_ty2
= vars ++ map hsLTyVarName tvs
| otherwise
@@ -869,8 +971,9 @@ I don't know if this is a good idea, but there it is.
---------------------
hsTyVarName :: HsTyVarBndr pass -> IdP pass
-hsTyVarName (UserTyVar (L _ n)) = n
-hsTyVarName (KindedTyVar (L _ n) _) = n
+hsTyVarName (UserTyVar _ (L _ n)) = n
+hsTyVarName (KindedTyVar _ (L _ n) _) = n
+hsTyVarName (XTyVarBndr{}) = panic "hsTyVarName"
hsLTyVarName :: LHsTyVarBndr pass -> IdP pass
hsLTyVarName = hsTyVarName . unLoc
@@ -881,8 +984,10 @@ hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs)
hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name]
-- All variables
-hsAllLTyVarNames (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs })
+hsAllLTyVarNames (HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = kvs }
+ , hsq_explicit = tvs })
= kvs ++ map hsLTyVarName tvs
+hsAllLTyVarNames (XLHsQTyVars _) = panic "hsAllLTyVarNames"
hsLTyVarLocName :: LHsTyVarBndr pass -> Located (IdP pass)
hsLTyVarLocName = fmap hsTyVarName
@@ -891,30 +996,35 @@ hsLTyVarLocNames :: LHsQTyVars pass -> [Located (IdP pass)]
hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
-- | Convert a LHsTyVarBndr to an equivalent LHsType.
-hsLTyVarBndrToType :: LHsTyVarBndr pass -> LHsType pass
+hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p)
hsLTyVarBndrToType = fmap cvt
- where cvt (UserTyVar n) = HsTyVar NotPromoted n
- cvt (KindedTyVar (L name_loc n) kind)
- = HsKindSig (L name_loc (HsTyVar NotPromoted (L name_loc n))) kind
+ where cvt (UserTyVar _ n) = HsTyVar noExt NotPromoted n
+ cvt (KindedTyVar _ (L name_loc n) kind)
+ = HsKindSig noExt
+ (L name_loc (HsTyVar noExt NotPromoted (L name_loc n))) kind
+ cvt (XTyVarBndr{}) = panic "hsLTyVarBndrToType"
-- | Convert a LHsTyVarBndrs to a list of types.
-- Works on *type* variable only, no kind vars.
-hsLTyVarBndrsToTypes :: LHsQTyVars pass -> [LHsType pass]
+hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)]
hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs
+hsLTyVarBndrsToTypes (XLHsQTyVars _) = panic "hsLTyVarBndrsToTypes"
---------------------
-wildCardName :: HsWildCardInfo GhcRn -> Name
+wildCardName :: HsWildCardInfo -> Name
wildCardName (AnonWildCard (L _ n)) = n
-- Two wild cards are the same when they have the same location
-sameWildCard :: Located (HsWildCardInfo pass)
- -> Located (HsWildCardInfo pass) -> Bool
+sameWildCard :: Located HsWildCardInfo -> Located HsWildCardInfo -> Bool
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
+ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty
+ignoreParens ty = ty
+
+isLHsForAllTy :: LHsType p -> Bool
+isLHsForAllTy (L _ (HsForAllTy {})) = True
+isLHsForAllTy _ = False
{-
************************************************************************
@@ -925,17 +1035,19 @@ ignoreParens ty = ty
-}
mkAnonWildCardTy :: HsType GhcPs
-mkAnonWildCardTy = HsWildCardTy (AnonWildCard PlaceHolder)
+mkAnonWildCardTy = HsWildCardTy noExt
-mkHsOpTy :: LHsType pass -> Located (IdP pass) -> LHsType pass -> HsType pass
-mkHsOpTy ty1 op ty2 = HsOpTy ty1 op ty2
+mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p))
+ -> LHsType (GhcPass p) -> HsType (GhcPass p)
+mkHsOpTy ty1 op ty2 = HsOpTy noExt ty1 op ty2
-mkHsAppTy :: LHsType pass -> LHsType pass -> LHsType pass
-mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
-
-mkHsAppTys :: LHsType pass -> [LHsType pass] -> LHsType pass
-mkHsAppTys = foldl mkHsAppTy
+mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+mkHsAppTy t1 t2
+ = addCLoc t1 t2 (HsAppTy noExt t1 (parenthesizeHsType appPrec t2))
+mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]
+ -> LHsType (GhcPass p)
+mkHsAppTys = foldl' mkHsAppTy
{-
************************************************************************
@@ -952,79 +1064,46 @@ mkHsAppTys = foldl mkHsAppTy
-- Also deals with (->) t1 t2; that is why it only works on LHsType Name
-- (see Trac #9096)
splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn)
-splitHsFunType (L _ (HsParTy ty))
+splitHsFunType (L _ (HsParTy _ ty))
= splitHsFunType ty
-splitHsFunType (L _ (HsFunTy x y))
+splitHsFunType (L _ (HsFunTy _ x y))
| (args, res) <- splitHsFunType y
= (x:args, res)
-splitHsFunType orig_ty@(L _ (HsAppTy t1 t2))
+splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2))
= go t1 [t2]
where -- Look for (->) t1 t2, possibly with parenthesisation
- go (L _ (HsTyVar _ (L _ fn))) tys | fn == funTyConName
+ go (L _ (HsTyVar _ _ (L _ fn))) tys | fn == funTyConName
, [t1,t2] <- tys
, (args, res) <- splitHsFunType t2
= (t1:args, res)
- go (L _ (HsAppTy t1 t2)) tys = go t1 (t2:tys)
- go (L _ (HsParTy ty)) tys = go ty tys
- go _ _ = ([], orig_ty) -- Failure to match
+ go (L _ (HsAppTy _ t1 t2)) tys = go t1 (t2:tys)
+ go (L _ (HsParTy _ ty)) tys = go ty tys
+ go _ _ = ([], orig_ty) -- Failure to match
splitHsFunType other = ([], other)
---------------------------------
--- | Retrieves the head of an HsAppsTy, if this can be done unambiguously,
--- without consulting fixities.
-getAppsTyHead_maybe :: [LHsAppType pass]
- -> Maybe (LHsType pass, [LHsType pass], LexicalFixity)
-getAppsTyHead_maybe tys = case splitHsAppsTy tys of
- ([app1:apps], []) -> -- no symbols, some normal types
- Just (mkHsAppTys app1 apps, [], Prefix)
- ([app1l:appsl, app1r:appsr], [L loc op]) -> -- one operator
- Just ( L loc (HsTyVar NotPromoted (L loc op))
- , [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr], Infix)
- _ -> -- can't figure it out
- Nothing
-
--- | Splits a [HsAppType pass] (the payload of an HsAppsTy) into regions of
--- prefix types (normal types) and infix operators.
--- If @splitHsAppsTy tys = (non_syms, syms)@, then @tys@ starts with the first
--- element of @non_syms@ followed by the first element of @syms@ followed by
--- the next element of @non_syms@, etc. It is guaranteed that the non_syms list
--- has one more element than the syms list.
-splitHsAppsTy :: [LHsAppType pass] -> ([[LHsType pass]], [Located (IdP pass)])
-splitHsAppsTy = go [] [] []
- where
- go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym)
- go acc acc_non acc_sym (L _ (HsAppPrefix ty) : rest)
- = go (ty : acc) acc_non acc_sym rest
- go acc acc_non acc_sym (L _ (HsAppInfix op) : rest)
- = go [] (reverse acc : acc_non) (op : acc_sym) rest
-
--- Retrieve the name of the "head" of a nested type application
+-- retrieve the name of the "head" of a nested type application
-- somewhat like splitHsAppTys, but a little more thorough
-- used to examine the result of a GADT-like datacon, so it doesn't handle
-- *all* cases (like lists, tuples, (~), etc.)
-hsTyGetAppHead_maybe :: LHsType pass
- -> Maybe (Located (IdP pass), [LHsType pass])
+hsTyGetAppHead_maybe :: LHsType (GhcPass p)
+ -> Maybe (Located (IdP (GhcPass p)), [LHsType (GhcPass p)])
hsTyGetAppHead_maybe = go []
where
- go tys (L _ (HsTyVar _ ln)) = Just (ln, tys)
- go tys (L _ (HsAppsTy apps))
- | Just (head, args, _) <- getAppsTyHead_maybe apps
- = go (args ++ tys) head
- go tys (L _ (HsAppTy l r)) = go (r : tys) l
- go tys (L _ (HsOpTy l (L loc n) r)) = Just (L loc n, l : r : tys)
- go tys (L _ (HsParTy t)) = go tys t
- go tys (L _ (HsKindSig t _)) = go tys t
+ go tys (L _ (HsTyVar _ _ ln)) = Just (ln, tys)
+ go tys (L _ (HsAppTy _ l r)) = go (r : tys) l
+ go tys (L _ (HsOpTy _ l (L loc n) r)) = Just (L loc n, l : r : tys)
+ go tys (L _ (HsParTy _ t)) = go tys t
+ go tys (L _ (HsKindSig _ t _)) = go tys t
go _ _ = Nothing
splitHsAppTys :: LHsType GhcRn -> [LHsType GhcRn]
-> (LHsType GhcRn, [LHsType GhcRn])
- -- no need to worry about HsAppsTy here
-splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as)
-splitHsAppTys (L _ (HsParTy f)) as = splitHsAppTys f as
-splitHsAppTys f as = (f,as)
+splitHsAppTys (L _ (HsAppTy _ f a)) as = splitHsAppTys f (a:as)
+splitHsAppTys (L _ (HsParTy _ f)) as = splitHsAppTys f as
+splitHsAppTys f as = (f,as)
--------------------------------
splitLHsPatSynTy :: LHsType pass
@@ -1048,29 +1127,33 @@ splitLHsSigmaTy ty
= (tvs, ctxt, ty2)
splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
+splitLHsForAllTy (L _ (HsParTy _ ty)) = splitLHsForAllTy ty
splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body)
-splitLHsForAllTy body = ([], body)
+splitLHsForAllTy body = ([], body)
splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass)
+splitLHsQualTy (L _ (HsParTy _ ty)) = splitLHsQualTy ty
splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body)
-splitLHsQualTy body = (noLoc [], body)
+splitLHsQualTy body = (noLoc [], body)
splitLHsInstDeclTy :: LHsSigType GhcRn
-> ([Name], LHsContext GhcRn, LHsType GhcRn)
-- Split up an instance decl type, returning the pieces
-splitLHsInstDeclTy (HsIB { hsib_vars = itkvs
+splitLHsInstDeclTy (HsIB { hsib_ext = itkvs
, hsib_body = inst_ty })
| (tvs, cxt, body_ty) <- splitLHsSigmaTy inst_ty
= (itkvs ++ map hsLTyVarName tvs, cxt, body_ty)
-- Return implicitly bound type and kind vars
-- For an instance decl, all of them are in scope
+splitLHsInstDeclTy (XHsImplicitBndrs _) = panic "splitLHsInstDeclTy"
getLHsInstDeclHead :: LHsSigType pass -> LHsType pass
getLHsInstDeclHead inst_ty
| (_tvs, _cxt, body_ty) <- splitLHsSigmaTy (hsSigType inst_ty)
= body_ty
-getLHsInstDeclClass_maybe :: LHsSigType pass -> Maybe (Located (IdP pass))
+getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p)
+ -> Maybe (Located (IdP (GhcPass p)))
-- Works on (HsSigType RdrName)
getLHsInstDeclClass_maybe inst_ty
= do { let head_ty = getLHsInstDeclHead inst_ty
@@ -1093,19 +1176,27 @@ type LFieldOcc pass = Located (FieldOcc pass)
-- Represents an *occurrence* of an unambiguous field. We store
-- both the 'RdrName' the user originally wrote, and after the
-- renamer, the selector function.
-data FieldOcc pass = FieldOcc { rdrNameFieldOcc :: Located RdrName
+data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass
+ , rdrNameFieldOcc :: Located RdrName
-- ^ See Note [Located RdrNames] in HsExpr
- , selectorFieldOcc :: PostRn pass (IdP pass)
}
-deriving instance Eq (PostRn pass (IdP pass)) => Eq (FieldOcc pass)
-deriving instance Ord (PostRn pass (IdP pass)) => Ord (FieldOcc pass)
-deriving instance (DataId pass) => Data (FieldOcc pass)
+
+ | XFieldOcc
+ (XXFieldOcc pass)
+deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p)) => Eq (FieldOcc p)
+deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p)) => Ord (FieldOcc p)
+
+type instance XCFieldOcc GhcPs = NoExt
+type instance XCFieldOcc GhcRn = Name
+type instance XCFieldOcc GhcTc = Id
+
+type instance XXFieldOcc (GhcPass _) = NoExt
instance Outputable (FieldOcc pass) where
ppr = ppr . rdrNameFieldOcc
mkFieldOcc :: Located RdrName -> FieldOcc GhcPs
-mkFieldOcc rdr = FieldOcc rdr PlaceHolder
+mkFieldOcc rdr = FieldOcc noExt rdr
-- | Ambiguous Field Occurrence
@@ -1121,37 +1212,50 @@ mkFieldOcc rdr = FieldOcc rdr PlaceHolder
-- Note [Disambiguating record fields] in TcExpr.
-- See Note [Located RdrNames] in HsExpr
data AmbiguousFieldOcc pass
- = Unambiguous (Located RdrName) (PostRn pass (IdP pass))
- | Ambiguous (Located RdrName) (PostTc pass (IdP pass))
-deriving instance ( Data pass
- , Data (PostTc pass (IdP pass))
- , Data (PostRn pass (IdP pass)))
- => Data (AmbiguousFieldOcc pass)
-
-instance Outputable (AmbiguousFieldOcc pass) where
+ = Unambiguous (XUnambiguous pass) (Located RdrName)
+ | Ambiguous (XAmbiguous pass) (Located RdrName)
+ | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass)
+
+type instance XUnambiguous GhcPs = NoExt
+type instance XUnambiguous GhcRn = Name
+type instance XUnambiguous GhcTc = Id
+
+type instance XAmbiguous GhcPs = NoExt
+type instance XAmbiguous GhcRn = NoExt
+type instance XAmbiguous GhcTc = Id
+
+type instance XXAmbiguousFieldOcc (GhcPass _) = NoExt
+
+instance p ~ GhcPass pass => Outputable (AmbiguousFieldOcc p) where
ppr = ppr . rdrNameAmbiguousFieldOcc
-instance OutputableBndr (AmbiguousFieldOcc pass) where
+instance p ~ GhcPass pass => OutputableBndr (AmbiguousFieldOcc p) where
pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc
pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc
mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs
-mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder
+mkAmbiguousFieldOcc rdr = Unambiguous noExt rdr
-rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc pass -> RdrName
-rdrNameAmbiguousFieldOcc (Unambiguous (L _ rdr) _) = rdr
-rdrNameAmbiguousFieldOcc (Ambiguous (L _ rdr) _) = rdr
+rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName
+rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr
+rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr
+rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc _)
+ = panic "rdrNameAmbiguousFieldOcc"
selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id
-selectorAmbiguousFieldOcc (Unambiguous _ sel) = sel
-selectorAmbiguousFieldOcc (Ambiguous _ sel) = sel
+selectorAmbiguousFieldOcc (Unambiguous sel _) = sel
+selectorAmbiguousFieldOcc (Ambiguous sel _) = sel
+selectorAmbiguousFieldOcc (XAmbiguousFieldOcc _)
+ = panic "selectorAmbiguousFieldOcc"
unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc
unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel
unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel
+unambiguousFieldOcc (XAmbiguousFieldOcc _) = panic "unambiguousFieldOcc"
-ambiguousFieldOcc :: FieldOcc pass -> AmbiguousFieldOcc pass
-ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel
+ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc
+ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr
+ambiguousFieldOcc (XFieldOcc _) = panic "ambiguousFieldOcc"
{-
************************************************************************
@@ -1161,33 +1265,41 @@ ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel
************************************************************************
-}
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsType pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsType p) where
ppr ty = pprHsType ty
instance Outputable HsTyLit where
ppr = ppr_tylit
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (LHsQTyVars pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (LHsQTyVars p) where
ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
+ ppr (XLHsQTyVars x) = ppr x
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsTyVarBndr pass) where
- ppr (UserTyVar n) = ppr n
- ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k]
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (HsTyVarBndr p) where
+ ppr (UserTyVar _ n) = ppr n
+ ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k]
+ ppr (XTyVarBndr n) = ppr n
-instance (Outputable thing) => Outputable (HsImplicitBndrs pass thing) where
+instance (p ~ GhcPass pass,Outputable thing)
+ => Outputable (HsImplicitBndrs p thing) where
ppr (HsIB { hsib_body = ty }) = ppr ty
+ ppr (XHsImplicitBndrs x) = ppr x
-instance (Outputable thing) => Outputable (HsWildCardBndrs pass thing) where
+instance (p ~ GhcPass pass,Outputable thing)
+ => Outputable (HsWildCardBndrs p thing) where
ppr (HsWC { hswc_body = ty }) = ppr ty
+ ppr (XHsWildCardBndrs x) = ppr x
-instance Outputable (HsWildCardInfo pass) where
+instance Outputable HsWildCardInfo where
ppr (AnonWildCard _) = char '_'
-pprHsForAll :: (SourceTextX pass, OutputableBndrId pass)
- => [LHsTyVarBndr pass] -> LHsContext pass -> SDoc
+pprAnonWildCard :: SDoc
+pprAnonWildCard = char '_'
+
+pprHsForAll :: (OutputableBndrId (GhcPass p))
+ => [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc
pprHsForAll = pprHsForAllExtra Nothing
-- | Version of 'pprHsForAll' that can also print an extra-constraints
@@ -1197,43 +1309,43 @@ pprHsForAll = pprHsForAllExtra Nothing
-- function for this is needed, as the extra-constraints wildcard is removed
-- from the actual context and type, and stored in a separate field, thus just
-- printing the type will not print the extra-constraints wildcard.
-pprHsForAllExtra :: (SourceTextX pass, OutputableBndrId pass)
- => Maybe SrcSpan -> [LHsTyVarBndr pass] -> LHsContext pass
- -> SDoc
+pprHsForAllExtra :: (OutputableBndrId (GhcPass p))
+ => Maybe SrcSpan -> [LHsTyVarBndr (GhcPass p)]
+ -> LHsContext (GhcPass p) -> SDoc
pprHsForAllExtra extra qtvs cxt
= pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt)
where
show_extra = isJust extra
-pprHsForAllTvs :: (SourceTextX pass, OutputableBndrId pass)
- => [LHsTyVarBndr pass] -> SDoc
-pprHsForAllTvs qtvs = sdocWithPprDebug $ \debug ->
- ppWhen (debug || not (null qtvs)) $ forAllLit <+> interppSP qtvs <> dot
+pprHsForAllTvs :: (OutputableBndrId (GhcPass p))
+ => [LHsTyVarBndr (GhcPass p)] -> SDoc
+pprHsForAllTvs qtvs
+ | null qtvs = whenPprDebug (forAllLit <+> dot)
+ | otherwise = forAllLit <+> interppSP qtvs <> dot
-pprHsContext :: (SourceTextX pass, OutputableBndrId pass)
- => HsContext pass -> SDoc
+pprHsContext :: (OutputableBndrId (GhcPass p)) => HsContext (GhcPass p) -> SDoc
pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
-pprHsContextNoArrow :: (SourceTextX pass, OutputableBndrId pass)
- => HsContext pass -> SDoc
+pprHsContextNoArrow :: (OutputableBndrId (GhcPass p))
+ => HsContext (GhcPass p) -> SDoc
pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe
-pprHsContextMaybe :: (SourceTextX pass, OutputableBndrId pass)
- => HsContext pass -> Maybe SDoc
+pprHsContextMaybe :: (OutputableBndrId (GhcPass p))
+ => HsContext (GhcPass p) -> Maybe SDoc
pprHsContextMaybe [] = Nothing
pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty pred
pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt)
-- For use in a HsQualTy, which always gets printed if it exists.
-pprHsContextAlways :: (SourceTextX pass, OutputableBndrId pass)
- => HsContext pass -> SDoc
+pprHsContextAlways :: (OutputableBndrId (GhcPass p))
+ => HsContext (GhcPass p) -> SDoc
pprHsContextAlways [] = parens empty <+> darrow
pprHsContextAlways [L _ ty] = ppr_mono_ty ty <+> darrow
pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow
-- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@
-pprHsContextExtra :: (SourceTextX pass, OutputableBndrId pass)
- => Bool -> HsContext pass -> SDoc
+pprHsContextExtra :: (OutputableBndrId (GhcPass p))
+ => Bool -> HsContext (GhcPass p) -> SDoc
pprHsContextExtra show_extra ctxt
| not show_extra
= pprHsContext ctxt
@@ -1244,13 +1356,14 @@ pprHsContextExtra show_extra ctxt
where
ctxt' = map ppr ctxt ++ [char '_']
-pprConDeclFields :: (SourceTextX pass, OutputableBndrId pass)
- => [LConDeclField pass] -> SDoc
+pprConDeclFields :: (OutputableBndrId (GhcPass p))
+ => [LConDeclField (GhcPass p)] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
cd_fld_doc = doc }))
= ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
+ ppr_fld (L _ (XConDeclField x)) = ppr x
ppr_names [n] = ppr n
ppr_names ns = sep (punctuate comma (map ppr ns))
@@ -1269,76 +1382,72 @@ seems like the Right Thing anyway.)
-- Printing works more-or-less as for Types
-pprHsType :: (SourceTextX pass, OutputableBndrId pass) => HsType pass -> SDoc
+pprHsType :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
pprHsType ty = ppr_mono_ty ty
-ppr_mono_lty :: (SourceTextX pass, OutputableBndrId pass)
- => LHsType pass -> SDoc
+ppr_mono_lty :: (OutputableBndrId (GhcPass p)) => LHsType (GhcPass p) -> SDoc
ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
-ppr_mono_ty :: (SourceTextX pass, OutputableBndrId pass)
- => HsType pass -> SDoc
+ppr_mono_ty :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
= sep [pprHsForAllTvs tvs, ppr_mono_lty ty]
ppr_mono_ty (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })
= sep [pprHsContextAlways ctxt, ppr_mono_lty ty]
-ppr_mono_ty (HsBangTy b ty) = ppr b <> ppr_mono_lty ty
-ppr_mono_ty (HsRecTy flds) = pprConDeclFields flds
-ppr_mono_ty (HsTyVar NotPromoted (L _ name))= pprPrefixOcc name
-ppr_mono_ty (HsTyVar Promoted (L _ name))
+ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty
+ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds
+ppr_mono_ty (HsTyVar _ NotPromoted (L _ name))= pprPrefixOcc name
+ppr_mono_ty (HsTyVar _ Promoted (L _ name))
= space <> quote (pprPrefixOcc name)
-- We need a space before the ' above, so the parser
-- does not attach it to the previous symbol
-ppr_mono_ty (HsFunTy ty1 ty2) = ppr_fun_ty ty1 ty2
-ppr_mono_ty (HsTupleTy con tys) = tupleParens std_con (pprWithCommas ppr tys)
+ppr_mono_ty (HsFunTy _ ty1 ty2) = ppr_fun_ty ty1 ty2
+ppr_mono_ty (HsTupleTy _ con tys) = tupleParens std_con (pprWithCommas ppr tys)
where std_con = case con of
HsUnboxedTuple -> UnboxedTuple
_ -> BoxedTuple
-ppr_mono_ty (HsSumTy tys) = tupleParens UnboxedTuple (pprWithBars ppr tys)
-ppr_mono_ty (HsKindSig ty kind) = parens (ppr_mono_lty ty <+> dcolon <+> ppr kind)
-ppr_mono_ty (HsListTy ty) = brackets (ppr_mono_lty ty)
-ppr_mono_ty (HsPArrTy ty) = paBrackets (ppr_mono_lty ty)
-ppr_mono_ty (HsIParamTy n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty)
-ppr_mono_ty (HsSpliceTy s _) = pprSplice s
-ppr_mono_ty (HsCoreTy ty) = ppr ty
-ppr_mono_ty (HsExplicitListTy Promoted _ tys)
+ppr_mono_ty (HsSumTy _ tys)
+ = tupleParens UnboxedTuple (pprWithBars ppr tys)
+ppr_mono_ty (HsKindSig _ ty kind)
+ = parens (ppr_mono_lty ty <+> dcolon <+> ppr kind)
+ppr_mono_ty (HsListTy _ ty) = brackets (ppr_mono_lty ty)
+ppr_mono_ty (HsIParamTy _ n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty)
+ppr_mono_ty (HsSpliceTy _ s) = pprSplice s
+ppr_mono_ty (HsExplicitListTy _ Promoted tys)
= quote $ brackets (interpp'SP tys)
-ppr_mono_ty (HsExplicitListTy NotPromoted _ tys)
+ppr_mono_ty (HsExplicitListTy _ NotPromoted tys)
= brackets (interpp'SP tys)
ppr_mono_ty (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
-ppr_mono_ty (HsTyLit t) = ppr_tylit t
+ppr_mono_ty (HsTyLit _ t) = ppr_tylit t
ppr_mono_ty (HsWildCardTy {}) = char '_'
-ppr_mono_ty (HsEqTy ty1 ty2)
- = ppr_mono_lty ty1 <+> char '~' <+> ppr_mono_lty ty2
-
-ppr_mono_ty (HsAppsTy tys)
- = hsep (map (ppr_app_ty . unLoc) tys)
+ppr_mono_ty (HsStarTy _ isUni) = char (if isUni then '★' else '*')
-ppr_mono_ty (HsAppTy fun_ty arg_ty)
+ppr_mono_ty (HsAppTy _ fun_ty arg_ty)
= hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]
-ppr_mono_ty (HsOpTy ty1 (L _ op) ty2)
+ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2)
= sep [ ppr_mono_lty ty1
, sep [pprInfixOcc op, ppr_mono_lty ty2 ] ]
-ppr_mono_ty (HsParTy ty)
+ppr_mono_ty (HsParTy _ ty)
= parens (ppr_mono_lty ty)
-- Put the parens in where the user did
-- But we still use the precedence stuff to add parens because
-- toHsType doesn't put in any HsParTys, so we may still need them
-ppr_mono_ty (HsDocTy ty doc)
+ppr_mono_ty (HsDocTy _ ty doc)
-- AZ: Should we add parens? Should we introduce "-- ^"?
= ppr_mono_lty ty <+> ppr (unLoc doc)
-- we pretty print Haddock comments on types as if they were
-- postfix operators
+ppr_mono_ty (XHsType t) = ppr t
+
--------------------------
-ppr_fun_ty :: (SourceTextX pass, OutputableBndrId pass)
- => LHsType pass -> LHsType pass -> SDoc
+ppr_fun_ty :: (OutputableBndrId (GhcPass p))
+ => LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc
ppr_fun_ty ty1 ty2
= let p1 = ppr_mono_lty ty1
p2 = ppr_mono_lty ty2
@@ -1346,18 +1455,43 @@ ppr_fun_ty ty1 ty2
sep [p1, text "->" <+> p2]
--------------------------
-ppr_app_ty :: (SourceTextX pass, OutputableBndrId pass)
- => HsAppType pass -> SDoc
-ppr_app_ty (HsAppInfix (L _ n)) = pprInfixOcc n
-ppr_app_ty (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n))))
- = pprPrefixOcc n
-ppr_app_ty (HsAppPrefix (L _ (HsTyVar Promoted (L _ n))))
- = space <> quote (pprPrefixOcc n) -- We need a space before the ' above, so
- -- the parser does not attach it to the
- -- previous symbol
-ppr_app_ty (HsAppPrefix ty) = ppr_mono_lty ty
-
---------------------------
ppr_tylit :: HsTyLit -> SDoc
ppr_tylit (HsNumTy _ i) = integer i
ppr_tylit (HsStrTy _ s) = text (show s)
+
+
+-- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses
+-- under precedence @p@.
+hsTypeNeedsParens :: PprPrec -> HsType pass -> Bool
+hsTypeNeedsParens p = go
+ where
+ go (HsForAllTy{}) = p >= funPrec
+ go (HsQualTy{}) = p >= funPrec
+ go (HsBangTy{}) = p > topPrec
+ go (HsRecTy{}) = False
+ go (HsTyVar{}) = False
+ go (HsFunTy{}) = p >= funPrec
+ go (HsTupleTy{}) = False
+ go (HsSumTy{}) = False
+ go (HsKindSig{}) = False
+ go (HsListTy{}) = False
+ go (HsIParamTy{}) = p > topPrec
+ go (HsSpliceTy{}) = False
+ go (HsExplicitListTy{}) = False
+ go (HsExplicitTupleTy{}) = False
+ go (HsTyLit{}) = False
+ go (HsWildCardTy{}) = False
+ go (HsStarTy{}) = False
+ go (HsAppTy{}) = p >= appPrec
+ go (HsOpTy{}) = p >= opPrec
+ go (HsParTy{}) = False
+ go (HsDocTy _ (L _ t) _) = go t
+ go (XHsType{}) = False
+
+-- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is
+-- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply
+-- returns @ty@.
+parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+parenthesizeHsType p lty@(L loc ty)
+ | hsTypeNeedsParens p ty = L loc (HsParTy NoExt lty)
+ | otherwise = lty
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index ba001ea7ff..c3537266e3 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -20,7 +20,7 @@ which deal with the instantiated versions are located elsewhere:
module HsUtils(
-- Terms
- mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypeOut, mkHsCaseAlt,
+ mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypes, mkHsCaseAlt,
mkSimpleMatch, unguardedGRHSs, unguardedRHS,
mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
@@ -50,7 +50,7 @@ module HsUtils(
-- Patterns
mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
- nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, nlParPat,
+ nlWildPatName, nlTuplePat, mkParPat, nlParPat,
mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
-- Types
@@ -63,16 +63,14 @@ module HsUtils(
mkLastStmt,
emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
+ unitRecStmtTc,
-- Template Haskell
mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkUntypedSplice,
mkHsQuasiQuote, unqualQuasiQuote,
- -- Flags
- noRebindableInfo,
-
-- Collecting binders
- isUnliftedHsBind, isBangedBind,
+ isUnliftedHsBind, isBangedHsBind,
collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
collectHsIdBinders,
@@ -84,7 +82,6 @@ module HsUtils(
hsLTyClDeclBinders, hsTyClForeignBinders,
hsPatSynSelectors, getPatSynBinds,
hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
- hsDataDefnBinders,
-- Collecting implicit binders
lStmtsImplicits, hsValBindsImplicits, lPatImplicits
@@ -92,6 +89,8 @@ module HsUtils(
#include "HsVersions.h"
+import GhcPrelude
+
import HsDecls
import HsBinds
import HsExpr
@@ -121,6 +120,7 @@ import Util
import Bag
import Outputable
import Constants
+import TyCon
import Data.Either
import Data.Function
@@ -138,53 +138,60 @@ from their components, compared with the nl* functions below which
just attach noSrcSpan to everything.
-}
-mkHsPar :: LHsExpr id -> LHsExpr id
-mkHsPar e = L (getLoc e) (HsPar e)
+mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+mkHsPar e = L (getLoc e) (HsPar noExt e)
-mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP id))
- -> [LPat id] -> Located (body id)
- -> LMatch id (Located (body id))
+mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
+ -> [LPat (GhcPass p)] -> Located (body (GhcPass p))
+ -> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch ctxt pats rhs
= L loc $
- Match ctxt pats Nothing (unguardedGRHSs rhs)
+ Match { m_ext = noExt, m_ctxt = ctxt, m_pats = pats
+ , m_grhss = unguardedGRHSs rhs }
where
loc = case pats of
[] -> getLoc rhs
(pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
-unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id))
+unguardedGRHSs :: Located (body (GhcPass p))
+ -> GRHSs (GhcPass p) (Located (body (GhcPass p)))
unguardedGRHSs rhs@(L loc _)
- = GRHSs (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
+ = GRHSs noExt (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
-unguardedRHS :: SrcSpan -> Located (body id) -> [LGRHS id (Located (body id))]
-unguardedRHS loc rhs = [L loc (GRHS [] rhs)]
+unguardedRHS :: SrcSpan -> Located (body (GhcPass p))
+ -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))]
+unguardedRHS loc rhs = [L loc (GRHS noExt [] rhs)]
-mkMatchGroup :: (PostTc name Type ~ PlaceHolder)
+mkMatchGroup :: (XMG name (Located (body name)) ~ NoExt)
=> Origin -> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
-mkMatchGroup origin matches = MG { mg_alts = mkLocatedList matches
- , mg_arg_tys = []
- , mg_res_ty = placeHolderType
+mkMatchGroup origin matches = MG { mg_ext = noExt
+ , mg_alts = mkLocatedList matches
, mg_origin = origin }
mkLocatedList :: [Located a] -> Located [Located a]
mkLocatedList [] = noLoc []
mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms
-mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
-mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
+mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExt e1 e2)
-mkHsAppType :: LHsExpr name -> LHsWcType name -> LHsExpr name
-mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType e t)
+mkHsAppType :: (XAppTypeE (GhcPass id) ~ LHsWcType GhcRn)
+ => LHsExpr (GhcPass id) -> LHsWcType GhcRn -> LHsExpr (GhcPass id)
+mkHsAppType e t = addCLoc e t_body (HsAppType paren_wct e)
+ where
+ t_body = hswc_body t
+ paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }
-mkHsAppTypeOut :: LHsExpr GhcTc -> LHsWcType GhcRn -> LHsExpr GhcTc
-mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t)
+mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
+mkHsAppTypes = foldl' mkHsAppType
mkHsLam :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
-mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
+mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExt matches))
where
matches = mkMatchGroup Generated
- [mkSimpleMatch LambdaExpr pats body]
+ [mkSimpleMatch LambdaExpr pats' body]
+ pats' = map (parenthesizePat appPrec) pats
mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
@@ -192,39 +199,40 @@ mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
-- |A simple case alternative with a single pattern, no binds, no guards;
-- pre-typechecking
-mkHsCaseAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id))
+mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p)))
+ -> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt pat expr
= mkSimpleMatch CaseAlt [pat] expr
-nlHsTyApp :: IdP name -> [Type] -> LHsExpr name
-nlHsTyApp fun_id tys = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id)))
+nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id)
+nlHsTyApp fun_id tys
+ = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExt (noLoc fun_id)))
-nlHsTyApps :: IdP name -> [Type] -> [LHsExpr name] -> LHsExpr name
-nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs
+nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)]
+ -> LHsExpr (GhcPass id)
+nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs
--------- Adding parens ---------
-mkLHsPar :: LHsExpr name -> LHsExpr name
--- Wrap in parens if hsExprNeedsParens says it needs them
+mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+-- Wrap in parens if (hsExprNeedsParens appPrec) says it needs them
-- So 'f x' becomes '(f x)', but '3' stays as '3'
-mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le)
- | otherwise = le
+mkLHsPar le@(L loc e) | hsExprNeedsParens appPrec e = L loc (HsPar noExt le)
+ | otherwise = le
-mkParPat :: LPat name -> LPat name
-mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)
- | otherwise = lp
+mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
+mkParPat lp@(L loc p) | patNeedsParens appPrec p = L loc (ParPat noExt lp)
+ | otherwise = lp
-nlParPat :: LPat name -> LPat name
-nlParPat p = noLoc (ParPat p)
+nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
+nlParPat p = noLoc (ParPat noExt p)
-------------------------------
-- These are the bits of syntax that contain rebindable names
-- See RnEnv.lookupSyntaxName
-mkHsIntegral :: IntegralLit -> PostTc GhcPs Type
- -> HsOverLit GhcPs
-mkHsFractional :: FractionalLit -> PostTc GhcPs Type -> HsOverLit GhcPs
-mkHsIsString :: SourceText -> FastString -> PostTc GhcPs Type
- -> HsOverLit GhcPs
+mkHsIntegral :: IntegralLit -> HsOverLit GhcPs
+mkHsFractional :: FractionalLit -> HsOverLit GhcPs
+mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs
mkHsDo :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs
mkHsComp :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
-> HsExpr GhcPs
@@ -233,135 +241,144 @@ mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs)
-> Pat GhcPs
mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs
-mkLastStmt :: SourceTextX idR
- => Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
+mkLastStmt :: Located (bodyR (GhcPass idR))
+ -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkBodyStmt :: Located (bodyR GhcPs)
- -> StmtLR idL GhcPs (Located (bodyR GhcPs))
-mkBindStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => LPat idL -> Located (bodyR idR)
- -> StmtLR idL idR (Located (bodyR idR))
+ -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs))
+mkBindStmt :: (XBindStmt (GhcPass idL) (GhcPass idR)
+ (Located (bodyR (GhcPass idR))) ~ NoExt)
+ => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR))
+ -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc)
-> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))
-emptyRecStmt :: StmtLR idL GhcPs bodyR
+emptyRecStmt :: StmtLR (GhcPass idL) GhcPs bodyR
emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR
emptyRecStmtId :: StmtLR GhcTc GhcTc bodyR
-mkRecStmt :: [LStmtLR idL GhcPs bodyR] -> StmtLR idL GhcPs bodyR
+mkRecStmt :: [LStmtLR (GhcPass idL) GhcPs bodyR]
+ -> StmtLR (GhcPass idL) GhcPs bodyR
-mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noExpr
-mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noExpr
-mkHsIsString src s = OverLit (HsIsString src s) noRebindableInfo noExpr
+mkHsIntegral i = OverLit noExt (HsIntegral i) noExpr
+mkHsFractional f = OverLit noExt (HsFractional f) noExpr
+mkHsIsString src s = OverLit noExt (HsIsString src s) noExpr
-noRebindableInfo :: PlaceHolder
-noRebindableInfo = PlaceHolder -- Just another placeholder;
-
-mkHsDo ctxt stmts = HsDo ctxt (mkLocatedList stmts) placeHolderType
+mkHsDo ctxt stmts = HsDo noExt ctxt (mkLocatedList stmts)
mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
where
last_stmt = L (getLoc expr) $ mkLastStmt expr
-mkHsIf :: SourceTextX p => LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
-mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
-
-mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType
-mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType
-
-mkTransformStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => [ExprLStmt idL] -> LHsExpr idR
- -> StmtLR idL idR (LHsExpr idL)
-mkTransformByStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
- -> StmtLR idL idR (LHsExpr idL)
-mkGroupUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => [ExprLStmt idL] -> LHsExpr idR
- -> StmtLR idL idR (LHsExpr idL)
-mkGroupByUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
- -> StmtLR idL idR (LHsExpr idL)
-
-emptyTransStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => StmtLR idL idR (LHsExpr idR)
-emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
+mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
+ -> HsExpr (GhcPass p)
+mkHsIf c a b = HsIf noExt (Just noSyntaxExpr) c a b
+
+mkNPat lit neg = NPat noExt lit neg noSyntaxExpr
+mkNPlusKPat id lit
+ = NPlusKPat noExt id lit (unLoc lit) noSyntaxExpr noSyntaxExpr
+
+mkTransformStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
+ -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
+mkTransformByStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
+ -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
+mkGroupUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
+ -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
+mkGroupByUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
+ -> LHsExpr GhcPs
+ -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
+
+emptyTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs)
+emptyTransStmt = TransStmt { trS_ext = noExt
+ , trS_form = panic "emptyTransStmt: form"
, trS_stmts = [], trS_bndrs = []
, trS_by = Nothing, trS_using = noLoc noExpr
, trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
- , trS_bind_arg_ty = PlaceHolder
, trS_fmap = noExpr }
mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u }
mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u }
mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
-mkLastStmt body = LastStmt body False noSyntaxExpr
-mkBodyStmt body = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
-mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder
-mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy
+mkLastStmt body = LastStmt noExt body False noSyntaxExpr
+mkBodyStmt body
+ = BodyStmt noExt body noSyntaxExpr noSyntaxExpr
+mkBindStmt pat body
+ = BindStmt noExt pat body noSyntaxExpr noSyntaxExpr
+mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr
-- don't use placeHolderTypeTc above, because that panics during zonking
-emptyRecStmt' :: forall idL idR body. SourceTextX idR =>
- PostTc idR Type -> StmtLR idL idR body
+emptyRecStmt' :: forall idL idR body.
+ XRecStmt (GhcPass idL) (GhcPass idR) body
+ -> StmtLR (GhcPass idL) (GhcPass idR) body
emptyRecStmt' tyVal =
RecStmt
{ recS_stmts = [], recS_later_ids = []
, recS_rec_ids = []
, recS_ret_fn = noSyntaxExpr
, recS_mfix_fn = noSyntaxExpr
- , recS_bind_fn = noSyntaxExpr, recS_bind_ty = tyVal
- , recS_later_rets = []
- , recS_rec_rets = [], recS_ret_ty = tyVal }
-
-emptyRecStmt = emptyRecStmt' placeHolderType
-emptyRecStmtName = emptyRecStmt' placeHolderType
-emptyRecStmtId = emptyRecStmt' unitTy -- a panic might trigger during zonking
+ , recS_bind_fn = noSyntaxExpr
+ , recS_ext = tyVal }
+
+unitRecStmtTc :: RecStmtTc
+unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy
+ , recS_later_rets = []
+ , recS_rec_rets = []
+ , recS_ret_ty = unitTy }
+
+emptyRecStmt = emptyRecStmt' noExt
+emptyRecStmtName = emptyRecStmt' noExt
+emptyRecStmtId = emptyRecStmt' unitRecStmtTc
+ -- a panic might trigger during zonking
mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
-------------------------------
--- A useful function for building @OpApps@. The operator is always a
-- variable, and we don't know the fixity yet.
-mkHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> HsExpr id
-mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op)))
- (error "mkOpApp:fixity") e2
+mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
+mkHsOpApp e1 op e2 = OpApp noExt e1 (noLoc (HsVar noExt (noLoc op))) e2
unqualSplice :: RdrName
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
-mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e
+mkUntypedSplice hasParen e = HsUntypedSplice noExt hasParen unqualSplice e
mkHsSpliceE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs
-mkHsSpliceE hasParen e = HsSpliceE (mkUntypedSplice hasParen e)
+mkHsSpliceE hasParen e = HsSpliceE noExt (mkUntypedSplice hasParen e)
mkHsSpliceTE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs
-mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e)
+mkHsSpliceTE hasParen e
+ = HsSpliceE noExt (HsTypedSplice noExt hasParen unqualSplice e)
mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs
-mkHsSpliceTy hasParen e
- = HsSpliceTy (HsUntypedSplice hasParen unqualSplice e) placeHolderKind
+mkHsSpliceTy hasParen e = HsSpliceTy noExt
+ (HsUntypedSplice noExt hasParen unqualSplice e)
mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs
-mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote
+mkHsQuasiQuote quoter span quote
+ = HsQuasiQuote noExt unqualSplice quoter span quote
unqualQuasiQuote :: RdrName
unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
-- A name (uniquified later) to
-- identify the quasi-quote
-mkHsString :: SourceTextX p => String -> HsLit p
-mkHsString s = HsString noSourceText (mkFastString s)
+mkHsString :: String -> HsLit (GhcPass p)
+mkHsString s = HsString NoSourceText (mkFastString s)
-mkHsStringPrimLit :: SourceTextX p => FastString -> HsLit p
+mkHsStringPrimLit :: FastString -> HsLit (GhcPass p)
mkHsStringPrimLit fs
- = HsStringPrim noSourceText (fastStringToByteString fs)
+ = HsStringPrim NoSourceText (fastStringToByteString fs)
-------------
-userHsLTyVarBndrs :: SrcSpan -> [Located (IdP name)] -> [LHsTyVarBndr name]
+userHsLTyVarBndrs :: SrcSpan -> [Located (IdP (GhcPass p))]
+ -> [LHsTyVarBndr (GhcPass p)]
-- Caller sets location
-userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]
+userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt v) | v <- bndrs ]
-userHsTyVarBndrs :: SrcSpan -> [IdP name] -> [LHsTyVarBndr name]
+userHsTyVarBndrs :: SrcSpan -> [IdP (GhcPass p)] -> [LHsTyVarBndr (GhcPass p)]
-- Caller sets location
-userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
+userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt (L loc v))
+ | v <- bndrs ]
{-
@@ -372,47 +389,49 @@ userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
************************************************************************
-}
-nlHsVar :: IdP id -> LHsExpr id
-nlHsVar n = noLoc (HsVar (noLoc n))
+nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id)
+nlHsVar n = noLoc (HsVar noExt (noLoc n))
-- NB: Only for LHsExpr **Id**
nlHsDataCon :: DataCon -> LHsExpr GhcTc
-nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con))
+nlHsDataCon con = noLoc (HsConLikeOut noExt (RealDataCon con))
-nlHsLit :: HsLit p -> LHsExpr p
-nlHsLit n = noLoc (HsLit n)
+nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p)
+nlHsLit n = noLoc (HsLit noExt n)
-nlHsIntLit :: HasDefaultX p => Integer -> LHsExpr p
-nlHsIntLit n = noLoc (HsLit (HsInt def (mkIntegralLit n)))
+nlHsIntLit :: Integer -> LHsExpr (GhcPass p)
+nlHsIntLit n = noLoc (HsLit noExt (HsInt noExt (mkIntegralLit n)))
-nlVarPat :: IdP id -> LPat id
-nlVarPat n = noLoc (VarPat (noLoc n))
+nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id)
+nlVarPat n = noLoc (VarPat noExt (noLoc n))
-nlLitPat :: HsLit p -> LPat p
-nlLitPat l = noLoc (LitPat l)
+nlLitPat :: HsLit GhcPs -> LPat GhcPs
+nlLitPat l = noLoc (LitPat noExt l)
-nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
-nlHsApp f x = noLoc (HsApp f (mkLHsPar x))
+nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+nlHsApp f x = noLoc (HsApp noExt f (mkLHsPar x))
-nlHsSyntaxApps :: SyntaxExpr id -> [LHsExpr id] -> LHsExpr id
+nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)]
+ -> LHsExpr (GhcPass id)
nlHsSyntaxApps (SyntaxExpr { syn_expr = fun
, syn_arg_wraps = arg_wraps
, syn_res_wrap = res_wrap }) args
| [] <- arg_wraps -- in the noSyntaxExpr case
= ASSERT( isIdHsWrapper res_wrap )
- foldl nlHsApp (noLoc fun) args
+ foldl' nlHsApp (noLoc fun) args
| otherwise
- = mkLHsWrap res_wrap (foldl nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"
+ = mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"
mkLHsWrap arg_wraps args))
-nlHsApps :: IdP id -> [LHsExpr id] -> LHsExpr id
-nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
+nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
+nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs
-nlHsVarApps :: IdP id -> [IdP id] -> LHsExpr id
-nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs))
+nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
+nlHsVarApps f xs = noLoc (foldl' mk (HsVar noExt (noLoc f))
+ (map ((HsVar noExt) . noLoc) xs))
where
- mk f a = HsApp (noLoc f) (noLoc a)
+ mk f a = HsApp noExt (noLoc f) (noLoc a)
nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat con vars = nlConPat con (map nlVarPat vars)
@@ -420,14 +439,18 @@ nlConVarPat con vars = nlConPat con (map nlVarPat vars)
nlConVarPatName :: Name -> [Name] -> LPat GhcRn
nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
-nlInfixConPat :: IdP id -> LPat id -> LPat id -> LPat id
-nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
+nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs
+nlInfixConPat con l r = noLoc (ConPatIn (noLoc con)
+ (InfixCon (parenthesizePat opPrec l)
+ (parenthesizePat opPrec r)))
nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
-nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
+nlConPat con pats =
+ noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))
nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
-nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
+nlConPatName con pats =
+ noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))
nlNullaryConPat :: IdP id -> LPat id
nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
@@ -438,88 +461,94 @@ nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
nlWildPat)))
nlWildPat :: LPat GhcPs
-nlWildPat = noLoc (WildPat placeHolderType ) -- Pre-typechecking
+nlWildPat = noLoc (WildPat noExt ) -- Pre-typechecking
nlWildPatName :: LPat GhcRn
-nlWildPatName = noLoc (WildPat placeHolderType ) -- Pre-typechecking
-
-nlWildPatId :: LPat GhcTc
-nlWildPatId = noLoc (WildPat placeHolderTypeTc ) -- Post-typechecking
+nlWildPatName = noLoc (WildPat noExt ) -- Pre-typechecking
nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
-nlHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> LHsExpr id
+nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
-nlHsPar :: LHsExpr id -> LHsExpr id
-nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
+nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+nlHsIf :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+ -> LHsExpr (GhcPass id)
nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs
-nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match]))
-nlHsPar e = noLoc (HsPar e)
+nlHsLam match = noLoc (HsLam noExt (mkMatchGroup Generated [match]))
+nlHsPar e = noLoc (HsPar noExt e)
-- Note [Rebindable nlHsIf]
-- nlHsIf should generate if-expressions which are NOT subject to
-- RebindableSyntax, so the first field of HsIf is Nothing. (#12080)
-nlHsIf cond true false = noLoc (HsIf Nothing cond true false)
+nlHsIf cond true false = noLoc (HsIf noExt Nothing cond true false)
-nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches))
-nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs)
+nlHsCase expr matches
+ = noLoc (HsCase noExt expr (mkMatchGroup Generated matches))
+nlList exprs = noLoc (ExplicitList noExt Nothing exprs)
-nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
-nlHsTyVar :: IdP name -> LHsType name
-nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
-nlHsParTy :: LHsType name -> LHsType name
+nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p)
+nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p)
-nlHsAppTy f t = noLoc (HsAppTy f t)
-nlHsTyVar x = noLoc (HsTyVar NotPromoted (noLoc x))
-nlHsFunTy a b = noLoc (HsFunTy a b)
-nlHsParTy t = noLoc (HsParTy t)
+nlHsAppTy f t = noLoc (HsAppTy noExt f (parenthesizeHsType appPrec t))
+nlHsTyVar x = noLoc (HsTyVar noExt NotPromoted (noLoc x))
+nlHsFunTy a b = noLoc (HsFunTy noExt (parenthesizeHsType funPrec a)
+ (parenthesize_fun_tail b))
+ where
+ parenthesize_fun_tail (L loc (HsFunTy ext ty1 ty2))
+ = L loc (HsFunTy ext (parenthesizeHsType funPrec ty1)
+ (parenthesize_fun_tail ty2))
+ parenthesize_fun_tail lty = lty
+nlHsParTy t = noLoc (HsParTy noExt t)
-nlHsTyConApp :: IdP name -> [LHsType name] -> LHsType name
-nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
+nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)
+nlHsTyConApp tycon tys = foldl' nlHsAppTy (nlHsTyVar tycon) tys
{-
Tuples. All these functions are *pre-typechecker* because they lack
types on the tuple.
-}
-mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
+mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
-- Makes a pre-typechecker boxed tuple, deals with 1 case
mkLHsTupleExpr [e] = e
-mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed
+mkLHsTupleExpr es
+ = noLoc $ ExplicitTuple noExt (map (noLoc . (Present noExt)) es) Boxed
-mkLHsVarTuple :: [IdP a] -> LHsExpr a
+mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids)
-nlTuplePat :: [LPat id] -> Boxity -> LPat id
-nlTuplePat pats box = noLoc (TuplePat pats box [])
+nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs
+nlTuplePat pats box = noLoc (TuplePat noExt pats box)
missingTupArg :: HsTupArg GhcPs
-missingTupArg = Missing placeHolderType
+missingTupArg = Missing noExt
-mkLHsPatTup :: [LPat id] -> LPat id
-mkLHsPatTup [] = noLoc $ TuplePat [] Boxed []
+mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
+mkLHsPatTup [] = noLoc $ TuplePat noExt [] Boxed
mkLHsPatTup [lpat] = lpat
-mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat lpats Boxed []
+mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat noExt lpats Boxed
-- The Big equivalents for the source tuple expressions
-mkBigLHsVarTup :: [IdP id] -> LHsExpr id
+mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
-mkBigLHsTup :: [LHsExpr id] -> LHsExpr id
+mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
mkBigLHsTup = mkChunkified mkLHsTupleExpr
-- The Big equivalents for the source tuple patterns
-mkBigLHsVarPatTup :: [IdP id] -> LPat id
+mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn
mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
-mkBigLHsPatTup :: [LPat id] -> LPat id
+mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
mkBigLHsPatTup = mkChunkified mkLHsPatTup
-- $big_tuples
@@ -595,8 +624,8 @@ mkHsSigEnv get_info sigs
-- of which use this function
where
(gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs
- is_gen_dm_sig (L _ (ClassOpSig True _ _)) = True
- is_gen_dm_sig _ = False
+ is_gen_dm_sig (L _ (ClassOpSig _ True _ _)) = True
+ is_gen_dm_sig _ = False
mk_pairs :: [LSig GhcRn] -> [(Name, a)]
mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs
@@ -609,8 +638,9 @@ mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]
mkClassOpSigs sigs
= map fiddle sigs
where
- fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty))
- fiddle sig = sig
+ fiddle (L loc (TypeSig _ nms ty))
+ = L loc (ClassOpSig noExt False nms (dropWildCards ty))
+ fiddle sig = sig
typeToLHsType :: Type -> LHsType GhcPs
-- ^ Converting a Type to an HsType RdrName
@@ -626,19 +656,29 @@ typeToLHsType ty
| isPredTy arg
, (theta, tau) <- tcSplitPhiTy ty
= noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
+ , hst_xqual = noExt
, hst_body = go tau })
go (FunTy arg res) = nlHsFunTy (go arg) (go res)
go ty@(ForAllTy {})
| (tvs, tau) <- tcSplitForAllTys ty
= noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
+ , hst_xforall = noExt
, hst_body = go tau })
go (TyVarTy tv) = nlHsTyVar (getRdrName tv)
go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2)
- go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy noSourceText n)
- go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy noSourceText s)
- go (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map go args')
+ go (LitTy (NumTyLit n))
+ = noLoc $ HsTyLit NoExt (HsNumTy NoSourceText n)
+ go (LitTy (StrTyLit s))
+ = noLoc $ HsTyLit NoExt (HsStrTy NoSourceText s)
+ go ty@(TyConApp tc args)
+ | any isInvisibleTyConBinder (tyConBinders tc)
+ -- We must produce an explicit kind signature here to make certain
+ -- programs kind-check. See Note [Kind signatures in typeToLHsType].
+ = noLoc $ HsKindSig NoExt lhs_ty (go (typeKind ty))
+ | otherwise = lhs_ty
where
- args' = filterOutInvisibleTypes tc args
+ lhs_ty = nlHsTyConApp (getRdrName tc) (map go args')
+ args' = filterOutInvisibleTypes tc args
go (CastTy ty _) = go ty
go (CoercionTy co) = pprPanic "toLHsSigWcType" (ppr co)
@@ -646,9 +686,58 @@ typeToLHsType ty
-- so we must remove them here (Trac #8563)
go_tv :: TyVar -> LHsTyVarBndr GhcPs
- go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
+ go_tv tv = noLoc $ KindedTyVar noExt (noLoc (getRdrName tv))
(go (tyVarKind tv))
+{-
+Note [Kind signatures in typeToLHsType]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are types that typeToLHsType can produce which require explicit kind
+signatures in order to kind-check. Here is an example from Trac #14579:
+
+ newtype Wat (x :: Proxy (a :: Type)) = MkWat (Maybe a) deriving Eq
+ newtype Glurp a = MkGlurp (Wat ('Proxy :: Proxy a)) deriving Eq
+
+The derived Eq instance for Glurp (without any kind signatures) would be:
+
+ instance Eq a => Eq (Glurp a) where
+ (==) = coerce @(Wat 'Proxy -> Wat 'Proxy -> Bool)
+ @(Glurp a -> Glurp a -> Bool)
+ (==) :: Glurp a -> Glurp a -> Bool
+
+(Where the visible type applications use types produced by typeToLHsType.)
+
+The type 'Proxy has an underspecified kind, so we must ensure that
+typeToLHsType ascribes it with its kind: ('Proxy :: Proxy a).
+
+We must be careful not to produce too many kind signatures, or else
+typeToLHsType can produce noisy types like
+('Proxy :: Proxy (a :: (Type :: Type))). In pursuit of this goal, we adopt the
+following criterion for choosing when to annotate types with kinds:
+
+* If there is a tycon application with any invisible arguments, annotate
+ the tycon application with its kind.
+
+Why is this the right criterion? The problem we encountered earlier was the
+result of an invisible argument (the `a` in ('Proxy :: Proxy a)) being
+underspecified, so producing a kind signature for 'Proxy will catch this.
+If there are no invisible arguments, then there is nothing to do, so we can
+avoid polluting the result type with redundant noise.
+
+What about a more complicated tycon, such as this?
+
+ T :: forall {j} (a :: j). a -> Type
+
+Unlike in the previous 'Proxy example, annotating an application of `T` to an
+argument (e.g., annotating T ty to obtain (T ty :: Type)) will not fix
+its invisible argument `j`. But because we apply this strategy recursively,
+`j` will be fixed because the kind of `ty` will be fixed! That is to say,
+something to the effect of (T (ty :: j) :: Type) will be produced.
+
+This strategy certainly isn't foolproof, as tycons that contain type families
+in their kind might break down. But we'd likely need visible kind application
+to make those work.
+-}
{- *********************************************************************
* *
@@ -656,41 +745,41 @@ typeToLHsType ty
* *
********************************************************************* -}
-mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
+mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
-- Avoid (HsWrap co (HsWrap co' _)).
-- See Note [Detecting forced eta expansion] in DsExpr
-mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
+mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
-mkHsWrap co_fn (HsWrap co_fn' e) = mkHsWrap (co_fn <.> co_fn') e
-mkHsWrap co_fn e = HsWrap co_fn e
+mkHsWrap co_fn (HsWrap _ co_fn' e) = mkHsWrap (co_fn <.> co_fn') e
+mkHsWrap co_fn e = HsWrap noExt co_fn e
mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b
- -> HsExpr id -> HsExpr id
+ -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b
- -> HsExpr id -> HsExpr id
+ -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
-mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id
+mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
-mkHsCmdWrap :: HsWrapper -> HsCmd id -> HsCmd id
+mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p)
mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
- | otherwise = HsCmdWrap w cmd
+ | otherwise = HsCmdWrap noExt w cmd
-mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id
+mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)
mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
-mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
+mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
- | otherwise = CoPat co_fn p ty
+ | otherwise = CoPat noExt co_fn p ty
-mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id
+mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
mkHsWrapPatCo co pat ty | isTcReflCo co = pat
- | otherwise = CoPat (mkWpCastN co) pat ty
+ | otherwise = CoPat noExt (mkWpCastN co) pat ty
mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
@@ -710,7 +799,7 @@ mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
mkFunBind fn ms = FunBind { fun_id = fn
, fun_matches = mkMatchGroup Generated ms
, fun_co_fn = idHsWrapper
- , bind_fvs = placeHolderNames
+ , fun_ext = noExt
, fun_tick = [] }
mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
@@ -719,31 +808,32 @@ mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
mkTopFunBind origin fn ms = FunBind { fun_id = fn
, fun_matches = mkMatchGroup origin ms
, fun_co_fn = idHsWrapper
- , bind_fvs = emptyNameSet -- NB: closed
+ , fun_ext = emptyNameSet -- NB: closed
-- binding
, fun_tick = [] }
mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
-mkVarBind :: IdP p -> LHsExpr p -> LHsBind p
+mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind var rhs = L (getLoc rhs) $
- VarBind { var_id = var, var_rhs = rhs, var_inline = False }
+ VarBind { var_ext = noExt,
+ var_id = var, var_rhs = rhs, var_inline = False }
mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
-> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs
-mkPatSynBind name details lpat dir = PatSynBind psb
+mkPatSynBind name details lpat dir = PatSynBind noExt psb
where
- psb = PSB{ psb_id = name
+ psb = PSB{ psb_ext = noExt
+ , psb_id = name
, psb_args = details
, psb_def = lpat
- , psb_dir = dir
- , psb_fvs = placeHolderNames }
+ , psb_dir = dir }
-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
-- considered infix.
isInfixFunBind :: HsBindLR id1 id2 -> Bool
-isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _)
+isInfixFunBind (FunBind _ _ (MG _ matches _) _ _)
= any (isInfixMatch . unLoc) (unLoc matches)
isInfixFunBind _ = False
@@ -758,17 +848,23 @@ mk_easy_FunBind loc fun pats expr
-- | Make a prefix, non-strict function 'HsMatchContext'
mkPrefixFunRhs :: Located id -> HsMatchContext id
-mkPrefixFunRhs n = FunRhs n Prefix NoSrcStrict
+mkPrefixFunRhs n = FunRhs { mc_fun = n
+ , mc_fixity = Prefix
+ , mc_strictness = NoSrcStrict }
------------
-mkMatch :: HsMatchContext (NameOrRdrName (IdP p)) -> [LPat p] -> LHsExpr p
- -> Located (HsLocalBinds p) -> LMatch p (LHsExpr p)
+mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
+ -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p)
+ -> Located (HsLocalBinds (GhcPass p))
+ -> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch ctxt pats expr lbinds
- = noLoc (Match ctxt (map paren pats) Nothing
- (GRHSs (unguardedRHS noSrcSpan expr) lbinds))
+ = noLoc (Match { m_ext = noExt
+ , m_ctxt = ctxt
+ , m_pats = map paren pats
+ , m_grhss = GRHSs noExt (unguardedRHS noSrcSpan expr) lbinds })
where
- paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
- | otherwise = lp
+ paren lp@(L l p) | patNeedsParens appPrec p = L l (ParPat noExt lp)
+ | otherwise = lp
{-
************************************************************************
@@ -794,49 +890,31 @@ to return a [Name] or [Id]. Before renaming the record punning
and wild-card mechanism makes it hard to know what is bound.
So these functions should not be applied to (HsSyn RdrName)
-Note [Unlifted id check in isHsUnliftedBind]
+Note [Unlifted id check in isUnliftedHsBind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose there is a binding with the type (Num a => (# a, a #)). Is this a
-strict binding that should be disallowed at the top level? At first glance,
-no, because it's a function. But consider how this is desugared via
-AbsBinds:
-
- -- x :: Num a => (# a, a #)
- x = (# 3, 4 #)
-
-becomes
-
- x = \ $dictNum ->
- let x_mono = (# fromInteger $dictNum 3, fromInteger $dictNum 4 #) in
- x_mono
-
-Note that the inner let is strict. And thus if we have a bunch of mutually
-recursive bindings of this form, we could end up in trouble. This was shown
-up in #9140.
+The function isUnliftedHsBind is used to complain if we make a top-level
+binding for a variable of unlifted type.
-But if there is a type signature on x, everything changes because of the
-desugaring used by AbsBindsSig:
+Such a binding is illegal if the top-level binding would be unlifted;
+but also if the local letrec generated by desugaring AbsBinds would be.
+E.g.
+ f :: Num a => (# a, a #)
+ g :: Num a => a -> a
+ f = ...g...
+ g = ...g...
- x :: Num a => (# a, a #)
- x = (# 3, 4 #)
+The top-level bindings for f,g are not unlifted (because of the Num a =>),
+but the local, recursive, monomorphic bindings are:
-becomes
+ t = /\a \(d:Num a).
+ letrec fm :: (# a, a #) = ...g...
+ gm :: a -> a = ...f...
+ in (fm, gm)
- x = \ $dictNum -> (# fromInteger $dictNum 3, fromInteger $dictNum 4 #)
-
-No strictness anymore! The bottom line here is that, for inferred types, we
-care about the strictness of the type after the =>. For checked types
-(AbsBindsSig), we care about the overall strictness.
-
-This matters. If we don't separate out the AbsBindsSig case, then GHC runs into
-a problem when compiling
-
- undefined :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a
-
-Looking only after the =>, we cannot tell if this is strict or not. (GHC panics
-if you try.) Looking at the whole type, on the other hand, tells you that this
-is a lifted function type, with no trouble at all.
+Here the binding for 'fm' is illegal. So generally we check the abe_mono types.
+BUT we have a special case when abs_sig is true;
+ see HsBinds Note [The abs_sig field of AbsBinds]
-}
----------------- Bindings --------------------------
@@ -846,35 +924,43 @@ is a lifted function type, with no trouble at all.
-- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage
-- information, see Note [Strict binds check] is DsBinds.
isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds
-isUnliftedHsBind (AbsBindsSig { abs_sig_export = id })
- = isUnliftedType (idType id)
isUnliftedHsBind bind
+ | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind
+ = if has_sig
+ then any (is_unlifted_id . abe_poly) exports
+ else any (is_unlifted_id . abe_mono) exports
+ -- If has_sig is True we wil never generate a binding for abe_mono,
+ -- so we don't need to worry about it being unlifted. The abe_poly
+ -- binding might not be: e.g. forall a. Num a => (# a, a #)
+
+ | otherwise
= any is_unlifted_id (collectHsBindBinders bind)
where
- is_unlifted_id id
- = case tcSplitSigmaTy (idType id) of
- (_, _, tau) -> isUnliftedType tau
- -- For the is_unlifted check, we need to look inside polymorphism
- -- and overloading. E.g. x = (# 1, True #)
- -- would get type forall a. Num a => (# a, Bool #)
- -- and we want to reject that. See Trac #9140
-
--- | Is a binding a strict variable bind (e.g. @!x = ...@)?
-isBangedBind :: HsBind GhcTc -> Bool
-isBangedBind b | isBangedPatBind b = True
-isBangedBind (FunBind {fun_matches = matches})
+ is_unlifted_id id = isUnliftedType (idType id)
+
+-- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)?
+isBangedHsBind :: HsBind GhcTc -> Bool
+isBangedHsBind (AbsBinds { abs_binds = binds })
+ = anyBag (isBangedHsBind . unLoc) binds
+isBangedHsBind (FunBind {fun_matches = matches})
| [L _ match] <- unLoc $ mg_alts matches
, FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
= True
-isBangedBind _ = False
-
-collectLocalBinders :: HsLocalBindsLR idL idR -> [IdP idL]
-collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
+isBangedHsBind (PatBind {pat_lhs = pat})
+ = isBangedLPat pat
+isBangedHsBind _
+ = False
+
+collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR)
+ -> [IdP (GhcPass idL)]
+collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds
-- No pattern synonyms here
-collectLocalBinders (HsIPBinds _) = []
-collectLocalBinders EmptyLocalBinds = []
+collectLocalBinders (HsIPBinds {}) = []
+collectLocalBinders (EmptyLocalBinds _) = []
+collectLocalBinders (XHsLocalBindsLR _) = []
-collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [IdP idL]
+collectHsIdBinders, collectHsValBinders
+ :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
-- Collect Id binders only, or Ids + pattern synonyms, respectively
collectHsIdBinders = collect_hs_val_binders True
collectHsValBinders = collect_hs_val_binders False
@@ -890,9 +976,11 @@ collectHsBindListBinders :: [LHsBindLR idL idR] -> [IdP idL]
-- Same as collectHsBindsBinders, but works over a list of bindings
collectHsBindListBinders = foldr (collect_bind False . unLoc) []
-collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [IdP idL]
-collect_hs_val_binders ps (ValBindsIn binds _) = collect_binds ps binds []
-collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds
+collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR)
+ -> [IdP (GhcPass idL)]
+collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds []
+collect_hs_val_binders ps (XValBindsLR (NValBinds binds _))
+ = collect_out_binds ps binds
collect_out_binds :: Bool -> [(RecFlag, LHsBinds p)] -> [IdP p]
collect_out_binds ps = foldr (collect_binds ps . snd) []
@@ -907,14 +995,15 @@ collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc
collect_bind _ (VarBind { var_id = f }) acc = f : acc
collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
-- I don't think we want the binders from the abe_binds
- -- The only time we collect binders from a typechecked
+
-- binding (hence see AbsBinds) is in zonking in TcHsSyn
-collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc
-collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc
+collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = L _ ps })) acc
| omitPatSyn = acc
| otherwise = ps : acc
+collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc
+collect_bind _ (XHsBindsLR _) acc = acc
-collectMethodBinders :: LHsBindsLR GhcPs idR -> [Located RdrName]
+collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)]
-- Used exclusively for the bindings of an instance decl which are all FunBinds
collectMethodBinders binds = foldrBag (get . unLoc) [] binds
where
@@ -923,26 +1012,35 @@ collectMethodBinders binds = foldrBag (get . unLoc) [] binds
-- Someone else complains about non-FunBinds
----------------- Statements --------------------------
-collectLStmtsBinders :: [LStmtLR idL idR body] -> [IdP idL]
+collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body]
+ -> [IdP (GhcPass idL)]
collectLStmtsBinders = concatMap collectLStmtBinders
-collectStmtsBinders :: [StmtLR idL idR body] -> [IdP idL]
+collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body]
+ -> [IdP (GhcPass idL)]
collectStmtsBinders = concatMap collectStmtBinders
-collectLStmtBinders :: LStmtLR idL idR body -> [IdP idL]
+collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body
+ -> [IdP (GhcPass idL)]
collectLStmtBinders = collectStmtBinders . unLoc
-collectStmtBinders :: StmtLR idL idR body -> [IdP idL]
+collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body
+ -> [IdP (GhcPass idL)]
-- Id Binders for a Stmt... [but what about pattern-sig type vars]?
-collectStmtBinders (BindStmt pat _ _ _ _)= collectPatBinders pat
-collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds
-collectStmtBinders (BodyStmt {}) = []
-collectStmtBinders (LastStmt {}) = []
-collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
- $ [s | ParStmtBlock ss _ _ <- xs, s <- ss]
+collectStmtBinders (BindStmt _ pat _ _ _) = collectPatBinders pat
+collectStmtBinders (LetStmt _ (L _ binds)) = collectLocalBinders binds
+collectStmtBinders (BodyStmt {}) = []
+collectStmtBinders (LastStmt {}) = []
+collectStmtBinders (ParStmt _ xs _ _) = collectLStmtsBinders
+ $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss]
collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
-collectStmtBinders ApplicativeStmt{} = []
+collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args
+ where
+ collectArgBinders (_, ApplicativeArgOne _ pat _ _) = collectPatBinders pat
+ collectArgBinders (_, ApplicativeArgMany _ _ _ pat) = collectPatBinders pat
+ collectArgBinders _ = []
+collectStmtBinders XStmtLR{} = panic "collectStmtBinders"
----------------- Patterns --------------------------
@@ -957,33 +1055,32 @@ collect_lpat :: LPat pass -> [IdP pass] -> [IdP pass]
collect_lpat (L _ pat) bndrs
= go pat
where
- go (VarPat (L _ var)) = var : bndrs
+ go (VarPat _ (L _ var)) = var : bndrs
go (WildPat _) = bndrs
- go (LazyPat pat) = collect_lpat pat bndrs
- go (BangPat pat) = collect_lpat pat bndrs
- go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs
- go (ViewPat _ pat _) = collect_lpat pat bndrs
- go (ParPat pat) = collect_lpat pat bndrs
+ go (LazyPat _ pat) = collect_lpat pat bndrs
+ go (BangPat _ pat) = collect_lpat pat bndrs
+ go (AsPat _ (L _ a) pat) = a : collect_lpat pat bndrs
+ go (ViewPat _ _ pat) = collect_lpat pat bndrs
+ go (ParPat _ pat) = collect_lpat pat bndrs
- go (ListPat pats _ _) = foldr collect_lpat bndrs pats
- go (PArrPat pats _) = foldr collect_lpat bndrs pats
- go (TuplePat pats _ _) = foldr collect_lpat bndrs pats
- go (SumPat pat _ _ _) = collect_lpat pat bndrs
+ go (ListPat _ pats) = foldr collect_lpat bndrs pats
+ go (TuplePat _ pats _) = foldr collect_lpat bndrs pats
+ go (SumPat _ pat _ _) = collect_lpat pat bndrs
go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps)
go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps)
-- See Note [Dictionary binders in ConPatOut]
- go (LitPat _) = bndrs
- go (NPat {}) = bndrs
- go (NPlusKPat (L _ n) _ _ _ _ _)= n : bndrs
+ go (LitPat _ _) = bndrs
+ go (NPat {}) = bndrs
+ go (NPlusKPat _ (L _ n) _ _ _ _)= n : bndrs
- go (SigPatIn pat _) = collect_lpat pat bndrs
- go (SigPatOut pat _) = collect_lpat pat bndrs
+ go (SigPat _ pat) = collect_lpat pat bndrs
- go (SplicePat (HsSpliced _ (HsSplicedPat pat)))
+ go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
= go pat
- go (SplicePat _) = bndrs
- go (CoPat _ pat _) = go pat
+ go (SplicePat _ _) = bndrs
+ go (CoPat _ _ pat _) = go pat
+ go (XPat {}) = bndrs
{-
Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
@@ -1018,6 +1115,7 @@ hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
hs_fords = foreign_decls })
= collectHsValBinders val_decls
++ hsTyClForeignBinders tycl_decls foreign_decls
+hsGroupBinders (XHsGroup {}) = panic "hsGroupBinders"
hsTyClForeignBinders :: [TyClGroup GhcRn]
-> [LForeignDecl GhcRn]
@@ -1032,7 +1130,7 @@ hsTyClForeignBinders tycl_decls foreign_decls
foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)
where
getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name]
- getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs
+ getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs
-------------------
hsLTyClDeclBinders :: Located (TyClDecl pass)
@@ -1048,15 +1146,19 @@ hsLTyClDeclBinders :: Located (TyClDecl pass)
hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
= ([L loc name], [])
+hsLTyClDeclBinders (L _ (FamDecl { tcdFam = XFamilyDecl _ }))
+ = panic "hsLTyClDeclBinders"
hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = ([L loc name], [])
hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name
, tcdSigs = sigs, tcdATs = ats }))
= (L loc cls_name :
[ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
- [ L mem_loc mem_name | L mem_loc (ClassOpSig False ns _) <- sigs, L _ mem_name <- ns ]
+ [ L mem_loc mem_name | L mem_loc (ClassOpSig _ False ns _) <- sigs
+ , L _ mem_name <- ns ]
, [])
hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn }))
= (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
+hsLTyClDeclBinders (L _ (XTyClDecl _)) = panic "hsLTyClDeclBinders"
-------------------
hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)]
@@ -1067,40 +1169,50 @@ hsForeignDeclsBinders foreign_decls
-------------------
-hsPatSynSelectors :: HsValBinds p -> [IdP p]
+hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)]
-- Collects record pattern-synonym selectors only; the pattern synonym
-- names are collected by collectHsValBinders.
-hsPatSynSelectors (ValBindsIn _ _) = panic "hsPatSynSelectors"
-hsPatSynSelectors (ValBindsOut binds _)
+hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
+hsPatSynSelectors (XValBindsLR (NValBinds binds _))
= foldrBag addPatSynSelector [] . unionManyBags $ map snd binds
addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]
addPatSynSelector bind sels
- | L _ (PatSynBind (PSB { psb_args = RecordPatSyn as })) <- bind
+ | L _ (PatSynBind _ (PSB { psb_args = RecCon as })) <- bind
= map (unLoc . recordPatSynSelectorId) as ++ sels
| otherwise = sels
getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
getPatSynBinds binds
= [ psb | (_, lbinds) <- binds
- , L _ (PatSynBind psb) <- bagToList lbinds ]
+ , L _ (PatSynBind _ psb) <- bagToList lbinds ]
-------------------
-hsLInstDeclBinders :: LInstDecl pass
- -> ([Located (IdP pass)], [LFieldOcc pass])
+hsLInstDeclBinders :: LInstDecl (GhcPass p)
+ -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
= foldMap (hsDataFamInstBinders . unLoc) dfis
hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
= hsDataFamInstBinders fi
hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
+hsLInstDeclBinders (L _ (ClsInstD _ (XClsInstDecl {})))
+ = panic "hsLInstDeclBinders"
+hsLInstDeclBinders (L _ (XInstDecl _))
+ = panic "hsLInstDeclBinders"
-------------------
-- the SrcLoc returned are for the whole declarations, not just the names
hsDataFamInstBinders :: DataFamInstDecl pass
-> ([Located (IdP pass)], [LFieldOcc pass])
-hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
+hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+ FamEqn { feqn_rhs = defn }}})
= hsDataDefnBinders defn
-- There can't be repeated symbols because only data instances have binders
+hsDataFamInstBinders (DataFamInstDecl
+ { dfid_eqn = HsIB { hsib_body = XFamEqn _}})
+ = panic "hsDataFamInstBinders"
+hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs _))
+ = panic "hsDataFamInstBinders"
-------------------
-- the SrcLoc returned are for the whole declarations, not just the names
@@ -1108,57 +1220,53 @@ hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass])
hsDataDefnBinders (HsDataDefn { dd_cons = cons })
= hsConDeclsBinders cons
-- See Note [Binders in family instances]
+hsDataDefnBinders (XHsDataDefn _) = panic "hsDataDefnBinders"
-------------------
+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])
- go _ [] = ([], [])
- 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
- -- 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
- 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']
- (ns, fs) = go remSeen' rs
-
- 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`
- unLoc . rdrNameFieldOcc . unLoc) v | v <- r']
- (ns, fs) = go remSeen' rs
- L loc (ConDeclH98 { con_name = name }) ->
- ([L loc (unLoc name)] ++ ns, fs)
- where (ns, fs) = go remSeen rs
+ -- 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 :: 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
+ -- have a record of the full location of the field declaration anyway
+ = 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_args = args })
+ -> (map (L loc . unLoc) names ++ ns, flds ++ fs)
+ where
+ (remSeen', flds) = get_flds remSeen args
+ (ns, fs) = go remSeen' rs
+
+ L loc (ConDeclH98 { con_name = name, con_args = args })
+ -> ([L loc (unLoc name)] ++ ns, flds ++ fs)
+ where
+ (remSeen', flds) = get_flds remSeen args
+ (ns, fs) = go remSeen' rs
+
+ L _ (XConDecl _) -> panic "hsConDeclsBinders"
+
+ get_flds :: Seen pass -> HsConDeclDetails pass
+ -> (Seen pass, [LFieldOcc pass])
+ get_flds remSeen (RecCon flds)
+ = (remSeen', fld_names)
+ where
+ fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds))
+ remSeen' = foldr (.) remSeen
+ [deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v
+ | v <- fld_names]
+ get_flds remSeen _
+ = (remSeen, [])
{-
@@ -1192,32 +1300,39 @@ The main purpose is to find names introduced by record wildcards so that we can
warning the user when they don't use those names (#4404)
-}
-lStmtsImplicits :: [LStmtLR GhcRn idR (Located (body idR))] -> NameSet
+lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]
+ -> NameSet
lStmtsImplicits = hs_lstmts
where
- hs_lstmts :: [LStmtLR GhcRn idR (Located (body idR))] -> NameSet
+ hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]
+ -> NameSet
hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet
- hs_stmt :: StmtLR GhcRn idR (Located (body idR)) -> NameSet
- hs_stmt (BindStmt pat _ _ _ _) = lPatImplicits pat
- hs_stmt (ApplicativeStmt args _ _) = unionNameSets (map do_arg args)
- where do_arg (_, ApplicativeArgOne pat _) = lPatImplicits pat
- do_arg (_, ApplicativeArgMany stmts _ _) = hs_lstmts stmts
- hs_stmt (LetStmt binds) = hs_local_binds (unLoc binds)
- hs_stmt (BodyStmt {}) = emptyNameSet
- hs_stmt (LastStmt {}) = emptyNameSet
- hs_stmt (ParStmt xs _ _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss]
+ hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))
+ -> NameSet
+ hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat
+ hs_stmt (ApplicativeStmt _ args _) = unionNameSets (map do_arg args)
+ where do_arg (_, ApplicativeArgOne _ pat _ _) = lPatImplicits pat
+ do_arg (_, ApplicativeArgMany _ stmts _ _) = hs_lstmts stmts
+ do_arg (_, XApplicativeArg _) = panic "lStmtsImplicits"
+ hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds)
+ hs_stmt (BodyStmt {}) = emptyNameSet
+ hs_stmt (LastStmt {}) = emptyNameSet
+ hs_stmt (ParStmt _ xs _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs
+ , s <- ss]
hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
+ hs_stmt (XStmtLR {}) = panic "lStmtsImplicits"
- hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
- hs_local_binds (HsIPBinds _) = emptyNameSet
- hs_local_binds EmptyLocalBinds = emptyNameSet
+ hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds
+ hs_local_binds (HsIPBinds {}) = emptyNameSet
+ hs_local_binds (EmptyLocalBinds _) = emptyNameSet
+ hs_local_binds (XHsLocalBindsLR _) = emptyNameSet
-hsValBindsImplicits :: HsValBindsLR GhcRn idR -> NameSet
-hsValBindsImplicits (ValBindsOut binds _)
+hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> NameSet
+hsValBindsImplicits (XValBindsLR (NValBinds binds _))
= foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds
-hsValBindsImplicits (ValBindsIn binds _)
+hsValBindsImplicits (ValBinds _ binds _)
= lhsBindsImplicits binds
lhsBindsImplicits :: LHsBindsLR GhcRn idR -> NameSet
@@ -1233,18 +1348,16 @@ lPatImplicits = hs_lpat
hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet
- hs_pat (LazyPat pat) = hs_lpat pat
- hs_pat (BangPat pat) = hs_lpat pat
- hs_pat (AsPat _ pat) = hs_lpat pat
- hs_pat (ViewPat _ pat _) = hs_lpat pat
- hs_pat (ParPat pat) = hs_lpat pat
- hs_pat (ListPat pats _ _) = hs_lpats pats
- hs_pat (PArrPat pats _) = hs_lpats pats
- hs_pat (TuplePat pats _ _) = hs_lpats pats
-
- hs_pat (SigPatIn pat _) = hs_lpat pat
- hs_pat (SigPatOut pat _) = hs_lpat pat
- hs_pat (CoPat _ pat _) = hs_pat pat
+ hs_pat (LazyPat _ pat) = hs_lpat pat
+ hs_pat (BangPat _ pat) = hs_lpat pat
+ hs_pat (AsPat _ _ pat) = hs_lpat pat
+ hs_pat (ViewPat _ _ pat) = hs_lpat pat
+ hs_pat (ParPat _ pat) = hs_lpat pat
+ hs_pat (ListPat _ pats) = hs_lpats pats
+ hs_pat (TuplePat _ pats _) = hs_lpats pats
+
+ hs_pat (SigPat _ pat) = hs_lpat pat
+ hs_pat (CoPat _ _ pat _) = hs_pat pat
hs_pat (ConPatIn _ ps) = details ps
hs_pat (ConPatOut {pat_args=ps}) = details ps
diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs
index 5c716d259c..244243a82f 100644
--- a/compiler/hsSyn/PlaceHolder.hs
+++ b/compiler/hsSyn/PlaceHolder.hs
@@ -6,14 +6,11 @@
module PlaceHolder where
-import Type ( Type )
-import Outputable
import Name
import NameSet
import RdrName
import Var
-import Data.Data hiding ( Fixity )
{-
@@ -27,32 +24,11 @@ import Data.Data hiding ( Fixity )
-- NB: These are intentionally open, allowing API consumers (like Haddock)
-- to declare new instances
--- | used as place holder in PostTc and PostRn values
-data PlaceHolder = PlaceHolder
- deriving (Data)
-
-placeHolderKind :: PlaceHolder
-placeHolderKind = PlaceHolder
-
-placeHolderFixity :: PlaceHolder
-placeHolderFixity = PlaceHolder
-
-placeHolderType :: PlaceHolder
-placeHolderType = PlaceHolder
-
-placeHolderTypeTc :: Type
-placeHolderTypeTc = panic "Evaluated the place holder for a PostTcType"
-
-placeHolderNames :: PlaceHolder
-placeHolderNames = PlaceHolder
-
placeHolderNamesTc :: NameSet
placeHolderNamesTc = emptyNameSet
-placeHolderHsWrapper :: PlaceHolder
-placeHolderHsWrapper = PlaceHolder
-
{-
+TODO:AZ: remove this, and check if we still need all the UndecidableInstances
Note [Pass sensitive types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
View Lorry Controller Status