diff options
Diffstat (limited to 'compiler/hsSyn')
| -rw-r--r-- | compiler/hsSyn/Convert.hs | 162 | ||||
| -rw-r--r-- | compiler/hsSyn/HsBinds.hs | 150 | ||||
| -rw-r--r-- | compiler/hsSyn/HsDecls.hs | 154 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExpr.hs | 246 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExpr.hs-boot | 46 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExtension.hs | 328 | ||||
| -rw-r--r-- | compiler/hsSyn/HsLit.hs | 71 | ||||
| -rw-r--r-- | compiler/hsSyn/HsPat.hs | 303 | ||||
| -rw-r--r-- | compiler/hsSyn/HsPat.hs-boot | 6 | ||||
| -rw-r--r-- | compiler/hsSyn/HsSyn.hs | 5 | ||||
| -rw-r--r-- | compiler/hsSyn/HsTypes.hs | 478 | ||||
| -rw-r--r-- | compiler/hsSyn/HsUtils.hs | 186 | ||||
| -rw-r--r-- | compiler/hsSyn/PlaceHolder.hs | 9 |
13 files changed, 795 insertions, 1349 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 5e15288b25..4336243e91 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -8,7 +8,6 @@ This module converts Template Haskell syntax into HsSyn {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} module Convert( convertToHsExpr, convertToPat, convertToHsDecls, convertToHsType, @@ -542,8 +541,7 @@ 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 noExt - (noLoc $ HsRecTy noExt rec_flds) ty') + ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty') ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) } cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness @@ -562,7 +560,7 @@ cvt_arg (Bang su ss, ty) ; ty' <- wrap_apps ty'' ; let su' = cvtSrcUnpackedness su ; let ss' = cvtSrcStrictness ss - ; returnL $ HsBangTy noExt (HsSrcBang NoSourceText su' ss') ty' } + ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' } cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) cvt_id_arg (i, str, ty) @@ -570,7 +568,7 @@ cvt_id_arg (i, str, ty) ; ty' <- cvt_arg (str,ty) ; return $ noLoc (ConDeclField { cd_fld_names - = [L li $ FieldOcc noExt (L li i')] + = [L li $ FieldOcc (L li i') PlaceHolder] , cd_fld_type = ty' , cd_fld_doc = Nothing}) } @@ -755,7 +753,7 @@ cvtLocalDecs doc 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 noExt (listToBag binds) sigs)) } + ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) } cvtClause :: HsMatchContext RdrName -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) @@ -1017,13 +1015,13 @@ cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs) cvtOverLit (IntegerL i) - = do { force i; return $ mkHsIntegral (mkIntegralLit i) } + = do { force i; return $ mkHsIntegral (mkIntegralLit i) placeHolderType} cvtOverLit (RationalL r) - = do { force r; return $ mkHsFractional (mkFractionalLit r) } + = do { force r; return $ mkHsFractional (mkFractionalLit r) placeHolderType} cvtOverLit (StringL s) = do { let { s' = mkFastString s } ; force s' - ; return $ mkHsIsString (quotedSourceText s) s' + ; return $ mkHsIsString (quotedSourceText s) s' placeHolderType } cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal" -- An Integer is like an (overloaded) '3' in a Haskell source program @@ -1054,9 +1052,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 noExt (mkFractionalLit f) } + = do { force f; return $ HsFloatPrim def (mkFractionalLit f) } cvtLit (DoublePrimL f) - = do { force f; return $ HsDoublePrim noExt (mkFractionalLit f) } + = do { force f; return $ HsDoublePrim def (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 } @@ -1085,45 +1083,40 @@ 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 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 } + | 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 [] } cvtp (UnboxedSumP p alt arity) = do { p' <- cvtPat p ; unboxedSumChecks alt arity - ; return $ SumPat noExt p' alt arity } + ; return $ SumPat p' alt arity placeHolderType } cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps ; pps <- mapM wrap_conpat ps' ; return $ ConPatIn s' (PrefixCon pps) } cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 - ; wrapParL (ParPat noExt) $ + ; wrapParL ParPat $ ConPatIn s' (InfixCon (mkParPat p1') (mkParPat 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 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' } + _ -> 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 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 noExt ps' } + ; return $ ListPat ps' placeHolderType Nothing } cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t - ; return $ SigPat (mkLHsSigWcType t') p' } + ; return $ SigPatIn p' (mkLHsSigWcType t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p - ; return $ ViewPat noExt e' p'} + ; return $ ViewPat e' p' placeHolderType } cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) cvtPatFld (s,p) @@ -1134,9 +1127,9 @@ cvtPatFld (s,p) , hsRecPun = False}) } wrap_conpat :: Hs.LPat GhcPs -> CvtM (Hs.LPat GhcPs) -wrap_conpat p@(L _ (ConPatIn _ (InfixCon{}))) = returnL $ ParPat noExt p +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 noExt 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@. @@ -1162,11 +1155,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 noExt nm' } + ; returnL $ UserTyVar nm' } cvt_tv (TH.KindedTV nm ki) = do { nm' <- tNameL nm ; ki' <- cvtKind ki - ; returnL $ KindedTyVar noExt nm' ki' } + ; returnL $ KindedTyVar nm' ki' } cvtRole :: TH.Role -> Maybe Coercion.Role cvtRole TH.NominalR = Just Coercion.Nominal @@ -1203,18 +1196,17 @@ 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 noExt - HsBoxedOrConstraintTuple tys') + else returnL (HsTupleTy HsBoxedOrConstraintTuple tys') | n == 1 -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor"))) | otherwise - -> mk_apps (HsTyVar noExt NotPromoted + -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n)))) tys' UnboxedTupleT n | tys' `lengthIs` n -- Saturated - -> returnL (HsTupleTy noExt HsUnboxedTuple tys') + -> returnL (HsTupleTy HsUnboxedTuple tys') | otherwise - -> mk_apps (HsTyVar noExt NotPromoted + -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n)))) tys' UnboxedSumT n | n < 2 @@ -1223,31 +1215,28 @@ cvtTypeKind ty_str ty , nest 2 $ text "Sums must have an arity of at least 2" ] | tys' `lengthIs` n -- Saturated - -> returnL (HsSumTy noExt tys') + -> returnL (HsSumTy tys') | otherwise - -> mk_apps (HsTyVar noExt NotPromoted - (noLoc (getRdrName (sumTyCon n)))) + -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n)))) tys' ArrowT | [x',y'] <- tys' -> do case x' of - (L _ HsFunTy{}) -> do { x'' <- returnL (HsParTy noExt x') - ; returnL (HsFunTy noExt x'' y') } - _ -> returnL (HsFunTy noExt x' y') + (L _ HsFunTy{}) -> do { x'' <- returnL (HsParTy x') + ; returnL (HsFunTy x'' y') } + _ -> returnL (HsFunTy x' y') | otherwise -> - mk_apps (HsTyVar noExt NotPromoted - (noLoc (getRdrName funTyCon))) + mk_apps (HsTyVar NotPromoted (noLoc (getRdrName funTyCon))) tys' ListT - | [x'] <- tys' -> returnL (HsListTy noExt x') + | [x'] <- tys' -> returnL (HsListTy x') | otherwise -> - mk_apps (HsTyVar noExt NotPromoted - (noLoc (getRdrName listTyCon))) + mk_apps (HsTyVar NotPromoted (noLoc (getRdrName listTyCon))) tys' VarT nm -> do { nm' <- tNameL nm - ; mk_apps (HsTyVar noExt NotPromoted nm') tys' } + ; mk_apps (HsTyVar NotPromoted nm') tys' } ConT nm -> do { nm' <- tconName nm - ; mk_apps (HsTyVar noExt NotPromoted (noLoc nm')) tys'} + ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' } ForallT tvs cxt ty | null tys' @@ -1263,11 +1252,11 @@ cvtTypeKind ty_str ty SigT ty ki -> do { ty' <- cvtType ty ; ki' <- cvtKind ki - ; mk_apps (HsKindSig noExt ty' ki') tys' + ; mk_apps (HsKindSig ty' ki') tys' } LitT lit - -> returnL (HsTyLit noExt (cvtTyLit lit)) + -> returnL (HsTyLit (cvtTyLit lit)) WildCardT -> mk_apps mkAnonWildCardTy tys' @@ -1276,7 +1265,7 @@ cvtTypeKind ty_str ty -> do { s' <- tconName s ; t1' <- cvtType t1 ; t2' <- cvtType t2 - ; mk_apps (HsTyVar noExt NotPromoted (noLoc s')) [t1', t2'] + ; mk_apps (HsTyVar NotPromoted (noLoc s')) [t1', t2'] } UInfixT t1 s t2 @@ -1288,46 +1277,46 @@ cvtTypeKind ty_str ty ParensT t -> do { t' <- cvtType t - ; returnL $ HsParTy noExt t' + ; returnL $ HsParTy t' } PromotedT nm -> do { nm' <- cName nm - ; mk_apps (HsTyVar noExt NotPromoted - (noLoc nm')) tys' } + ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' } -- Promoted data constructor; hence cName PromotedTupleT n | n == 1 -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str))) | m == n -- Saturated - -> returnL (HsExplicitTupleTy noExt tys') + -> do { let kis = replicate m placeHolderKind + ; returnL (HsExplicitTupleTy kis tys') + } where m = length tys' PromotedNilT - -> returnL (HsExplicitListTy noExt Promoted []) + -> returnL (HsExplicitListTy Promoted placeHolderKind []) PromotedConsT -- See Note [Representing concrete syntax in types] -- in Language.Haskell.TH.Syntax - | [ty1, L _ (HsExplicitListTy _ ip tys2)] <- tys' - -> returnL (HsExplicitListTy noExt ip (ty1:tys2)) + | [ty1, L _ (HsExplicitListTy ip _ tys2)] <- tys' + -> returnL (HsExplicitListTy ip placeHolderKind (ty1:tys2)) | otherwise - -> mk_apps (HsTyVar noExt NotPromoted - (noLoc (getRdrName consDataCon))) + -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName consDataCon))) tys' StarT - -> returnL (HsTyVar noExt NotPromoted (noLoc + -> returnL (HsTyVar NotPromoted (noLoc (getRdrName liftedTypeKindTyCon))) ConstraintT - -> returnL (HsTyVar noExt NotPromoted + -> returnL (HsTyVar NotPromoted (noLoc (getRdrName constraintKindTyCon))) EqualityT - | [x',y'] <- tys' -> returnL (HsEqTy noExt x' y') + | [x',y'] <- tys' -> returnL (HsEqTy x' y') | otherwise -> - mk_apps (HsTyVar noExt NotPromoted + mk_apps (HsTyVar NotPromoted (noLoc (getRdrName eqPrimTyCon))) tys' _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) @@ -1339,15 +1328,15 @@ 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 noExt head_ty' p_ty) tys } + ; mk_apps (HsAppTy head_ty' p_ty) tys } where -- See Note [Adding parens for splices] add_parens t - | isCompoundHsType t = returnL (HsParTy noExt t) + | isCompoundHsType t = returnL (HsParTy t) | otherwise = return t wrap_apps :: LHsType GhcPs -> CvtM (LHsType GhcPs) -wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy noExt t) +wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t) wrap_apps t = return t -- --------------------------------------------------------------------- @@ -1378,7 +1367,7 @@ 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 noExt arg ret_ty_l) } + ; return (HsFunTy arg ret_ty_l) } split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType GhcPs]) split_ty_app ty = go ty [] @@ -1396,17 +1385,17 @@ cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s) cvtOpAppT :: LHsType GhcPs -> RdrName -> LHsType GhcPs -> LHsType GhcPs cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _) = L (combineSrcSpans loc1 loc2) $ - HsAppsTy noExt (t1' ++ [noLoc $ HsAppInfix noExt (noLoc op)] ++ t2') + HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2') where - t1' | L _ (HsAppsTy _ t1s) <- t1 + t1' | L _ (HsAppsTy t1s) <- t1 = t1s | otherwise - = [noLoc $ HsAppPrefix noExt t1] + = [noLoc $ HsAppPrefix t1] - t2' | L _ (HsAppsTy _ t2s) <- t2 + t2' | L _ (HsAppsTy t2s) <- t2 = t2s | otherwise - = [noLoc $ HsAppPrefix noExt t2] + = [noLoc $ HsAppPrefix t2] cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs) cvtKind = cvtTypeKind "kind" @@ -1446,16 +1435,13 @@ 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)) @@ -1505,16 +1491,15 @@ mkHsForAllTy :: [TH.TyVarBndr] -> SrcSpan -- ^ The location of the returned 'LHsType' if it needs an -- explicit forall - -> LHsQTyVars GhcPs + -> LHsQTyVars name -- ^ The converted type variable binders - -> LHsType GhcPs + -> LHsType name -- ^ The converted rho type - -> LHsType GhcPs + -> LHsType name -- ^ 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 @@ -1529,16 +1514,15 @@ mkHsQualTy :: TH.Cxt -> SrcSpan -- ^ The location of the returned 'LHsType' if it needs an -- explicit context - -> LHsContext GhcPs + -> LHsContext name -- ^ The converted context - -> LHsType GhcPs + -> LHsType name -- ^ The converted tau type - -> LHsType GhcPs + -> LHsType name -- ^ The complete type, qualified with a context if necessary mkHsQualTy ctxt loc ctxt' ty | null ctxt = ty - | otherwise = L loc $ HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt' - , hst_body = ty } + | otherwise = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = ty } -------------------------------------------------------------------- -- Turning Name back into RdrName diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index c65018bde8..0dc5dd08ba 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -14,9 +14,6 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} module HsBinds where @@ -27,7 +24,6 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, GRHSs, pprPatBind ) import {-# SOURCE #-} HsPat ( LPat ) -import PlaceHolder import HsExtension import HsTypes import PprCore () @@ -92,7 +88,7 @@ data HsLocalBindsLR idL idR type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR) -deriving instance (DataIdLR idL idR) => Data (HsLocalBindsLR idL idR) +deriving instance (DataId idL, DataId idR) => Data (HsLocalBindsLR idL idR) -- | Haskell Value Bindings type HsValBinds id = HsValBindsLR id id @@ -107,68 +103,18 @@ data HsValBindsLR idL idR -- Before renaming RHS; idR is always RdrName -- Not dependency analysed -- Recursive by default - ValBinds - (XValBinds idL idR) + ValBindsIn (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. - | XValBindsLR - (XXValBindsLR idL idR) - -deriving instance (DataIdLR idL idR) => Data (HsValBindsLR idL idR) - --- --------------------------------------------------------------------- --- Deal with ValBindsOut - -data XHsValBindsLR idL - = NValBindsOut - [(RecFlag, LHsBinds idL)] - [LSig GhcRn] -deriving instance (DataId idL) => Data (XHsValBindsLR idL) - --- The ValBindsIn pattern exists so we can use the COMPLETE pragma for these --- patterns -pattern - ValBindsIn :: - (XValBinds idL idR) -> - (LHsBindsLR idL idR) -> - [LSig idR] -> - HsValBindsLR idL idR -pattern - ValBindsOut :: - [(RecFlag, LHsBinds idL)] -> - [LSig GhcRn] -> - HsValBindsLR idL idR - -pattern - ValBindsIn x b s - = ValBinds x b s -pattern - ValBindsOut a b - = XValBindsLR (NValBindsOut a b) - -{-# - COMPLETE - ValBindsIn, - ValBindsOut - #-} - --- This is not extensible using the parameterised GhcPass namespace --- type instance --- XValBinds (GhcPass pass) (GhcPass pass') = NoFieldExt --- type instance --- XNewValBindsLR (GhcPass pass) (GhcPass pass') --- = NewHsValBindsLR (GhcPass pass) (GhcPass pass') -type instance - XValBinds pL pR = PlaceHolder -type instance - XXValBindsLR pL pR - = XHsValBindsLR pL - --- --------------------------------------------------------------------- + | ValBindsOut + [(RecFlag, LHsBinds idL)] + [LSig GhcRn] -- AZ: how to do this? + +deriving instance (DataId idL, DataId idR) => Data (HsValBindsLR idL idR) -- | Located Haskell Binding type LHsBind id = LHsBindLR id id @@ -339,7 +285,7 @@ data HsBindLR idL idR -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR idL idR) => Data (HsBindLR idL idR) +deriving instance (DataId idL, DataId idR) => Data (HsBindLR idL idR) -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] -- @@ -379,7 +325,7 @@ data PatSynBind idL idR psb_def :: LPat idR, -- ^ Right-hand side psb_dir :: HsPatSynDir idR -- ^ Directionality } -deriving instance (DataIdLR idL idR) => Data (PatSynBind idL idR) +deriving instance (DataId idL, DataId idR) => Data (PatSynBind idL idR) {- Note [AbsBinds] @@ -614,17 +560,17 @@ Specifically, it's just an error thunk -} -instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) - => Outputable (HsLocalBindsLR (GhcPass idL) (GhcPass idR)) where +instance (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsLocalBindsLR idL idR) where ppr (HsValBinds bs) = ppr bs ppr (HsIPBinds bs) = ppr bs ppr EmptyLocalBinds = empty -instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) - => Outputable (HsValBindsLR (GhcPass idL) (GhcPass idR)) where - ppr (ValBindsIn _ binds sigs) +instance (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsValBindsLR idL idR) where + ppr (ValBindsIn binds sigs) = pprDeclList (pprLHsBindsForUser binds sigs) ppr (ValBindsOut sccs sigs) @@ -638,19 +584,17 @@ instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), pp_rec Recursive = text "rec" pp_rec NonRecursive = text "nonrec" -pprLHsBinds :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) - => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc +pprLHsBinds :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) + => LHsBindsLR idL idR -> SDoc pprLHsBinds binds | isEmptyLHsBinds binds = empty | otherwise = pprDeclList (map ppr (bagToList binds)) -pprLHsBindsForUser :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), - OutputableBndrId (GhcPass idR), - SourceTextX (GhcPass id2), - OutputableBndrId (GhcPass id2)) - => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc] +pprLHsBindsForUser :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR, + SourceTextX id2, OutputableBndrId id2) + => LHsBindsLR idL idR -> [LSig 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 @@ -692,11 +636,11 @@ eqEmptyLocalBinds EmptyLocalBinds = True eqEmptyLocalBinds _ = False isEmptyValBinds :: HsValBindsLR a b -> Bool -isEmptyValBinds (ValBindsIn _ ds sigs) = isEmptyLHsBinds ds && null sigs +isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b -emptyValBindsIn = ValBindsIn noExt emptyBag [] +emptyValBindsIn = ValBindsIn emptyBag [] emptyValBindsOut = ValBindsOut [] [] emptyLHsBinds :: LHsBindsLR idL idR @@ -706,23 +650,22 @@ isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool isEmptyLHsBinds = isEmptyBag ------------ -plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) - -> HsValBinds(GhcPass a) -plusHsValBinds (ValBindsIn _ ds1 sigs1) (ValBindsIn _ ds2 sigs2) - = ValBindsIn noExt (ds1 `unionBags` ds2) (sigs1 ++ sigs2) +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 _ _ = panic "HsBinds.plusHsValBinds" -instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) - => Outputable (HsBindLR (GhcPass idL) (GhcPass idR)) where +instance (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsBindLR idL idR) where ppr mbind = ppr_monobind mbind -ppr_monobind :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) - => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc +ppr_monobind :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) + => HsBindLR idL idR -> SDoc ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss @@ -762,9 +705,9 @@ instance (OutputableBndrId p) => Outputable (ABExport p) where , nest 2 (pprTcSpecPrags prags) , nest 2 (text "wrap:" <+> ppr wrap)] -instance (SourceTextX (GhcPass idR), - OutputableBndrId idL, OutputableBndrId (GhcPass idR)) - => Outputable (PatSynBind idL (GhcPass idR)) where +instance (SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) + => Outputable (PatSynBind idL idR) where ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, psb_dir = dir }) = ppr_lhs <+> ppr_rhs @@ -809,7 +752,7 @@ data HsIPBinds id [LIPBind id] TcEvBinds -- Only in typechecker output; binds -- uses of the implicit parameters -deriving instance (DataIdLR id id) => Data (HsIPBinds id) +deriving instance (DataId id) => Data (HsIPBinds id) isEmptyIPBinds :: HsIPBinds id -> Bool isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds @@ -833,15 +776,13 @@ 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 (DataIdLR id id) => Data (IPBind id) +deriving instance (DataId name) => Data (IPBind name) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsIPBinds (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsIPBinds p) where ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) $$ whenPprDebug (ppr ds) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p) ) - => Outputable (IPBind (GhcPass p)) where +instance (SourceTextX p, 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 @@ -1007,7 +948,7 @@ data Sig pass (Located [Located (IdP pass)]) (Maybe (Located (IdP pass))) -deriving instance (DataIdLR pass pass) => Data (Sig pass) +deriving instance (DataId pass) => Data (Sig pass) -- | Located Fixity Signature type LFixitySig pass = Located (FixitySig pass) @@ -1114,12 +1055,11 @@ 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 (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (Sig (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (Sig pass) where ppr sig = ppr_sig sig -ppr_sig :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p) ) - => Sig (GhcPass p) -> SDoc +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) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 0d906cb68d..55d43fd058 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -195,7 +195,7 @@ data HsGroup id hs_docs :: [LDocDecl] } -deriving instance (DataIdLR id id) => Data (HsGroup id) +deriving instance (DataId id) => Data (HsGroup id) emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } @@ -212,8 +212,7 @@ emptyGroup = HsGroup { hs_tyclds = [], hs_splcds = [], hs_docs = [] } -appendGroups :: HsGroup (GhcPass a) -> HsGroup (GhcPass a) - -> HsGroup (GhcPass a) +appendGroups :: HsGroup a -> HsGroup a -> HsGroup a appendGroups HsGroup { hs_valds = val_groups1, @@ -256,8 +255,8 @@ appendGroups hs_vects = vects1 ++ vects2, hs_docs = docs1 ++ docs2 } -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsDecl pass) where ppr (TyClD dcl) = ppr dcl ppr (ValD binds) = ppr binds ppr (DefD def) = ppr def @@ -273,8 +272,8 @@ instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) ppr (DocD doc) = ppr doc ppr (RoleAnnotD ra) = ppr ra -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsGroup (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsGroup pass) where ppr (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_derivds = deriv_decls, @@ -318,8 +317,8 @@ data SpliceDecl id SpliceExplicitFlag deriving instance (DataId id) => Data (SpliceDecl id) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (SpliceDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (SpliceDecl pass) where ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f {- @@ -634,17 +633,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 + HsParTy lty -> rhs_annotated lty + HsKindSig {} -> True + _ -> False hsDeclHasCusk (DataDecl { tcdDataCusk = cusk }) = cusk hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars -- Pretty-printing TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~ -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (TyClDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (TyClDecl pass) where ppr (FamDecl { tcdFam = decl }) = ppr decl ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity @@ -675,8 +674,8 @@ instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) <+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context) <+> pprFundeps (map unLoc fds) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (TyClGroup (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (TyClGroup pass) where ppr (TyClGroup { group_tyclds = tyclds , group_roles = roles , group_instds = instds @@ -686,11 +685,11 @@ instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) ppr roles $$ ppr instds -pp_vanilla_decl_head :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Located (IdP (GhcPass p)) - -> LHsQTyVars (GhcPass p) +pp_vanilla_decl_head :: (SourceTextX pass, OutputableBndrId pass) + => Located (IdP pass) + -> LHsQTyVars pass -> LexicalFixity - -> HsContext (GhcPass p) + -> HsContext pass -> SDoc pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context = hsep [pprHsContext context, pp_tyvars tyvars] @@ -965,21 +964,21 @@ famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True -- | 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 -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (FamilyDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (FamilyDecl pass) where ppr = pprFamilyDecl TopLevel -pprFamilyDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc +pprFamilyDecl :: (SourceTextX pass, OutputableBndrId pass) + => TopLevelFlag -> FamilyDecl pass -> SDoc pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon , fdTyVars = tyvars , fdFixity = fixity @@ -1096,8 +1095,8 @@ data HsDerivingClause pass } deriving instance (DataId id) => Data (HsDerivingClause id) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsDerivingClause (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsDerivingClause pass) where ppr (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L _ dct }) = hsep [ text "deriving" @@ -1205,7 +1204,7 @@ gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs) (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') + L _ (HsFunTy (L l (HsRecTy flds)) res_ty') -> (RecCon (L l flds), res_ty') _other -> (PrefixCon [], tau) @@ -1214,9 +1213,9 @@ hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) -pp_data_defn :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => (HsContext (GhcPass p) -> SDoc) -- Printing the header - -> HsDataDefn (GhcPass p) +pp_data_defn :: (SourceTextX pass, OutputableBndrId pass) + => (HsContext pass -> SDoc) -- Printing the header + -> HsDataDefn pass -> SDoc pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context , dd_cType = mb_ct @@ -1238,27 +1237,26 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context Just kind -> dcolon <+> ppr kind pp_derivings (L _ ds) = vcat (map ppr ds) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsDataDefn (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsDataDefn pass) 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 (GhcPass p), OutputableBndrId (GhcPass p)) - => [LConDecl (GhcPass p)] -> SDoc +pp_condecls :: (SourceTextX pass, OutputableBndrId pass) + => [LConDecl pass] -> 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 (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (ConDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (ConDecl pass) where ppr = pprConDecl -pprConDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => ConDecl (GhcPass p) -> SDoc +pprConDecl :: (SourceTextX pass, OutputableBndrId pass) => ConDecl pass -> SDoc pprConDecl (ConDeclH98 { con_name = L _ con , con_qvars = mtvs , con_cxt = mcxt @@ -1479,12 +1477,12 @@ data InstDecl pass -- Both class and family instances { tfid_inst :: TyFamInstDecl pass } deriving instance (DataId id) => Data (InstDecl id) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (TyFamInstDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (TyFamInstDecl pass) where ppr = pprTyFamInstDecl TopLevel -pprTyFamInstDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc +pprTyFamInstDecl :: (SourceTextX pass, OutputableBndrId pass) + => TopLevelFlag -> TyFamInstDecl pass -> SDoc pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn @@ -1492,16 +1490,16 @@ ppr_instance_keyword :: TopLevelFlag -> SDoc ppr_instance_keyword TopLevel = text "instance" ppr_instance_keyword NotTopLevel = empty -ppr_fam_inst_eqn :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => TyFamInstEqn (GhcPass p) -> SDoc +ppr_fam_inst_eqn :: (SourceTextX pass, OutputableBndrId pass) + => TyFamInstEqn pass -> 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_deflt_eqn :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LTyFamDefltEqn (GhcPass p) -> SDoc +ppr_fam_deflt_eqn :: (SourceTextX pass, OutputableBndrId pass) + => LTyFamDefltEqn pass -> SDoc ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon , feqn_pats = tvs , feqn_fixity = fixity @@ -1509,12 +1507,12 @@ ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon = text "type" <+> pp_vanilla_decl_head tycon tvs fixity [] <+> equals <+> ppr rhs -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (DataFamInstDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (DataFamInstDecl pass) where ppr = pprDataFamInstDecl TopLevel -pprDataFamInstDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc +pprDataFamInstDecl :: (SourceTextX pass, OutputableBndrId pass) + => TopLevelFlag -> DataFamInstDecl pass -> SDoc pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = tycon , feqn_pats = pats @@ -1530,12 +1528,12 @@ pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}}) = ppr nd -pprFamInstLHS :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Located (IdP (GhcPass p)) - -> HsTyPats (GhcPass p) +pprFamInstLHS :: (SourceTextX pass, OutputableBndrId pass) + => Located (IdP pass) + -> HsTyPats pass -> LexicalFixity - -> HsContext (GhcPass p) - -> Maybe (LHsKind (GhcPass p)) + -> HsContext pass + -> Maybe (LHsKind pass) -> SDoc pprFamInstLHS thing typats fixity context mb_kind_sig -- explicit type patterns @@ -1555,8 +1553,8 @@ pprFamInstLHS thing typats fixity context mb_kind_sig | otherwise = empty -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (ClsInstDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (ClsInstDecl pass) where ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats , cid_overlap_mode = mbOverlap @@ -1594,8 +1592,8 @@ ppOverlapPragma mb = maybe_stext (SourceText src) _ = text src <+> text "#-}" -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (InstDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (InstDecl pass) where ppr (ClsInstD { cid_inst = decl }) = ppr decl ppr (TyFamInstD { tfid_inst = decl }) = ppr decl ppr (DataFamInstD { dfid_inst = decl }) = ppr decl @@ -1636,8 +1634,8 @@ data DerivDecl pass = DerivDecl } deriving instance (DataId pass) => Data (DerivDecl pass) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (DerivDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (DerivDecl pass) where ppr (DerivDecl { deriv_type = ty , deriv_strategy = ds , deriv_overlap_mode = o }) @@ -1671,8 +1669,8 @@ data DefaultDecl pass -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId pass) => Data (DefaultDecl pass) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (DefaultDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (DefaultDecl pass) where ppr (DefaultDecl tys) = text "default" <+> parens (interpp'SP tys) @@ -1775,8 +1773,8 @@ data ForeignExport = CExport (Located CExportSpec) -- contains the calling -- pretty printing of foreign declarations -- -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (ForeignDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (ForeignDecl pass) 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) @@ -1882,14 +1880,14 @@ collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] pprFullRuleName :: Located (SourceText, RuleName) -> SDoc pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (RuleDecls (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (RuleDecls pass) where ppr (HsRules st rules) = pprWithSourceText st (text "{-# RULES") <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (RuleDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (RuleDecl pass) where ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs) = sep [pprFullRuleName name <+> ppr act, nest 4 (pp_forall <+> pprExpr (unLoc lhs)), @@ -1898,8 +1896,8 @@ instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) pp_forall | null ns = empty | otherwise = forAllLit <+> fsep (map ppr ns) <> dot -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (RuleBndr (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (RuleBndr pass) where ppr (RuleBndr name) = ppr name ppr (RuleBndrSig name ty) = parens (ppr name <> dcolon <> ppr ty) @@ -1986,8 +1984,8 @@ lvectInstDecl (L _ (HsVectInstIn _)) = True lvectInstDecl (L _ (HsVectInstOut _)) = True lvectInstDecl _ = False -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (VectDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (VectDecl pass) where ppr (HsVect _ v rhs) = sep [text "{-# VECTORISE" <+> ppr v, nest 4 $ @@ -2108,8 +2106,8 @@ data AnnDecl pass = HsAnnotation -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId pass) => Data (AnnDecl pass) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (AnnDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (AnnDecl pass) where ppr (HsAnnotation _ provenance expr) = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index b8904c768e..fedaa4491a 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -11,7 +11,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -- | Abstract Haskell syntax for expressions. module HsExpr where @@ -110,7 +109,7 @@ noPostTcTable = [] data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p , syn_arg_wraps :: [HsWrapper] , syn_res_wrap :: HsWrapper } -deriving instance (DataIdLR p p) => Data (SyntaxExpr p) +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) @@ -134,8 +133,7 @@ mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc name -- don't care about filling in syn_arg_wraps because we're clearly -- not past the typechecker -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (SyntaxExpr (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (SyntaxExpr p) where ppr (SyntaxExpr { syn_expr = expr , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) @@ -706,7 +704,7 @@ data HsExpr p | HsWrap HsWrapper -- TRANSLATION (HsExpr p) -deriving instance (DataIdLR p p) => Data (HsExpr p) +deriving instance (DataId p) => Data (HsExpr p) -- | Located Haskell Tuple Argument -- @@ -723,7 +721,7 @@ type LHsTupArg id = Located (HsTupArg id) data HsTupArg id = Present (LHsExpr id) -- ^ The argument | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type -deriving instance (DataIdLR id id) => Data (HsTupArg id) +deriving instance (DataId id) => Data (HsTupArg id) tupArgPresent :: LHsTupArg id -> Bool tupArgPresent (L _ (Present {})) = True @@ -801,19 +799,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 (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsExpr (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p) where ppr expr = pprExpr expr ----------------------- -- pprExpr, pprLExpr, pprBinds call pprDeeper; -- the underscore versions do not -pprLExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsExpr (GhcPass p) -> SDoc +pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc pprLExpr (L _ e) = pprExpr e -pprExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsExpr (GhcPass p) -> SDoc +pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e | otherwise = pprDeeper (ppr_expr e) @@ -829,18 +824,16 @@ isQuietHsExpr (HsAppTypeOut _ _) = True isQuietHsExpr (OpApp _ _ _ _) = True isQuietHsExpr _ = False -pprBinds :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) - => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc +pprBinds :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) + => HsLocalBindsLR idL idR -> SDoc pprBinds b = pprDeeper (ppr b) ----------------------- -ppr_lexpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsExpr (GhcPass p) -> SDoc +ppr_lexpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc ppr_lexpr e = ppr_expr (unLoc e) -ppr_expr :: forall p. (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsExpr (GhcPass p) -> SDoc +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 @@ -1058,13 +1051,11 @@ 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 (GhcPass p) - , OutputableBndrId (GhcPass p)) - => LHsWcTypeX (LHsWcType (GhcPass p)) +data LHsWcTypeX = forall p. (SourceTextX p, OutputableBndrId p) + => LHsWcTypeX (LHsWcType p) -ppr_apps :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsExpr (GhcPass p) - -> [Either (LHsExpr (GhcPass p)) LHsWcTypeX] +ppr_apps :: (SourceTextX p, OutputableBndrId p) => HsExpr p + -> [Either (LHsExpr p) LHsWcTypeX] -> SDoc ppr_apps (HsApp (L _ fun) arg) args = ppr_apps fun (Left arg : args) @@ -1094,19 +1085,16 @@ fixities should do the job, except in debug mode (-dppr-debug) so we can see the structure of the parse tree. -} -pprDebugParendExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsExpr (GhcPass p) -> SDoc +pprDebugParendExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc pprDebugParendExpr expr = getPprStyle (\sty -> if debugStyle sty then pprParendLExpr expr else pprLExpr expr) -pprParendLExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsExpr (GhcPass p) -> SDoc +pprParendLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc pprParendLExpr (L _ e) = pprParendExpr e -pprParendExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsExpr (GhcPass p) -> SDoc +pprParendExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc pprParendExpr expr | hsExprNeedsParens expr = parens (pprExpr expr) | otherwise = pprExpr expr @@ -1254,7 +1242,7 @@ data HsCmd id (HsCmd id) -- If cmd :: arg1 --> res -- wrap :: arg1 "->" arg2 -- Then (HsCmdWrap wrap cmd) :: arg2 --> res -deriving instance (DataIdLR id id) => Data (HsCmd id) +deriving instance (DataId id) => Data (HsCmd id) -- | Haskell Array Application Type data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp @@ -1275,21 +1263,18 @@ data HsCmdTop 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 (DataIdLR p p) => Data (HsCmdTop p) +deriving instance (DataId p) => Data (HsCmdTop p) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsCmd (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p) where ppr cmd = pprCmd cmd ----------------------- -- pprCmd and pprLCmd call pprDeeper; -- the underscore versions do not -pprLCmd :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsCmd (GhcPass p) -> SDoc +pprLCmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc pprLCmd (L _ c) = pprCmd c -pprCmd :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsCmd (GhcPass p) -> SDoc +pprCmd :: (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc pprCmd c | isQuietHsCmd c = ppr_cmd c | otherwise = pprDeeper (ppr_cmd c) @@ -1303,12 +1288,10 @@ isQuietHsCmd (HsCmdApp _ _) = True isQuietHsCmd _ = False ----------------------- -ppr_lcmd :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsCmd (GhcPass p) -> SDoc +ppr_lcmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc ppr_lcmd c = ppr_cmd (unLoc c) -ppr_cmd :: forall p. (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsCmd (GhcPass p) -> SDoc +ppr_cmd :: forall p. (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c) ppr_cmd (HsCmdApp c e) @@ -1369,13 +1352,11 @@ ppr_cmd (HsCmdArrForm op _ _ args) = hang (text "(|" <> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <> text "|)") -pprCmdArg :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsCmdTop (GhcPass p) -> SDoc +pprCmdArg :: (SourceTextX p, OutputableBndrId p) => HsCmdTop p -> SDoc pprCmdArg (HsCmdTop cmd _ _ _) = ppr_lcmd cmd -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsCmdTop (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmdTop p) where ppr = pprCmdArg {- @@ -1434,11 +1415,10 @@ data Match p body m_pats :: [LPat p], -- The patterns m_grhss :: (GRHSs p body) } -deriving instance (Data body,DataIdLR p p) => Data (Match p body) +deriving instance (Data body,DataId p) => Data (Match p body) -instance (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), - Outputable body) - => Outputable (Match (GhcPass idR) body) where +instance (SourceTextX idR, OutputableBndrId idR, Outputable body) + => Outputable (Match idR body) where ppr = pprMatch {- @@ -1520,7 +1500,7 @@ data GRHSs p body grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause } -deriving instance (Data body,DataIdLR p p) => Data (GRHSs p body) +deriving instance (Data body,DataId p) => Data (GRHSs p body) -- | Located Guarded Right-Hand Side type LGRHS id body = Located (GRHS id body) @@ -1528,37 +1508,32 @@ 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,DataIdLR id id) => Data (GRHS id body) +deriving instance (Data body,DataId id) => Data (GRHS id body) -- We know the list must have at least one @Match@ in it. -pprMatches :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), - Outputable body) - => MatchGroup (GhcPass idR) body -> SDoc +pprMatches :: (SourceTextX idR, OutputableBndrId idR, Outputable body) + => MatchGroup 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 -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), - Outputable body) - => MatchGroup (GhcPass idR) body -> SDoc +pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body) + => MatchGroup idR body -> SDoc pprFunBind matches = pprMatches matches -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprPatBind :: forall bndr p body. (SourceTextX (GhcPass p), - SourceTextX (GhcPass bndr), - OutputableBndrId (GhcPass bndr), - OutputableBndrId (GhcPass p), +pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr, + OutputableBndrId bndr, + OutputableBndrId p, Outputable body) - => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc + => LPat bndr -> GRHSs p body -> SDoc pprPatBind pat (grhss) - = sep [ppr pat, nest 2 - (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)] + = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP p)) grhss)] -pprMatch :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), - Outputable body) - => Match (GhcPass idR) body -> SDoc +pprMatch :: (SourceTextX idR, OutputableBndrId idR, Outputable body) + => Match idR body -> SDoc pprMatch match = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats) , nest 2 (pprGRHSs ctxt (m_grhss match)) ] @@ -1591,9 +1566,8 @@ pprMatch match (pat1:pats1) = m_pats match (pat2:pats2) = pats1 -pprGRHSs :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), - Outputable body) - => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc +pprGRHSs :: (SourceTextX idR, OutputableBndrId idR, Outputable body) + => HsMatchContext idL -> GRHSs 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 @@ -1601,9 +1575,8 @@ pprGRHSs ctxt (GRHSs grhss (L _ binds)) $$ ppUnless (eqEmptyLocalBinds binds) (text "where" $$ nest 4 (pprBinds binds)) -pprGRHS :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), - Outputable body) - => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc +pprGRHS :: (SourceTextX idR, OutputableBndrId idR, Outputable body) + => HsMatchContext idL -> GRHS idR body -> SDoc pprGRHS ctxt (GRHS [] body) = pp_rhs ctxt body @@ -1786,7 +1759,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- With rebindable syntax the type might not -- be quite as simple as (m (tya, tyb, tyc)). } -deriving instance (Data body, DataIdLR idL idR) +deriving instance (Data body, DataId idL, DataId idR) => Data (StmtLR idL idR body) data TransForm -- The 'f' below is the 'using' function, 'e' is the by function @@ -1800,7 +1773,7 @@ data ParStmtBlock idL idR [ExprLStmt idL] [IdP idR] -- The variables to be returned (SyntaxExpr idR) -- The return operator -deriving instance (DataIdLR idL idR) => Data (ParStmtBlock idL idR) +deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR) -- | Applicative Argument data ApplicativeArg idL idR @@ -1815,7 +1788,8 @@ data ApplicativeArg idL idR [ExprLStmt idL] -- stmts (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) (LPat idL) -- (v1,...,vn) -deriving instance (DataIdLR idL idR) => Data (ApplicativeArg idL idR) + +deriving instance (DataId idL, DataId idR) => Data (ApplicativeArg idL idR) {- Note [The type of bind in Stmts] @@ -1982,22 +1956,19 @@ Bool flag that is True when the original statement was a BodyStmt, so that we can pretty-print it correctly. -} -instance (SourceTextX (GhcPass idL), OutputableBndrId (GhcPass idL)) - => Outputable (ParStmtBlock (GhcPass idL) idR) where +instance (SourceTextX idL, OutputableBndrId idL) + => Outputable (ParStmtBlock idL idR) where ppr (ParStmtBlock stmts _ _) = interpp'SP stmts -instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR), - Outputable body) - => Outputable (StmtLR (GhcPass idL) (GhcPass idR) body) where +instance (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR, Outputable body) + => Outputable (StmtLR idL idR body) where ppr stmt = pprStmt stmt -pprStmt :: forall idL idR body . (SourceTextX (GhcPass idL), - SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), - OutputableBndrId (GhcPass idR), +pprStmt :: forall idL idR body . (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR, Outputable body) - => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc + => (StmtLR idL idR body) -> SDoc pprStmt (LastStmt expr ret_stripped _) = whenPprDebug (text "[last]") <+> (if ret_stripped then text "return" else empty) <+> @@ -2031,17 +2002,17 @@ 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 (GhcPass idL) -> [SDoc] + flattenStmt :: ExprLStmt idL -> [SDoc] flattenStmt (L _ (ApplicativeStmt args _ _)) = concatMap flattenArg args flattenStmt stmt = [ppr stmt] flattenArg (_, ApplicativeArgOne pat expr isBody) | isBody = -- See Note [Applicative BodyStmt] [ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") - :: ExprStmt (GhcPass idL))] + :: ExprStmt idL)] | otherwise = [ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") - :: ExprStmt (GhcPass idL))] + :: ExprStmt idL)] flattenArg (_, ApplicativeArgMany stmts _ _) = concatMap flattenStmt stmts @@ -2056,10 +2027,10 @@ pprStmt (ApplicativeStmt args mb_join _) pp_arg (_, ApplicativeArgOne pat expr isBody) | isBody = -- See Note [Applicative BodyStmt] ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") - :: ExprStmt (GhcPass idL)) + :: ExprStmt idL) | otherwise = ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") - :: ExprStmt (GhcPass idL)) + :: ExprStmt idL) pp_arg (_, ApplicativeArgMany stmts return pat) = ppr pat <+> text "<-" <+> @@ -2067,9 +2038,8 @@ pprStmt (ApplicativeStmt args mb_join _) (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)])) (error "pprStmt")) -pprTransformStmt :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) - -> Maybe (LHsExpr (GhcPass p)) -> SDoc +pprTransformStmt :: (SourceTextX p, OutputableBndrId p) + => [IdP p] -> LHsExpr p -> Maybe (LHsExpr p) -> SDoc pprTransformStmt bndrs using by = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs)) , nest 2 (ppr using) @@ -2085,9 +2055,8 @@ pprBy :: Outputable body => Maybe body -> SDoc pprBy Nothing = empty pprBy (Just e) = text "by" <+> ppr e -pprDo :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p), - Outputable body) - => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc +pprDo :: (SourceTextX p, OutputableBndrId p, Outputable body) + => HsStmtContext any -> [LStmt 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 @@ -2097,16 +2066,14 @@ pprDo PArrComp stmts = paBrackets $ pprComp stmts pprDo MonadComp stmts = brackets $ pprComp stmts pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt -ppr_do_stmts :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR), - Outputable body) - => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc +ppr_do_stmts :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR, Outputable body) + => [LStmtLR idL idR body] -> SDoc -- Print a bunch of do stmts ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) -pprComp :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p), - Outputable body) - => [LStmt (GhcPass p) body] -> SDoc +pprComp :: (SourceTextX p, OutputableBndrId p, Outputable body) + => [LStmt p body] -> SDoc pprComp quals -- Prints: body | qual1, ..., qualn | Just (initStmts, L _ (LastStmt body _ _)) <- snocView quals = if null initStmts @@ -2120,9 +2087,8 @@ pprComp quals -- Prints: body | qual1, ..., qualn | otherwise = pprPanic "pprComp" (pprQuals quals) -pprQuals :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p), - Outputable body) - => [LStmt (GhcPass p) body] -> SDoc +pprQuals :: (SourceTextX p, OutputableBndrId p, Outputable body) + => [LStmt p body] -> SDoc -- Show list comprehension qualifiers separated by commas pprQuals quals = interpp'SP quals @@ -2160,7 +2126,7 @@ data HsSplice id ThModFinalizers -- TH finalizers produced by the splice. (HsSplicedThing id) -- The result of splicing deriving Typeable -deriving instance (DataIdLR id id) => Data (HsSplice id) +deriving instance (DataId id) => Data (HsSplice id) -- | 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 @@ -2202,7 +2168,7 @@ data HsSplicedThing id | HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern deriving Typeable -deriving instance (DataIdLR id id) => Data (HsSplicedThing id) +deriving instance (DataId id) => Data (HsSplicedThing id) -- See Note [Pending Splices] type SplicePointName = Name @@ -2226,6 +2192,7 @@ data PendingTcSplice = PendingTcSplice SplicePointName (LHsExpr GhcTc) deriving Data + {- Note [Pending Splices] ~~~~~~~~~~~~~~~~~~~~~~ @@ -2290,33 +2257,30 @@ 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 (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsSplicedThing (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) + => Outputable (HsSplicedThing p) where ppr (HsSplicedExpr e) = ppr_expr e ppr (HsSplicedTy t) = ppr t ppr (HsSplicedPat p) = ppr p -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsSplice (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsSplice p) where ppr s = pprSplice s -pprPendingSplice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => SplicePointName -> LHsExpr (GhcPass p) -> SDoc +pprPendingSplice :: (SourceTextX p, OutputableBndrId p) + => SplicePointName -> LHsExpr p -> SDoc pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e) -pprSpliceDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc +pprSpliceDecl :: (SourceTextX p, OutputableBndrId p) + => HsSplice 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 (GhcPass p), OutputableBndrId (GhcPass p)) - => HsSplice (GhcPass p) -> SDoc +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 e = pprSplice e -pprSplice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsSplice (GhcPass p) -> SDoc +pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc pprSplice (HsTypedSplice HasParens n e) = ppr_splice (text "$$(") n e (text ")") pprSplice (HsTypedSplice HasDollar n e) @@ -2337,8 +2301,8 @@ ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <> char '[' <> ppr quoter <> vbar <> ppr quote <> text "|]" -ppr_splice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc +ppr_splice :: (SourceTextX p, OutputableBndrId p) + => SDoc -> (IdP p) -> LHsExpr p -> SDoc -> SDoc ppr_splice herald n e trail = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail @@ -2351,19 +2315,17 @@ data HsBracket p = ExpBr (LHsExpr p) -- [| expr |] | VarBr Bool (IdP p) -- True: 'x, False: ''T -- (The Bool flag is used only in pprHsBracket) | TExpBr (LHsExpr p) -- [|| expr ||] -deriving instance (DataIdLR p p) => Data (HsBracket p) +deriving instance (DataId p) => Data (HsBracket p) isTypedBracket :: HsBracket id -> Bool isTypedBracket (TExpBr {}) = True isTypedBracket _ = False -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsBracket (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsBracket p) where ppr = pprHsBracket -pprHsBracket :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsBracket (GhcPass p) -> SDoc +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) @@ -2406,10 +2368,10 @@ data ArithSeqInfo id | FromThenTo (LHsExpr id) (LHsExpr id) (LHsExpr id) -deriving instance (DataIdLR id id) => Data (ArithSeqInfo id) +deriving instance (DataId id) => Data (ArithSeqInfo id) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (ArithSeqInfo (GhcPass p)) where +instance (SourceTextX p, 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] ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] @@ -2625,21 +2587,19 @@ matchContextErrString (StmtCtxt ListComp) = text "list comprehension" matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" matchContextErrString (StmtCtxt PArrComp) = text "array comprehension" -pprMatchInCtxt :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), +pprMatchInCtxt :: (SourceTextX idR, OutputableBndrId idR, -- TODO:AZ these constraints do not make sense - Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))), - Outputable body) - => Match (GhcPass idR) body -> SDoc + Outputable (NameOrRdrName (NameOrRdrName (IdP idR))), + Outputable body) + => Match idR body -> SDoc pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) <> colon) 4 (pprMatch match) -pprStmtInCtxt :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), - OutputableBndrId (GhcPass idR), +pprStmtInCtxt :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR, Outputable body) - => HsStmtContext (IdP (GhcPass idL)) - -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc + => HsStmtContext (IdP idL) -> StmtLR idL idR body -> SDoc pprStmtInCtxt ctxt (LastStmt e _ _) | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts" = hang (text "In the expression:") 2 (ppr e) diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot index 8b8fcde3ce..bac8a5a183 100644 --- a/compiler/hsSyn/HsExpr.hs-boot +++ b/compiler/hsSyn/HsExpr.hs-boot @@ -5,7 +5,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} module HsExpr where @@ -13,7 +12,7 @@ import SrcLoc ( Located ) import Outputable ( SDoc, Outputable ) import {-# SOURCE #-} HsPat ( LPat ) import BasicTypes ( SpliceExplicitFlag(..)) -import HsExtension ( OutputableBndrId, DataId, DataIdLR, SourceTextX, GhcPass ) +import HsExtension ( OutputableBndrId, DataId, SourceTextX ) import Data.Data hiding ( Fixity ) type role HsExpr nominal @@ -29,39 +28,32 @@ data MatchGroup (a :: *) (body :: *) data GRHSs (a :: *) (body :: *) data SyntaxExpr (i :: *) -instance (DataIdLR p p) => Data (HsSplice p) -instance (DataIdLR p p) => Data (HsExpr p) -instance (DataIdLR p p) => Data (HsCmd p) +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,DataIdLR p p) => Data (GRHSs p body) -instance (DataIdLR p p) => Data (SyntaxExpr p) +instance (Data body,DataId p) => Data (GRHSs p body) +instance (DataId p) => Data (SyntaxExpr p) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsExpr (GhcPass p)) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsCmd (GhcPass p)) +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p) +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p) type LHsExpr a = Located (HsExpr a) -pprLExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsExpr (GhcPass p) -> SDoc +pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc -pprExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsExpr (GhcPass p) -> SDoc +pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc -pprSplice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsSplice (GhcPass p) -> SDoc +pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc -pprSpliceDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc +pprSpliceDecl :: (SourceTextX p, OutputableBndrId p) + => HsSplice p -> SpliceExplicitFlag -> SDoc -pprPatBind :: forall bndr p body. (SourceTextX (GhcPass p), - SourceTextX (GhcPass bndr), - OutputableBndrId (GhcPass bndr), - OutputableBndrId (GhcPass p), +pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr, + OutputableBndrId bndr, + OutputableBndrId p, Outputable body) - => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc + => LPat bndr -> GRHSs p body -> SDoc -pprFunBind :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), - Outputable body) - => MatchGroup (GhcPass idR) body -> SDoc +pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body) + => MatchGroup idR body -> SDoc diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs index b88906b2d0..80dfa67ea3 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -7,9 +7,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder module HsExtension where @@ -58,10 +55,6 @@ haskell-src-exts ASTs as well. -} --- | Used when constructing a term with an unused extension point. -noExt :: PlaceHolder -noExt = PlaceHolder - -- | Used as a data type index for the hsSyn AST data GhcPass (c :: Pass) deriving instance Eq (GhcPass c) @@ -83,8 +76,6 @@ type instance PostTc GhcPs ty = PlaceHolder type instance PostTc GhcRn ty = PlaceHolder type instance PostTc GhcTc ty = ty --- deriving instance (Data ty) => Data (PostTc (GhcPass 'Parsed) ty) - -- | Types that are not defined until after renaming type family PostRn x ty -- Note [Pass sensitive types] in PlaceHolder type instance PostRn GhcPs ty = PlaceHolder @@ -96,214 +87,88 @@ type family IdP p type instance IdP GhcPs = RdrName type instance IdP GhcRn = Name type instance IdP GhcTc = Id --- type instance IdP (GHC x) = IdP x - -type LIdP p = Located (IdP p) - --- --------------------------------------------------------------------- --- type families for the Pat extension points -type family XWildPat x -type family XVarPat x -type family XLazyPat x -type family XAsPat x -type family XParPat x -type family XBangPat x -type family XListPat x -type family XTuplePat x -type family XSumPat x -type family XPArrPat x -type family XConPat x -type family XViewPat x -type family XSplicePat x -type family XLitPat x -type family XNPat x -type family XNPlusKPat x -type family XSigPat x -type family XCoPat x -type family XXPat x - - -type ForallXPat (c :: * -> Constraint) (x :: *) = - ( c (XWildPat x) - , c (XVarPat x) - , c (XLazyPat x) - , c (XAsPat x) - , c (XParPat x) - , c (XBangPat x) - , c (XListPat x) - , c (XTuplePat x) - , c (XSumPat x) - , c (XPArrPat x) - , c (XViewPat x) - , c (XSplicePat x) - , c (XLitPat x) - , c (XNPat x) - , c (XNPlusKPat x) - , c (XSigPat x) - , c (XCoPat x) - , c (XXPat x) - ) --- --------------------------------------------------------------------- --- ValBindsLR type families -type family XValBinds x x' -type family XXValBindsLR x x' -type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *)= - ( c (XValBinds x x') - , c (XXValBindsLR x x') - ) - - - - --- We define a type family for each HsLit extension point. This is based on --- prepending 'X' to the constructor name, for ease of reference. -type family XHsChar x -type family XHsCharPrim x -type family XHsString x +-- We define a type family for each extension point. This is based on prepending +-- 'X' to the constructor name, for ease of reference. +type family XHsChar x +type family XHsCharPrim x +type family XHsString x type family XHsStringPrim x -type family XHsInt x -type family XHsIntPrim x -type family XHsWordPrim x -type family XHsInt64Prim x +type family XHsInt x +type family XHsIntPrim x +type family XHsWordPrim x +type family XHsInt64Prim x type family XHsWord64Prim x -type family XHsInteger x -type family XHsRat x -type family XHsFloatPrim x +type family XHsInteger x +type family XHsRat x +type family XHsFloatPrim x type family XHsDoublePrim x -type family XXLit x --- | Helper to apply a constraint to all HsLit extension points. It has one +-- | Helper to apply a constraint to all extension points. It has one -- entry per extension point type family. -type ForallXHsLit (c :: * -> Constraint) (x :: *) = - ( c (XHsChar x) - , c (XHsCharPrim x) - , c (XHsString x) +type ForallX (c :: * -> Constraint) (x :: *) = + ( c (XHsChar x) + , c (XHsCharPrim x) + , c (XHsString x) , c (XHsStringPrim x) - , c (XHsInt x) - , c (XHsIntPrim x) - , c (XHsWordPrim x) - , c (XHsInt64Prim x) + , c (XHsInt x) + , c (XHsIntPrim x) + , c (XHsWordPrim x) + , c (XHsInt64Prim x) , c (XHsWord64Prim x) - , c (XHsInteger x) - , c (XHsRat x) - , c (XHsFloatPrim x) + , c (XHsInteger x) + , c (XHsRat x) + , c (XHsFloatPrim x) , c (XHsDoublePrim x) - , c (XXLit x) ) -type family XOverLit x -type family XXOverLit x +-- Provide the specific extension types for the parser phase. +type instance XHsChar GhcPs = SourceText +type instance XHsCharPrim GhcPs = SourceText +type instance XHsString GhcPs = SourceText +type instance XHsStringPrim GhcPs = SourceText +type instance XHsInt GhcPs = () +type instance XHsIntPrim GhcPs = SourceText +type instance XHsWordPrim GhcPs = SourceText +type instance XHsInt64Prim GhcPs = SourceText +type instance XHsWord64Prim GhcPs = SourceText +type instance XHsInteger GhcPs = SourceText +type instance XHsRat GhcPs = () +type instance XHsFloatPrim GhcPs = () +type instance XHsDoublePrim GhcPs = () + +-- Provide the specific extension types for the renamer phase. +type instance XHsChar GhcRn = SourceText +type instance XHsCharPrim GhcRn = SourceText +type instance XHsString GhcRn = SourceText +type instance XHsStringPrim GhcRn = SourceText +type instance XHsInt GhcRn = () +type instance XHsIntPrim GhcRn = SourceText +type instance XHsWordPrim GhcRn = SourceText +type instance XHsInt64Prim GhcRn = SourceText +type instance XHsWord64Prim GhcRn = SourceText +type instance XHsInteger GhcRn = SourceText +type instance XHsRat GhcRn = () +type instance XHsFloatPrim GhcRn = () +type instance XHsDoublePrim GhcRn = () + +-- Provide the specific extension types for the typechecker phase. +type instance XHsChar GhcTc = SourceText +type instance XHsCharPrim GhcTc = SourceText +type instance XHsString GhcTc = SourceText +type instance XHsStringPrim GhcTc = SourceText +type instance XHsInt GhcTc = () +type instance XHsIntPrim GhcTc = SourceText +type instance XHsWordPrim GhcTc = SourceText +type instance XHsInt64Prim GhcTc = SourceText +type instance XHsWord64Prim GhcTc = SourceText +type instance XHsInteger GhcTc = SourceText +type instance XHsRat GhcTc = () +type instance XHsFloatPrim GhcTc = () +type instance XHsDoublePrim GhcTc = () -type ForallXOverLit (c :: * -> Constraint) (x :: *) = - ( c (XOverLit x) - , c (XXOverLit x) - ) - --- --------------------------------------------------------------------- --- Type families for the Type type families - -type family XForAllTy x -type family XQualTy x -type family XTyVar x -type family XAppsTy x -type family XAppTy x -type family XFunTy x -type family XListTy x -type family XPArrTy x -type family XTupleTy x -type family XSumTy x -type family XOpTy x -type family XParTy x -type family XIParamTy x -type family XEqTy x -type family XKindSig x -type family XSpliceTy x -type family XDocTy x -type family XBangTy x -type family XRecTy x -type family XExplicitListTy x -type family XExplicitTupleTy x -type family XTyLit x -type family XWildCardTy x -type family XXType x - --- | Helper to apply a constraint to all extension points. It has one --- entry per extension point type family. -type ForallXType (c :: * -> Constraint) (x :: *) = - ( c (XForAllTy x) - , c (XQualTy x) - , c (XTyVar x) - , c (XAppsTy x) - , c (XAppTy x) - , c (XFunTy x) - , c (XListTy x) - , c (XPArrTy x) - , c (XTupleTy x) - , c (XSumTy x) - , c (XOpTy x) - , c (XParTy x) - , c (XIParamTy x) - , c (XEqTy x) - , c (XKindSig x) - , c (XSpliceTy x) - , c (XDocTy x) - , c (XBangTy x) - , c (XRecTy x) - , c (XExplicitListTy x) - , c (XExplicitTupleTy x) - , c (XTyLit x) - , c (XWildCardTy x) - , c (XXType x) - ) - --- --------------------------------------------------------------------- - -type family XUserTyVar x -type family XKindedTyVar x -type family XXTyVarBndr x - -type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) = - ( c (XUserTyVar x) - , c (XKindedTyVar x) - , c (XXTyVarBndr x) - ) - --- --------------------------------------------------------------------- - -type family XAppInfix x -type family XAppPrefix x -type family XXAppType x - -type ForallXAppType (c :: * -> Constraint) (x :: *) = - ( c (XAppInfix x) - , c (XAppPrefix x) - , c (XXAppType x) - ) - --- --------------------------------------------------------------------- - -type family XFieldOcc x -type family XXFieldOcc x - -type ForallXFieldOcc (c :: * -> Constraint) (x :: *) = - ( c (XFieldOcc x) - , c (XXFieldOcc x) - ) - --- --------------------------------------------------------------------- - -type family XUnambiguous x -type family XAmbiguous x -type family XXAmbiguousFieldOcc x - -type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) = - ( c (XUnambiguous x) - , c (XAmbiguous x) - , c (XXAmbiguousFieldOcc x) - ) -- --------------------------------------------------------------------- @@ -347,6 +212,22 @@ instance HasSourceText SourceText where -- ---------------------------------------------------------------------- +-- | Defaults for each annotation, used to simplify creation in arbitrary +-- contexts +class HasDefault a where + def :: a + +instance HasDefault () where + def = () + +instance HasDefault SourceText where + def = NoSourceText + +-- | Provide a single constraint that captures the requirement for a default +-- across all the extension points. +type HasDefaultX x = ForallX HasDefault x + +-- ---------------------------------------------------------------------- -- | Conversion of annotations from one type index to another. This is required -- where the AST is converted from one pass to another, and the extension values -- need to be brought along if possible. So for example a 'SourceText' is @@ -373,46 +254,15 @@ type ConvertIdX a b = XHsStringPrim a ~ XHsStringPrim b, XHsString a ~ XHsString b, XHsCharPrim a ~ XHsCharPrim b, - XHsChar a ~ XHsChar b, - XXLit a ~ XXLit b) + XHsChar a ~ XHsChar b) --- ---------------------------------------------------------------------- - --- | Provide a summary constraint that gives all am Outputable constraint to --- extension points needing one -type OutputableX p = - ( Outputable (XXPat p) - , Outputable (XXPat GhcRn) - , Outputable (XSigPat p) - , Outputable (XSigPat GhcRn) - , Outputable (XXLit p) - , Outputable (XXOverLit p) - , Outputable (XXType p) - ) --- TODO: Should OutputableX be included in OutputableBndrId? -- ---------------------------------------------------------------------- -- type DataId p = ( Data p - - , ForallXHsLit Data p - , ForallXPat Data p - - -- AZ: The following ForAllXXXX shoulbe be unnecessary? Driven by ValBindsOut - -- , ForallXPat Data (GhcPass 'Parsed) - , ForallXPat Data (GhcPass 'Renamed) - -- , ForallXPat Data (GhcPass 'Typechecked) - , ForallXType Data (GhcPass 'Renamed) - - , ForallXOverLit Data p - , ForallXType Data p - , ForallXTyVarBndr Data p - , ForallXAppType Data p - , ForallXFieldOcc Data p - , ForallXAmbiguousFieldOcc Data p - + , ForallX Data p , Data (NameOrRdrName (IdP p)) , Data (IdP p) @@ -432,16 +282,10 @@ type DataId p = , Data (PostTc p [Type]) ) -type DataIdLR pL pR = - ( DataId pL - , DataId pR - , ForallXValBindsLR Data pL pR - ) -- |Constraint type to bundle up the requirement for 'OutputableBndr' on both -- the @id@ and the 'NameOrRdrName' type for it type OutputableBndrId id = ( OutputableBndr (NameOrRdrName (IdP id)) , OutputableBndr (IdP id) - , OutputableX id ) diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs index a47b0ff4fe..7f0864eccc 100644 --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs @@ -28,7 +28,6 @@ import Type ( Type ) import Outputable import FastString import HsExtension -import PlaceHolder import Data.ByteString (ByteString) import Data.Data hiding ( Fixity ) @@ -78,25 +77,8 @@ data HsLit x | HsDoublePrim (XHsDoublePrim x) FractionalLit -- ^ Unboxed Double - | XLit (XXLit x) - deriving instance (DataId x) => Data (HsLit 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 _) = PlaceHolder -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 _) = PlaceHolder -type instance XHsFloatPrim (GhcPass _) = PlaceHolder -type instance XHsDoublePrim (GhcPass _) = PlaceHolder -type instance XXLit (GhcPass _) = PlaceHolder - instance Eq (HsLit x) where (HsChar _ x1) == (HsChar _ x2) = x1==x2 @@ -117,25 +99,11 @@ instance Eq (HsLit x) where -- | Haskell Overloaded Literal data HsOverLit p = OverLit { - ol_ext :: (XOverLit p), - ol_val :: OverLitVal, - ol_witness :: HsExpr p} -- Note [Overloaded literal witnesses] - - | XOverLit - (XXOverLit p) -deriving instance (DataIdLR p p) => Data (HsOverLit p) - -data OverLitTc - = OverLitTc { - ol_rebindable :: Bool, -- Note [ol_rebindable] - ol_type :: Type } - deriving Data - -type instance XOverLit GhcPs = PlaceHolder -type instance XOverLit GhcRn = Bool -- Note [ol_rebindable] -type instance XOverLit GhcTc = OverLitTc - -type instance XXOverLit (GhcPass _) = PlaceHolder + 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) => Data (HsOverLit p) -- Note [Literal source text] in BasicTypes for SourceText fields in -- the following @@ -151,9 +119,8 @@ negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i) negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f) negateOverLitVal _ = panic "negateOverLitVal: argument is not a number" -overLitType :: HsOverLit GhcTc -> Type -overLitType (OverLit (OverLitTc _ ty) _ _) = ty -overLitType XOverLit{} = panic "overLitType" +overLitType :: HsOverLit p -> PostTc p Type +overLitType = ol_type -- | Convert a literal from one index type to another, updating the annotations -- according to the relevant 'Convertable' instance @@ -171,7 +138,6 @@ 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] @@ -205,10 +171,8 @@ found to have. -- Comparison operations are needed when grouping literals -- for compiling pattern-matching (module MatchLit) -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 (HsOverLit p) where + (OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2 instance Eq OverLitVal where (HsIntegral i1) == (HsIntegral i2) = i1 == i2 @@ -216,10 +180,8 @@ instance Eq OverLitVal where (HsIsString _ s1) == (HsIsString _ s2) = s1 == s2 _ == _ = False -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 (HsOverLit p) where + compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2 instance Ord OverLitVal where compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2 @@ -233,7 +195,7 @@ instance Ord OverLitVal where compare (HsIsString _ _) (HsFractional _) = GT -- Instance specific to GhcPs, need the SourceText -instance (SourceTextX (GhcPass x)) => Outputable (HsLit (GhcPass x)) where +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) @@ -255,18 +217,16 @@ instance (SourceTextX (GhcPass x)) => Outputable (HsLit (GhcPass x)) where = pp_st_suffix (getSourceText st) primInt64Suffix (pprPrimInt64 i) ppr (HsWord64Prim st w) = pp_st_suffix (getSourceText 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 (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsOverLit (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) + => Outputable (HsOverLit p) where ppr (OverLit {ol_val=val, ol_witness=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)) @@ -279,7 +239,7 @@ instance Outputable OverLitVal where -- mainly for too reasons: -- * We do not want to expose their internal representation -- * The warnings become too messy -pmPprHsLit :: (SourceTextX (GhcPass x)) => HsLit (GhcPass x) -> SDoc +pmPprHsLit :: (SourceTextX x) => HsLit x -> SDoc pmPprHsLit (HsChar _ c) = pprHsChar c pmPprHsLit (HsCharPrim _ c) = pprHsChar c pmPprHsLit (HsString st s) = pprWithSourceText (getSourceText st) @@ -294,4 +254,3 @@ 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 diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index e0904b89fc..e05d8bbf68 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -15,11 +15,9 @@ -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} module HsPat ( Pat(..), InPat, OutPat, LPat, - ListPatTc(..), HsConPatDetails, hsConPatArgs, HsRecFields(..), HsRecField'(..), LHsRecField', @@ -51,7 +49,6 @@ import HsExtension import HsTypes import TcEvidence import BasicTypes -import PlaceHolder -- others: import PprCore ( {- instance OutputableBndr TyVar -} ) import TysWiredIn @@ -81,47 +78,42 @@ type LPat p = Located (Pat p) -- For details on above see note [Api annotations] in ApiAnnotation data Pat p = ------------ Simple patterns --------------- - WildPat (XWildPat p) -- ^ Wildcard Pattern + WildPat (PostTc p Type) -- ^ 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 (XVarPat p) - (Located (IdP p)) -- ^ Variable Pattern + | VarPat (Located (IdP p)) -- ^ Variable Pattern -- See Note [Located RdrNames] in HsExpr - | LazyPat (XLazyPat p) - (LPat p) -- ^ Lazy Pattern + | LazyPat (LPat p) -- ^ Lazy Pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' -- For details on above see note [Api annotations] in ApiAnnotation - | AsPat (XAsPat p) - (Located (IdP p)) (LPat p) -- ^ As pattern + | AsPat (Located (IdP p)) (LPat p) -- ^ As pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' -- For details on above see note [Api annotations] in ApiAnnotation - | ParPat (XParPat p) - (LPat p) -- ^ Parenthesised pattern + | ParPat (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 (XBangPat p) - (LPat p) -- ^ Bang pattern + | BangPat (LPat p) -- ^ Bang pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' -- For details on above see note [Api annotations] in ApiAnnotation ------------ Lists, tuples, arrays --------------- - | ListPat (XListPat p) - -- See XListPat type instances below. - -- For OverloadedLists a Just (ty,fn) gives - -- overall type of the pattern, and the toList - -- function to convert the scrutinee to a list value - [LPat p] + | ListPat [LPat p] + (PostTc p Type) -- The type of the elements + (Maybe (PostTc p Type, SyntaxExpr p)) -- For rebindable syntax + -- For OverloadedLists a Just (ty,fn) gives + -- overall type of the pattern, and the toList + -- function to convert the scrutinee to a list value -- ^ Syntactic List -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, @@ -129,13 +121,12 @@ data Pat p -- For details on above see note [Api annotations] in ApiAnnotation - | TuplePat (XTuplePat p) - -- after typechecking, holds the types of the tuple components - [LPat p] -- Tuple sub-patterns + | TuplePat [LPat p] -- Tuple sub-patterns Boxity -- UnitPat is TuplePat [] - -- 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. + [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. -- But it's essential -- data T a where -- T1 :: Int -> T Int @@ -155,12 +146,12 @@ data Pat p -- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@, -- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@ - | SumPat (XSumPat p) -- PlaceHolder before typechecker, filled in - -- afterwards with the types of the - -- alternative - (LPat p) -- Sum sub-pattern + | SumPat (LPat p) -- Sum sub-pattern ConTag -- Alternative (one-based) Arity -- Arity (INVARIANT: ≥ 2) + (PostTc p [Type]) -- PlaceHolder before typechecker, filled in + -- afterwards with the types of the + -- alternative -- ^ Anonymous sum pattern -- -- - 'ApiAnnotation.AnnKeywordId' : @@ -168,8 +159,8 @@ data Pat p -- 'ApiAnnotation.AnnClose' @'#)'@ -- For details on above see note [Api annotations] in ApiAnnotation - | PArrPat (XPArrPat p) -- After typechecking, the type of the elements - [LPat p] -- Syntactic parallel array + | PArrPat [LPat p] -- Syntactic parallel array + (PostTc p Type) -- The type of the elements -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, -- 'ApiAnnotation.AnnClose' @':]'@ @@ -204,11 +195,11 @@ data Pat p -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | ViewPat (XViewPat p) -- The overall type of the pattern - -- (= the argument type of the view function) - -- for hsPatType. - (LHsExpr p) + | ViewPat (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 --------------- @@ -216,34 +207,31 @@ data Pat p -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | SplicePat (XSplicePat p) - (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes) + | SplicePat (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes) ------------ Literal and n+k patterns --------------- - | LitPat (XLitPat p) - (HsLit p) -- ^ Literal Pattern + | LitPat (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 (XNPlusKPat p) -- Type of overall pattern - (Located (IdP p)) -- n+k pattern + | NPlusKPat (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 @@ -251,22 +239,24 @@ 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 - | SigPat (XSigPat p) -- Before typechecker - -- Signature can bind both - -- kind and type vars - -- After typechecker: Type - (LPat p) -- Pattern with a type signature + | 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 -- ^ Pattern with a type signature ------------ Pattern coercions (translation only) --------------- - | CoPat (XCoPat p) - HsWrapper -- Coercion Pattern + | CoPat HsWrapper -- Coercion Pattern -- If co :: t1 ~ t2, p :: t2, -- then (CoPat co p) :: t1 (Pat p) -- Why not LPat? Ans: existing locn will do @@ -274,74 +264,8 @@ 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 - - -- | Trees that Grow extension point for new constructors - | XPat - (XXPat p) deriving instance (DataId p) => Data (Pat p) --- | The typechecker-specific information for a 'ListPat' -data ListPatTc = - ListPatTc Type -- The type of the elements - (Maybe (Type, SyntaxExpr GhcTc)) -- For rebindable syntax - -- For OverloadedLists a Just (ty,fn) gives - -- overall type of the pattern, and the toList - -- function to convert the scrutinee to a list value - deriving Data - --- --------------------------------------------------------------------- - -type instance XWildPat GhcPs = PlaceHolder -type instance XWildPat GhcRn = PlaceHolder -type instance XWildPat GhcTc = Type - -type instance XVarPat (GhcPass _) = PlaceHolder -type instance XLazyPat (GhcPass _) = PlaceHolder -type instance XAsPat (GhcPass _) = PlaceHolder -type instance XParPat (GhcPass _) = PlaceHolder -type instance XBangPat (GhcPass _) = PlaceHolder - -type instance XListPat GhcPs = PlaceHolder -type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn) -- For rebindable syntax -type instance XListPat GhcTc = ListPatTc - -type instance XTuplePat GhcPs = PlaceHolder -type instance XTuplePat GhcRn = PlaceHolder -type instance XTuplePat GhcTc = [Type] - -type instance XSumPat GhcPs = PlaceHolder -type instance XSumPat GhcRn = PlaceHolder -type instance XSumPat GhcTc = [Type] - -type instance XPArrPat GhcPs = PlaceHolder -type instance XPArrPat GhcRn = PlaceHolder -type instance XPArrPat GhcTc = Type - -type instance XViewPat GhcPs = PlaceHolder -type instance XViewPat GhcRn = PlaceHolder -type instance XViewPat GhcTc = Type - -type instance XSplicePat (GhcPass _) = PlaceHolder -type instance XLitPat (GhcPass _) = PlaceHolder - -type instance XNPat GhcPs = PlaceHolder -type instance XNPat GhcRn = PlaceHolder -type instance XNPat GhcTc = Type - -type instance XNPlusKPat GhcPs = PlaceHolder -type instance XNPlusKPat GhcRn = PlaceHolder -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 _) = PlaceHolder -type instance XXPat (GhcPass _) = PlaceHolder - --- --------------------------------------------------------------------- - - -- | Haskell Constructor Pattern Details type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p)) @@ -458,24 +382,24 @@ data HsRecField' id arg = HsRecField { -- -- See also Note [Disambiguating record fields] in TcExpr. -hsRecFields :: HsRecFields p arg -> [XFieldOcc p] +hsRecFields :: HsRecFields p arg -> [PostRn p (IdP 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 (XFieldOcc pass) -hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl +hsRecFieldSel :: HsRecField pass arg -> Located (PostRn pass (IdP pass)) +hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl hsRecFieldId :: HsRecField GhcTc arg -> Located Id hsRecFieldId = hsRecFieldSel -hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName +hsRecUpdFieldRdr :: HsRecUpdField p -> Located RdrName hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id -hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc +hsRecUpdFieldId = fmap selectorFieldOcc . hsRecUpdFieldOcc hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl @@ -489,8 +413,8 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl ************************************************************************ -} -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (Pat (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (Pat pass) where ppr = pprPat pprPatBndr :: OutputableBndr name => name -> SDoc @@ -502,12 +426,10 @@ pprPatBndr var -- Print with type info if -dppr-debug is on else pprPrefixOcc var -pprParendLPat :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LPat (GhcPass p) -> SDoc +pprParendLPat :: (SourceTextX pass, OutputableBndrId pass) => LPat pass -> SDoc pprParendLPat (L _ p) = pprParendPat p -pprParendPat :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Pat (GhcPass p) -> SDoc +pprParendPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc pprParendPat p = sdocWithDynFlags $ \ dflags -> if need_parens dflags p then parens (pprPat p) @@ -521,31 +443,29 @@ pprParendPat p = sdocWithDynFlags $ \ dflags -> -- But otherwise the CoPat is discarded, so it -- is the pattern inside that matters. Sigh. -pprPat :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Pat (GhcPass p) -> SDoc -pprPat (VarPat _ (L _ var)) = pprPatBndr var +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 +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 (SigPat ty pat) = 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 (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 (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, pat_binds = binds, pat_args = details }) = sdocWithDynFlags $ \dflags -> @@ -558,16 +478,14 @@ 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 (GhcPass p), OutputableBndr con, - OutputableBndrId (GhcPass p)) - => con -> HsConPatDetails (GhcPass p) -> SDoc + +pprUserCon :: (SourceTextX p, OutputableBndr con, OutputableBndrId p) + => con -> HsConPatDetails p -> SDoc pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 pprUserCon c details = pprPrefixOcc c <+> pprConArgs details -pprConArgs :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsConPatDetails (GhcPass p) -> SDoc +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 (RecCon rpats) = ppr rpats @@ -606,12 +524,9 @@ mkPrefixConPat dc pats tys mkNilPat :: Type -> OutPat p mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] -mkCharLitPat :: (SourceTextX (GhcPass p)) - => SourceText -> Char -> OutPat (GhcPass p) +mkCharLitPat :: (SourceTextX p) => SourceText -> Char -> OutPat p mkCharLitPat src c = mkPrefixConPat charDataCon - [noLoc $ LitPat PlaceHolder - (HsCharPrim (setSourceText src) c)] - [] + [noLoc $ LitPat (HsCharPrim (setSourceText src) c)] [] {- ************************************************************************ @@ -646,7 +561,7 @@ The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. -} isBangedLPat :: LPat p -> Bool -isBangedLPat (L _ (ParPat _ p)) = isBangedLPat p +isBangedLPat (L _ (ParPat p)) = isBangedLPat p isBangedLPat (L _ (BangPat {})) = True isBangedLPat _ = False @@ -664,8 +579,8 @@ 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 @@ -692,14 +607,15 @@ 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 (SigPat _ pat) = go pat - go1 (TuplePat _ pats _) = all go pats - go1 (SumPat {}) = False + 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 _ _ _ _) = False -- See Note [Unboxed sum patterns aren't irrefutable] go1 (ListPat {}) = False go1 (PArrPat {}) = False -- ? @@ -721,8 +637,6 @@ isIrrefutableHsPat pat -- since we cannot know until the splice is evaluated. go1 (SplicePat {}) = False - go1 (XPat {}) = False - {- Note [Unboxed sum patterns aren't irrefutable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as @@ -750,9 +664,10 @@ hsPatNeedsParens (NPlusKPat {}) = True hsPatNeedsParens (SplicePat {}) = False hsPatNeedsParens (ConPatIn _ ds) = conPatNeedsParens ds hsPatNeedsParens p@(ConPatOut {}) = conPatNeedsParens (pat_args p) -hsPatNeedsParens (SigPat {}) = True +hsPatNeedsParens (SigPatIn {}) = True +hsPatNeedsParens (SigPatOut {}) = True hsPatNeedsParens (ViewPat {}) = True -hsPatNeedsParens (CoPat _ _ p _) = hsPatNeedsParens p +hsPatNeedsParens (CoPat _ p _) = hsPatNeedsParens p hsPatNeedsParens (WildPat {}) = False hsPatNeedsParens (VarPat {}) = False hsPatNeedsParens (LazyPat {}) = False @@ -765,7 +680,6 @@ hsPatNeedsParens (ListPat {}) = False hsPatNeedsParens (PArrPat {}) = False hsPatNeedsParens (LitPat {}) = False hsPatNeedsParens (NPat {}) = False -hsPatNeedsParens (XPat {}) = True -- conservative default conPatNeedsParens :: HsConDetails a b -> Bool conPatNeedsParens (PrefixCon {}) = False @@ -777,29 +691,30 @@ conPatNeedsParens (RecCon {}) = False -} -- May need to add more cases -collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar +collectEvVarsPats :: [Pat p] -> Bag EvVar collectEvVarsPats = unionManyBags . map collectEvVarsPat -collectEvVarsLPat :: LPat GhcTc -> Bag EvVar +collectEvVarsLPat :: LPat p -> Bag EvVar collectEvVarsLPat (L _ pat) = collectEvVarsPat pat -collectEvVarsPat :: Pat GhcTc -> Bag EvVar +collectEvVarsPat :: Pat p -> 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 + PArrPat ps _ -> unionManyBags $ map collectEvVarsLPat ps ConPatOut {pat_dicts = dicts, pat_args = args} - -> unionBags (listToBag dicts) + -> unionBags (listToBag dicts) $ unionManyBags $ map collectEvVarsLPat $ hsConPatArgs args - SigPat _ p -> collectEvVarsLPat p - CoPat _ _ p _ -> collectEvVarsPat p - ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn" - _other_pat -> emptyBag + SigPatOut p _ -> collectEvVarsLPat p + CoPat _ p _ -> collectEvVarsPat p + ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn" + SigPatIn _ _ -> panic "foldMapPatBag: SigPatIn" + _other_pat -> emptyBag diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot index 47dae434ce..8cb82ed22e 100644 --- a/compiler/hsSyn/HsPat.hs-boot +++ b/compiler/hsSyn/HsPat.hs-boot @@ -4,19 +4,17 @@ -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE FlexibleInstances #-} module HsPat where import SrcLoc( Located ) import Data.Data hiding (Fixity) import Outputable -import HsExtension ( SourceTextX, DataId, OutputableBndrId, GhcPass ) +import HsExtension ( SourceTextX, DataId, OutputableBndrId ) type role Pat nominal data Pat (i :: *) type LPat i = Located (Pat i) instance (DataId p) => Data (Pat p) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (Pat (GhcPass p)) +instance (SourceTextX pass, OutputableBndrId pass) => Outputable (Pat pass) diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs index 280f5d36ce..62bfa2e5c5 100644 --- a/compiler/hsSyn/HsSyn.hs +++ b/compiler/hsSyn/HsSyn.hs @@ -15,7 +15,6 @@ therefore, is almost nothing but re-exporting. {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} module HsSyn ( module HsBinds, @@ -113,8 +112,8 @@ data HsModule name -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId name) => Data (HsModule name) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsModule (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsModule pass) 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 d9c1b46d0e..f5b4149f99 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -15,10 +15,9 @@ HsTypes: Abstract syntax: user-defined types -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} module HsTypes ( - HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind, + HsType(..), LHsType, HsKind, LHsKind, HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), HsImplicitBndrs(..), @@ -45,7 +44,7 @@ module HsTypes ( rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, unambiguousFieldOcc, ambiguousFieldOcc, - HsWildCardInfo(..), mkAnonWildCardTy, pprAnonWildCard, + HsWildCardInfo(..), mkAnonWildCardTy, wildCardName, sameWildCard, mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody, @@ -76,7 +75,6 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) import PlaceHolder ( PlaceHolder(..) ) import HsExtension -import HsLit () -- for instances import Id ( Id ) import Name( Name ) @@ -112,11 +110,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) {- @@ -272,7 +270,7 @@ data LHsQTyVars pass -- See Note [HsType binders] -- See Note [Dependent LHsQTyVars] in TcHsType } -deriving instance (DataIdLR pass pass) => Data (LHsQTyVars pass) +deriving instance (DataId pass) => Data (LHsQTyVars pass) mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs @@ -407,11 +405,9 @@ 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 -- ^ @@ -419,20 +415,12 @@ data HsTyVarBndr pass -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - - | XTyVarBndr - (XXTyVarBndr pass) -deriving instance (DataIdLR pass pass) => Data (HsTyVarBndr pass) - -type instance XUserTyVar (GhcPass _) = PlaceHolder -type instance XKindedTyVar (GhcPass _) = PlaceHolder -type instance XXTyVarBndr (GhcPass _) = PlaceHolder +deriving instance (DataId pass) => Data (HsTyVarBndr pass) -- | 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 @@ -441,22 +429,19 @@ hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit -- | Haskell Type data HsType pass = HsForAllTy -- See Note [HsType binders] - { hst_xforall :: XForAllTy pass, - hst_bndrs :: [LHsTyVarBndr 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_xqual :: XQualTy pass - , hst_ctxt :: LHsContext pass -- Context C => blah - , hst_body :: LHsType pass } + { hst_ctxt :: LHsContext pass -- Context C => blah + , hst_body :: LHsType pass } - | HsTyVar (XTyVar pass) - Promoted -- whether explicitly promoted, for the pretty + | HsTyVar Promoted -- whether explicitly promoted, for the pretty -- printer (Located (IdP pass)) -- Type variable, type constructor, or data constructor @@ -466,62 +451,53 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsAppsTy (XAppsTy pass) - [LHsAppType pass] -- Used only before renaming, + | HsAppsTy [LHsAppType pass] -- Used only before renaming, -- Note [HsAppsTy] -- ^ - 'ApiAnnotation.AnnKeywordId' : None - | HsAppTy (XAppTy pass) - (LHsType pass) + | HsAppTy (LHsType pass) (LHsType pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation - | HsFunTy (XFunTy pass) - (LHsType pass) -- function type + | HsFunTy (LHsType pass) -- function type (LHsType pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow', -- For details on above see note [Api annotations] in ApiAnnotation - | HsListTy (XListTy pass) - (LHsType pass) -- Element type + | HsListTy (LHsType pass) -- Element type -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, -- 'ApiAnnotation.AnnClose' @']'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsPArrTy (XPArrTy pass) - (LHsType pass) -- Elem. type of parallel array: [:t:] + | 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 (XTupleTy pass) - HsTupleSort + | HsTupleTy 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 (XSumTy pass) - [LHsType pass] -- Element types (length gives arity) + | HsSumTy [LHsType pass] -- Element types (length gives arity) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@, -- 'ApiAnnotation.AnnClose' '#)'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsOpTy (XOpTy pass) - (LHsType pass) (Located (IdP pass)) (LHsType pass) + | HsOpTy (LHsType pass) (Located (IdP pass)) (LHsType pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation - | HsParTy (XParTy pass) - (LHsType pass) -- See Note [Parens in HsSyn] in HsExpr + | HsParTy (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' @'('@, @@ -529,8 +505,7 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsIParamTy (XIParamTy pass) - (Located HsIPName) -- (?x :: ty) + | HsIParamTy (Located HsIPName) -- (?x :: ty) (LHsType pass) -- Implicit parameters as they occur in -- contexts -- ^ @@ -540,8 +515,7 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsEqTy (XEqTy pass) - (LHsType pass) -- ty1 ~ ty2 + | HsEqTy (LHsType pass) -- ty1 ~ ty2 (LHsType pass) -- Always allowed even without -- TypeOperators, and has special -- kinding rule @@ -552,8 +526,7 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsKindSig (XKindSig pass) - (LHsType pass) -- (ty :: kind) + | HsKindSig (LHsType pass) -- (ty :: kind) (LHsKind pass) -- A type with a kind signature -- ^ -- > (ty :: kind) @@ -563,21 +536,19 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsSpliceTy (XSpliceTy pass) - (HsSplice pass) -- Includes quasi-quotes + | HsSpliceTy (HsSplice pass) -- Includes quasi-quotes + (PostTc pass Kind) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsDocTy (XDocTy pass) - (LHsType pass) LHsDocString -- A documented type + | HsDocTy (LHsType pass) LHsDocString -- A documented type -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation - | HsBangTy (XBangTy pass) - HsSrcBang (LHsType pass) -- Bang-style type annotations + | HsBangTy HsSrcBang (LHsType pass) -- Bang-style type annotations -- ^ - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@, -- 'ApiAnnotation.AnnClose' @'#-}'@ @@ -585,22 +556,21 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsRecTy (XRecTy pass) - [LConDeclField pass] -- Only in data type declarations + | HsRecTy [LConDeclField pass] -- Only in data type declarations -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnClose' @'}'@ -- For details on above see note [Api annotations] in ApiAnnotation - -- | HsCoreTy (XCoreTy pass) Type -- An escape hatch for tunnelling a *closed* - -- -- Core Type through HsSyn. - -- -- ^ - 'ApiAnnotation.AnnKeywordId' : None + | HsCoreTy 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' @']'@ @@ -608,78 +578,24 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation | HsExplicitTupleTy -- A promoted explicit tuple - (XExplicitTupleTy pass) + [PostTc pass Kind] -- See Note [Promoted lists and tuples] [LHsType pass] -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsTyLit (XTyLit pass) HsTyLit -- A promoted numeric literal. + | HsTyLit HsTyLit -- A promoted numeric literal. -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation - | HsWildCardTy (XWildCardTy pass) -- A type wildcard + | HsWildCardTy (HsWildCardInfo pass) -- A type wildcard -- See Note [The wildcard story for types] -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation - - -- For adding new constructors via Trees that Grow - | XHsType - (XXType pass) -deriving instance (DataIdLR pass pass) => Data (HsType 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 _) = PlaceHolder -type instance XQualTy (GhcPass _) = PlaceHolder -type instance XTyVar (GhcPass _) = PlaceHolder -type instance XAppsTy (GhcPass _) = PlaceHolder -type instance XAppTy (GhcPass _) = PlaceHolder -type instance XFunTy (GhcPass _) = PlaceHolder -type instance XListTy (GhcPass _) = PlaceHolder -type instance XPArrTy (GhcPass _) = PlaceHolder -type instance XTupleTy (GhcPass _) = PlaceHolder -type instance XSumTy (GhcPass _) = PlaceHolder -type instance XOpTy (GhcPass _) = PlaceHolder -type instance XParTy (GhcPass _) = PlaceHolder -type instance XIParamTy (GhcPass _) = PlaceHolder -type instance XEqTy (GhcPass _) = PlaceHolder -type instance XKindSig (GhcPass _) = PlaceHolder - -type instance XSpliceTy GhcPs = PlaceHolder -type instance XSpliceTy GhcRn = PlaceHolder -type instance XSpliceTy GhcTc = Kind - -type instance XDocTy (GhcPass _) = PlaceHolder -type instance XBangTy (GhcPass _) = PlaceHolder -type instance XRecTy (GhcPass _) = PlaceHolder - -type instance XExplicitListTy GhcPs = PlaceHolder -type instance XExplicitListTy GhcRn = PlaceHolder -type instance XExplicitListTy GhcTc = Kind - -type instance XExplicitTupleTy GhcPs = PlaceHolder -type instance XExplicitTupleTy GhcRn = PlaceHolder -type instance XExplicitTupleTy GhcTc = [Kind] - -type instance XTyLit (GhcPass _) = PlaceHolder - -type instance XWildCardTy GhcPs = PlaceHolder -type instance XWildCardTy GhcRn = HsWildCardInfo GhcRn -type instance XWildCardTy GhcTc = HsWildCardInfo GhcTc - -type instance XXType (GhcPass _) = NewHsTypeX - +deriving instance (DataId pass) => Data (HsType pass) -- Note [Literal source text] in BasicTypes for SourceText fields in -- the following @@ -689,8 +605,7 @@ data HsTyLit | HsStrTy SourceText FastString deriving Data --- AZ: fold this into the XWildCardTy completely, removing the type -newtype HsWildCardInfo pass -- See Note [The wildcard story for types] +newtype HsWildCardInfo pass -- See Note [The wildcard story for types] = AnonWildCard (PostRn pass (Located Name)) -- A anonymous wild card ('_'). A fresh Name is generated for -- each individual anonymous wildcard during renaming @@ -702,21 +617,12 @@ type LHsAppType pass = Located (HsAppType pass) -- | Haskell Application Type data HsAppType pass - = HsAppInfix (XAppInfix pass) - (Located (IdP pass)) -- either a symbol or an id in backticks - | HsAppPrefix (XAppPrefix pass) - (LHsType pass) -- anything else, including things like (+) - - | XAppType - (XXAppType pass) -deriving instance (DataIdLR pass pass) => Data (HsAppType pass) - -type instance XAppInfix (GhcPass _) = PlaceHolder -type instance XAppPrefix (GhcPass _) = PlaceHolder -type instance XXAppType (GhcPass _) = PlaceHolder + = 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 (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsAppType (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsAppType pass) where ppr = ppr_app_ty {- @@ -858,10 +764,10 @@ data ConDeclField pass -- Record fields have Haddoc docs on them -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR pass pass) => Data (ConDeclField pass) +deriving instance (DataId pass) => Data (ConDeclField pass) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (ConDeclField (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (ConDeclField pass) where ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty -- HsConDetails is used for patterns/expressions *and* for data type @@ -883,11 +789,11 @@ instance (Outputable arg, Outputable rec) -- parser and rejigs them using information about fixities from the renamer. -- See Note [Sorting out the result type] in RdrHsSyn updateGadtResult - :: (Monad m, OutputableX GhcRn) + :: (Monad m) => (SDoc -> m ()) -> SDoc -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) - -- ^ Original details + -- ^ Original details -> LHsType GhcRn -- ^ Original result type -> m (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]), LHsType GhcRn) @@ -968,9 +874,8 @@ 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 (XTyVarBndr{}) = panic "hsTyVarName" +hsTyVarName (UserTyVar (L _ n)) = n +hsTyVarName (KindedTyVar (L _ n) _) = n hsLTyVarName :: LHsTyVarBndr pass -> IdP pass hsLTyVarName = hsTyVarName . unLoc @@ -991,17 +896,15 @@ hsLTyVarLocNames :: LHsQTyVars pass -> [Located (IdP pass)] hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) -- | Convert a LHsTyVarBndr to an equivalent LHsType. -hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p) +hsLTyVarBndrToType :: LHsTyVarBndr pass -> LHsType pass hsLTyVarBndrToType = fmap cvt - 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" + 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 -- | Convert a LHsTyVarBndrs to a list of types. -- Works on *type* variable only, no kind vars. -hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)] +hsLTyVarBndrsToTypes :: LHsQTyVars pass -> [LHsType pass] hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs --------------------- @@ -1014,9 +917,9 @@ sameWildCard :: Located (HsWildCardInfo pass) 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 (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = ignoreParens ty +ignoreParens ty = ty {- ************************************************************************ @@ -1027,17 +930,15 @@ ignoreParens ty = ty -} mkAnonWildCardTy :: HsType GhcPs -mkAnonWildCardTy = HsWildCardTy noExt +mkAnonWildCardTy = HsWildCardTy (AnonWildCard PlaceHolder) -mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p)) - -> LHsType (GhcPass p) -> HsType (GhcPass p) -mkHsOpTy ty1 op ty2 = HsOpTy noExt ty1 op ty2 +mkHsOpTy :: LHsType pass -> Located (IdP pass) -> LHsType pass -> HsType pass +mkHsOpTy ty1 op ty2 = HsOpTy ty1 op ty2 -mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy noExt t1 t2) +mkHsAppTy :: LHsType pass -> LHsType pass -> LHsType pass +mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) -mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] - -> LHsType (GhcPass p) +mkHsAppTys :: LHsType pass -> [LHsType pass] -> LHsType pass mkHsAppTys = foldl mkHsAppTy @@ -1056,37 +957,36 @@ 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 (GhcPass p)] - -> Maybe ( LHsType (GhcPass p) - , [LHsType (GhcPass p)], LexicalFixity) +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 noExt NotPromoted (L loc op)) + Just ( L loc (HsTyVar NotPromoted (L loc op)) , [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr], Infix) _ -> -- can't figure it out Nothing @@ -1101,36 +1001,35 @@ 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 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 acc acc_non acc_sym (L _ (HsAppInfix op) : rest) = go [] (reverse acc : acc_non) (op : acc_sym) rest - go _ _ _ (L _ (XAppType _):_) = panic "splitHsAppsTy" -- 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 (GhcPass p) - -> Maybe (Located (IdP (GhcPass p)), [LHsType (GhcPass p)]) +hsTyGetAppHead_maybe :: LHsType pass + -> Maybe (Located (IdP pass), [LHsType pass]) hsTyGetAppHead_maybe = go [] where - go tys (L _ (HsTyVar _ _ ln)) = Just (ln, tys) - go tys (L _ (HsAppsTy _ apps)) + 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 (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 _ _ = 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 @@ -1155,12 +1054,12 @@ splitLHsSigmaTy ty splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass) splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body) -splitLHsForAllTy (L _ (HsParTy _ t)) = splitLHsForAllTy t +splitLHsForAllTy (L _ (HsParTy t)) = splitLHsForAllTy t splitLHsForAllTy body = ([], body) splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass) splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body) -splitLHsQualTy (L _ (HsParTy _ t)) = splitLHsQualTy t +splitLHsQualTy (L _ (HsParTy t)) = splitLHsQualTy t splitLHsQualTy body = (noLoc [], body) splitLHsInstDeclTy :: LHsSigType GhcRn @@ -1178,8 +1077,7 @@ getLHsInstDeclHead inst_ty | (_tvs, _cxt, body_ty) <- splitLHsSigmaTy (hsSigType inst_ty) = body_ty -getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p) - -> Maybe (Located (IdP (GhcPass p))) +getLHsInstDeclClass_maybe :: LHsSigType pass -> Maybe (Located (IdP pass)) -- Works on (HsSigType RdrName) getLHsInstDeclClass_maybe inst_ty = do { let head_ty = getLHsInstDeclHead inst_ty @@ -1202,28 +1100,19 @@ 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 { extFieldOcc :: XFieldOcc pass - , rdrNameFieldOcc :: Located RdrName +data FieldOcc pass = FieldOcc { rdrNameFieldOcc :: Located RdrName -- ^ See Note [Located RdrNames] in HsExpr + , selectorFieldOcc :: PostRn pass (IdP pass) } - - | XFieldOcc - (XXFieldOcc pass) -deriving instance (Eq (XFieldOcc (GhcPass p))) => Eq (FieldOcc (GhcPass p)) -deriving instance (Ord (XFieldOcc (GhcPass p))) => Ord (FieldOcc (GhcPass p)) +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) -type instance XFieldOcc GhcPs = PlaceHolder -type instance XFieldOcc GhcRn = Name -type instance XFieldOcc GhcTc = Id - -type instance XXFieldOcc (GhcPass _) = PlaceHolder - instance Outputable (FieldOcc pass) where ppr = ppr . rdrNameFieldOcc mkFieldOcc :: Located RdrName -> FieldOcc GhcPs -mkFieldOcc rdr = FieldOcc PlaceHolder rdr +mkFieldOcc rdr = FieldOcc rdr PlaceHolder -- | Ambiguous Field Occurrence @@ -1239,51 +1128,34 @@ mkFieldOcc rdr = FieldOcc PlaceHolder rdr -- Note [Disambiguating record fields] in TcExpr. -- See Note [Located RdrNames] in HsExpr data AmbiguousFieldOcc pass - = Unambiguous (XUnambiguous pass) (Located RdrName) - | Ambiguous (XAmbiguous pass) (Located RdrName) - | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass) + = Unambiguous (Located RdrName) (PostRn pass (IdP pass)) + | Ambiguous (Located RdrName) (PostTc pass (IdP pass)) deriving instance DataId pass => Data (AmbiguousFieldOcc pass) -type instance XUnambiguous GhcPs = PlaceHolder -type instance XUnambiguous GhcRn = Name -type instance XUnambiguous GhcTc = Id - -type instance XAmbiguous GhcPs = PlaceHolder -type instance XAmbiguous GhcRn = PlaceHolder -type instance XAmbiguous GhcTc = Id - -type instance XXAmbiguousFieldOcc (GhcPass _) = PlaceHolder - -instance Outputable (AmbiguousFieldOcc (GhcPass p)) where +instance Outputable (AmbiguousFieldOcc pass) where ppr = ppr . rdrNameAmbiguousFieldOcc -instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where +instance OutputableBndr (AmbiguousFieldOcc pass) where pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs -mkAmbiguousFieldOcc rdr = Unambiguous noExt rdr +mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder -rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName -rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr -rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr -rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc _) - = panic "rdrNameAmbiguousFieldOcc" +rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc pass -> RdrName +rdrNameAmbiguousFieldOcc (Unambiguous (L _ rdr) _) = rdr +rdrNameAmbiguousFieldOcc (Ambiguous (L _ rdr) _) = rdr selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id -selectorAmbiguousFieldOcc (Unambiguous sel _) = sel -selectorAmbiguousFieldOcc (Ambiguous sel _) = sel -selectorAmbiguousFieldOcc (XAmbiguousFieldOcc _) - = panic "selectorAmbiguousFieldOcc" +selectorAmbiguousFieldOcc (Unambiguous _ sel) = sel +selectorAmbiguousFieldOcc (Ambiguous _ sel) = sel 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 GhcTc -> AmbiguousFieldOcc GhcTc -ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr -ambiguousFieldOcc (XFieldOcc _) = panic "ambiguousFieldOcc" +ambiguousFieldOcc :: FieldOcc pass -> AmbiguousFieldOcc pass +ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel {- ************************************************************************ @@ -1293,22 +1165,21 @@ ambiguousFieldOcc (XFieldOcc _) = panic "ambiguousFieldOcc" ************************************************************************ -} -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsType (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsType pass) where ppr ty = pprHsType ty instance Outputable HsTyLit where ppr = ppr_tylit -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (LHsQTyVars (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (LHsQTyVars pass) where ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsTyVarBndr (GhcPass p)) where - ppr (UserTyVar _ n) = ppr n - ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k] - ppr (XTyVarBndr n) = ppr n +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 (Outputable thing) => Outputable (HsImplicitBndrs pass thing) where ppr (HsIB { hsib_body = ty }) = ppr ty @@ -1319,11 +1190,8 @@ instance (Outputable thing) => Outputable (HsWildCardBndrs pass thing) where instance Outputable (HsWildCardInfo pass) where ppr (AnonWildCard _) = char '_' -pprAnonWildCard :: SDoc -pprAnonWildCard = char '_' - -pprHsForAll :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc +pprHsForAll :: (SourceTextX pass, OutputableBndrId pass) + => [LHsTyVarBndr pass] -> LHsContext pass -> SDoc pprHsForAll = pprHsForAllExtra Nothing -- | Version of 'pprHsForAll' that can also print an extra-constraints @@ -1333,44 +1201,44 @@ 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 (GhcPass p), OutputableBndrId (GhcPass p)) - => Maybe SrcSpan -> [LHsTyVarBndr (GhcPass p)] - -> LHsContext (GhcPass p) -> SDoc +pprHsForAllExtra :: (SourceTextX pass, OutputableBndrId pass) + => Maybe SrcSpan -> [LHsTyVarBndr pass] -> LHsContext pass + -> SDoc pprHsForAllExtra extra qtvs cxt = pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt) where show_extra = isJust extra -pprHsForAllTvs :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => [LHsTyVarBndr (GhcPass p)] -> SDoc +pprHsForAllTvs :: (SourceTextX pass, OutputableBndrId pass) + => [LHsTyVarBndr pass] -> SDoc pprHsForAllTvs qtvs | null qtvs = whenPprDebug (forAllLit <+> dot) | otherwise = forAllLit <+> interppSP qtvs <> dot -pprHsContext :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsContext (GhcPass p) -> SDoc +pprHsContext :: (SourceTextX pass, OutputableBndrId pass) + => HsContext pass -> SDoc pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe -pprHsContextNoArrow :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsContext (GhcPass p) -> SDoc +pprHsContextNoArrow :: (SourceTextX pass, OutputableBndrId pass) + => HsContext pass -> SDoc pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe -pprHsContextMaybe :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsContext (GhcPass p) -> Maybe SDoc +pprHsContextMaybe :: (SourceTextX pass, OutputableBndrId pass) + => HsContext pass -> 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 (GhcPass p), OutputableBndrId (GhcPass p)) - => HsContext (GhcPass p) -> SDoc +pprHsContextAlways :: (SourceTextX pass, OutputableBndrId pass) + => HsContext pass -> 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 (GhcPass p), OutputableBndrId (GhcPass p)) - => Bool -> HsContext (GhcPass p) -> SDoc +pprHsContextExtra :: (SourceTextX pass, OutputableBndrId pass) + => Bool -> HsContext pass -> SDoc pprHsContextExtra show_extra ctxt | not show_extra = pprHsContext ctxt @@ -1381,8 +1249,8 @@ pprHsContextExtra show_extra ctxt where ctxt' = map ppr ctxt ++ [char '_'] -pprConDeclFields :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => [LConDeclField (GhcPass p)] -> SDoc +pprConDeclFields :: (SourceTextX pass, OutputableBndrId pass) + => [LConDeclField pass] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) where ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, @@ -1406,79 +1274,76 @@ seems like the Right Thing anyway.) -- Printing works more-or-less as for Types -pprHsType :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsType (GhcPass p) -> SDoc +pprHsType :: (SourceTextX pass, OutputableBndrId pass) => HsType pass -> SDoc pprHsType ty = ppr_mono_ty ty -ppr_mono_lty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsType (GhcPass p) -> SDoc +ppr_mono_lty :: (SourceTextX pass, OutputableBndrId pass) + => LHsType pass -> SDoc ppr_mono_lty ty = ppr_mono_ty (unLoc ty) -ppr_mono_ty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsType (GhcPass p) -> SDoc +ppr_mono_ty :: (SourceTextX pass, OutputableBndrId pass) + => HsType pass -> 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 (XHsType t) = ppr t -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 (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 (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) = 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 (HsWildCardTy {}) = char '_' +ppr_mono_ty (HsTyLit t) = ppr_tylit t +ppr_mono_ty (HsWildCardTy {}) = char '_' -ppr_mono_ty (HsEqTy _ ty1 ty2) +ppr_mono_ty (HsEqTy ty1 ty2) = ppr_mono_lty ty1 <+> char '~' <+> ppr_mono_lty ty2 -ppr_mono_ty (HsAppsTy _ tys) +ppr_mono_ty (HsAppsTy tys) = hsep (map (ppr_app_ty . unLoc) tys) -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_fun_ty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc +ppr_fun_ty :: (SourceTextX pass, OutputableBndrId pass) + => LHsType pass -> LHsType pass -> SDoc ppr_fun_ty ty1 ty2 = let p1 = ppr_mono_lty ty1 p2 = ppr_mono_lty ty2 @@ -1486,17 +1351,16 @@ ppr_fun_ty ty1 ty2 sep [p1, text "->" <+> p2] -------------------------- -ppr_app_ty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsAppType (GhcPass p) -> SDoc -ppr_app_ty (HsAppInfix _ (L _ n)) = pprInfixOcc n -ppr_app_ty (HsAppPrefix _ (L _ (HsTyVar _ NotPromoted (L _ n)))) +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)))) +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_app_ty (XAppType ty) = ppr ty +ppr_app_ty (HsAppPrefix ty) = ppr_mono_lty ty -------------------------- ppr_tylit :: HsTyLit -> SDoc diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 3543690602..8e17994993 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -215,20 +215,22 @@ mkLHsPar :: LHsExpr name -> LHsExpr name mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le) | otherwise = le -mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name) -mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat PlaceHolder lp) +mkParPat :: LPat name -> LPat name +mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp) | otherwise = lp -nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name) -nlParPat p = noLoc (ParPat noExt p) +nlParPat :: LPat name -> LPat name +nlParPat p = noLoc (ParPat p) ------------------------------- -- These are the bits of syntax that contain rebindable names -- See RnEnv.lookupSyntaxName -mkHsIntegral :: IntegralLit -> HsOverLit GhcPs -mkHsFractional :: FractionalLit -> HsOverLit GhcPs -mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs +mkHsIntegral :: IntegralLit -> PostTc GhcPs Type + -> HsOverLit GhcPs +mkHsFractional :: FractionalLit -> PostTc GhcPs Type -> HsOverLit GhcPs +mkHsIsString :: SourceText -> FastString -> PostTc GhcPs Type + -> HsOverLit GhcPs mkHsDo :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs mkHsComp :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs @@ -253,9 +255,9 @@ emptyRecStmtId :: StmtLR GhcTc GhcTc bodyR mkRecStmt :: [LStmtLR idL GhcPs bodyR] -> StmtLR idL GhcPs bodyR -mkHsIntegral i = OverLit noExt (HsIntegral i) noExpr -mkHsFractional f = OverLit noExt (HsFractional f) noExpr -mkHsIsString src s = OverLit noExt (HsIsString src s) noExpr +mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noExpr +mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noExpr +mkHsIsString src s = OverLit (HsIsString src s) noRebindableInfo noExpr noRebindableInfo :: PlaceHolder noRebindableInfo = PlaceHolder -- Just another placeholder; @@ -268,9 +270,8 @@ mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) 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 noExt lit neg noSyntaxExpr -mkNPlusKPat id lit - = NPlusKPat noExt id lit (unLoc lit) noSyntaxExpr noSyntaxExpr +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 @@ -341,8 +342,8 @@ mkHsSpliceTE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e) mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs -mkHsSpliceTy hasParen e = HsSpliceTy noExt - (HsUntypedSplice hasParen unqualSplice e) +mkHsSpliceTy hasParen e + = HsSpliceTy (HsUntypedSplice hasParen unqualSplice e) placeHolderKind mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote @@ -360,15 +361,13 @@ mkHsStringPrimLit fs = HsStringPrim noSourceText (fastStringToByteString fs) ------------- -userHsLTyVarBndrs :: SrcSpan -> [Located (IdP (GhcPass p))] - -> [LHsTyVarBndr (GhcPass p)] +userHsLTyVarBndrs :: SrcSpan -> [Located (IdP name)] -> [LHsTyVarBndr name] -- Caller sets location -userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt v) | v <- bndrs ] +userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ] -userHsTyVarBndrs :: SrcSpan -> [IdP (GhcPass p)] -> [LHsTyVarBndr (GhcPass p)] +userHsTyVarBndrs :: SrcSpan -> [IdP name] -> [LHsTyVarBndr name] -- Caller sets location -userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt (L loc v)) - | v <- bndrs ] +userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ] {- @@ -389,14 +388,14 @@ nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con)) nlHsLit :: HsLit p -> LHsExpr p nlHsLit n = noLoc (HsLit n) -nlHsIntLit :: Integer -> LHsExpr (GhcPass p) -nlHsIntLit n = noLoc (HsLit (HsInt noExt (mkIntegralLit n))) +nlHsIntLit :: HasDefaultX p => Integer -> LHsExpr p +nlHsIntLit n = noLoc (HsLit (HsInt def (mkIntegralLit n))) -nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id) -nlVarPat n = noLoc (VarPat noExt (noLoc n)) +nlVarPat :: IdP id -> LPat id +nlVarPat n = noLoc (VarPat (noLoc n)) -nlLitPat :: HsLit GhcPs -> LPat GhcPs -nlLitPat l = noLoc (LitPat noExt l) +nlLitPat :: HsLit p -> LPat p +nlLitPat l = noLoc (LitPat l) nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id nlHsApp f x = noLoc (HsApp f (mkLHsPar x)) @@ -478,17 +477,17 @@ nlHsIf cond true false = noLoc (HsIf Nothing cond true false) nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches)) nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs) -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 :: LHsType name -> LHsType name -> LHsType name +nlHsTyVar :: IdP name -> LHsType name +nlHsFunTy :: LHsType name -> LHsType name -> LHsType name +nlHsParTy :: LHsType name -> LHsType name -nlHsAppTy f t = noLoc (HsAppTy noExt f t) -nlHsTyVar x = noLoc (HsTyVar noExt NotPromoted (noLoc x)) -nlHsFunTy a b = noLoc (HsFunTy noExt a b) -nlHsParTy t = noLoc (HsParTy noExt t) +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) -nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) +nlHsTyConApp :: IdP name -> [LHsType name] -> LHsType name nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys {- @@ -504,16 +503,16 @@ mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed mkLHsVarTuple :: [IdP a] -> LHsExpr a mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) -nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs -nlTuplePat pats box = noLoc (TuplePat noExt pats box) +nlTuplePat :: [LPat id] -> Boxity -> LPat id +nlTuplePat pats box = noLoc (TuplePat pats box []) missingTupArg :: HsTupArg GhcPs missingTupArg = Missing placeHolderType -mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn -mkLHsPatTup [] = noLoc $ TuplePat noExt [] Boxed +mkLHsPatTup :: [LPat id] -> LPat id +mkLHsPatTup [] = noLoc $ TuplePat [] Boxed [] mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat noExt lpats Boxed +mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat lpats Boxed [] -- The Big equivalents for the source tuple expressions mkBigLHsVarTup :: [IdP id] -> LHsExpr id @@ -523,10 +522,10 @@ mkBigLHsTup :: [LHsExpr id] -> LHsExpr id mkBigLHsTup = mkChunkified mkLHsTupleExpr -- The Big equivalents for the source tuple patterns -mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn +mkBigLHsVarPatTup :: [IdP id] -> LPat id mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs) -mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn +mkBigLHsPatTup :: [LPat id] -> LPat id mkBigLHsPatTup = mkChunkified mkLHsPatTup -- $big_tuples @@ -633,18 +632,16 @@ 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 noExt (HsNumTy noSourceText n) - go (LitTy (StrTyLit s)) = noLoc $ HsTyLit noExt (HsStrTy noSourceText s) + 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') where args' = filterOutInvisibleTypes tc args @@ -655,7 +652,7 @@ typeToLHsType ty -- so we must remove them here (Trac #8563) go_tv :: TyVar -> LHsTyVarBndr GhcPs - go_tv tv = noLoc $ KindedTyVar noExt (noLoc (getRdrName tv)) + go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv)) (go (tyVarKind tv)) @@ -693,13 +690,13 @@ mkHsCmdWrap w cmd | isIdHsWrapper w = cmd mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c) -mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) +mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p - | otherwise = CoPat noExt co_fn p ty + | otherwise = CoPat co_fn p ty -mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) +mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id mkHsWrapPatCo co pat ty | isTcReflCo co = pat - | otherwise = CoPat noExt (mkWpCastN co) pat ty + | otherwise = CoPat (mkWpCastN co) pat ty mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr @@ -772,16 +769,14 @@ mkPrefixFunRhs n = FunRhs { mc_fun = n , mc_strictness = NoSrcStrict } ------------ -mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) - -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) - -> Located (HsLocalBinds (GhcPass p)) - -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) +mkMatch :: HsMatchContext (NameOrRdrName (IdP p)) -> [LPat p] -> LHsExpr p + -> Located (HsLocalBinds p) -> LMatch p (LHsExpr p) mkMatch ctxt pats expr lbinds = noLoc (Match { m_ctxt = ctxt , m_pats = map paren pats , m_grhss = GRHSs (unguardedRHS noSrcSpan expr) lbinds }) where - paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat noExt lp) + paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) | otherwise = lp {- @@ -892,8 +887,8 @@ collectHsBindListBinders :: [LHsBindLR idL idR] -> [IdP idL] 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 ps (ValBindsIn binds _) = collect_binds ps binds [] +collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds collect_out_binds :: Bool -> [(RecFlag, LHsBinds p)] -> [IdP p] collect_out_binds ps = foldr (collect_binds ps . snd) [] @@ -957,33 +952,33 @@ 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 (PArrPat 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 (SigPat _ pat) = collect_lpat pat bndrs + go (SigPatIn pat _) = collect_lpat pat bndrs + go (SigPatOut 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 (XPat {}) = bndrs + go (SplicePat _) = bndrs + go (CoPat _ pat _) = go pat {- Note [Dictionary binders in ConPatOut] See also same Note in DsArrows @@ -1032,7 +1027,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 (extFieldOcc . unLoc) fs + getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs ------------------- hsLTyClDeclBinders :: Located (TyClDecl pass) @@ -1070,7 +1065,7 @@ hsForeignDeclsBinders foreign_decls hsPatSynSelectors :: HsValBinds p -> [IdP p] -- Collects record pattern-synonym selectors only; the pattern synonym -- names are collected by collectHsValBinders. -hsPatSynSelectors (ValBindsIn _ _ _) = panic "hsPatSynSelectors" +hsPatSynSelectors (ValBindsIn _ _) = panic "hsPatSynSelectors" hsPatSynSelectors (ValBindsOut binds _) = foldrBag addPatSynSelector [] . unionManyBags $ map snd binds @@ -1128,11 +1123,11 @@ hsConDeclsBinders cons = go id cons 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)))])) _) + L _ (HsFunTy + (L _ (HsAppsTy + [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _res_ty) -> record_gadt flds - L _ (HsFunTy _ (L _ (HsRecTy _ flds)) _res_ty) + L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty) -> record_gadt flds _other -> (map (L loc . unLoc) names ++ ns, fs) @@ -1218,7 +1213,7 @@ lStmtsImplicits = hs_lstmts hsValBindsImplicits :: HsValBindsLR GhcRn idR -> NameSet hsValBindsImplicits (ValBindsOut binds _) = foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds -hsValBindsImplicits (ValBindsIn _ binds _) +hsValBindsImplicits (ValBindsIn binds _) = lhsBindsImplicits binds lhsBindsImplicits :: LHsBindsLR GhcRn idR -> NameSet @@ -1234,17 +1229,18 @@ 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 (SigPat _ 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 (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 (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 55778d9adf..0b4711a364 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs @@ -6,10 +6,10 @@ module PlaceHolder where -import GhcPrelude ( Eq(..), Ord(..) ) +import GhcPrelude () import Type ( Type ) -import Outputable hiding ( (<>) ) +import Outputable import Name import NameSet import RdrName @@ -31,10 +31,7 @@ import Data.Data hiding ( Fixity ) -- | used as place holder in PostTc and PostRn values data PlaceHolder = PlaceHolder - deriving (Data,Eq,Ord) - -instance Outputable PlaceHolder where - ppr _ = text "PlaceHolder" + deriving (Data) placeHolderKind :: PlaceHolder placeHolderKind = PlaceHolder |