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(
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"
{-
************************************************************************
* *
......
......@@ -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' } }
----------------
......
......@@ -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)
......
This diff is collapsed.
This diff is collapsed.
......@@ -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
......@@ -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)))
......
......@@ -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
......
......@@ -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)
......@@ -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
......
......@@ -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
......
......@@ -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)
)
......@@ -232,6 +232,7 @@ module GHC (
defaultFixity, maxPrecedence,
negateFixity,
compareFixity,
LexicalFixity(..),
-- ** Source locations
SrcLoc(..), RealSrcLoc,
......
......@@ -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)