summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2016-12-08 10:43:32 +0200
committerAlan Zimmerman <alan.zimm@gmail.com>2016-12-12 20:50:56 +0200
commit8f6d241a74efa6f6280689a9b14c36c6a9f4c231 (patch)
tree166fabd22a3f726364eb5f7492bcf5d2ec59c0f4
parentbc3d37dada357b04fc5a35f740b4fe7e05292b06 (diff)
downloadhaskell-8f6d241a74efa6f6280689a9b14c36c6a9f4c231.tar.gz
Add infix flag for class and data declarations
Summary: At the moment, data and type declarations using infix formatting produce the same AST as those using prefix. So type a ++ b = c and type (++) a b = c cannot be distinguished in the parsed source, without looking at the OccName details of the constructor being defined. Having access to the OccName requires an additional constraint which explodes out over the entire AST because of its recursive definitions. In keeping with moving the parsed source to more directly reflect the source code as parsed, add a specific flag to the declaration to indicate the fixity, as used in a Match now too. Note: this flag is to capture the fixity used for the lexical definition of the type, primarily for use by ppr and ghc-exactprint. Updates haddock submodule. Test Plan: ./validate Reviewers: mpickering, goldfire, bgamari, austin Reviewed By: mpickering Subscribers: thomie Differential Revision: https://phabricator.haskell.org/D2828 GHC Trac Issues: #12942
Diffstat
-rw-r--r--compiler/basicTypes/BasicTypes.hs12
-rw-r--r--compiler/hsSyn/Convert.hs17
-rw-r--r--compiler/hsSyn/HsBinds.hs34
-rw-r--r--compiler/hsSyn/HsDecls.hs144
-rw-r--r--compiler/hsSyn/HsExpr.hs127
-rw-r--r--compiler/hsSyn/HsExpr.hs-boot19
-rw-r--r--compiler/hsSyn/HsLit.hs5
-rw-r--r--compiler/hsSyn/HsPat.hs17
-rw-r--r--compiler/hsSyn/HsPat.hs-boot4
-rw-r--r--compiler/hsSyn/HsSyn.hs5
-rw-r--r--compiler/hsSyn/HsTypes.hs67
-rw-r--r--compiler/hsSyn/PlaceHolder.hs7
-rw-r--r--compiler/main/GHC.hs1
-rw-r--r--compiler/parser/RdrHsSyn.hs64
-rw-r--r--compiler/rename/RnBinds.hs2
-rw-r--r--compiler/rename/RnSource.hs22
-rw-r--r--compiler/rename/RnTypes.hs2
-rw-r--r--compiler/typecheck/TcAnnotations.hs2
-rw-r--r--compiler/typecheck/TcBinds.hs2
-rw-r--r--compiler/typecheck/TcEnv.hs5
-rw-r--r--compiler/typecheck/TcGenFunctor.hs1
-rw-r--r--compiler/typecheck/TcMatches.hs1
-rw-r--r--compiler/typecheck/TcPat.hs3
-rw-r--r--compiler/typecheck/TcPatSyn.hs9
-rw-r--r--compiler/utils/BooleanFormula.hs7
m---------utils/haddock0
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
View Lorry Controller Status