Commit 499e4382 authored by Alan Zimmerman's avatar Alan Zimmerman

Add HsSyn prettyprinter tests

Summary:
Add prettyprinter tests, which take a file, parse it, pretty print it,
re-parse the pretty printed version and then compare the original and
new ASTs (ignoring locations)

Updates haddock submodule to match the AST changes.

There are three issues outstanding

1. Extra parens around a context are not reproduced. This will require an
   AST change and will be done in a separate patch.

2. Currently if an `HsTickPragma` is found, this is not pretty-printed,
   to prevent noise in the output.

   I am not sure what the desired behaviour in this case is, so have left
   it as before. Test Ppr047 is marked as expected fail for this.

3. Apart from in a context, the ParsedSource AST keeps all the parens from
   the original source.  Something is happening in the renamer to remove the
   parens around visible type application, causing T12530 to fail, as the
   dumped splice decl is after the renamer.

   This needs to be fixed by keeping the parens, but I do not know where they
   are being removed.  I have amended the test to pass, by removing the parens
   in the expected output.

Test Plan: ./validate

Reviewers: goldfire, mpickering, simonpj, bgamari, austin

Reviewed By: simonpj, bgamari

Subscribers: simonpj, goldfire, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D2752

GHC Trac Issues: #3384
parent 83d69dca
......@@ -30,7 +30,7 @@ module BasicTypes(
FunctionOrData(..),
WarningTxt(..), StringLiteral(..),
WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..),
Fixity(..), FixityDirection(..),
defaultFixity, maxPrecedence, minPrecedence,
......@@ -90,14 +90,17 @@ module BasicTypes(
inlinePragmaSpec, inlinePragmaSat,
inlinePragmaActivation, inlinePragmaRuleMatchInfo,
setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
pprInline, pprInlineDebug,
SuccessFlag(..), succeeded, failed, successIf,
FractionalLit(..), negateFractionalLit, integralFractionalLit,
SourceText,
SourceText(..), pprWithSourceText,
IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit
IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit,
SpliceExplicitFlag(..)
) where
import FastString
......@@ -312,6 +315,9 @@ data StringLiteral = StringLiteral
instance Eq StringLiteral where
(StringLiteral _ a) == (StringLiteral _ b) = a == b
instance Outputable StringLiteral where
ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)
-- | Warning Text
--
-- reason/explanation from a WARNING or DEPRECATED pragma
......@@ -322,11 +328,30 @@ data WarningTxt = WarningTxt (Located SourceText)
deriving (Eq, Data)
instance Outputable WarningTxt where
ppr (WarningTxt _ ws)
= doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))
ppr (DeprecatedTxt _ ds)
= text "Deprecated:" <+>
doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))
ppr (WarningTxt lsrc ws)
= case unLoc lsrc of
NoSourceText -> pp_ws ws
SourceText src -> text src <+> pp_ws ws <+> text "#-}"
ppr (DeprecatedTxt lsrc ds)
= case unLoc lsrc of
NoSourceText -> pp_ws ds
SourceText src -> text src <+> pp_ws ds <+> text "#-}"
pp_ws :: [Located StringLiteral] -> SDoc
pp_ws [l] = ppr $ unLoc l
pp_ws ws
= text "["
<+> vcat (punctuate comma (map (ppr . unLoc) ws))
<+> text "]"
pprWarningTxtForMsg :: WarningTxt -> SDoc
pprWarningTxtForMsg (WarningTxt _ ws)
= doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))
pprWarningTxtForMsg (DeprecatedTxt _ ds)
= text "Deprecated:" <+>
doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))
{-
************************************************************************
......@@ -375,12 +400,12 @@ maxPrecedence = 9
minPrecedence = 0
defaultFixity :: Fixity
defaultFixity = Fixity (show maxPrecedence) maxPrecedence InfixL
defaultFixity = Fixity NoSourceText maxPrecedence InfixL
negateFixity, funTyFixity :: Fixity
-- Wired-in fixities
negateFixity = Fixity "6" 6 InfixL -- Fixity of unary negate
funTyFixity = Fixity "0" 0 InfixR -- Fixity of '->'
negateFixity = Fixity NoSourceText 6 InfixL -- Fixity of unary negate
funTyFixity = Fixity NoSourceText 0 InfixR -- Fixity of '->'
{-
Consider
......@@ -979,8 +1004,21 @@ For OverLitVal
HsIsString "\x41nd" == "And"
-}
type SourceText = String -- Note [Literal source text],[Pragma source text]
-- Note [Literal source text],[Pragma source text]
data SourceText = SourceText String
| NoSourceText -- ^ For when code is generated, e.g. TH,
-- deriving. The pretty printer will then make
-- its own representation of the item.
deriving (Data, Show, Eq )
instance Outputable SourceText where
ppr (SourceText s) = text "SourceText" <+> text s
ppr NoSourceText = text "NoSourceText"
-- | Special combinator for showing string literals.
pprWithSourceText :: SourceText -> SDoc -> SDoc
pprWithSourceText NoSourceText d = d
pprWithSourceText (SourceText src) _ = text src
{-
************************************************************************
......@@ -1117,7 +1155,7 @@ isEmptyInlineSpec _ = False
defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
:: InlinePragma
defaultInlinePragma = InlinePragma { inl_src = "{-# INLINE"
defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE"
, inl_act = AlwaysActive
, inl_rule = FunLike
, inl_inline = EmptyInlineSpec
......@@ -1175,8 +1213,8 @@ setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }
instance Outputable Activation where
ppr AlwaysActive = brackets (text "ALWAYS")
ppr NeverActive = brackets (text "NEVER")
ppr AlwaysActive = empty
ppr NeverActive = brackets (text "~")
ppr (ActiveBefore _ n) = brackets (char '~' <> int n)
ppr (ActiveAfter _ n) = brackets (int n)
......@@ -1191,10 +1229,21 @@ instance Outputable InlineSpec where
ppr EmptyInlineSpec = empty
instance Outputable InlinePragma where
ppr (InlinePragma { inl_inline = inline, inl_act = activation
, inl_rule = info, inl_sat = mb_arity })
= ppr inline <> pp_act inline activation <+> pp_sat <+> pp_info
ppr = pprInline
pprInline :: InlinePragma -> SDoc
pprInline = pprInline' True
pprInlineDebug :: InlinePragma -> SDoc
pprInlineDebug = pprInline' False
pprInline' :: Bool -> InlinePragma -> SDoc
pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation
, inl_rule = info, inl_sat = mb_arity })
= pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info
where
pp_inl x = if emptyInline then empty else ppr x
pp_act Inline AlwaysActive = empty
pp_act NoInline NeverActive = empty
pp_act _ act = ppr act
......@@ -1356,3 +1405,8 @@ treatZeroAsInf n = Int n
-- | Inject any integer into an 'IntWithInf'
mkIntWithInf :: Int -> IntWithInf
mkIntWithInf = Int
data SpliceExplicitFlag
= ExplicitSplice | -- ^ <=> $(f x y)
ImplicitSplice -- ^ <=> f x y, i.e. a naked top level expression
deriving Data
......@@ -495,7 +495,7 @@ data DataConRep
-- emit a warning (in checkValidDataCon) and treat it like
-- @(HsSrcBang _ NoSrcUnpack SrcLazy)@
data HsSrcBang =
HsSrcBang (Maybe SourceText) -- Note [Pragma source text] in BasicTypes
HsSrcBang SourceText -- Note [Pragma source text] in BasicTypes
SrcUnpackedness
SrcStrictness
deriving Data.Data
......
......@@ -1122,7 +1122,8 @@ seqId = pcMiscPrelId seqName ty info
`setRuleInfo` mkRuleInfo [seq_cast_rule]
inline_prag
= alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter "0" 0
= alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter
NoSourceText 0
-- Make 'seq' not inline-always, so that simpleOptExpr
-- (see CoreSubst.simple_app) won't inline 'seq' on the
-- LHS of rules. That way we can have rules for 'seq';
......
......@@ -316,6 +316,9 @@ instance Data Var where
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "Var"
instance HasOccName Var where
occName = nameOccName . varName
varUnique :: Var -> Unique
varUnique var = mkUniqueGrimily (realUnique var)
......
......@@ -402,7 +402,7 @@ pprIdBndrInfo info
has_lbv = not (hasNoOneShotInfo lbv_info)
doc = showAttributes
[ (has_prag, text "InlPrag=" <> ppr prag_info)
[ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info)
, (has_occ, text "Occ=" <> ppr occ_info)
, (has_dmd, text "Dmd=" <> ppr dmd_info)
, (has_lbv , text "OS=" <> ppr lbv_info)
......
......@@ -888,9 +888,10 @@ addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) =
(return ty1)
(return arr_ty)
(return lr)
addTickHsCmd (HsCmdArrForm e fix cmdtop) =
liftM3 HsCmdArrForm
addTickHsCmd (HsCmdArrForm e f fix cmdtop) =
liftM4 HsCmdArrForm
(addTickLHsExpr e)
(return f)
(return fix)
(mapM (liftL (addTickHsCmdTop)) cmdtop)
......
......@@ -607,7 +607,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdDo (L _ stmts) _) env_ids = do
-- -----------------------------------
-- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn
dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do
dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ _ args) env_ids = do
let env_ty = mkBigCoreVarTupTy env_ids
core_op <- dsLExpr op
(core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
......
......@@ -37,7 +37,6 @@ import TysPrim
import TyCon
import TysWiredIn
import BasicTypes
import FastString ( unpackFS )
import Literal
import PrelNames
import DynFlags
......@@ -95,7 +94,7 @@ dsCCall lbl args may_gc result_ty
uniq <- newUnique
dflags <- getDynFlags
let
target = StaticTarget (unpackFS lbl) lbl Nothing True
target = StaticTarget NoSourceText lbl Nothing True
the_fcall = CCall (CCallSpec target CCallConv may_gc)
the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
......
......@@ -218,7 +218,7 @@ dsFCall fn_id co fcall mDeclHeader = do
CApiConv safety) ->
do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)
let fcall' = CCall (CCallSpec
(StaticTarget (unpackFS wrapperName)
(StaticTarget NoSourceText
wrapperName mUnitId
True)
CApiConv safety)
......
......@@ -944,7 +944,7 @@ repTy :: HsType Name -> DsM (Core TH.TypeQ)
repTy ty@(HsForAllTy {}) = repForall ty
repTy ty@(HsQualTy {}) = repForall ty
repTy (HsTyVar (L _ n))
repTy (HsTyVar _ (L _ n))
| isTvOcc occ = do tv1 <- lookupOcc n
repTvar tv1
| isDataOcc occ = do tc1 <- lookupOcc n
......@@ -970,7 +970,8 @@ repTy (HsListTy t) = do
repTapp tcon t1
repTy (HsPArrTy t) = do
t1 <- repLTy t
tcon <- repTy (HsTyVar (noLoc (tyConName parrTyCon)))
tcon <- repTy (HsTyVar NotPromoted
(noLoc (tyConName parrTyCon)))
repTapp tcon t1
repTy (HsTupleTy HsUnboxedTuple tys) = do
tys1 <- repLTys tys
......@@ -995,7 +996,7 @@ repTy (HsKindSig t k) = do
k1 <- repLKind k
repTSig t1 k1
repTy (HsSpliceTy splice _) = repSplice splice
repTy (HsExplicitListTy _ tys) = do
repTy (HsExplicitListTy _ _ tys) = do
tys1 <- repLTys tys
repTPromotedList tys1
repTy (HsExplicitTupleTy _ tys) = do
......@@ -1041,7 +1042,7 @@ repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind)
repNonArrowLKind (L _ ki) = repNonArrowKind ki
repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind)
repNonArrowKind (HsTyVar (L _ name))
repNonArrowKind (HsTyVar _ (L _ name))
| isLiftedTypeKindTyConName name = repKStar
| name `hasKey` constraintKindTyConKey = repKConstraint
| isTvOcc (nameOccName name) = lookupOcc name >>= repKVar
......@@ -1073,10 +1074,10 @@ repRole (L _ Nothing) = rep2 inferRName []
repSplice :: HsSplice Name -> DsM (Core a)
-- See Note [How brackets and nested splices are handled] in TcSplice
-- We return a CoreExpr of any old type; the context should know
repSplice (HsTypedSplice n _) = rep_splice n
repSplice (HsUntypedSplice n _) = rep_splice n
repSplice (HsQuasiQuote n _ _ _) = rep_splice n
repSplice e@(HsSpliced _ _) = pprPanic "repSplice" (ppr e)
repSplice (HsTypedSplice _ n _) = rep_splice n
repSplice (HsUntypedSplice _ n _) = rep_splice n
repSplice (HsQuasiQuote n _ _ _) = rep_splice n
repSplice e@(HsSpliced _ _) = pprPanic "repSplice" (ppr e)
rep_splice :: Name -> DsM (Core a)
rep_splice splice_name
......@@ -2345,15 +2346,15 @@ repLiteral lit
mk_integer :: Integer -> DsM HsLit
mk_integer i = do integer_ty <- lookupType integerTyConName
return $ HsInteger "" i integer_ty
return $ HsInteger NoSourceText i integer_ty
mk_rational :: FractionalLit -> DsM HsLit
mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ HsRat r rat_ty
mk_string :: FastString -> DsM HsLit
mk_string s = return $ HsString "" s
mk_string s = return $ HsString NoSourceText s
mk_char :: Char -> DsM HsLit
mk_char c = return $ HsChar "" c
mk_char c = return $ HsChar NoSourceText c
repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
repOverloadedLiteral (OverLit { ol_val = val})
......
......@@ -291,11 +291,11 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
-- which might be ok if we have 'instance IsString Int'
--
| not type_change, isIntTy ty, Just int_lit <- mb_int_lit
= mk_con_pat intDataCon (HsIntPrim "" int_lit)
= mk_con_pat intDataCon (HsIntPrim NoSourceText int_lit)
| not type_change, isWordTy ty, Just int_lit <- mb_int_lit
= mk_con_pat wordDataCon (HsWordPrim "" int_lit)
= mk_con_pat wordDataCon (HsWordPrim NoSourceText int_lit)
| not type_change, isStringTy ty, Just str_lit <- mb_str_lit
= tidy_lit_pat (HsString "" str_lit)
= tidy_lit_pat (HsString NoSourceText str_lit)
-- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
-- If we do convert to the constructor form, we'll generate a case
-- expression on a Float# or Double# and that's not allowed in Core; see
......
This diff is collapsed.
......@@ -22,7 +22,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
GRHSs, pprPatBind )
import {-# SOURCE #-} HsPat ( LPat )
import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId )
import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId,HasOccNameId )
import HsTypes
import PprCore ()
import CoreSyn
......@@ -437,13 +437,15 @@ Specifically,
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
ppr (HsValBinds bs) = ppr bs
ppr (HsIPBinds bs) = ppr bs
ppr EmptyLocalBinds = empty
instance (OutputableBndrId idL, OutputableBndrId idR)
instance (OutputableBndrId idL, OutputableBndrId idR,
HasOccNameId idL, HasOccNameId idR)
=> Outputable (HsValBindsLR idL idR) where
ppr (ValBindsIn binds sigs)
= pprDeclList (pprLHsBindsForUser binds sigs)
......@@ -459,14 +461,16 @@ instance (OutputableBndrId idL, OutputableBndrId idR)
pp_rec Recursive = text "rec"
pp_rec NonRecursive = text "nonrec"
pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR)
pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR,
HasOccNameId idL, HasOccNameId idR)
=> LHsBindsLR idL idR -> SDoc
pprLHsBinds binds
| isEmptyLHsBinds binds = empty
| otherwise = pprDeclList (map ppr (bagToList binds))
pprLHsBindsForUser :: (OutputableBndrId idL, OutputableBndrId idR,
OutputableBndrId id2)
OutputableBndrId id2, HasOccNameId id2,
HasOccNameId idL, HasOccNameId idR)
=> LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
-- pprLHsBindsForUser is different to pprLHsBinds because
-- a) No braces: 'let' and 'where' include a list of HsBindGroups
......@@ -504,6 +508,10 @@ isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds
isEmptyLocalBinds EmptyLocalBinds = True
eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
eqEmptyLocalBinds EmptyLocalBinds = True
eqEmptyLocalBinds _ = False
isEmptyValBinds :: HsValBindsLR a b -> Bool
isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
......@@ -553,11 +561,13 @@ So the desugarer tries to do a better job:
in (fm,gm)
-}
instance (OutputableBndrId idL, OutputableBndrId idR)
instance (OutputableBndrId idL, OutputableBndrId idR,
HasOccNameId idL, HasOccNameId idR)
=> Outputable (HsBindLR idL idR) where
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
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
......@@ -613,7 +623,7 @@ instance (OutputableBndr id) => Outputable (ABExport id) where
, nest 2 (pprTcSpecPrags prags)
, nest 2 (text "wrap:" <+> ppr wrap)]
instance (OutputableBndr idL, OutputableBndrId idR)
instance (OutputableBndr idL, OutputableBndrId idR, HasOccNameId idR)
=> Outputable (PatSynBind idL idR) where
ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,
psb_dir = dir })
......@@ -685,11 +695,12 @@ data IPBind id
= IPBind (Either (Located HsIPName) id) (LHsExpr id)
deriving instance (DataId name) => Data (IPBind name)
instance (OutputableBndrId id) => Outputable (HsIPBinds id) where
instance (OutputableBndrId id, HasOccNameId id)
=> Outputable (HsIPBinds id) where
ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
$$ ifPprDebug (ppr ds)
instance (OutputableBndrId id) => Outputable (IPBind id) where
instance (OutputableBndrId id, HasOccNameId 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
......@@ -946,28 +957,36 @@ 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) => Outputable (Sig name) where
instance (OutputableBndrId name, HasOccNameId name)
=> Outputable (Sig name) where
ppr sig = ppr_sig sig
ppr_sig :: (OutputableBndrId name) => Sig name -> SDoc
ppr_sig :: (OutputableBndrId name, HasOccNameId 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)
| otherwise = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id))
ppr_sig (FixSig fix_sig) = ppr fix_sig
ppr_sig (SpecSig var ty inl)
= pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl)
ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
ppr_sig (SpecInstSig _ ty)
= pragBrackets (text "SPECIALIZE instance" <+> ppr ty)
ppr_sig (SpecSig var ty inl@(InlinePragma { inl_inline = spec }))
= pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var)
(interpp'SP ty) inl)
where
pragmaSrc = case spec of
EmptyInlineSpec -> "{-# SPECIALISE"
_ -> "{-# SPECIALISE_INLINE"
ppr_sig (InlineSig var inl)
= pragSrcBrackets (inl_src inl) "{-# INLINE" (pprInline inl
<+> pprPrefixOcc (unLoc var))
ppr_sig (SpecInstSig src ty)
= pragSrcBrackets src "{-# SPECIALISE" (text "instance" <+> ppr ty)
ppr_sig (MinimalSig _ bf) = pragBrackets (pprMinimalSig bf)
ppr_sig (PatSynSig names sig_ty)
= text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)
ppr_sig (SCCFunSig _ fn Nothing)
= pragBrackets (text "SCC" <+> ppr fn)
ppr_sig (SCCFunSig _ fn (Just str))
= pragBrackets (text "SCC" <+> ppr fn <+> ppr (sl_st str))
ppr_sig (SCCFunSig src fn (Just str))
= pragSrcBrackets src "{-# SCC#-}" (ppr fn <+> ppr str)
instance OutputableBndr name => Outputable (FixitySig name) where
ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
......@@ -975,7 +994,13 @@ instance OutputableBndr name => Outputable (FixitySig name) where
pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
pragBrackets :: SDoc -> SDoc
pragBrackets doc = text "{-#" <+> doc <+> ptext (sLit "#-}")
pragBrackets doc = text "{-#" <+> doc <+> text "#-}"
-- | Using SourceText in case the pragma was spelled differently or used mixed
-- case
pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc
pragSrcBrackets (SourceText src) _ doc = text src <+> doc <+> text "#-}"
pragSrcBrackets NoSourceText alt doc = text alt <+> doc <+> text "#-}"
pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc
pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]
......@@ -983,19 +1008,21 @@ pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]
pprvars = hsep $ punctuate comma (map pprPrefixOcc vars)
pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc
pprSpec var pp_ty inl = text "SPECIALIZE" <+> pp_inl <+> pprVarSig [var] pp_ty
pprSpec var pp_ty inl = pp_inl <+> pprVarSig [var] pp_ty
where
pp_inl | isDefaultInlinePragma inl = empty
| otherwise = ppr inl
| otherwise = pprInline inl
pprTcSpecPrags :: TcSpecPrags -> SDoc
pprTcSpecPrags IsDefaultMethod = text "<default method>"
pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps)
instance Outputable TcSpecPrag where
ppr (SpecPrag var _ inl) = pprSpec var (text "<type>") inl
ppr (SpecPrag var _ inl)
= text "SPECIALIZE" <+> pprSpec var (text "<type>") inl
pprMinimalSig :: OutputableBndr name => LBooleanFormula (Located name) -> SDoc
pprMinimalSig :: (OutputableBndr name, HasOccName name)
=> LBooleanFormula (Located name) -> SDoc
pprMinimalSig (L _ bf) = text "MINIMAL" <+> ppr (fmap unLoc bf)
{-
......
This diff is collapsed.
This diff is collapsed.
......@@ -10,7 +10,8 @@ module HsExpr where
import SrcLoc ( Located )
import Outputable ( SDoc, Outputable )
import {-# SOURCE #-} HsPat ( LPat )
import PlaceHolder ( DataId, OutputableBndrId )
import BasicTypes ( SpliceExplicitFlag(..))
import PlaceHolder ( DataId, OutputableBndrId, HasOccNameId )
import Data.Data hiding ( Fixity )
type role HsExpr nominal
......@@ -33,20 +34,27 @@ 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) => Outputable (HsExpr id)
instance (OutputableBndrId id) => Outputable (HsCmd id)
instance (OutputableBndrId id, HasOccNameId id) => Outputable (HsExpr id)
instance (OutputableBndrId id, HasOccNameId id) => Outputable (HsCmd id)
type LHsExpr a = Located (HsExpr a)
pprLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc
pprLExpr :: (OutputableBndrId id, HasOccNameId id) => LHsExpr id -> SDoc
pprExpr :: (OutputableBndrId id) => HsExpr id -> SDoc
pprExpr :: (OutputableBndrId id,HasOccNameId id) => HsExpr id -> SDoc
pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc
pprSplice :: (OutputableBndrId id, HasOccNameId id)
=> HsSplice id -> SDoc
pprSpliceDecl :: (OutputableBndrId id, HasOccNameId id)
=> HsSplice id -> SpliceExplicitFlag -> SDoc
pprPatBind :: (OutputableBndrId bndr,
OutputableBndrId id, Outputable body)
OutputableBndrId id,
HasOccNameId id,
HasOccNameId bndr,
Outputable body)
=> LPat bndr -> GRHSs id body -> SDoc
pprFunBind :: (OutputableBndrId idR, Outputable body)
pprFunBind :: (OutputableBndrId idR, HasOccNameId idR, Outputable body)
=> MatchGroup idR body -> SDoc
......@@ -12,8 +12,8 @@ module HsImpExp where
import Module ( ModuleName )
import HsDoc ( HsDocString )