fenfire-0.1: Preprocessor/Hsx/Pretty.hs
{-# OPTIONS_GHC -w #-}
-----------------------------------------------------------------------------
-- |
-- Module : Preprocessor.Hsx.Pretty
-- Original : Language.Haskell.Pretty
-- Copyright : (c) Niklas Broberg 2004,
-- (c) The GHC Team, Noel Winstanley 1997-2000
-- License : BSD-style (see the file LICENSE.txt)
--
-- Maintainer : Niklas Broberg, d00nibro@dtek.chalmers.se
-- Stability : experimental
-- Portability : portable
--
-- Pretty printer for Haskell with extensions.
--
-----------------------------------------------------------------------------
module Preprocessor.Hsx.Pretty (
-- * Pretty printing
Pretty,
prettyPrintStyleMode, prettyPrintWithMode, prettyPrint,
-- * Pretty-printing styles (from "Text.PrettyPrint.HughesPJ")
P.Style(..), P.style, P.Mode(..),
-- * Haskell formatting modes
PPHsMode(..), Indent, PPLayout(..), defaultMode) where
import Preprocessor.Hsx.Syntax
import qualified Text.PrettyPrint as P
infixl 5 $$$
-----------------------------------------------------------------------------
-- | Varieties of layout we can use.
data PPLayout = PPOffsideRule -- ^ classical layout
| PPSemiColon -- ^ classical layout made explicit
| PPInLine -- ^ inline decls, with newlines between them
| PPNoLayout -- ^ everything on a single line
deriving Eq
type Indent = Int
-- | Pretty-printing parameters.
--
-- /Note:/ the 'onsideIndent' must be positive and less than all other indents.
data PPHsMode = PPHsMode {
-- | indentation of a class or instance
classIndent :: Indent,
-- | indentation of a @do@-expression
doIndent :: Indent,
-- | indentation of the body of a
-- @case@ expression
caseIndent :: Indent,
-- | indentation of the declarations in a
-- @let@ expression
letIndent :: Indent,
-- | indentation of the declarations in a
-- @where@ clause
whereIndent :: Indent,
-- | indentation added for continuation
-- lines that would otherwise be offside
onsideIndent :: Indent,
-- | blank lines between statements?
spacing :: Bool,
-- | Pretty-printing style to use
layout :: PPLayout,
-- | add GHC-style @LINE@ pragmas to output?
linePragmas :: Bool,
-- | not implemented yet
comments :: Bool
}
-- | The default mode: pretty-print using the offside rule and sensible
-- defaults.
defaultMode :: PPHsMode
defaultMode = PPHsMode{
classIndent = 8,
doIndent = 3,
caseIndent = 4,
letIndent = 4,
whereIndent = 6,
onsideIndent = 2,
spacing = True,
layout = PPOffsideRule,
linePragmas = False,
comments = True
}
-- | Pretty printing monad
newtype DocM s a = DocM (s -> a)
instance Functor (DocM s) where
fmap f xs = do x <- xs; return (f x)
instance Monad (DocM s) where
(>>=) = thenDocM
(>>) = then_DocM
return = retDocM
{-# INLINE thenDocM #-}
{-# INLINE then_DocM #-}
{-# INLINE retDocM #-}
{-# INLINE unDocM #-}
{-# INLINE getPPEnv #-}
thenDocM :: DocM s a -> (a -> DocM s b) -> DocM s b
thenDocM m k = DocM $ (\s -> case unDocM m $ s of a -> unDocM (k a) $ s)
then_DocM :: DocM s a -> DocM s b -> DocM s b
then_DocM m k = DocM $ (\s -> case unDocM m $ s of _ -> unDocM k $ s)
retDocM :: a -> DocM s a
retDocM a = DocM (\_s -> a)
unDocM :: DocM s a -> (s -> a)
unDocM (DocM f) = f
-- all this extra stuff, just for this one function.
getPPEnv :: DocM s s
getPPEnv = DocM id
-- So that pp code still looks the same
-- this means we lose some generality though
-- | The document type produced by these pretty printers uses a 'PPHsMode'
-- environment.
type Doc = DocM PPHsMode P.Doc
-- | Things that can be pretty-printed, including all the syntactic objects
-- in "Preprocessor.Syntax".
class Pretty a where
-- | Pretty-print something in isolation.
pretty :: a -> Doc
-- | Pretty-print something in a precedence context.
prettyPrec :: Int -> a -> Doc
pretty = prettyPrec 0
prettyPrec _ = pretty
-- The pretty printing combinators
empty :: Doc
empty = return P.empty
nest :: Int -> Doc -> Doc
nest i m = m >>= return . P.nest i
-- Literals
text, ptext :: String -> Doc
text = return . P.text
ptext = return . P.text
char :: Char -> Doc
char = return . P.char
int :: Int -> Doc
int = return . P.int
integer :: Integer -> Doc
integer = return . P.integer
float :: Float -> Doc
float = return . P.float
double :: Double -> Doc
double = return . P.double
rational :: Rational -> Doc
rational = return . P.rational
-- Simple Combining Forms
parens, brackets, braces,quotes,doubleQuotes :: Doc -> Doc
parens d = d >>= return . P.parens
brackets d = d >>= return . P.brackets
braces d = d >>= return . P.braces
quotes d = d >>= return . P.quotes
doubleQuotes d = d >>= return . P.doubleQuotes
parensIf :: Bool -> Doc -> Doc
parensIf True = parens
parensIf False = id
-- Constants
semi,comma,colon,space,equals :: Doc
semi = return P.semi
comma = return P.comma
colon = return P.colon
space = return P.space
equals = return P.equals
lparen,rparen,lbrack,rbrack,lbrace,rbrace :: Doc
lparen = return P.lparen
rparen = return P.rparen
lbrack = return P.lbrack
rbrack = return P.rbrack
lbrace = return P.lbrace
rbrace = return P.rbrace
-- Combinators
(<>),(<+>),($$),($+$) :: Doc -> Doc -> Doc
aM <> bM = do{a<-aM;b<-bM;return (a P.<> b)}
aM <+> bM = do{a<-aM;b<-bM;return (a P.<+> b)}
aM $$ bM = do{a<-aM;b<-bM;return (a P.$$ b)}
aM $+$ bM = do{a<-aM;b<-bM;return (a P.$+$ b)}
hcat,hsep,vcat,sep,cat,fsep,fcat :: [Doc] -> Doc
hcat dl = sequence dl >>= return . P.hcat
hsep dl = sequence dl >>= return . P.hsep
vcat dl = sequence dl >>= return . P.vcat
sep dl = sequence dl >>= return . P.sep
cat dl = sequence dl >>= return . P.cat
fsep dl = sequence dl >>= return . P.fsep
fcat dl = sequence dl >>= return . P.fcat
-- Some More
hang :: Doc -> Int -> Doc -> Doc
hang dM i rM = do{d<-dM;r<-rM;return $ P.hang d i r}
-- Yuk, had to cut-n-paste this one from Pretty.hs
punctuate :: Doc -> [Doc] -> [Doc]
punctuate _ [] = []
punctuate p (d1:ds) = go d1 ds
where
go d [] = [d]
go d (e:es) = (d <> p) : go e es
-- | render the document with a given style and mode.
renderStyleMode :: P.Style -> PPHsMode -> Doc -> String
renderStyleMode ppStyle ppMode d = P.renderStyle ppStyle . unDocM d $ ppMode
-- | render the document with a given mode.
renderWithMode :: PPHsMode -> Doc -> String
renderWithMode = renderStyleMode P.style
-- | render the document with 'defaultMode'.
render :: Doc -> String
render = renderWithMode defaultMode
-- | pretty-print with a given style and mode.
prettyPrintStyleMode :: Pretty a => P.Style -> PPHsMode -> a -> String
prettyPrintStyleMode ppStyle ppMode = renderStyleMode ppStyle ppMode . pretty
-- | pretty-print with the default style and a given mode.
prettyPrintWithMode :: Pretty a => PPHsMode -> a -> String
prettyPrintWithMode = prettyPrintStyleMode P.style
-- | pretty-print with the default style and 'defaultMode'.
prettyPrint :: Pretty a => a -> String
prettyPrint = prettyPrintWithMode defaultMode
fullRenderWithMode :: PPHsMode -> P.Mode -> Int -> Float ->
(P.TextDetails -> a -> a) -> a -> Doc -> a
fullRenderWithMode ppMode m i f fn e mD =
P.fullRender m i f fn e $ (unDocM mD) ppMode
fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> a)
-> a -> Doc -> a
fullRender = fullRenderWithMode defaultMode
------------------------- Pretty-Print a Module --------------------
instance Pretty HsModule where
pretty (HsModule pos prags m mbExports imp decls) =
markLine pos $
topLevel (ppHsModuleHeader prags m mbExports)
(map pretty imp ++ map pretty decls)
-------------------------- Module Header ------------------------------
ppHsModuleHeader :: [HsPragma] -> Module -> Maybe [HsExportSpec] -> Doc
ppHsModuleHeader prags m mbExportList = mySep $ prags' ++ [
text "module",
pretty m,
maybePP (parenList . map pretty) mbExportList,
text "where"]
where prags' = map (\(HsPragma s) -> text $ "{-#" ++ s ++ "#-}") prags
instance Pretty Module where
pretty (Module modName) = text modName
instance Pretty HsExportSpec where
pretty (HsEVar name) = pretty name
pretty (HsEAbs name) = pretty name
pretty (HsEThingAll name) = pretty name <> text "(..)"
pretty (HsEThingWith name nameList) =
pretty name <> (parenList . map pretty $ nameList)
pretty (HsEModuleContents m) = text "module" <+> pretty m
instance Pretty HsImportDecl where
pretty (HsImportDecl pos m qual mbName mbSpecs) =
markLine pos $
mySep [text "import",
if qual then text "qualified" else empty,
pretty m,
maybePP (\m' -> text "as" <+> pretty m') mbName,
maybePP exports mbSpecs]
where
exports (b,specList) =
if b then text "hiding" <+> specs else specs
where specs = parenList . map pretty $ specList
instance Pretty HsImportSpec where
pretty (HsIVar name) = pretty name
pretty (HsIAbs name) = pretty name
pretty (HsIThingAll name) = pretty name <> text "(..)"
pretty (HsIThingWith name nameList) =
pretty name <> (parenList . map pretty $ nameList)
------------------------- Declarations ------------------------------
instance Pretty HsDecl where
pretty (HsTypeDecl loc name nameList htype) =
blankline $
markLine loc $
mySep ( [text "type", pretty name]
++ map pretty nameList
++ [equals, pretty htype])
pretty (HsDataDecl loc context name nameList constrList derives) =
blankline $
markLine loc $
mySep ( [text "data", ppHsContext context, pretty name]
++ map pretty nameList)
<+> (myVcat (zipWith (<+>) (equals : repeat (char '|'))
(map pretty constrList))
$$$ ppHsDeriving derives)
pretty (HsGDataDecl loc context name nameList gadtList) =
blankline $
markLine loc $
mySep ( [text "data", ppHsContext context, pretty name]
++ map pretty nameList ++ [text "where"])
$$$ ppBody classIndent (map pretty gadtList)
pretty (HsNewTypeDecl pos context name nameList constr derives) =
blankline $
markLine pos $
mySep ( [text "newtype", ppHsContext context, pretty name]
++ map pretty nameList)
<+> equals <+> (pretty constr $$$ ppHsDeriving derives)
--m{spacing=False}
-- special case for empty class declaration
pretty (HsClassDecl pos context name nameList fundeps []) =
blankline $
markLine pos $
mySep ( [text "class", ppHsContext context, pretty name]
++ map pretty nameList ++ [ppFunDeps fundeps])
pretty (HsClassDecl pos context name nameList fundeps declList) =
blankline $
markLine pos $
mySep ( [text "class", ppHsContext context, pretty name]
++ map pretty nameList ++ [ppFunDeps fundeps, text "where"])
$$$ ppBody classIndent (map pretty declList)
-- m{spacing=False}
-- special case for empty instance declaration
pretty (HsInstDecl pos context name args []) =
blankline $
markLine pos $
mySep ( [text "instance", ppHsContext context, pretty name]
++ map ppHsAType args)
pretty (HsInstDecl pos context name args declList) =
blankline $
markLine pos $
mySep ( [text "instance", ppHsContext context, pretty name]
++ map ppHsAType args ++ [text "where"])
$$$ ppBody classIndent (map pretty declList)
pretty (HsDefaultDecl pos htypes) =
blankline $
markLine pos $
text "default" <+> parenList (map pretty htypes)
pretty (HsSpliceDecl pos splice) =
blankline $
markLine pos $
pretty splice
pretty (HsTypeSig pos nameList qualType) =
blankline $
markLine pos $
mySep ((punctuate comma . map pretty $ nameList)
++ [text "::", pretty qualType])
pretty (HsFunBind matches) =
foldr ($$$) empty (map pretty matches)
pretty (HsPatBind pos pat rhs whereBinds) =
markLine pos $
myFsep [pretty pat, pretty rhs] $$$ ppWhere whereBinds
pretty (HsInfixDecl pos assoc prec opList) =
blankline $
markLine pos $
mySep ([pretty assoc, int prec]
++ (punctuate comma . map pretty $ opList))
pretty (HsForImp pos cconv saf str name typ) =
blankline $
markLine pos $
mySep [text "foreign import", pretty cconv, pretty saf,
text (show str), pretty name, text "::", pretty typ]
pretty (HsForExp pos cconv str name typ) =
blankline $
markLine pos $
mySep [text "foreign export", pretty cconv,
text (show str), pretty name, text "::", pretty typ]
instance Pretty HsAssoc where
pretty HsAssocNone = text "infix"
pretty HsAssocLeft = text "infixl"
pretty HsAssocRight = text "infixr"
instance Pretty HsMatch where
pretty (HsMatch pos f ps rhs whereBinds) =
markLine pos $
myFsep (lhs ++ [pretty rhs])
$$$ ppWhere whereBinds
where
lhs = case ps of
l:r:ps' | isSymbolName f ->
let hd = [pretty l, ppHsName f, pretty r] in
if null ps' then hd
else parens (myFsep hd) : map (prettyPrec 2) ps'
_ -> pretty f : map (prettyPrec 2) ps
ppWhere :: HsBinds -> Doc
ppWhere (HsBDecls []) = empty
ppWhere (HsBDecls l) = nest 2 (text "where" $$$ ppBody whereIndent (map pretty l))
ppWhere (HsIPBinds b) = nest 2 (text "where" $$$ ppBody whereIndent (map pretty b))
------------------------- FFI stuff -------------------------------------
instance Pretty HsSafety where
pretty PlayRisky = text "unsafe"
pretty (PlaySafe b) = text $ if b then "threadsafe" else "safe"
instance Pretty HsCallConv where
pretty StdCall = text "stdcall"
pretty CCall = text "ccall"
------------------------- Data & Newtype Bodies -------------------------
instance Pretty HsQualConDecl where
pretty (HsQualConDecl _pos tvs ctxt con) =
myFsep [ppForall (Just tvs), ppHsContext ctxt, pretty con]
instance Pretty HsGadtDecl where
pretty (HsGadtDecl _pos name ty) =
myFsep [pretty name, text "::", pretty ty]
instance Pretty HsConDecl where
pretty (HsRecDecl name fieldList) =
pretty name <> (braceList . map ppField $ fieldList)
pretty (HsConDecl name@(HsSymbol _) [l, r]) =
myFsep [prettyPrec prec_btype l, ppHsName name,
prettyPrec prec_btype r]
pretty (HsConDecl name typeList) =
mySep $ ppHsName name : map (prettyPrec prec_atype) typeList
ppField :: ([HsName],HsBangType) -> Doc
ppField (names, ty) =
myFsepSimple $ (punctuate comma . map pretty $ names) ++
[text "::", pretty ty]
instance Pretty HsBangType where
prettyPrec _ (HsBangedTy ty) = char '!' <> ppHsAType ty
prettyPrec p (HsUnBangedTy ty) = prettyPrec p ty
ppHsDeriving :: [HsQName] -> Doc
ppHsDeriving [] = empty
ppHsDeriving [d] = text "deriving" <+> ppHsQName d
ppHsDeriving ds = text "deriving" <+> parenList (map ppHsQName ds)
------------------------- Types -------------------------
{-
instance Pretty HsQualType where
pretty (HsQualType context htype) =
myFsep [ppHsContext context, pretty htype]
-}
ppHsBType :: HsType -> Doc
ppHsBType = prettyPrec prec_btype
ppHsAType :: HsType -> Doc
ppHsAType = prettyPrec prec_atype
-- precedences for types
prec_btype, prec_atype :: Int
prec_btype = 1 -- left argument of ->,
-- or either argument of an infix data constructor
prec_atype = 2 -- argument of type or data constructor, or of a class
instance Pretty HsType where
prettyPrec p (HsTyForall mtvs ctxt htype) = parensIf (p > 0) $
myFsep [ppForall mtvs, ppHsContext ctxt, pretty htype]
prettyPrec p (HsTyFun a b) = parensIf (p > 0) $
myFsep [ppHsBType a, text "->", pretty b]
prettyPrec _ (HsTyTuple bxd l) =
let ds = map pretty l
in case bxd of
Boxed -> parenList ds
Unboxed -> hashParenList ds
prettyPrec p (HsTyApp a b)
| a == list_tycon = brackets $ pretty b -- special case
| otherwise = parensIf (p > prec_btype) $
myFsep [pretty a, ppHsAType b]
prettyPrec _ (HsTyVar name) = pretty name
prettyPrec _ (HsTyCon name) = pretty name
prettyPrec _ (HsTyPred asst) = pretty asst
prettyPrec _ (HsTyInfix a op b) = parens (myFsep [pretty op, parens (pretty a), parens (pretty b)])
ppForall :: Maybe [HsName] -> Doc
ppForall Nothing = empty
ppForall (Just []) = empty
ppForall (Just vs) = myFsep (text "forall" : map pretty vs ++ [char '.'])
------------------- Functional Dependencies -------------------
instance Pretty HsFunDep where
pretty (HsFunDep from to) =
myFsep $ map pretty from ++ [text "->"] ++ map pretty to
ppFunDeps :: [HsFunDep] -> Doc
ppFunDeps [] = empty
ppFunDeps fds = myFsep $ (char '|':) . punctuate comma . map pretty $ fds
------------------------- Expressions -------------------------
instance Pretty HsRhs where
pretty (HsUnGuardedRhs e) = equals <+> pretty e
pretty (HsGuardedRhss guardList) = myVcat . map pretty $ guardList
instance Pretty HsGuardedRhs where
pretty (HsGuardedRhs _pos guards ppBody) =
myFsep $ [char '|'] ++ (punctuate comma . map pretty $ guards) ++ [equals, pretty ppBody]
instance Pretty HsLiteral where
pretty (HsInt i) = integer i
pretty (HsChar c) = text (show c)
pretty (HsString s) = text (show s)
pretty (HsFrac r) = double (fromRational r)
-- GHC unboxed literals:
pretty (HsCharPrim c) = text (show c) <> char '#'
pretty (HsStringPrim s) = text (show s) <> char '#'
pretty (HsIntPrim i) = integer i <> char '#'
pretty (HsFloatPrim r) = float (fromRational r) <> char '#'
pretty (HsDoublePrim r) = double (fromRational r) <> text "##"
instance Pretty HsExp where
pretty (HsLit l) = pretty l
-- lambda stuff
pretty (HsInfixApp a op b) = myFsep [pretty a, pretty op, pretty b]
pretty (HsNegApp e) = myFsep [char '-', pretty e]
pretty (HsApp a b) = myFsep [pretty a, pretty b]
pretty (HsLambda _loc expList ppBody) = myFsep $
char '\\' : map pretty expList ++ [text "->", pretty ppBody]
-- keywords
-- two cases for lets
pretty (HsLet (HsBDecls declList) letBody) =
ppLetExp declList letBody
pretty (HsLet (HsIPBinds bindList) letBody) =
ppLetExp bindList letBody
pretty (HsDLet bindList letBody) =
myFsep [text "dlet" <+> ppBody letIndent (map pretty bindList),
text "in", pretty letBody]
pretty (HsWith exp bindList) =
pretty exp $$$ ppWith bindList
pretty (HsIf cond thenexp elsexp) =
myFsep [text "if", pretty cond,
text "then", pretty thenexp,
text "else", pretty elsexp]
pretty (HsCase cond altList) =
myFsep [text "case", pretty cond, text "of"]
$$$ ppBody caseIndent (map pretty altList)
pretty (HsDo stmtList) =
text "do" $$$ ppBody doIndent (map pretty stmtList)
pretty (HsMDo stmtList) =
text "mdo" $$$ ppBody doIndent (map pretty stmtList)
-- Constructors & Vars
pretty (HsVar name) = pretty name
pretty (HsIPVar ipname) = pretty ipname
pretty (HsCon name) = pretty name
pretty (HsTuple expList) = parenList . map pretty $ expList
-- weird stuff
pretty (HsParen e) = parens . pretty $ e
pretty (HsLeftSection e op) = parens (pretty e <+> pretty op)
pretty (HsRightSection op e) = parens (pretty op <+> pretty e)
pretty (HsRecConstr c fieldList) =
pretty c <> (braceList . map pretty $ fieldList)
pretty (HsRecUpdate e fieldList) =
pretty e <> (braceList . map pretty $ fieldList)
-- patterns
-- special case that would otherwise be buggy
pretty (HsAsPat name (HsIrrPat e)) =
myFsep [pretty name <> char '@', char '~' <> pretty e]
pretty (HsAsPat name e) = hcat [pretty name, char '@', pretty e]
pretty HsWildCard = char '_'
pretty (HsIrrPat e) = char '~' <> pretty e
-- Lists
pretty (HsList list) =
bracketList . punctuate comma . map pretty $ list
pretty (HsEnumFrom e) =
bracketList [pretty e, text ".."]
pretty (HsEnumFromTo from to) =
bracketList [pretty from, text "..", pretty to]
pretty (HsEnumFromThen from thenE) =
bracketList [pretty from <> comma, pretty thenE, text ".."]
pretty (HsEnumFromThenTo from thenE to) =
bracketList [pretty from <> comma, pretty thenE,
text "..", pretty to]
pretty (HsListComp e stmtList) =
bracketList ([pretty e, char '|']
++ (punctuate comma . map pretty $ stmtList))
pretty (HsExpTypeSig _pos e ty) =
myFsep [pretty e, text "::", pretty ty]
-- Template Haskell
pretty (HsReifyExp r) = pretty r
pretty (HsBracketExp b) = pretty b
pretty (HsSpliceExp s) = pretty s
-- regular patterns
pretty (HsRPats _ rs) =
myFsep $ text "[/" : map pretty rs ++ [text "/]"]
pretty (HsSeqRP rs) =
myFsep $ text "(/" : map pretty rs ++ [text "/)"]
pretty (HsStarRP r) = pretty r <> char '*'
pretty (HsStarGRP r) = pretty r <> text "*!"
pretty (HsPlusRP r) = pretty r <> char '+'
pretty (HsPlusGRP r) = pretty r <> text "+!"
pretty (HsOptRP r) = pretty r <> char '?'
pretty (HsOptGRP r) = pretty r <> text "?!"
pretty (HsEitherRP r1 r2) = parens . myFsep $
[pretty r1, char '|', pretty r2]
-- special case that would otherwise be buggy
pretty (HsCAsRP n (HsIrrPat e)) =
myFsep [pretty n <> text "@:", char '~' <> pretty e]
pretty (HsCAsRP n r) = hcat [pretty n, text "@:", pretty r]
-- Hsx
pretty (HsXTag _ n attrs mattr cs) =
let ax = maybe [] (return . pretty) mattr
in hcat $
(myFsep $ (char '<' <> pretty n): map pretty attrs ++ ax ++ [char '>']):
map pretty cs ++ [myFsep $ [text "</" <> pretty n, char '>']]
pretty (HsXETag _ n attrs mattr) =
let ax = maybe [] (return . pretty) mattr
in myFsep $ (char '<' <> pretty n): map pretty attrs ++ ax ++ [text "/>"]
pretty (HsXPcdata s) = text s
pretty (HsXExpTag e) =
myFsep $ [text "<%", pretty e, text "%>"]
instance Pretty HsXAttr where
pretty (HsXAttr n v) =
myFsep [pretty n, char '=', pretty v]
instance Pretty HsXName where
pretty (HsXName n) = text n
pretty (HsXDomName d n) = text d <> char ':' <> text n
--ppLetExp :: [HsDecl] -> HsExp -> Doc
ppLetExp l b = myFsep [text "let" <+> ppBody letIndent (map pretty l),
text "in", pretty b]
ppWith binds = nest 2 (text "with" $$$ ppBody withIndent (map pretty binds))
withIndent = whereIndent
--------------------- Template Haskell -------------------------
instance Pretty HsReify where
pretty (HsReifyDecl name) = ppReify "reifyDecl" name
pretty (HsReifyType name) = ppReify "reifyType" name
pretty (HsReifyFixity name) = ppReify "reifyFixity" name
ppReify t n = myFsep [text t, pretty n]
instance Pretty HsBracket where
pretty (HsExpBracket e) = ppBracket "[|" e
pretty (HsPatBracket p) = ppBracket "[p|" p
pretty (HsTypeBracket t) = ppBracket "[t|" t
pretty (HsDeclBracket d) =
myFsep $ text "[d|" : map pretty d ++ [text "|]"]
ppBracket o x = myFsep [text o, pretty x, text "|]"]
instance Pretty HsSplice where
pretty (HsIdSplice s) = char '$' <> text s
pretty (HsParenSplice e) =
myFsep [text "$(", pretty e, char ')']
------------------------- Patterns -----------------------------
instance Pretty HsPat where
prettyPrec _ (HsPVar name) = pretty name
prettyPrec _ (HsPLit lit) = pretty lit
prettyPrec _ (HsPNeg p) = myFsep [char '-', pretty p]
prettyPrec p (HsPInfixApp a op b) = parensIf (p > 0) $
myFsep [pretty a, pretty (HsQConOp op), pretty b]
prettyPrec p (HsPApp n ps) = parensIf (p > 1) $
myFsep (pretty n : map pretty ps)
prettyPrec _ (HsPTuple ps) = parenList . map pretty $ ps
prettyPrec _ (HsPList ps) =
bracketList . punctuate comma . map pretty $ ps
prettyPrec _ (HsPParen p) = parens . pretty $ p
prettyPrec _ (HsPRec c fields) =
pretty c <> (braceList . map pretty $ fields)
-- special case that would otherwise be buggy
prettyPrec _ (HsPAsPat name (HsPIrrPat pat)) =
myFsep [pretty name <> char '@', char '~' <> pretty pat]
prettyPrec _ (HsPAsPat name pat) =
hcat [pretty name, char '@', pretty pat]
prettyPrec _ HsPWildCard = char '_'
prettyPrec _ (HsPIrrPat pat) = char '~' <> pretty pat
prettyPrec _ (HsPRPat _ rs) =
myFsep $ text "[/" : map pretty rs ++ [text "/]"]
prettyPrec _ (HsPatTypeSig _pos pat ty) =
myFsep [pretty pat, text "::", pretty ty]
-- Hsx
prettyPrec _ (HsPXTag _ n attrs mattr cp) =
let ap = maybe [] (return . pretty) mattr
in hcat $ -- TODO: should not introduce blanks
(myFsep $ (char '<' <> pretty n): map pretty attrs ++ ap ++ [char '>']):
prettyChildren cp ++ [myFsep $ [text "</" <> pretty n, char '>']]
prettyPrec _ (HsPXETag _ n attrs mattr) =
let ap = maybe [] (return . pretty) mattr
in myFsep $ (char '<' <> pretty n): map pretty attrs ++ ap ++ [text "/>"]
prettyPrec _ (HsPXPcdata s) = text s
prettyPrec _ (HsPXPatTag p) =
myFsep $ [text "<%", pretty p, text "%>"]
prettyChildren :: HsPat -> [Doc]
prettyChildren p = case p of
HsPList ps -> map prettyChild ps
HsPRPat _ _ -> [pretty p]
_ -> error "The pattern representing the children of an xml pattern\
\ should always be a list."
prettyChild :: HsPat -> Doc
prettyChild p = case p of
HsPXTag _ _ _ _ _ -> pretty p
HsPXETag _ _ _ _ -> pretty p
HsPXPatTag _ -> pretty p
HsPXPcdata _ -> pretty p
_ -> pretty $ HsPXPatTag p
instance Pretty HsPXAttr where
pretty (HsPXAttr n p) =
myFsep [pretty n, char '=', pretty p]
instance Pretty HsPatField where
pretty (HsPFieldPat name pat) =
myFsep [pretty name, equals, pretty pat]
--------------------- Regular Patterns -------------------------
instance Pretty HsRPat where
pretty (HsRPStar r) = pretty r <> char '*'
pretty (HsRPStarG r) = pretty r <> text "*!"
pretty (HsRPPlus r) = pretty r <> char '+'
pretty (HsRPPlusG r) = pretty r <> text "+!"
pretty (HsRPOpt r) = pretty r <> char '?'
pretty (HsRPOptG r) = pretty r <> text "?!"
pretty (HsRPEither r1 r2) = parens . myFsep $
[pretty r1, char '|', pretty r2]
pretty (HsRPSeq rs) =
myFsep $ text "(/" : map pretty rs ++ [text "/)"]
-- special case that would otherwise be buggy
pretty (HsRPCAs n (HsRPPat (HsPIrrPat p))) =
myFsep [pretty n <> text "@:", char '~' <> pretty p]
pretty (HsRPCAs n r) = hcat [pretty n, text "@:", pretty r]
-- special case that would otherwise be buggy
pretty (HsRPAs n (HsRPPat (HsPIrrPat p))) =
myFsep [pretty n <> text "@:", char '~' <> pretty p]
pretty (HsRPAs n r) = hcat [pretty n, char '@', pretty r]
pretty (HsRPPat p) = pretty p
pretty (HsRPParen rp) = parens . pretty $ rp
------------------------- Case bodies -------------------------
instance Pretty HsAlt where
pretty (HsAlt _pos e gAlts binds) =
pretty e <+> pretty gAlts $$$ ppWhere binds
instance Pretty HsGuardedAlts where
pretty (HsUnGuardedAlt e) = text "->" <+> pretty e
pretty (HsGuardedAlts altList) = myVcat . map pretty $ altList
instance Pretty HsGuardedAlt where
pretty (HsGuardedAlt _pos guards body) =
myFsep $ char '|': (punctuate comma . map pretty $ guards) ++ [text "->", pretty body]
------------------------- Statements in monads, guards & list comprehensions -----
instance Pretty HsStmt where
pretty (HsGenerator _loc e from) =
pretty e <+> text "<-" <+> pretty from
pretty (HsQualifier e) = pretty e
-- two cases for lets
pretty (HsLetStmt (HsBDecls declList)) =
ppLetStmt declList
pretty (HsLetStmt (HsIPBinds bindList)) =
ppLetStmt bindList
ppLetStmt l = text "let" $$$ ppBody letIndent (map pretty l)
------------------------- Record updates
instance Pretty HsFieldUpdate where
pretty (HsFieldUpdate name e) =
myFsep [pretty name, equals, pretty e]
------------------------- Names -------------------------
instance Pretty HsQOp where
pretty (HsQVarOp n) = ppHsQNameInfix n
pretty (HsQConOp n) = ppHsQNameInfix n
ppHsQNameInfix :: HsQName -> Doc
ppHsQNameInfix name
| isSymbolName (getName name) = ppHsQName name
| otherwise = char '`' <> ppHsQName name <> char '`'
instance Pretty HsQName where
pretty name = case name of
UnQual (HsSymbol ('#':_)) -> char '(' <+> ppHsQName name <+> char ')'
_ -> parensIf (isSymbolName (getName name)) (ppHsQName name)
ppHsQName :: HsQName -> Doc
ppHsQName (UnQual name) = ppHsName name
ppHsQName (Qual m name) = pretty m <> char '.' <> ppHsName name
ppHsQName (Special sym) = text (specialName sym)
instance Pretty HsOp where
pretty (HsVarOp n) = ppHsNameInfix n
pretty (HsConOp n) = ppHsNameInfix n
ppHsNameInfix :: HsName -> Doc
ppHsNameInfix name
| isSymbolName name = ppHsName name
| otherwise = char '`' <> ppHsName name <> char '`'
instance Pretty HsName where
pretty name = case name of
HsSymbol ('#':_) -> char '(' <+> ppHsName name <+> char ')'
_ -> parensIf (isSymbolName name) (ppHsName name)
ppHsName :: HsName -> Doc
ppHsName (HsIdent s) = text s
ppHsName (HsSymbol s) = text s
instance Pretty HsIPName where
pretty (HsIPDup s) = char '?' <> text s
pretty (HsIPLin s) = char '%' <> text s
instance Pretty HsIPBind where
pretty (HsIPBind _loc ipname exp) =
myFsep [pretty ipname, equals, pretty exp]
instance Pretty HsCName where
pretty (HsVarName n) = pretty n
pretty (HsConName n) = pretty n
isSymbolName :: HsName -> Bool
isSymbolName (HsSymbol _) = True
isSymbolName _ = False
getName :: HsQName -> HsName
getName (UnQual s) = s
getName (Qual _ s) = s
getName (Special HsCons) = HsSymbol ":"
getName (Special HsFunCon) = HsSymbol "->"
getName (Special s) = HsIdent (specialName s)
specialName :: HsSpecialCon -> String
specialName HsUnitCon = "()"
specialName HsListCon = "[]"
specialName HsFunCon = "->"
specialName (HsTupleCon n) = "(" ++ replicate (n-1) ',' ++ ")"
specialName HsCons = ":"
ppHsContext :: HsContext -> Doc
ppHsContext [] = empty
ppHsContext context = mySep [parenList (map pretty context), text "=>"]
-- hacked for multi-parameter type classes
instance Pretty HsAsst where
pretty (HsClassA a ts) = myFsep $ ppHsQName a : map ppHsAType ts
pretty (HsIParam i t) = myFsep $ [pretty i, text "::", pretty t]
------------------------- pp utils -------------------------
maybePP :: (a -> Doc) -> Maybe a -> Doc
maybePP pp Nothing = empty
maybePP pp (Just a) = pp a
parenList :: [Doc] -> Doc
parenList = parens . myFsepSimple . punctuate comma
hashParenList :: [Doc] -> Doc
hashParenList = hashParens . myFsepSimple . punctuate comma
where hashParens = parens . hashes
hashes = \doc -> char '#' <> doc <> char '#'
braceList :: [Doc] -> Doc
braceList = braces . myFsepSimple . punctuate comma
bracketList :: [Doc] -> Doc
bracketList = brackets . myFsepSimple
-- Wrap in braces and semicolons, with an extra space at the start in
-- case the first doc begins with "-", which would be scanned as {-
flatBlock :: [Doc] -> Doc
flatBlock = braces . (space <>) . hsep . punctuate semi
-- Same, but put each thing on a separate line
prettyBlock :: [Doc] -> Doc
prettyBlock = braces . (space <>) . vcat . punctuate semi
-- Monadic PP Combinators -- these examine the env
blankline :: Doc -> Doc
blankline dl = do{e<-getPPEnv;if spacing e && layout e /= PPNoLayout
then space $$ dl else dl}
topLevel :: Doc -> [Doc] -> Doc
topLevel header dl = do
e <- fmap layout getPPEnv
case e of
PPOffsideRule -> header $$ vcat dl
PPSemiColon -> header $$ prettyBlock dl
PPInLine -> header $$ prettyBlock dl
PPNoLayout -> header <+> flatBlock dl
ppBody :: (PPHsMode -> Int) -> [Doc] -> Doc
ppBody f dl = do
e <- fmap layout getPPEnv
case e of PPOffsideRule -> indent
PPSemiColon -> indentExplicit
_ -> flatBlock dl
where
indent = do{i <-fmap f getPPEnv;nest i . vcat $ dl}
indentExplicit = do {i <- fmap f getPPEnv;
nest i . prettyBlock $ dl}
($$$) :: Doc -> Doc -> Doc
a $$$ b = layoutChoice (a $$) (a <+>) b
mySep :: [Doc] -> Doc
mySep = layoutChoice mySep' hsep
where
-- ensure paragraph fills with indentation.
mySep' [x] = x
mySep' (x:xs) = x <+> fsep xs
mySep' [] = error "Internal error: mySep"
myVcat :: [Doc] -> Doc
myVcat = layoutChoice vcat hsep
myFsepSimple :: [Doc] -> Doc
myFsepSimple = layoutChoice fsep hsep
-- same, except that continuation lines are indented,
-- which is necessary to avoid triggering the offside rule.
myFsep :: [Doc] -> Doc
myFsep = layoutChoice fsep' hsep
where fsep' [] = empty
fsep' (d:ds) = do
e <- getPPEnv
let n = onsideIndent e
nest n (fsep (nest (-n) d:ds))
layoutChoice :: (a -> Doc) -> (a -> Doc) -> a -> Doc
layoutChoice a b dl = do e <- getPPEnv
if layout e == PPOffsideRule ||
layout e == PPSemiColon
then a dl else b dl
-- Prefix something with a LINE pragma, if requested.
-- GHC's LINE pragma actually sets the current line number to n-1, so
-- that the following line is line n. But if there's no newline before
-- the line we're talking about, we need to compensate by adding 1.
markLine :: SrcLoc -> Doc -> Doc
markLine loc doc = do
e <- getPPEnv
let y = srcLine loc
let line l =
text ("{-# LINE " ++ show l ++ " \"" ++ srcFilename loc ++ "\" #-}")
if linePragmas e then layoutChoice (line y $$) (line (y+1) <+>) doc
else doc