Commit 8f6d241a authored by Alan Zimmerman's avatar Alan Zimmerman

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
parent bc3d37da
...@@ -36,6 +36,7 @@ module BasicTypes( ...@@ -36,6 +36,7 @@ module BasicTypes(
defaultFixity, maxPrecedence, minPrecedence, defaultFixity, maxPrecedence, minPrecedence,
negateFixity, funTyFixity, negateFixity, funTyFixity,
compareFixity, compareFixity,
LexicalFixity(..),
RecFlag(..), isRec, isNonRec, boolToRecFlag, RecFlag(..), isRec, isNonRec, boolToRecFlag,
Origin(..), isGenerated, Origin(..), isGenerated,
...@@ -107,7 +108,7 @@ import FastString ...@@ -107,7 +108,7 @@ import FastString
import Outputable import Outputable
import SrcLoc ( Located,unLoc ) import SrcLoc ( Located,unLoc )
import StaticFlags( opt_PprStyle_Debug ) import StaticFlags( opt_PprStyle_Debug )
import Data.Data hiding (Fixity) import Data.Data hiding (Fixity, Prefix, Infix)
import Data.Function (on) import Data.Function (on)
{- {-
...@@ -433,6 +434,15 @@ compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2) ...@@ -433,6 +434,15 @@ compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2)
left = (False, False) left = (False, False)
error_please = (True, 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"
{- {-
************************************************************************ ************************************************************************
* * * *
......
...@@ -182,8 +182,9 @@ cvtDec (TySynD tc tvs rhs) ...@@ -182,8 +182,9 @@ cvtDec (TySynD tc tvs rhs)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
; rhs' <- cvtType rhs ; rhs' <- cvtType rhs
; returnJustL $ TyClD $ ; returnJustL $ TyClD $
SynDecl { tcdLName = tc' SynDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdTyVars = tvs', tcdFVs = placeHolderNames , tcdFixity = Prefix
, tcdFVs = placeHolderNames
, tcdRhs = rhs' } } , tcdRhs = rhs' } }
cvtDec (DataD ctxt tc tvs ksig constrs derivs) cvtDec (DataD ctxt tc tvs ksig constrs derivs)
...@@ -207,6 +208,7 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs) ...@@ -207,6 +208,7 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs)
, dd_kindSig = ksig' , dd_kindSig = ksig'
, dd_cons = cons', dd_derivs = derivs' } , dd_cons = cons', dd_derivs = derivs' }
; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
, tcdDataDefn = defn , tcdDataDefn = defn
, tcdDataCusk = PlaceHolder , tcdDataCusk = PlaceHolder
, tcdFVs = placeHolderNames }) } , tcdFVs = placeHolderNames }) }
...@@ -222,6 +224,7 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) ...@@ -222,6 +224,7 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
, dd_cons = [con'] , dd_cons = [con']
, dd_derivs = derivs' } , dd_derivs = derivs' }
; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
, tcdDataDefn = defn , tcdDataDefn = defn
, tcdDataCusk = PlaceHolder , tcdDataCusk = PlaceHolder
, tcdFVs = placeHolderNames }) } , tcdFVs = placeHolderNames }) }
...@@ -237,6 +240,7 @@ cvtDec (ClassD ctxt cl tvs fds decs) ...@@ -237,6 +240,7 @@ cvtDec (ClassD ctxt cl tvs fds decs)
; at_defs <- mapM cvt_at_def ats' ; at_defs <- mapM cvt_at_def ats'
; returnJustL $ TyClD $ ; returnJustL $ TyClD $
ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
, tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
, tcdMeths = binds' , tcdMeths = binds'
, tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []
...@@ -282,7 +286,7 @@ cvtDec (DataFamilyD tc tvs kind) ...@@ -282,7 +286,7 @@ cvtDec (DataFamilyD tc tvs kind)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
; result <- cvtMaybeKindToFamilyResultSig kind ; result <- cvtMaybeKindToFamilyResultSig kind
; returnJustL $ TyClD $ FamDecl $ ; returnJustL $ TyClD $ FamDecl $
FamilyDecl DataFamily tc' tvs' result Nothing } FamilyDecl DataFamily tc' tvs' Prefix result Nothing }
cvtDec (DataInstD ctxt tc tys ksig constrs derivs) cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
= do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
...@@ -297,6 +301,7 @@ cvtDec (DataInstD ctxt tc tys ksig constrs derivs) ...@@ -297,6 +301,7 @@ cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
; returnJustL $ InstD $ DataFamInstD ; returnJustL $ InstD $ DataFamInstD
{ dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats' { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
, dfid_defn = defn , dfid_defn = defn
, dfid_fixity = Prefix
, dfid_fvs = placeHolderNames } }} , dfid_fvs = placeHolderNames } }}
cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs) cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
...@@ -311,6 +316,7 @@ cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs) ...@@ -311,6 +316,7 @@ cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
; returnJustL $ InstD $ DataFamInstD ; returnJustL $ InstD $ DataFamInstD
{ dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats' { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
, dfid_defn = defn , dfid_defn = defn
, dfid_fixity = Prefix
, dfid_fvs = placeHolderNames } }} , dfid_fvs = placeHolderNames } }}
cvtDec (TySynInstD tc eqn) cvtDec (TySynInstD tc eqn)
...@@ -323,13 +329,13 @@ cvtDec (TySynInstD tc eqn) ...@@ -323,13 +329,13 @@ cvtDec (TySynInstD tc eqn)
cvtDec (OpenTypeFamilyD head) cvtDec (OpenTypeFamilyD head)
= do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
; returnJustL $ TyClD $ FamDecl $ ; returnJustL $ TyClD $ FamDecl $
FamilyDecl OpenTypeFamily tc' tyvars' result' injectivity' } FamilyDecl OpenTypeFamily tc' tyvars' Prefix result' injectivity' }
cvtDec (ClosedTypeFamilyD head eqns) cvtDec (ClosedTypeFamilyD head eqns)
= do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
; eqns' <- mapM (cvtTySynEqn tc') eqns ; eqns' <- mapM (cvtTySynEqn tc') eqns
; returnJustL $ TyClD $ FamDecl $ ; returnJustL $ TyClD $ FamDecl $
FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tyvars' result' FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix result'
injectivity' } injectivity' }
cvtDec (TH.RoleAnnotD tc roles) cvtDec (TH.RoleAnnotD tc roles)
...@@ -384,6 +390,7 @@ cvtTySynEqn tc (TySynEqn lhs rhs) ...@@ -384,6 +390,7 @@ cvtTySynEqn tc (TySynEqn lhs rhs)
; rhs' <- cvtType rhs ; rhs' <- cvtType rhs
; returnL $ TyFamEqn { tfe_tycon = tc ; returnL $ TyFamEqn { tfe_tycon = tc
, tfe_pats = mkHsImplicitBndrs lhs' , tfe_pats = mkHsImplicitBndrs lhs'
, tfe_fixity = Prefix
, tfe_rhs = rhs' } } , tfe_rhs = rhs' } }
---------------- ----------------
......
...@@ -22,7 +22,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, ...@@ -22,7 +22,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
GRHSs, pprPatBind ) GRHSs, pprPatBind )
import {-# SOURCE #-} HsPat ( LPat ) import {-# SOURCE #-} HsPat ( LPat )
import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId,HasOccNameId ) import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId )
import HsTypes import HsTypes
import PprCore () import PprCore ()
import CoreSyn import CoreSyn
...@@ -437,15 +437,13 @@ Specifically, ...@@ -437,15 +437,13 @@ Specifically,
it's just an error thunk it's just an error thunk
-} -}
instance (OutputableBndrId idL, OutputableBndrId idR, instance (OutputableBndrId idL, OutputableBndrId idR)
HasOccNameId idL, HasOccNameId idR)
=> Outputable (HsLocalBindsLR idL idR) where => Outputable (HsLocalBindsLR idL idR) where
ppr (HsValBinds bs) = ppr bs ppr (HsValBinds bs) = ppr bs
ppr (HsIPBinds bs) = ppr bs ppr (HsIPBinds bs) = ppr bs
ppr EmptyLocalBinds = empty ppr EmptyLocalBinds = empty
instance (OutputableBndrId idL, OutputableBndrId idR, instance (OutputableBndrId idL, OutputableBndrId idR)
HasOccNameId idL, HasOccNameId idR)
=> Outputable (HsValBindsLR idL idR) where => Outputable (HsValBindsLR idL idR) where
ppr (ValBindsIn binds sigs) ppr (ValBindsIn binds sigs)
= pprDeclList (pprLHsBindsForUser binds sigs) = pprDeclList (pprLHsBindsForUser binds sigs)
...@@ -461,16 +459,14 @@ instance (OutputableBndrId idL, OutputableBndrId idR, ...@@ -461,16 +459,14 @@ instance (OutputableBndrId idL, OutputableBndrId idR,
pp_rec Recursive = text "rec" pp_rec Recursive = text "rec"
pp_rec NonRecursive = text "nonrec" pp_rec NonRecursive = text "nonrec"
pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR, pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR)
HasOccNameId idL, HasOccNameId idR)
=> LHsBindsLR idL idR -> SDoc => LHsBindsLR idL idR -> SDoc
pprLHsBinds binds pprLHsBinds binds
| isEmptyLHsBinds binds = empty | isEmptyLHsBinds binds = empty
| otherwise = pprDeclList (map ppr (bagToList binds)) | otherwise = pprDeclList (map ppr (bagToList binds))
pprLHsBindsForUser :: (OutputableBndrId idL, OutputableBndrId idR, pprLHsBindsForUser :: (OutputableBndrId idL, OutputableBndrId idR,
OutputableBndrId id2, HasOccNameId id2, OutputableBndrId id2)
HasOccNameId idL, HasOccNameId idR)
=> LHsBindsLR idL idR -> [LSig id2] -> [SDoc] => LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
-- pprLHsBindsForUser is different to pprLHsBinds because -- pprLHsBindsForUser is different to pprLHsBinds because
-- a) No braces: 'let' and 'where' include a list of HsBindGroups -- a) No braces: 'let' and 'where' include a list of HsBindGroups
...@@ -561,13 +557,11 @@ So the desugarer tries to do a better job: ...@@ -561,13 +557,11 @@ So the desugarer tries to do a better job:
in (fm,gm) in (fm,gm)
-} -}
instance (OutputableBndrId idL, OutputableBndrId idR, instance (OutputableBndrId idL, OutputableBndrId idR)
HasOccNameId idL, HasOccNameId idR)
=> Outputable (HsBindLR idL idR) where => Outputable (HsBindLR idL idR) where
ppr mbind = ppr_monobind mbind ppr mbind = ppr_monobind mbind
ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR, ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR)
HasOccNameId idL, HasOccNameId idR)
=> HsBindLR idL idR -> SDoc => HsBindLR idL idR -> SDoc
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
...@@ -623,7 +617,7 @@ instance (OutputableBndr id) => Outputable (ABExport id) where ...@@ -623,7 +617,7 @@ instance (OutputableBndr id) => Outputable (ABExport id) where
, nest 2 (pprTcSpecPrags prags) , nest 2 (pprTcSpecPrags prags)
, nest 2 (text "wrap:" <+> ppr wrap)] , nest 2 (text "wrap:" <+> ppr wrap)]
instance (OutputableBndr idL, OutputableBndrId idR, HasOccNameId idR) instance (OutputableBndr idL, OutputableBndrId idR)
=> Outputable (PatSynBind idL idR) where => Outputable (PatSynBind idL idR) where
ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,
psb_dir = dir }) psb_dir = dir })
...@@ -695,12 +689,11 @@ data IPBind id ...@@ -695,12 +689,11 @@ data IPBind id
= IPBind (Either (Located HsIPName) id) (LHsExpr id) = IPBind (Either (Located HsIPName) id) (LHsExpr id)
deriving instance (DataId name) => Data (IPBind name) deriving instance (DataId name) => Data (IPBind name)
instance (OutputableBndrId id, HasOccNameId id) instance (OutputableBndrId id ) => Outputable (HsIPBinds id) where
=> Outputable (HsIPBinds id) where
ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
$$ ifPprDebug (ppr ds) $$ 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) ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
where name = case lr of where name = case lr of
Left (L _ ip) -> pprBndr LetBind ip Left (L _ ip) -> pprBndr LetBind ip
...@@ -957,11 +950,10 @@ signatures. Since some of the signatures contain a list of names, testing for ...@@ -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. equality is not enough -- we have to check if they overlap.
-} -}
instance (OutputableBndrId name, HasOccNameId name) instance (OutputableBndrId name ) => Outputable (Sig name) where
=> Outputable (Sig name) where
ppr sig = ppr_sig sig 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 (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (ClassOpSig is_deflt vars ty) ppr_sig (ClassOpSig is_deflt vars ty)
| is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
...@@ -1021,7 +1013,7 @@ instance Outputable TcSpecPrag where ...@@ -1021,7 +1013,7 @@ instance Outputable TcSpecPrag where
ppr (SpecPrag var _ inl) ppr (SpecPrag var _ inl)
= text "SPECIALIZE" <+> pprSpec var (text "<type>") inl = text "SPECIALIZE" <+> pprSpec var (text "<type>") inl
pprMinimalSig :: (OutputableBndr name, HasOccName name) pprMinimalSig :: (OutputableBndr name)
=> LBooleanFormula (Located name) -> SDoc => LBooleanFormula (Located name) -> SDoc
pprMinimalSig (L _ bf) = text "MINIMAL" <+> ppr (fmap unLoc bf) pprMinimalSig (L _ bf) = text "MINIMAL" <+> ppr (fmap unLoc bf)
......
...@@ -98,8 +98,7 @@ import Name ...@@ -98,8 +98,7 @@ import Name
import BasicTypes import BasicTypes
import Coercion import Coercion
import ForeignCall import ForeignCall
import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId, OutputableBndrId, import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId, OutputableBndrId )
HasOccNameId )
import NameSet import NameSet
-- others: -- others:
...@@ -111,7 +110,7 @@ import SrcLoc ...@@ -111,7 +110,7 @@ import SrcLoc
import Bag import Bag
import Maybes import Maybes
import Data.Data hiding (TyCon,Fixity) import Data.Data hiding (TyCon,Fixity, Infix)
{- {-
************************************************************************ ************************************************************************
...@@ -252,8 +251,7 @@ appendGroups ...@@ -252,8 +251,7 @@ appendGroups
hs_vects = vects1 ++ vects2, hs_vects = vects1 ++ vects2,
hs_docs = docs1 ++ docs2 } hs_docs = docs1 ++ docs2 }
instance (OutputableBndrId name, HasOccNameId name) instance (OutputableBndrId name) => Outputable (HsDecl name) where
=> Outputable (HsDecl name) where
ppr (TyClD dcl) = ppr dcl ppr (TyClD dcl) = ppr dcl
ppr (ValD binds) = ppr binds ppr (ValD binds) = ppr binds
ppr (DefD def) = ppr def ppr (DefD def) = ppr def
...@@ -269,8 +267,7 @@ instance (OutputableBndrId name, HasOccNameId name) ...@@ -269,8 +267,7 @@ instance (OutputableBndrId name, HasOccNameId name)
ppr (DocD doc) = ppr doc ppr (DocD doc) = ppr doc
ppr (RoleAnnotD ra) = ppr ra ppr (RoleAnnotD ra) = ppr ra
instance (OutputableBndrId name, HasOccNameId name) instance (OutputableBndrId name) => Outputable (HsGroup name) where
=> Outputable (HsGroup name) where
ppr (HsGroup { hs_valds = val_decls, ppr (HsGroup { hs_valds = val_decls,
hs_tyclds = tycl_decls, hs_tyclds = tycl_decls,
hs_derivds = deriv_decls, hs_derivds = deriv_decls,
...@@ -314,8 +311,7 @@ data SpliceDecl id ...@@ -314,8 +311,7 @@ data SpliceDecl id
SpliceExplicitFlag SpliceExplicitFlag
deriving instance (DataId id) => Data (SpliceDecl id) deriving instance (DataId id) => Data (SpliceDecl id)
instance (OutputableBndrId name, HasOccNameId name) instance (OutputableBndrId name) => Outputable (SpliceDecl name) where
=> Outputable (SpliceDecl name) where
ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f
{- {-
...@@ -484,6 +480,7 @@ data TyClDecl name ...@@ -484,6 +480,7 @@ data TyClDecl name
SynDecl { tcdLName :: Located name -- ^ Type constructor SynDecl { tcdLName :: Located name -- ^ Type constructor
, tcdTyVars :: LHsQTyVars name -- ^ Type variables; for an associated type , tcdTyVars :: LHsQTyVars name -- ^ Type variables; for an associated type
-- these include outer binders -- these include outer binders
, tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration
, tcdRhs :: LHsType name -- ^ RHS of type declaration , tcdRhs :: LHsType name -- ^ RHS of type declaration
, tcdFVs :: PostRn name NameSet } , tcdFVs :: PostRn name NameSet }
...@@ -504,6 +501,7 @@ data TyClDecl name ...@@ -504,6 +501,7 @@ data TyClDecl name
-- type F a = a -> a -- type F a = a -> a
-- Here the type decl for 'f' includes 'a' -- Here the type decl for 'f' includes 'a'
-- in its tcdTyVars -- in its tcdTyVars
, tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration
, tcdDataDefn :: HsDataDefn name , tcdDataDefn :: HsDataDefn name
, tcdDataCusk :: PostRn name Bool -- ^ does this have a CUSK? , tcdDataCusk :: PostRn name Bool -- ^ does this have a CUSK?
, tcdFVs :: PostRn name NameSet } , tcdFVs :: PostRn name NameSet }
...@@ -511,6 +509,7 @@ data TyClDecl name ...@@ -511,6 +509,7 @@ data TyClDecl name
| ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context... | ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context...
tcdLName :: Located name, -- ^ Name of the class tcdLName :: Located name, -- ^ Name of the class
tcdTyVars :: LHsQTyVars name, -- ^ Class type variables tcdTyVars :: LHsQTyVars name, -- ^ Class type variables
tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration
tcdFDs :: [Located (FunDep (Located name))], tcdFDs :: [Located (FunDep (Located name))],
-- ^ Functional deps -- ^ Functional deps
tcdSigs :: [LSig name], -- ^ Methods' signatures tcdSigs :: [LSig name], -- ^ Methods' signatures
...@@ -633,19 +632,21 @@ hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars ...@@ -633,19 +632,21 @@ hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
-- Pretty-printing TyClDecl -- Pretty-printing TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~ -- ~~~~~~~~~~~~~~~~~~~~~~~~
instance (OutputableBndrId name, HasOccNameId name) instance (OutputableBndrId name) => Outputable (TyClDecl name) where
=> Outputable (TyClDecl name) where
ppr (FamDecl { tcdFam = decl }) = ppr decl 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" <+> = hang (text "type" <+>
pp_vanilla_decl_head ltycon tyvars [] <+> equals) pp_vanilla_decl_head ltycon tyvars fixity [] <+> equals)
4 (ppr rhs) 4 (ppr rhs)
ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdDataDefn = defn }) ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
= pp_data_defn (pp_vanilla_decl_head ltycon tyvars) defn , tcdDataDefn = defn })
= pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn
ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
tcdFixity = fixity,
tcdFDs = fds, tcdFDs = fds,
tcdSigs = sigs, tcdMeths = methods, tcdSigs = sigs, tcdMeths = methods,
tcdATs = ats, tcdATDefs = at_defs}) tcdATs = ats, tcdATDefs = at_defs})
...@@ -659,11 +660,10 @@ instance (OutputableBndrId name, HasOccNameId name) ...@@ -659,11 +660,10 @@ instance (OutputableBndrId name, HasOccNameId name)
pprLHsBindsForUser methods sigs) ] pprLHsBindsForUser methods sigs) ]
where where
top_matter = text "class" top_matter = text "class"
<+> pp_vanilla_decl_head lclas tyvars (unLoc context) <+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context)
<+> pprFundeps (map unLoc fds) <+> pprFundeps (map unLoc fds)
instance (OutputableBndrId name, HasOccNameId name) instance (OutputableBndrId name) => Outputable (TyClGroup name) where
=> Outputable (TyClGroup name) where
ppr (TyClGroup { group_tyclds = tyclds ppr (TyClGroup { group_tyclds = tyclds
, group_roles = roles , group_roles = roles
, group_instds = instds , group_instds = instds
...@@ -673,16 +673,16 @@ instance (OutputableBndrId name, HasOccNameId name) ...@@ -673,16 +673,16 @@ instance (OutputableBndrId name, HasOccNameId name)
ppr roles $$ ppr roles $$
ppr instds ppr instds
pp_vanilla_decl_head :: (OutputableBndrId name, HasOccNameId name) pp_vanilla_decl_head :: (OutputableBndrId name) => Located name
=> Located name
-> LHsQTyVars name -> LHsQTyVars name
-> LexicalFixity
-> HsContext name -> HsContext name
-> SDoc -> 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] = hsep [pprHsContext context, pp_tyvars tyvars]
where where
pp_tyvars (varl:varsr) pp_tyvars (varl:varsr)
| isSymOcc $ occName (unLoc thing) | fixity == Infix
= hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing) = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing)
, hsep (map (ppr.unLoc) varsr)] , hsep (map (ppr.unLoc) varsr)]
| otherwise = hsep [ pprPrefixOcc (unLoc thing) | otherwise = hsep [ pprPrefixOcc (unLoc thing)
...@@ -892,6 +892,7 @@ data FamilyDecl name = FamilyDecl ...@@ -892,6 +892,7 @@ data FamilyDecl name = FamilyDecl
{ fdInfo :: FamilyInfo name -- type/data, closed/open { fdInfo :: FamilyInfo name -- type/data, closed/open
, fdLName :: Located name -- type constructor , fdLName :: Located name -- type constructor
, fdTyVars :: LHsQTyVars name -- type variables , fdTyVars :: LHsQTyVars name -- type variables
, fdFixity :: LexicalFixity -- Fixity used in the declaration
, fdResultSig :: LFamilyResultSig name -- result signature , fdResultSig :: LFamilyResultSig name -- result signature
, fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann
} }
...@@ -955,18 +956,18 @@ resultVariableName :: FamilyResultSig a -> Maybe a ...@@ -955,18 +956,18 @@ resultVariableName :: FamilyResultSig a -> Maybe a
resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig
resultVariableName _ = Nothing resultVariableName _ = Nothing
instance (OutputableBndrId name, HasOccNameId name) instance (OutputableBndrId name) => Outputable (FamilyDecl name) where
=> Outputable (FamilyDecl name) where
ppr = pprFamilyDecl TopLevel ppr = pprFamilyDecl TopLevel
pprFamilyDecl :: (OutputableBndrId name, HasOccNameId name) pprFamilyDecl :: (OutputableBndrId name)
=> TopLevelFlag -> FamilyDecl name -> SDoc => TopLevelFlag -> FamilyDecl name -> SDoc
pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
, fdTyVars = tyvars , fdTyVars = tyvars
, fdFixity = fixity
, fdResultSig = L _ result , fdResultSig = L _ result
, fdInjectivityAnn = mb_inj }) , fdInjectivityAnn = mb_inj })
= vcat [ pprFlavour info <+> pp_top_level <+> = 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 pp_kind <+> pp_inj <+> pp_where
, nest 2 $ pp_eqns ] , nest 2 $ pp_eqns ]
where where
...@@ -1076,7 +1077,7 @@ data HsDerivingClause name ...@@ -1076,7 +1077,7 @@ data HsDerivingClause name
} }
deriving instance (DataId id) => Data (HsDerivingClause id) deriving instance (DataId id) => Data (HsDerivingClause id)
instance (OutputableBndrId name, HasOccNameId name) instance (OutputableBndrId name)
=> Outputable (HsDerivingClause name) where => Outputable (HsDerivingClause name) where
ppr (HsDerivingClause { deriv_clause_strategy = dcs ppr (HsDerivingClause { deriv_clause_strategy = dcs
, deriv_clause_tys = L _ dct }) , deriv_clause_tys = L _ dct })
...@@ -1193,7 +1194,7 @@ hsConDeclArgTys (PrefixCon tys) = tys ...@@ -1193,7 +1194,7 @@ hsConDeclArgTys (PrefixCon tys) = tys
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds)