diff options
26 files changed, 270 insertions, 309 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index 92c1d1315b..20533a8516 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -36,6 +36,7 @@ module BasicTypes( defaultFixity, maxPrecedence, minPrecedence, negateFixity, funTyFixity, compareFixity, + LexicalFixity(..), RecFlag(..), isRec, isNonRec, boolToRecFlag, Origin(..), isGenerated, @@ -107,7 +108,7 @@ import FastString import Outputable import SrcLoc ( Located,unLoc ) import StaticFlags( opt_PprStyle_Debug ) -import Data.Data hiding (Fixity) +import Data.Data hiding (Fixity, Prefix, Infix) import Data.Function (on) {- @@ -433,6 +434,15 @@ compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2) left = (False, False) error_please = (True, False) +-- |Captures the fixity of declarations as they are parsed. This is not +-- necessarily the same as the fixity declaration, as the normal fixity may be +-- overridden using parens or backticks. +data LexicalFixity = Prefix | Infix deriving (Typeable,Data,Eq) + +instance Outputable LexicalFixity where + ppr Prefix = text "Prefix" + ppr Infix = text "Infix" + {- ************************************************************************ * * diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 2409db856a..efd04283ab 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -182,8 +182,9 @@ cvtDec (TySynD tc tvs rhs) = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs ; rhs' <- cvtType rhs ; returnJustL $ TyClD $ - SynDecl { tcdLName = tc' - , tcdTyVars = tvs', tcdFVs = placeHolderNames + SynDecl { tcdLName = tc', tcdTyVars = tvs' + , tcdFixity = Prefix + , tcdFVs = placeHolderNames , tcdRhs = rhs' } } cvtDec (DataD ctxt tc tvs ksig constrs derivs) @@ -207,6 +208,7 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs) , dd_kindSig = ksig' , dd_cons = cons', dd_derivs = derivs' } ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' + , tcdFixity = Prefix , tcdDataDefn = defn , tcdDataCusk = PlaceHolder , tcdFVs = placeHolderNames }) } @@ -222,6 +224,7 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) , dd_cons = [con'] , dd_derivs = derivs' } ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' + , tcdFixity = Prefix , tcdDataDefn = defn , tcdDataCusk = PlaceHolder , tcdFVs = placeHolderNames }) } @@ -237,6 +240,7 @@ cvtDec (ClassD ctxt cl tvs fds decs) ; at_defs <- mapM cvt_at_def ats' ; returnJustL $ TyClD $ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' + , tcdFixity = Prefix , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' , tcdMeths = binds' , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] @@ -282,7 +286,7 @@ cvtDec (DataFamilyD tc tvs kind) = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs ; result <- cvtMaybeKindToFamilyResultSig kind ; returnJustL $ TyClD $ FamDecl $ - FamilyDecl DataFamily tc' tvs' result Nothing } + FamilyDecl DataFamily tc' tvs' Prefix result Nothing } cvtDec (DataInstD ctxt tc tys ksig constrs derivs) = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys @@ -297,6 +301,7 @@ cvtDec (DataInstD ctxt tc tys ksig constrs derivs) ; returnJustL $ InstD $ DataFamInstD { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats' , dfid_defn = defn + , dfid_fixity = Prefix , dfid_fvs = placeHolderNames } }} cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs) @@ -311,6 +316,7 @@ cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs) ; returnJustL $ InstD $ DataFamInstD { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats' , dfid_defn = defn + , dfid_fixity = Prefix , dfid_fvs = placeHolderNames } }} cvtDec (TySynInstD tc eqn) @@ -323,13 +329,13 @@ cvtDec (TySynInstD tc eqn) cvtDec (OpenTypeFamilyD head) = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head ; returnJustL $ TyClD $ FamDecl $ - FamilyDecl OpenTypeFamily tc' tyvars' result' injectivity' } + FamilyDecl OpenTypeFamily tc' tyvars' Prefix result' injectivity' } cvtDec (ClosedTypeFamilyD head eqns) = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head ; eqns' <- mapM (cvtTySynEqn tc') eqns ; returnJustL $ TyClD $ FamDecl $ - FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tyvars' result' + FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix result' injectivity' } cvtDec (TH.RoleAnnotD tc roles) @@ -384,6 +390,7 @@ cvtTySynEqn tc (TySynEqn lhs rhs) ; rhs' <- cvtType rhs ; returnL $ TyFamEqn { tfe_tycon = tc , tfe_pats = mkHsImplicitBndrs lhs' + , tfe_fixity = Prefix , tfe_rhs = rhs' } } ---------------- diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index eeb446e838..1f58bbfc11 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -22,7 +22,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, GRHSs, pprPatBind ) import {-# SOURCE #-} HsPat ( LPat ) -import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId,HasOccNameId ) +import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId ) import HsTypes import PprCore () import CoreSyn @@ -437,15 +437,13 @@ Specifically, it's just an error thunk -} -instance (OutputableBndrId idL, OutputableBndrId idR, - HasOccNameId idL, HasOccNameId idR) +instance (OutputableBndrId idL, OutputableBndrId idR) => Outputable (HsLocalBindsLR idL idR) where ppr (HsValBinds bs) = ppr bs ppr (HsIPBinds bs) = ppr bs ppr EmptyLocalBinds = empty -instance (OutputableBndrId idL, OutputableBndrId idR, - HasOccNameId idL, HasOccNameId idR) +instance (OutputableBndrId idL, OutputableBndrId idR) => Outputable (HsValBindsLR idL idR) where ppr (ValBindsIn binds sigs) = pprDeclList (pprLHsBindsForUser binds sigs) @@ -461,16 +459,14 @@ instance (OutputableBndrId idL, OutputableBndrId idR, pp_rec Recursive = text "rec" pp_rec NonRecursive = text "nonrec" -pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR, - HasOccNameId idL, HasOccNameId idR) +pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR) => LHsBindsLR idL idR -> SDoc pprLHsBinds binds | isEmptyLHsBinds binds = empty | otherwise = pprDeclList (map ppr (bagToList binds)) pprLHsBindsForUser :: (OutputableBndrId idL, OutputableBndrId idR, - OutputableBndrId id2, HasOccNameId id2, - HasOccNameId idL, HasOccNameId idR) + 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 @@ -561,13 +557,11 @@ So the desugarer tries to do a better job: in (fm,gm) -} -instance (OutputableBndrId idL, OutputableBndrId idR, - HasOccNameId idL, HasOccNameId idR) +instance (OutputableBndrId idL, OutputableBndrId idR) => Outputable (HsBindLR idL idR) where ppr mbind = ppr_monobind mbind -ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR, - HasOccNameId idL, HasOccNameId idR) +ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR) => HsBindLR idL idR -> SDoc ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) @@ -623,7 +617,7 @@ instance (OutputableBndr id) => Outputable (ABExport id) where , nest 2 (pprTcSpecPrags prags) , nest 2 (text "wrap:" <+> ppr wrap)] -instance (OutputableBndr idL, OutputableBndrId idR, HasOccNameId idR) +instance (OutputableBndr idL, OutputableBndrId idR) => Outputable (PatSynBind idL idR) where ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, psb_dir = dir }) @@ -695,12 +689,11 @@ data IPBind id = IPBind (Either (Located HsIPName) id) (LHsExpr id) deriving instance (DataId name) => Data (IPBind name) -instance (OutputableBndrId id, HasOccNameId id) - => Outputable (HsIPBinds id) where +instance (OutputableBndrId id ) => Outputable (HsIPBinds id) where ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) $$ ifPprDebug (ppr ds) -instance (OutputableBndrId id, HasOccNameId id) => Outputable (IPBind id) where +instance (OutputableBndrId id ) => Outputable (IPBind id) where ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) where name = case lr of Left (L _ ip) -> pprBndr LetBind ip @@ -957,11 +950,10 @@ 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 (OutputableBndrId name, HasOccNameId name) - => Outputable (Sig name) where +instance (OutputableBndrId name ) => Outputable (Sig name) where ppr sig = ppr_sig sig -ppr_sig :: (OutputableBndrId name, HasOccNameId name) => Sig name -> SDoc +ppr_sig :: (OutputableBndrId name ) => Sig name -> 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) @@ -1021,7 +1013,7 @@ instance Outputable TcSpecPrag where ppr (SpecPrag var _ inl) = text "SPECIALIZE" <+> pprSpec var (text "<type>") inl -pprMinimalSig :: (OutputableBndr name, HasOccName name) +pprMinimalSig :: (OutputableBndr name) => LBooleanFormula (Located name) -> SDoc pprMinimalSig (L _ bf) = text "MINIMAL" <+> ppr (fmap unLoc bf) diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index c82cd8b0f2..e3029a23f5 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -98,8 +98,7 @@ import Name import BasicTypes import Coercion import ForeignCall -import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId, OutputableBndrId, - HasOccNameId ) +import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId, OutputableBndrId ) import NameSet -- others: @@ -111,7 +110,7 @@ import SrcLoc import Bag import Maybes -import Data.Data hiding (TyCon,Fixity) +import Data.Data hiding (TyCon,Fixity, Infix) {- ************************************************************************ @@ -252,8 +251,7 @@ appendGroups hs_vects = vects1 ++ vects2, hs_docs = docs1 ++ docs2 } -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (HsDecl name) where +instance (OutputableBndrId name) => Outputable (HsDecl name) where ppr (TyClD dcl) = ppr dcl ppr (ValD binds) = ppr binds ppr (DefD def) = ppr def @@ -269,8 +267,7 @@ instance (OutputableBndrId name, HasOccNameId name) ppr (DocD doc) = ppr doc ppr (RoleAnnotD ra) = ppr ra -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (HsGroup name) where +instance (OutputableBndrId name) => Outputable (HsGroup name) where ppr (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_derivds = deriv_decls, @@ -314,8 +311,7 @@ data SpliceDecl id SpliceExplicitFlag deriving instance (DataId id) => Data (SpliceDecl id) -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (SpliceDecl name) where +instance (OutputableBndrId name) => Outputable (SpliceDecl name) where ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f {- @@ -484,6 +480,7 @@ data TyClDecl name SynDecl { tcdLName :: Located name -- ^ Type constructor , tcdTyVars :: LHsQTyVars name -- ^ Type variables; for an associated type -- these include outer binders + , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration , tcdRhs :: LHsType name -- ^ RHS of type declaration , tcdFVs :: PostRn name NameSet } @@ -504,6 +501,7 @@ data TyClDecl name -- type F a = a -> a -- Here the type decl for 'f' includes 'a' -- in its tcdTyVars + , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration , tcdDataDefn :: HsDataDefn name , tcdDataCusk :: PostRn name Bool -- ^ does this have a CUSK? , tcdFVs :: PostRn name NameSet } @@ -511,6 +509,7 @@ data TyClDecl name | ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context... tcdLName :: Located name, -- ^ Name of the class tcdTyVars :: LHsQTyVars name, -- ^ Class type variables + tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration tcdFDs :: [Located (FunDep (Located name))], -- ^ Functional deps tcdSigs :: [LSig name], -- ^ Methods' signatures @@ -633,19 +632,21 @@ hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars -- Pretty-printing TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~ -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (TyClDecl name) where +instance (OutputableBndrId name) => Outputable (TyClDecl name) where ppr (FamDecl { tcdFam = decl }) = ppr decl - ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdRhs = rhs }) + ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity + , tcdRhs = rhs }) = hang (text "type" <+> - pp_vanilla_decl_head ltycon tyvars [] <+> equals) + pp_vanilla_decl_head ltycon tyvars fixity [] <+> equals) 4 (ppr rhs) - ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdDataDefn = defn }) - = pp_data_defn (pp_vanilla_decl_head ltycon tyvars) defn + ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity + , tcdDataDefn = defn }) + = pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, + tcdFixity = fixity, tcdFDs = fds, tcdSigs = sigs, tcdMeths = methods, tcdATs = ats, tcdATDefs = at_defs}) @@ -659,11 +660,10 @@ instance (OutputableBndrId name, HasOccNameId name) pprLHsBindsForUser methods sigs) ] where top_matter = text "class" - <+> pp_vanilla_decl_head lclas tyvars (unLoc context) - <+> pprFundeps (map unLoc fds) + <+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context) + <+> pprFundeps (map unLoc fds) -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (TyClGroup name) where +instance (OutputableBndrId name) => Outputable (TyClGroup name) where ppr (TyClGroup { group_tyclds = tyclds , group_roles = roles , group_instds = instds @@ -673,16 +673,16 @@ instance (OutputableBndrId name, HasOccNameId name) ppr roles $$ ppr instds -pp_vanilla_decl_head :: (OutputableBndrId name, HasOccNameId name) - => Located name +pp_vanilla_decl_head :: (OutputableBndrId name) => Located name -> LHsQTyVars name + -> LexicalFixity -> HsContext name -> SDoc -pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) context +pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context = hsep [pprHsContext context, pp_tyvars tyvars] where pp_tyvars (varl:varsr) - | isSymOcc $ occName (unLoc thing) + | fixity == Infix = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing) , hsep (map (ppr.unLoc) varsr)] | otherwise = hsep [ pprPrefixOcc (unLoc thing) @@ -892,6 +892,7 @@ data FamilyDecl name = FamilyDecl { fdInfo :: FamilyInfo name -- type/data, closed/open , fdLName :: Located name -- type constructor , fdTyVars :: LHsQTyVars name -- type variables + , fdFixity :: LexicalFixity -- Fixity used in the declaration , fdResultSig :: LFamilyResultSig name -- result signature , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann } @@ -955,18 +956,18 @@ resultVariableName :: FamilyResultSig a -> Maybe a resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig resultVariableName _ = Nothing -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (FamilyDecl name) where +instance (OutputableBndrId name) => Outputable (FamilyDecl name) where ppr = pprFamilyDecl TopLevel -pprFamilyDecl :: (OutputableBndrId name, HasOccNameId name) +pprFamilyDecl :: (OutputableBndrId name) => TopLevelFlag -> FamilyDecl name -> SDoc pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon , fdTyVars = tyvars + , fdFixity = fixity , fdResultSig = L _ result , fdInjectivityAnn = mb_inj }) = vcat [ pprFlavour info <+> pp_top_level <+> - pp_vanilla_decl_head ltycon tyvars [] <+> + pp_vanilla_decl_head ltycon tyvars fixity [] <+> pp_kind <+> pp_inj <+> pp_where , nest 2 $ pp_eqns ] where @@ -1076,7 +1077,7 @@ data HsDerivingClause name } deriving instance (DataId id) => Data (HsDerivingClause id) -instance (OutputableBndrId name, HasOccNameId name) +instance (OutputableBndrId name) => Outputable (HsDerivingClause name) where ppr (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L _ dct }) @@ -1193,7 +1194,7 @@ hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) -pp_data_defn :: (OutputableBndrId name, HasOccNameId name) +pp_data_defn :: (OutputableBndrId name) => (HsContext name -> SDoc) -- Printing the header -> HsDataDefn name -> SDoc @@ -1217,27 +1218,23 @@ 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 (OutputableBndrId name, HasOccNameId name) - => Outputable (HsDataDefn name) where +instance (OutputableBndrId name) => Outputable (HsDataDefn name) where ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d instance Outputable NewOrData where ppr NewType = text "newtype" ppr DataType = text "data" -pp_condecls :: (OutputableBndrId name, HasOccNameId name) - => [LConDecl name] -> SDoc +pp_condecls :: (OutputableBndrId name) => [LConDecl name] -> 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 (OutputableBndrId name, HasOccNameId name) - => Outputable (ConDecl name) where +instance (OutputableBndrId name) => Outputable (ConDecl name) where ppr = pprConDecl -pprConDecl :: (OutputableBndrId name, HasOccNameId name) - => ConDecl name -> SDoc +pprConDecl :: (OutputableBndrId name) => ConDecl name -> SDoc pprConDecl (ConDeclH98 { con_name = L _ con , con_qvars = mtvs , con_cxt = mcxt @@ -1348,9 +1345,10 @@ type TyFamDefltEqn name = TyFamEqn name (LHsQTyVars name) -- See Note [Type family instance declarations in HsSyn] data TyFamEqn name pats = TyFamEqn - { tfe_tycon :: Located name - , tfe_pats :: pats - , tfe_rhs :: LHsType name } + { tfe_tycon :: Located name + , tfe_pats :: pats + , tfe_fixity :: LexicalFixity -- ^ Fixity used in the declaration + , tfe_rhs :: LHsType name } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' @@ -1382,6 +1380,7 @@ data DataFamInstDecl name = DataFamInstDecl { dfid_tycon :: Located name , dfid_pats :: HsTyPats name -- LHS + , dfid_fixity :: LexicalFixity -- ^ Fixity used in the declaration , dfid_defn :: HsDataDefn name -- RHS , dfid_fvs :: PostRn name NameSet } -- Free vars for dependency analysis -- ^ @@ -1440,11 +1439,10 @@ data InstDecl name -- Both class and family instances { tfid_inst :: TyFamInstDecl name } deriving instance (DataId id) => Data (InstDecl id) -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (TyFamInstDecl name) where +instance (OutputableBndrId name) => Outputable (TyFamInstDecl name) where ppr = pprTyFamInstDecl TopLevel -pprTyFamInstDecl :: (OutputableBndrId name, HasOccNameId name) +pprTyFamInstDecl :: (OutputableBndrId name) => TopLevelFlag -> TyFamInstDecl name -> SDoc pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn @@ -1453,56 +1451,57 @@ ppr_instance_keyword :: TopLevelFlag -> SDoc ppr_instance_keyword TopLevel = text "instance" ppr_instance_keyword NotTopLevel = empty -ppr_fam_inst_eqn :: (OutputableBndrId name, HasOccNameId name) - => LTyFamInstEqn name -> SDoc +ppr_fam_inst_eqn :: (OutputableBndrId name) => LTyFamInstEqn name -> SDoc ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon , tfe_pats = pats + , tfe_fixity = fixity , tfe_rhs = rhs })) - = pp_fam_inst_lhs tycon pats [] <+> equals <+> ppr rhs + = pp_fam_inst_lhs tycon pats fixity [] <+> equals <+> ppr rhs -ppr_fam_deflt_eqn :: (OutputableBndrId name, HasOccNameId name) - => LTyFamDefltEqn name -> SDoc +ppr_fam_deflt_eqn :: (OutputableBndrId name) => LTyFamDefltEqn name -> SDoc ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon , tfe_pats = tvs + , tfe_fixity = fixity , tfe_rhs = rhs })) - = text "type" <+> pp_vanilla_decl_head tycon tvs [] <+> equals <+> ppr rhs + = text "type" <+> pp_vanilla_decl_head tycon tvs fixity [] + <+> equals <+> ppr rhs -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (DataFamInstDecl name) where +instance (OutputableBndrId name) => Outputable (DataFamInstDecl name) where ppr = pprDataFamInstDecl TopLevel -pprDataFamInstDecl :: (OutputableBndrId name, HasOccNameId name) +pprDataFamInstDecl :: (OutputableBndrId name) => TopLevelFlag -> DataFamInstDecl name -> SDoc pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_tycon = tycon , dfid_pats = pats + , dfid_fixity = fixity , dfid_defn = defn }) = pp_data_defn pp_hdr defn where - pp_hdr ctxt = ppr_instance_keyword top_lvl <+> pp_fam_inst_lhs tycon pats ctxt + pp_hdr ctxt = ppr_instance_keyword top_lvl + <+> pp_fam_inst_lhs tycon pats fixity ctxt pprDataFamInstFlavour :: DataFamInstDecl name -> SDoc pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) }) = ppr nd -pp_fam_inst_lhs :: (OutputableBndrId name, HasOccNameId name) - => Located name +pp_fam_inst_lhs :: (OutputableBndrId name) => Located name -> HsTyPats name + -> LexicalFixity -> HsContext name -> SDoc -pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) context +pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) fixity context -- explicit type patterns = hsep [ pprHsContext context, pp_pats typats] where pp_pats (patl:patsr) - | isSymOcc $ occName (unLoc thing) + | fixity == Infix = hsep [pprParendHsType (unLoc patl), pprInfixOcc (unLoc thing) , hsep (map (pprParendHsType.unLoc) patsr)] | otherwise = hsep [ pprPrefixOcc (unLoc thing) , hsep (map (pprParendHsType.unLoc) (patl:patsr))] pp_pats [] = empty -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (ClsInstDecl name) where +instance (OutputableBndrId name) => Outputable (ClsInstDecl name) where ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats , cid_overlap_mode = mbOverlap @@ -1540,8 +1539,7 @@ ppOverlapPragma mb = maybe_stext (SourceText src) _ = text src <+> text "#-}" -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (InstDecl name) where +instance (OutputableBndrId name) => Outputable (InstDecl name) where ppr (ClsInstD { cid_inst = decl }) = ppr decl ppr (TyFamInstD { tfid_inst = decl }) = ppr decl ppr (DataFamInstD { dfid_inst = decl }) = ppr decl @@ -1582,8 +1580,7 @@ data DerivDecl name = DerivDecl } deriving instance (DataId name) => Data (DerivDecl name) -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (DerivDecl name) where +instance (OutputableBndrId name) => Outputable (DerivDecl name) where ppr (DerivDecl { deriv_type = ty , deriv_strategy = ds , deriv_overlap_mode = o }) @@ -1617,8 +1614,7 @@ data DefaultDecl name -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId name) => Data (DefaultDecl name) -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (DefaultDecl name) where +instance (OutputableBndrId name) => Outputable (DefaultDecl name) where ppr (DefaultDecl tys) = text "default" <+> parens (interpp'SP tys) @@ -1721,8 +1717,7 @@ data ForeignExport = CExport (Located CExportSpec) -- contains the calling -- pretty printing of foreign declarations -- -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (ForeignDecl name) where +instance (OutputableBndrId name) => Outputable (ForeignDecl name) 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) @@ -1828,14 +1823,12 @@ collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] pprFullRuleName :: Located (SourceText, RuleName) -> SDoc pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (RuleDecls name) where +instance (OutputableBndrId name) => Outputable (RuleDecls name) where ppr (HsRules st rules) = pprWithSourceText st (text "{-# RULES") <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (RuleDecl name) where +instance (OutputableBndrId name) => Outputable (RuleDecl name) where ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs) = sep [pprFullRuleName name <+> ppr act, nest 4 (pp_forall <+> pprExpr (unLoc lhs)), @@ -1844,8 +1837,7 @@ instance (OutputableBndrId name, HasOccNameId name) pp_forall | null ns = empty | otherwise = forAllLit <+> fsep (map ppr ns) <> dot -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (RuleBndr name) where +instance (OutputableBndrId name) => Outputable (RuleBndr name) where ppr (RuleBndr name) = ppr name ppr (RuleBndrSig name ty) = parens (ppr name <> dcolon <> ppr ty) @@ -1932,8 +1924,7 @@ lvectInstDecl (L _ (HsVectInstIn _)) = True lvectInstDecl (L _ (HsVectInstOut _)) = True lvectInstDecl _ = False -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (VectDecl name) where +instance (OutputableBndrId name) => Outputable (VectDecl name) where ppr (HsVect _ v rhs) = sep [text "{-# VECTORISE" <+> ppr v, nest 4 $ @@ -2054,8 +2045,7 @@ data AnnDecl name = HsAnnotation -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId name) => Data (AnnDecl name) -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (AnnDecl name) where +instance (OutputableBndrId name) => Outputable (AnnDecl name) 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 78ee4e05a0..8cead39c68 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -22,7 +22,7 @@ import HsDecls import HsPat import HsLit import PlaceHolder ( PostTc,PostRn,DataId,DataIdPost, - NameOrRdrName,OutputableBndrId, HasOccNameId ) + NameOrRdrName,OutputableBndrId ) import HsTypes import HsBinds @@ -134,8 +134,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 (OutputableBndrId id, HasOccNameId id) - => Outputable (SyntaxExpr id) where +instance (OutputableBndrId id) => Outputable (SyntaxExpr id) where ppr (SyntaxExpr { syn_expr = expr , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) @@ -771,17 +770,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 (OutputableBndrId id, HasOccNameId id) - => Outputable (HsExpr id) where +instance (OutputableBndrId id) => Outputable (HsExpr id) where ppr expr = pprExpr expr ----------------------- -- pprExpr, pprLExpr, pprBinds call pprDeeper; -- the underscore versions do not -pprLExpr :: (OutputableBndrId id, HasOccNameId id) => LHsExpr id -> SDoc +pprLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc pprLExpr (L _ e) = pprExpr e -pprExpr :: (OutputableBndrId id,HasOccNameId id) => HsExpr id -> SDoc +pprExpr :: (OutputableBndrId id) => HsExpr id -> SDoc pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e | otherwise = pprDeeper (ppr_expr e) @@ -797,17 +795,15 @@ isQuietHsExpr (HsAppTypeOut _ _) = True isQuietHsExpr (OpApp _ _ _ _) = True isQuietHsExpr _ = False -pprBinds :: (OutputableBndrId idL, OutputableBndrId idR, - HasOccNameId idL, HasOccNameId idR) +pprBinds :: (OutputableBndrId idL, OutputableBndrId idR) => HsLocalBindsLR idL idR -> SDoc pprBinds b = pprDeeper (ppr b) ----------------------- -ppr_lexpr :: (OutputableBndrId id,HasOccNameId id) => LHsExpr id -> SDoc +ppr_lexpr :: (OutputableBndrId id) => LHsExpr id -> SDoc ppr_lexpr e = ppr_expr (unLoc e) -ppr_expr :: forall id. (OutputableBndrId id,HasOccNameId id) - => HsExpr id -> SDoc +ppr_expr :: forall id. (OutputableBndrId id) => HsExpr id -> SDoc ppr_expr (HsVar (L _ v)) = pprPrefixOcc v ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv) ppr_expr (HsIPVar v) = ppr v @@ -1010,11 +1006,9 @@ 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 id. (OutputableBndrId id, HasOccNameId id) - => LHsWcTypeX (LHsWcType id) +data LHsWcTypeX = forall id. (OutputableBndrId id) => LHsWcTypeX (LHsWcType id) -ppr_apps :: (OutputableBndrId id,HasOccNameId id) - => HsExpr id +ppr_apps :: (OutputableBndrId id) => HsExpr id -> [Either (LHsExpr id) LHsWcTypeX] -> SDoc ppr_apps (HsApp (L _ fun) arg) args @@ -1045,17 +1039,16 @@ fixities should do the job, except in debug mode (-dppr-debug) so we can see the structure of the parse tree. -} -pprDebugParendExpr :: (OutputableBndrId id, HasOccNameId id) - => LHsExpr id -> SDoc +pprDebugParendExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc pprDebugParendExpr expr = getPprStyle (\sty -> if debugStyle sty then pprParendLExpr expr else pprLExpr expr) -pprParendLExpr :: (OutputableBndrId id, HasOccNameId id) => LHsExpr id -> SDoc +pprParendLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc pprParendLExpr (L _ e) = pprParendExpr e -pprParendExpr :: (OutputableBndrId id, HasOccNameId id) => HsExpr id -> SDoc +pprParendExpr :: (OutputableBndrId id) => HsExpr id -> SDoc pprParendExpr expr | hsExprNeedsParens expr = parens (pprExpr expr) | otherwise = pprExpr expr @@ -1139,7 +1132,7 @@ data HsCmd id (LHsExpr id) -- The operator. -- After type-checking, a type abstraction to be -- applied to the type of the local environment tuple - FunctionFixity -- Whether the operator appeared prefix or infix when + LexicalFixity -- Whether the operator appeared prefix or infix when -- parsed. (Maybe Fixity) -- fixity (filled in by the renamer), for forms that -- were converted from OpApp's by the renamer @@ -1223,17 +1216,16 @@ data HsCmdTop id (CmdSyntaxTable id) -- See Note [CmdSyntaxTable] deriving instance (DataId id) => Data (HsCmdTop id) -instance (OutputableBndrId id, HasOccNameId id) => Outputable (HsCmd id) where +instance (OutputableBndrId id) => Outputable (HsCmd id) where ppr cmd = pprCmd cmd ----------------------- -- pprCmd and pprLCmd call pprDeeper; -- the underscore versions do not -pprLCmd :: (OutputableBndrId id, HasOccName id, HasOccName (NameOrRdrName id)) - => LHsCmd id -> SDoc +pprLCmd :: (OutputableBndrId id) => LHsCmd id -> SDoc pprLCmd (L _ c) = pprCmd c -pprCmd :: (OutputableBndrId id, HasOccNameId id) => HsCmd id -> SDoc +pprCmd :: (OutputableBndrId id) => HsCmd id -> SDoc pprCmd c | isQuietHsCmd c = ppr_cmd c | otherwise = pprDeeper (ppr_cmd c) @@ -1247,11 +1239,10 @@ isQuietHsCmd (HsCmdApp _ _) = True isQuietHsCmd _ = False ----------------------- -ppr_lcmd :: (OutputableBndrId id, HasOccNameId id) => LHsCmd id -> SDoc +ppr_lcmd :: (OutputableBndrId id) => LHsCmd id -> SDoc ppr_lcmd c = ppr_cmd (unLoc c) -ppr_cmd :: forall id. (OutputableBndrId id, HasOccNameId id) - => HsCmd id -> SDoc +ppr_cmd :: forall id. (OutputableBndrId id) => HsCmd id -> SDoc ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c) ppr_cmd (HsCmdApp c e) @@ -1306,12 +1297,11 @@ ppr_cmd (HsCmdArrForm op _ _ args) = hang (text "(|" <> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <> text "|)") -pprCmdArg :: (OutputableBndrId id, HasOccNameId id) => HsCmdTop id -> SDoc +pprCmdArg :: (OutputableBndrId id) => HsCmdTop id -> SDoc pprCmdArg (HsCmdTop cmd _ _ _) = ppr_lcmd cmd -instance (OutputableBndrId id, HasOccNameId id) - => Outputable (HsCmdTop id) where +instance (OutputableBndrId id) => Outputable (HsCmdTop id) where ppr = pprCmdArg {- @@ -1376,7 +1366,7 @@ data Match id body } deriving instance (Data body,DataId id) => Data (Match id body) -instance (OutputableBndrId idR, HasOccNameId idR, Outputable body) +instance (OutputableBndrId idR, Outputable body) => Outputable (Match idR body) where ppr = pprMatch @@ -1471,29 +1461,26 @@ deriving instance (Data body,DataId id) => Data (GRHS id body) -- We know the list must have at least one @Match@ in it. -pprMatches :: (OutputableBndrId idR, HasOccNameId idR, Outputable body) +pprMatches :: (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 :: (OutputableBndrId idR, HasOccNameId idR, Outputable body) +pprFunBind :: (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 id body. (OutputableBndrId bndr, OutputableBndrId id, - HasOccNameId id, - HasOccNameId bndr, Outputable body) => LPat bndr -> GRHSs id body -> SDoc pprPatBind pat (grhss) = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)] -pprMatch :: (OutputableBndrId idR, HasOccNameId idR, Outputable body) - => Match idR body -> SDoc +pprMatch :: (OutputableBndrId idR, Outputable body) => Match idR body -> SDoc pprMatch match = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats) , nest 2 ppr_maybe_ty @@ -1528,7 +1515,7 @@ pprMatch match Nothing -> empty -pprGRHSs :: (OutputableBndrId idR, HasOccNameId idR, Outputable body) +pprGRHSs :: (OutputableBndrId idR, Outputable body) => HsMatchContext idL -> GRHSs idR body -> SDoc pprGRHSs ctxt (GRHSs grhss (L _ binds)) = vcat (map (pprGRHS ctxt . unLoc) grhss) @@ -1537,7 +1524,7 @@ pprGRHSs ctxt (GRHSs grhss (L _ binds)) $$ ppUnless (eqEmptyLocalBinds binds) (text "where" $$ nest 4 (pprBinds binds)) -pprGRHS :: (OutputableBndrId idR, HasOccNameId idR, Outputable body) +pprGRHS :: (OutputableBndrId idR, Outputable body) => HsMatchContext idL -> GRHS idR body -> SDoc pprGRHS ctxt (GRHS [] body) = pp_rhs ctxt body @@ -1883,17 +1870,14 @@ In any other context than 'MonadComp', the fields for most of these 'SyntaxExpr's stay bottom. -} -instance (OutputableBndrId idL, HasOccNameId idL) - => Outputable (ParStmtBlock idL idR) where +instance (OutputableBndrId idL) => Outputable (ParStmtBlock idL idR) where ppr (ParStmtBlock stmts _ _) = interpp'SP stmts -instance (OutputableBndrId idL, OutputableBndrId idR, - HasOccNameId idL, HasOccNameId idR, Outputable body) +instance (OutputableBndrId idL, OutputableBndrId idR, Outputable body) => Outputable (StmtLR idL idR body) where ppr stmt = pprStmt stmt pprStmt :: forall idL idR body . (OutputableBndrId idL, OutputableBndrId idR, - HasOccNameId idL, HasOccNameId idR, Outputable body) => (StmtLR idL idR body) -> SDoc pprStmt (LastStmt expr ret_stripped _) @@ -1957,7 +1941,7 @@ pprStmt (ApplicativeStmt args mb_join _) (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)])) (error "pprStmt")) -pprTransformStmt :: (OutputableBndrId id, HasOccNameId id) +pprTransformStmt :: (OutputableBndrId id) => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc pprTransformStmt bndrs using by = sep [ text "then" <+> ifPprDebug (braces (ppr bndrs)) @@ -1974,7 +1958,7 @@ pprBy :: Outputable body => Maybe body -> SDoc pprBy Nothing = empty pprBy (Just e) = text "by" <+> ppr e -pprDo :: (OutputableBndrId id, HasOccNameId id, Outputable body) +pprDo :: (OutputableBndrId id, Outputable body) => HsStmtContext any -> [LStmt id body] -> SDoc pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts @@ -1985,14 +1969,12 @@ pprDo PArrComp stmts = paBrackets $ pprComp stmts pprDo MonadComp stmts = brackets $ pprComp stmts pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt -ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, - HasOccNameId idL, HasOccNameId idR, Outputable body) +ppr_do_stmts :: (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 :: (OutputableBndrId id, HasOccNameId id, Outputable body) - => [LStmt id body] -> SDoc +pprComp :: (OutputableBndrId id, Outputable body) => [LStmt id body] -> SDoc pprComp quals -- Prints: body | qual1, ..., qualn | Just (initStmts, L _ (LastStmt body _ _)) <- snocView quals = if null initStmts @@ -2006,8 +1988,7 @@ pprComp quals -- Prints: body | qual1, ..., qualn | otherwise = pprPanic "pprComp" (pprQuals quals) -pprQuals :: (OutputableBndrId id, HasOccNameId id, Outputable body) - => [LStmt id body] -> SDoc +pprQuals :: (OutputableBndrId id, Outputable body) => [LStmt id body] -> SDoc -- Show list comprehension qualifiers separated by commas pprQuals quals = interpp'SP quals @@ -2181,33 +2162,29 @@ splices. In contrast, when pretty printing the output of the type checker, we sense, although I hate to add another constructor to HsExpr. -} -instance (OutputableBndrId id, HasOccNameId id) - => Outputable (HsSplicedThing id) where +instance (OutputableBndrId id) => Outputable (HsSplicedThing id) where ppr (HsSplicedExpr e) = ppr_expr e ppr (HsSplicedTy t) = ppr t ppr (HsSplicedPat p) = ppr p -instance (OutputableBndrId id, HasOccNameId id) - => Outputable (HsSplice id) where +instance (OutputableBndrId id) => Outputable (HsSplice id) where ppr s = pprSplice s -pprPendingSplice :: (OutputableBndrId id, HasOccNameId id) +pprPendingSplice :: (OutputableBndrId id) => SplicePointName -> LHsExpr id -> SDoc pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e) -pprSpliceDecl :: (OutputableBndrId id, HasOccNameId id) +pprSpliceDecl :: (OutputableBndrId id) => HsSplice id -> 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 :: (OutputableBndrId id, HasOccNameId id) - => HsSplice id -> SDoc +ppr_splice_decl :: (OutputableBndrId id) => HsSplice id -> SDoc ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty ppr_splice_decl e = pprSplice e -pprSplice :: (OutputableBndrId id, HasOccNameId id) - => HsSplice id -> SDoc +pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc pprSplice (HsTypedSplice HasParens n e) = ppr_splice (text "$$(") n e (text ")") pprSplice (HsTypedSplice NoParens n e) @@ -2224,7 +2201,7 @@ ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <> char '[' <> ppr quoter <> vbar <> ppr quote <> text "|]" -ppr_splice :: (OutputableBndrId id, HasOccNameId id) +ppr_splice :: (OutputableBndrId id) => SDoc -> id -> LHsExpr id -> SDoc -> SDoc ppr_splice herald n e trail = herald <> ifPprDebug (brackets (ppr n)) <> ppr e <> trail @@ -2244,21 +2221,20 @@ isTypedBracket :: HsBracket id -> Bool isTypedBracket (TExpBr {}) = True isTypedBracket _ = False -instance (OutputableBndrId id, HasOccNameId id) - => Outputable (HsBracket id) where +instance (OutputableBndrId id) => Outputable (HsBracket id) where ppr = pprHsBracket -pprHsBracket :: (OutputableBndrId id, HasOccNameId id) => HsBracket id -> SDoc +pprHsBracket :: (OutputableBndrId id) => HsBracket id -> SDoc pprHsBracket (ExpBr e) = thBrackets empty (ppr e) pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp) pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds)) pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) pprHsBracket (VarBr True n) - = char '\'' <> pprPrefixVar (isSymOcc $ occName n) (ppr n) + = char '\'' <> pprPrefixOcc n pprHsBracket (VarBr False n) - = text "''" <> pprPrefixVar (isSymOcc $ occName n) (ppr n) + = text "''" <> pprPrefixOcc n pprHsBracket (TExpBr e) = thTyBrackets (ppr e) thBrackets :: SDoc -> SDoc -> SDoc @@ -2294,7 +2270,7 @@ data ArithSeqInfo id (LHsExpr id) deriving instance (DataId id) => Data (ArithSeqInfo id) -instance (OutputableBndrId id, HasOccName id, HasOccName (NameOrRdrName id)) +instance (OutputableBndrId id) => Outputable (ArithSeqInfo id) where ppr (From e1) = hcat [ppr e1, pp_dotdot] ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] @@ -2313,17 +2289,11 @@ pp_dotdot = text " .. " ************************************************************************ -} -data FunctionFixity = Prefix | Infix deriving (Typeable,Data,Eq) - -instance Outputable FunctionFixity where - ppr Prefix = text "Prefix" - ppr Infix = text "Infix" - -- | Haskell Match Context -- -- Context of a Match data HsMatchContext id - = FunRhs (Located id) FunctionFixity -- ^Function binding for f, fixity + = FunRhs (Located id) LexicalFixity -- ^Function binding for f, fixity | LambdaExpr -- ^Patterns of a lambda | CaseAlt -- ^Patterns and guards on a case alternative | IfAlt -- ^Guards of a multi-way if alternative @@ -2482,7 +2452,7 @@ matchContextErrString (StmtCtxt ListComp) = text "list comprehension" matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" matchContextErrString (StmtCtxt PArrComp) = text "array comprehension" -pprMatchInCtxt :: (OutputableBndrId idR, HasOccNameId idR, +pprMatchInCtxt :: (OutputableBndrId idR, Outputable (NameOrRdrName (NameOrRdrName idR)), Outputable body) => Match idR body -> SDoc @@ -2491,7 +2461,6 @@ pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) 4 (pprMatch match) pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR, - HasOccNameId idL, HasOccNameId idR, Outputable body) => HsStmtContext idL -> StmtLR idL idR body -> SDoc pprStmtInCtxt ctxt (LastStmt e _ _) diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot index 070465e1cc..dad2a78185 100644 --- a/compiler/hsSyn/HsExpr.hs-boot +++ b/compiler/hsSyn/HsExpr.hs-boot @@ -11,7 +11,7 @@ import SrcLoc ( Located ) import Outputable ( SDoc, Outputable ) import {-# SOURCE #-} HsPat ( LPat ) import BasicTypes ( SpliceExplicitFlag(..)) -import PlaceHolder ( DataId, OutputableBndrId, HasOccNameId ) +import PlaceHolder ( DataId, OutputableBndrId ) import Data.Data hiding ( Fixity ) type role HsExpr nominal @@ -34,27 +34,24 @@ instance (Data body,DataId id) => Data (MatchGroup id body) instance (Data body,DataId id) => Data (GRHSs id body) instance (DataId id) => Data (SyntaxExpr id) -instance (OutputableBndrId id, HasOccNameId id) => Outputable (HsExpr id) -instance (OutputableBndrId id, HasOccNameId id) => Outputable (HsCmd id) +instance (OutputableBndrId id) => Outputable (HsExpr id) +instance (OutputableBndrId id) => Outputable (HsCmd id) type LHsExpr a = Located (HsExpr a) -pprLExpr :: (OutputableBndrId id, HasOccNameId id) => LHsExpr id -> SDoc +pprLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc -pprExpr :: (OutputableBndrId id,HasOccNameId id) => HsExpr id -> SDoc +pprExpr :: (OutputableBndrId id) => HsExpr id -> SDoc -pprSplice :: (OutputableBndrId id, HasOccNameId id) - => HsSplice id -> SDoc +pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc -pprSpliceDecl :: (OutputableBndrId id, HasOccNameId id) +pprSpliceDecl :: (OutputableBndrId id) => HsSplice id -> SpliceExplicitFlag -> SDoc pprPatBind :: (OutputableBndrId bndr, OutputableBndrId id, - HasOccNameId id, - HasOccNameId bndr, Outputable body) => LPat bndr -> GRHSs id body -> SDoc -pprFunBind :: (OutputableBndrId idR, HasOccNameId idR, Outputable body) +pprFunBind :: (OutputableBndrId idR, Outputable body) => MatchGroup idR body -> SDoc diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs index e513fe9e00..fe60748602 100644 --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs @@ -23,7 +23,7 @@ import BasicTypes ( FractionalLit(..),SourceText(..),pprWithSourceText ) import Type ( Type ) import Outputable import FastString -import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId, HasOccNameId ) +import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId ) import Data.ByteString (ByteString) import Data.Data hiding ( Fixity ) @@ -185,8 +185,7 @@ 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 (OutputableBndrId id, HasOccNameId id) - => Outputable (HsOverLit id) where +instance (OutputableBndrId id) => Outputable (HsOverLit id) where ppr (OverLit {ol_val=val, ol_witness=witness}) = ppr val <+> (ifPprDebug (parens (pprExpr witness))) diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 853e8cb70d..c29f0c25be 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -409,8 +409,7 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl ************************************************************************ -} -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (Pat name) where +instance (OutputableBndrId name) => Outputable (Pat name) where ppr = pprPat pprPatBndr :: OutputableBndr name => name -> SDoc @@ -422,11 +421,10 @@ pprPatBndr var -- Print with type info if -dppr-debug is on else pprPrefixOcc var -pprParendLPat :: (OutputableBndrId name, HasOccNameId name) - => LPat name -> SDoc +pprParendLPat :: (OutputableBndrId name) => LPat name -> SDoc pprParendLPat (L _ p) = pprParendPat p -pprParendPat :: (OutputableBndrId name, HasOccNameId name) => Pat name -> SDoc +pprParendPat :: (OutputableBndrId name) => Pat name -> SDoc pprParendPat p = sdocWithDynFlags $ \ dflags -> if need_parens dflags p then parens (pprPat p) @@ -440,7 +438,7 @@ pprParendPat p = sdocWithDynFlags $ \ dflags -> -- But otherwise the CoPat is discarded, so it -- is the pattern inside that matters. Sigh. -pprPat :: (OutputableBndrId name, HasOccNameId name) => Pat name -> SDoc +pprPat :: (OutputableBndrId name) => Pat name -> SDoc pprPat (VarPat (L _ var)) = pprPatBndr var pprPat (WildPat _) = char '_' pprPat (LazyPat pat) = char '~' <> pprParendLPat pat @@ -477,13 +475,12 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, else pprUserCon (unLoc con) details -pprUserCon :: (OutputableBndr con, OutputableBndrId id, HasOccNameId id) +pprUserCon :: (OutputableBndr con, OutputableBndrId id) => con -> HsConPatDetails id -> SDoc pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 pprUserCon c details = pprPrefixOcc c <+> pprConArgs details -pprConArgs :: (OutputableBndrId id, HasOccNameId id) - => HsConPatDetails id -> SDoc +pprConArgs :: (OutputableBndrId id) => HsConPatDetails id -> SDoc pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats) pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2] pprConArgs (RecCon rpats) = ppr rpats @@ -598,7 +595,7 @@ looksLazyLPat (L _ (VarPat {})) = False looksLazyLPat (L _ (WildPat {})) = False looksLazyLPat _ = True -isIrrefutableHsPat :: (OutputableBndrId id, HasOccNameId id) => LPat id -> Bool +isIrrefutableHsPat :: (OutputableBndrId id) => LPat id -> Bool -- (isIrrefutableHsPat p) is true if matching against p cannot fail, -- in the sense of falling through to the next pattern. -- (NB: this is not quite the same as the (silly) defn diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot index 8bcaa5a1e0..aba5686085 100644 --- a/compiler/hsSyn/HsPat.hs-boot +++ b/compiler/hsSyn/HsPat.hs-boot @@ -10,11 +10,11 @@ import SrcLoc( Located ) import Data.Data hiding (Fixity) import Outputable -import PlaceHolder ( DataId, OutputableBndrId,HasOccNameId ) +import PlaceHolder ( DataId, OutputableBndrId ) type role Pat nominal data Pat (i :: *) type LPat i = Located (Pat i) instance (DataId id) => Data (Pat id) -instance (OutputableBndrId name, HasOccNameId name) => Outputable (Pat name) +instance (OutputableBndrId name) => Outputable (Pat name) diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs index 93e43546a9..e7cae91572 100644 --- a/compiler/hsSyn/HsSyn.hs +++ b/compiler/hsSyn/HsSyn.hs @@ -44,6 +44,7 @@ import HsTypes import BasicTypes ( Fixity, WarningTxt ) import HsUtils import HsDoc +import OccName ( HasOccName(..) ) -- others: import Outputable @@ -108,8 +109,8 @@ data HsModule name -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId name) => Data (HsModule name) -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (HsModule name) where +instance (OutputableBndrId name, HasOccName name) + => Outputable (HsModule name) 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 e3e5246f4b..53f200fab4 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -71,7 +71,7 @@ module HsTypes ( import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..), - OutputableBndrId, HasOccNameId ) + OutputableBndrId ) import Id ( Id ) import Name( Name ) @@ -89,7 +89,7 @@ import Outputable import FastString import Maybes( isJust ) -import Data.Data hiding ( Fixity ) +import Data.Data hiding ( Fixity, Prefix, Infix ) import Data.Maybe ( fromMaybe ) import Control.Monad ( unless ) @@ -610,8 +610,7 @@ data HsAppType name | HsAppPrefix (LHsType name) -- anything else, including things like (+) deriving instance (DataId name) => Data (HsAppType name) -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (HsAppType name) where +instance (OutputableBndrId name) => Outputable (HsAppType name) where ppr = ppr_app_ty TopPrec {- @@ -755,8 +754,7 @@ data ConDeclField name -- Record fields have Haddoc docs on them -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId name) => Data (ConDeclField name) -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (ConDeclField name) where +instance (OutputableBndrId name) => Outputable (ConDeclField name) where ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty -- HsConDetails is used for patterns/expressions *and* for data type @@ -969,13 +967,14 @@ splitHsFunType other = ([], other) -------------------------------- -- | Retrieves the head of an HsAppsTy, if this can be done unambiguously, -- without consulting fixities. -getAppsTyHead_maybe :: [LHsAppType name] -> Maybe (LHsType name, [LHsType name]) +getAppsTyHead_maybe :: [LHsAppType name] + -> Maybe (LHsType name, [LHsType name], LexicalFixity) getAppsTyHead_maybe tys = case splitHsAppsTy tys of ([app1:apps], []) -> -- no symbols, some normal types - Just (mkHsAppTys app1 apps, []) + Just (mkHsAppTys app1 apps, [], Prefix) ([app1l:appsl, app1r:appsr], [L loc op]) -> -- one operator Just ( L loc (HsTyVar NotPromoted (L loc op)) - , [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr]) + , [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr], Infix) _ -> -- can't figure it out Nothing @@ -1003,7 +1002,7 @@ hsTyGetAppHead_maybe = go [] where go tys (L _ (HsTyVar _ ln)) = Just (ln, tys) go tys (L _ (HsAppsTy apps)) - | Just (head, args) <- getAppsTyHead_maybe 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) @@ -1152,19 +1151,16 @@ ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel ************************************************************************ -} -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (HsType name) where +instance (OutputableBndrId name) => Outputable (HsType name) where ppr ty = pprHsType ty instance Outputable HsTyLit where ppr = ppr_tylit -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (LHsQTyVars name) where +instance (OutputableBndrId name) => Outputable (LHsQTyVars name) where ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs -instance (OutputableBndrId name, HasOccNameId name) - => Outputable (HsTyVarBndr name) where +instance (OutputableBndrId name) => Outputable (HsTyVarBndr name) where ppr (UserTyVar n) = ppr n ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k] @@ -1177,7 +1173,7 @@ instance (Outputable thing) => Outputable (HsWildCardBndrs name thing) where instance Outputable (HsWildCardInfo name) where ppr (AnonWildCard _) = char '_' -pprHsForAll :: (OutputableBndrId name, HasOccNameId name) +pprHsForAll :: (OutputableBndrId name) => [LHsTyVarBndr name] -> LHsContext name -> SDoc pprHsForAll = pprHsForAllExtra Nothing @@ -1188,7 +1184,7 @@ 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 :: (OutputableBndrId name, HasOccNameId name) +pprHsForAllExtra :: (OutputableBndrId name) => Maybe SrcSpan -> [LHsTyVarBndr name] -> LHsContext name -> SDoc pprHsForAllExtra extra qtvs cxt @@ -1196,38 +1192,32 @@ pprHsForAllExtra extra qtvs cxt where show_extra = isJust extra -pprHsForAllTvs :: (OutputableBndrId name, HasOccNameId name) - => [LHsTyVarBndr name] -> SDoc +pprHsForAllTvs :: (OutputableBndrId name) => [LHsTyVarBndr name] -> SDoc pprHsForAllTvs qtvs | show_forall = forAllLit <+> interppSP qtvs <> dot | otherwise = empty where show_forall = opt_PprStyle_Debug || not (null qtvs) -pprHsContext :: (OutputableBndrId name, HasOccNameId name) - => HsContext name -> SDoc +pprHsContext :: (OutputableBndrId name) => HsContext name -> SDoc pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe -pprHsContextNoArrow :: (OutputableBndrId name, HasOccNameId name) - => HsContext name -> SDoc +pprHsContextNoArrow :: (OutputableBndrId name) => HsContext name -> SDoc pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe -pprHsContextMaybe :: (OutputableBndrId name, HasOccNameId name) - => HsContext name -> Maybe SDoc +pprHsContextMaybe :: (OutputableBndrId name) => HsContext name -> Maybe SDoc pprHsContextMaybe [] = Nothing pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty FunPrec pred pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt) -- For use in a HsQualTy, which always gets printed if it exists. -pprHsContextAlways :: (OutputableBndrId name, HasOccNameId name) - => HsContext name -> SDoc +pprHsContextAlways :: (OutputableBndrId name) => HsContext name -> SDoc pprHsContextAlways [] = parens empty <+> darrow pprHsContextAlways [L _ ty] = ppr_mono_ty FunPrec ty <+> darrow pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow -- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@ -pprHsContextExtra :: (OutputableBndrId name, HasOccNameId name) - => Bool -> HsContext name -> SDoc +pprHsContextExtra :: (OutputableBndrId name) => Bool -> HsContext name -> SDoc pprHsContextExtra show_extra ctxt | not show_extra = pprHsContext ctxt @@ -1238,8 +1228,7 @@ pprHsContextExtra show_extra ctxt where ctxt' = map ppr ctxt ++ [char '_'] -pprConDeclFields :: (OutputableBndrId name, HasOccNameId name) - => [LConDeclField name] -> SDoc +pprConDeclFields :: (OutputableBndrId name) => [LConDeclField name] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) where ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, @@ -1263,18 +1252,15 @@ seems like the Right Thing anyway.) -- Printing works more-or-less as for Types -pprHsType, pprParendHsType :: (OutputableBndrId name, HasOccNameId name) - => HsType name -> SDoc +pprHsType, pprParendHsType :: (OutputableBndrId name) => HsType name -> SDoc pprHsType ty = ppr_mono_ty TopPrec ty pprParendHsType ty = ppr_mono_ty TyConPrec ty -ppr_mono_lty :: (OutputableBndrId name, HasOccNameId name) - => TyPrec -> LHsType name -> SDoc +ppr_mono_lty :: (OutputableBndrId name) => TyPrec -> LHsType name -> SDoc ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) -ppr_mono_ty :: (OutputableBndrId name, HasOccNameId name) - => TyPrec -> HsType name -> SDoc +ppr_mono_ty :: (OutputableBndrId name) => TyPrec -> HsType name -> SDoc ppr_mono_ty ctxt_prec (HsForAllTy { hst_bndrs = tvs, hst_body = ty }) = maybeParen ctxt_prec FunPrec $ sep [pprHsForAllTvs tvs, ppr_mono_lty TopPrec ty] @@ -1337,7 +1323,7 @@ ppr_mono_ty ctxt_prec (HsDocTy ty doc) -- postfix operators -------------------------- -ppr_fun_ty :: (OutputableBndrId name, HasOccNameId name) +ppr_fun_ty :: (OutputableBndrId name) => TyPrec -> LHsType name -> LHsType name -> SDoc ppr_fun_ty ctxt_prec ty1 ty2 = let p1 = ppr_mono_lty FunPrec ty1 @@ -1347,8 +1333,7 @@ ppr_fun_ty ctxt_prec ty1 ty2 sep [p1, text "->" <+> p2] -------------------------- -ppr_app_ty :: (OutputableBndrId name, HasOccNameId name) - => TyPrec -> HsAppType name -> SDoc +ppr_app_ty :: (OutputableBndrId name) => TyPrec -> HsAppType name -> SDoc ppr_app_ty _ (HsAppInfix (L _ n)) = pprInfixOcc n ppr_app_ty _ (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n)))) = pprPrefixOcc n diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs index c29e8f9cb4..2e195df799 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs @@ -142,10 +142,3 @@ type OutputableBndrId id = ( OutputableBndr id , OutputableBndr (NameOrRdrName id) ) - --- |Constraint type to bundle up the requirement for 'HasOccName' on both --- the @id@ and the 'NameOrRdrName' type for it -type HasOccNameId id = - ( HasOccName id - , HasOccName (NameOrRdrName id) - ) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 3345ddfe22..cf066d0ea7 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -232,6 +232,7 @@ module GHC ( defaultFixity, maxPrecedence, negateFixity, compareFixity, + LexicalFixity(..), -- ** Source locations SrcLoc(..), RealSrcLoc, diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index d964cc2469..2c9600427c 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -137,11 +137,12 @@ mkClassDecl :: SrcSpan mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls ; let cxt = fromMaybe (noLoc []) mcxt - ; (cls, tparams,ann) <- checkTyClHdr True tycl_hdr + ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams ; at_defs <- mapM (eitherToP . mkATDefault) at_insts ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars + , tcdFixity = fixity , tcdFDs = snd (unLoc fds) , tcdSigs = mkClassOpSigs sigs , tcdMeths = binds @@ -157,10 +158,12 @@ mkATDefault :: LTyFamInstDecl RdrName -- We use the Either monad because this also called -- from Convert.hs mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e })) - | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs } <- e + | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity + , tfe_rhs = rhs } <- e = do { tvs <- checkTyVars (text "default") equalsDots tc (hsib_body pats) ; return (L loc (TyFamEqn { tfe_tycon = tc , tfe_pats = tvs + , tfe_fixity = fixity , tfe_rhs = rhs })) } mkTyData :: SrcSpan @@ -172,11 +175,12 @@ mkTyData :: SrcSpan -> HsDeriving RdrName -> P (LTyClDecl RdrName) mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv - = do { (tc, tparams,ann) <- checkTyClHdr False tycl_hdr + = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars, + tcdFixity = fixity, tcdDataDefn = defn, tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames })) } @@ -203,19 +207,21 @@ mkTySynonym :: SrcSpan -> LHsType RdrName -- RHS -> P (LTyClDecl RdrName) mkTySynonym loc lhs rhs - = do { (tc, tparams,ann) <- checkTyClHdr False lhs + = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars + , tcdFixity = fixity , tcdRhs = rhs, tcdFVs = placeHolderNames })) } mkTyFamInstEqn :: LHsType RdrName -> LHsType RdrName -> P (TyFamInstEqn RdrName,[AddAnn]) mkTyFamInstEqn lhs rhs - = do { (tc, tparams, ann) <- checkTyClHdr False lhs + = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; return (TyFamEqn { tfe_tycon = tc , tfe_pats = mkHsImplicitBndrs tparams + , tfe_fixity = fixity , tfe_rhs = rhs }, ann) } @@ -228,12 +234,13 @@ mkDataFamInst :: SrcSpan -> HsDeriving RdrName -> P (LInstDecl RdrName) mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv - = do { (tc, tparams,ann) <- checkTyClHdr False tycl_hdr + = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ; return (L loc (DataFamInstD ( DataFamInstDecl { dfid_tycon = tc , dfid_pats = mkHsImplicitBndrs tparams + , dfid_fixity = fixity , dfid_defn = defn, dfid_fvs = placeHolderNames }))) } mkTyFamInst :: SrcSpan @@ -250,11 +257,12 @@ mkFamDecl :: SrcSpan -> Maybe (LInjectivityAnn RdrName) -- Injectivity annotation -> P (LTyClDecl RdrName) mkFamDecl loc info lhs ksig injAnn - = do { (tc, tparams, ann) <- checkTyClHdr False lhs + = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams ; return (L loc (FamDecl (FamilyDecl{ fdInfo = info, fdLName = tc , fdTyVars = tyvars + , fdFixity = fixity , fdResultSig = ksig , fdInjectivityAnn = injAnn }))) } where @@ -722,39 +730,41 @@ checkTyClHdr :: Bool -- True <=> class header -> LHsType RdrName -> P (Located RdrName, -- the head symbol (type or class name) [LHsType RdrName], -- parameters of head symbol + LexicalFixity, -- the declaration is in infix format [AddAnn]) -- API Annotation for HsParTy when stripping parens -- Well-formedness check and decomposition of type and class heads. -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) -- Int :*: Bool into (:*:, [Int, Bool]) -- returning the pieces checkTyClHdr is_cls ty - = goL ty [] [] + = goL ty [] [] Prefix where - goL (L l ty) acc ann = go l ty acc ann - - go l (HsTyVar _ (L _ tc)) acc ann - | isRdrTc tc = return (L l tc, acc, ann) - go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann - | isRdrTc tc = return (ltc, t1:t2:acc, ann) - go l (HsParTy ty) acc ann = goL ty acc (ann ++ mkParensApiAnn l) - go _ (HsAppTy t1 t2) acc ann = goL t1 (t2:acc) ann - go _ (HsAppsTy ts) acc ann - | Just (head, args) <- getAppsTyHead_maybe ts = goL head (args ++ acc) ann - - go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann + goL (L l ty) acc ann fix = go l ty acc ann fix + + go l (HsTyVar _ (L _ tc)) acc ann fix + | isRdrTc tc = return (L l tc, acc, fix, ann) + go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann _fix + | isRdrTc tc = return (ltc, t1:t2:acc, Infix, ann) + go l (HsParTy ty) acc ann fix = goL ty acc (ann ++ mkParensApiAnn l) fix + go _ (HsAppTy t1 t2) acc ann fix = goL t1 (t2:acc) ann fix + go _ (HsAppsTy ts) acc ann _fix + | Just (head, args, fixity) <- getAppsTyHead_maybe ts + = goL head (args ++ acc) ann fixity + + go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann fix | occNameFS (rdrNameOcc star) == fsLit "*" - = return (L loc (nameRdrName starKindTyConName), [], ann) + = return (L loc (nameRdrName starKindTyConName), [], fix, ann) | occNameFS (rdrNameOcc star) == fsLit "★" - = return (L loc (nameRdrName unicodeStarKindTyConName), [], ann) + = return (L loc (nameRdrName unicodeStarKindTyConName), [], fix, ann) - go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann - = return (L l (nameRdrName tup_name), ts, ann) + go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann fix + = return (L l (nameRdrName tup_name), ts, fix, ann) where arity = length ts tup_name | is_cls = cTupleTyConName arity | otherwise = getName (tupleTyCon Boxed arity) -- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?) - go l _ _ _ + go l _ _ _ _ = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty) @@ -926,7 +936,7 @@ checkFunBind :: SDoc -> [AddAnn] -> SrcSpan -> Located RdrName - -> FunctionFixity + -> LexicalFixity -> [LHsExpr RdrName] -> Maybe (LHsType RdrName) -> Located (GRHSs RdrName (LHsExpr RdrName)) @@ -1031,7 +1041,7 @@ splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg)) splitBang _ = Nothing isFunLhs :: LHsExpr RdrName - -> P (Maybe (Located RdrName, FunctionFixity, [LHsExpr RdrName],[AddAnn])) + -> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr RdrName],[AddAnn])) -- A variable binding is parsed as a FunBind. -- Just (fun, is_infix, arg_pats) if e is a function LHS -- diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 56830861d2..c232e76ea0 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -42,7 +42,7 @@ import NameSet import RdrName ( RdrName, rdrNameOcc ) import SrcLoc import ListSetOps ( findDupsEq ) -import BasicTypes ( RecFlag(..) ) +import BasicTypes ( RecFlag(..), LexicalFixity(..) ) import Digraph ( SCC(..) ) import Bag import Util diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 4d0f926b83..65acf808ab 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -798,11 +798,13 @@ rnTyFamInstEqn :: Maybe (Name, [Name]) -> RnM (TyFamInstEqn Name, FreeVars) rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon , tfe_pats = pats + , tfe_fixity = fixity , tfe_rhs = rhs }) = do { (tycon', pats', rhs', fvs) <- rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn ; return (TyFamEqn { tfe_tycon = tycon' , tfe_pats = pats' + , tfe_fixity = fixity , tfe_rhs = rhs' }, fvs) } rnTyFamDefltEqn :: Name @@ -810,12 +812,14 @@ rnTyFamDefltEqn :: Name -> RnM (TyFamDefltEqn Name, FreeVars) rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon , tfe_pats = tyvars + , tfe_fixity = fixity , tfe_rhs = rhs }) = bindHsQTyVars ctx Nothing (Just cls) [] tyvars $ \ tyvars' _ -> do { tycon' <- lookupFamInstName (Just cls) tycon ; (rhs', fvs) <- rnLHsType ctx rhs ; return (TyFamEqn { tfe_tycon = tycon' , tfe_pats = tyvars' + , tfe_fixity = fixity , tfe_rhs = rhs' }, fvs) } where ctx = TyFamilyCtx tycon @@ -825,11 +829,13 @@ rnDataFamInstDecl :: Maybe (Name, [Name]) -> RnM (DataFamInstDecl Name, FreeVars) rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon , dfid_pats = pats + , dfid_fixity = fixity , dfid_defn = defn }) = do { (tycon', pats', (defn', _), fvs) <- rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn ; return (DataFamInstDecl { dfid_tycon = tycon' , dfid_pats = pats' + , dfid_fixity = fixity , dfid_defn = defn' , dfid_fvs = fvs }, fvs) } @@ -1632,7 +1638,8 @@ rnTyClDecl (FamDecl { tcdFam = decl }) = do { (decl', fvs) <- rnFamDecl Nothing decl ; return (FamDecl decl', fvs) } -rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs }) +rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, + tcdFixity = fixity, tcdRhs = rhs }) = do { tycon' <- lookupLocatedTopBndrRn tycon ; kvs <- freeKiTyVarsKindVars <$> extractHsTyRdrTyVars rhs ; let doc = TySynCtx tycon @@ -1642,11 +1649,13 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs }) do { (rhs', fvs) <- rnTySyn doc rhs ; return ((tyvars', rhs'), fvs) } ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars' + , tcdFixity = fixity , tcdRhs = rhs', tcdFVs = fvs }, fvs) } -- "data", "newtype" declarations -- both top level and (for an associated type) in an instance decl -rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn }) +rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, + tcdFixity = fixity, tcdDataDefn = defn }) = do { tycon' <- lookupLocatedTopBndrRn tycon ; kvs <- extractDataDefnKindVars defn ; let doc = TyDataCtx tycon @@ -1662,11 +1671,13 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn ; let cusk = hsTvbAllKinded tyvars' && (not typeintype || no_kvs) ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars' + , tcdFixity = fixity , tcdDataDefn = defn', tcdDataCusk = cusk , tcdFVs = fvs }, fvs) } rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, - tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, + tcdTyVars = tyvars, tcdFixity = fixity, + tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs}) = do { lcls' <- lookupLocatedTopBndrRn lcls @@ -1720,7 +1731,8 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', - tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', + tcdTyVars = tyvars', tcdFixity = fixity, + tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', tcdDocs = docs', tcdFVs = all_fvs }, all_fvs ) } @@ -1811,6 +1823,7 @@ rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested -> FamilyDecl RdrName -> RnM (FamilyDecl Name, FreeVars) rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars + , fdFixity = fixity , fdInfo = info, fdResultSig = res_sig , fdInjectivityAnn = injectivity }) = do { tycon' <- lookupLocatedTopBndrRn tycon @@ -1825,6 +1838,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } ; (info', fv2) <- rn_info info ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars' + , fdFixity = fixity , fdInfo = info', fdResultSig = res_sig' , fdInjectivityAnn = injectivity' } , fv1 `plusFV` fv2) } diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 00e27152de..f3fcf88ade 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -50,7 +50,7 @@ import FieldLabel import Util import BasicTypes ( compareFixity, funTyFixity, negateFixity, - Fixity(..), FixityDirection(..) ) + Fixity(..), FixityDirection(..), LexicalFixity(..) ) import Outputable import FastString import Maybes diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs index ddd29b13ed..33eb83b401 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -65,6 +65,6 @@ annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod #endif -annCtxt :: (OutputableBndrId id, HasOccNameId id) => AnnDecl id -> SDoc +annCtxt :: (OutputableBndrId id) => AnnDecl id -> SDoc annCtxt ann = hang (text "In the annotation:") 2 (ppr ann) diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 31d650d6dc..2206480585 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -1703,7 +1703,7 @@ the common case.) -} -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name -patMonoBindsCtxt :: (OutputableBndrId id, HasOccNameId id, Outputable body) +patMonoBindsCtxt :: (OutputableBndrId id, Outputable body) => LPat id -> GRHSs Name body -> SDoc patMonoBindsCtxt pat grhss = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 0d4b8f5609..6135800752 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -827,11 +827,10 @@ data InstBindings a -- Used only to improve error messages } -instance (OutputableBndrId a, HasOccNameId a) => Outputable (InstInfo a) where +instance (OutputableBndrId a) => Outputable (InstInfo a) where ppr = pprInstInfoDetails -pprInstInfoDetails :: (OutputableBndrId a, HasOccNameId a) - => InstInfo a -> SDoc +pprInstInfoDetails :: (OutputableBndrId a) => InstInfo a -> SDoc pprInstInfoDetails info = hang (pprInstanceHdr (iSpec info) <+> text "where") 2 (details (iBinds info)) diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs index 96dfd4cb61..1f0df61770 100644 --- a/compiler/typecheck/TcGenFunctor.hs +++ b/compiler/typecheck/TcGenFunctor.hs @@ -15,6 +15,7 @@ module TcGenFunctor ( gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds ) where +import BasicTypes ( LexicalFixity(..) ) import Bag import DataCon import FastString diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index 01586c0230..fcb48ce512 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -21,6 +21,7 @@ module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambd import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr ) +import BasicTypes ( LexicalFixity(..) ) import HsSyn import TcRnMonad import TcEnv diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 10e50d40ae..b1d444aee5 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -1186,8 +1186,7 @@ polyPatSig sig_ty = hang (text "Illegal polymorphic type signature in pattern:") 2 (ppr sig_ty) -lazyUnliftedPatErr :: (OutputableBndrId name, HasOccNameId name) - => Pat name -> TcM () +lazyUnliftedPatErr :: (OutputableBndrId name) => Pat name -> TcM () lazyUnliftedPatErr pat = failWithTc $ hang (text "A lazy (~) pattern cannot contain unlifted types:") diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 3e6897117b..47a27b3853 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -764,22 +764,19 @@ tcCheckPatSynPat = go go1 SigPatOut{} = panic "SigPatOut in output of renamer" go1 CoPat{} = panic "CoPat in output of renamer" -asPatInPatSynErr :: (OutputableBndrId name, HasOccNameId name) - => Pat name -> TcM a +asPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a asPatInPatSynErr pat = failWithTc $ hang (text "Pattern synonym definition cannot contain as-patterns (@):") 2 (ppr pat) -thInPatSynErr :: (OutputableBndrId name, HasOccNameId name) - => Pat name -> TcM a +thInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a thInPatSynErr pat = failWithTc $ hang (text "Pattern synonym definition cannot contain Template Haskell:") 2 (ppr pat) -nPlusKPatInPatSynErr :: (OutputableBndrId name, HasOccNameId name) - => Pat name -> TcM a +nPlusKPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a nPlusKPatInPatSynErr pat = failWithTc $ hang (text "Pattern synonym definition cannot contain n+k-pattern:") diff --git a/compiler/utils/BooleanFormula.hs b/compiler/utils/BooleanFormula.hs index ec9a8892c6..13f6e21f31 100644 --- a/compiler/utils/BooleanFormula.hs +++ b/compiler/utils/BooleanFormula.hs @@ -23,7 +23,6 @@ import MonadUtils import Outputable import Binary import SrcLoc -import OccName ( HasOccName(..), isSymOcc ) ---------------------------------------------------------------------- -- Boolean formula type and smart constructors @@ -201,14 +200,14 @@ pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0 pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs) -instance (Outputable a, HasOccName a) => Outputable (BooleanFormula a) where +instance (OutputableBndr a) => Outputable (BooleanFormula a) where ppr = pprBooleanFormulaNormal -pprBooleanFormulaNormal :: (Outputable a, HasOccName a) +pprBooleanFormulaNormal :: (OutputableBndr a) => BooleanFormula a -> SDoc pprBooleanFormulaNormal = go where - go (Var x) = pprPrefixVar (isSymOcc (occName x)) (ppr x) + go (Var x) = pprPrefixOcc x go (And xs) = fsep $ punctuate comma (map (go . unLoc) xs) go (Or []) = keyword $ text "FALSE" go (Or xs) = fsep $ intersperse vbar (map (go . unLoc) xs) diff --git a/utils/haddock b/utils/haddock -Subproject a5946c015e372750fd8d2054bb8a7e975149c9c +Subproject f951caf888eabd8742059f26e516e3392658fc8 |