module FrontEnd.HsPretty (PPLayout(..),PPHsMode(..),
render,
ppHsModule,
ppHsDecl,
ppHsDecls,
ppHsExp,
ppHsStmt,
ppHsPat,
ppHsAlt,
ppGAlt,
ppHsGuardedRhs
) where
import Data.Char
import qualified Text.PrettyPrint.HughesPJ as P
import Doc.DocLike(TextLike(..),DocLike(..))
import Doc.PPrint(pprint)
import FlagDump as FD
import FrontEnd.HsSyn
import FrontEnd.Rename(unRename)
import FrontEnd.SrcLoc(Located(..))
import Name.Name
import Name.Names
import Options
import qualified Doc.DocLike as DL
import qualified Doc.PPrint as P
infixl 5 $$$
data PPLayout = PPOffsideRule
| PPSemiColon
| PPInLine
| PPNoLayout
deriving Eq
type Indent = Int
data PPHsMode = PPHsMode {
classIndent,
doIndent,
caseIndent,
letIndent,
whereIndent :: Indent,
onsideIndent :: Indent,
spacing :: Bool,
layout :: PPLayout,
comments :: Bool
}
defaultMode = PPHsMode{
classIndent = 8,
doIndent = 3,
caseIndent = 4,
letIndent = 4,
whereIndent = 6,
onsideIndent = 2,
spacing = True,
layout = PPOffsideRule,
comments = True
}
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
thenDocM m k = DocM $ (\s -> case unDocM m $ s of a -> unDocM (k a) $ s)
then_DocM m k = DocM $ (\s ->case unDocM m $ s of a -> unDocM k $ s)
retDocM a = DocM (\s -> a)
unDocM :: DocM s a -> (s -> a)
unDocM (DocM f) = f
getPPEnv :: DocM s s
getPPEnv = DocM id
type Doc = DocM PPHsMode P.Doc
nest :: Int -> Doc -> Doc
nest i m = m >>= return . P.nest i
dropAs (HsAsPat _ e) = e
dropAs e = e
instance DL.TextLike Doc where
empty = return P.empty
text = return . P.text
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
parens, brackets, braces :: Doc -> Doc
parens d = d >>= return . P.parens
parenszh d = d >>= \d' -> return $ P.text "(# " P.<> d' P.<> P.text " #)"
brackets d = d >>= return . P.brackets
braces d = d >>= return . P.braces
semi,comma,equals :: Doc
semi = return P.semi
comma = return P.comma
equals = return P.equals
instance DocLike Doc where
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 dl = sequence dl >>= return . P.hcat
hsep dl = sequence dl >>= return . P.hsep
vcat dl = sequence dl >>= return . P.vcat
($$) :: Doc -> Doc -> Doc
aM $$ bM = do{a<-aM;b<-bM;return (a P.$$ b)}
fsep :: [Doc] -> Doc
fsep dl = sequence dl >>= return . P.fsep
punctuate :: Doc -> [Doc] -> [Doc]
punctuate p [] = []
punctuate p (d:ds) = go d ds
where
go d [] = [d]
go d (e:es) = (d <> p) : go e es
renderWithMode :: PPHsMode -> Doc -> String
renderWithMode ppMode d = P.render . unDocM d $ ppMode
render :: Doc -> String
render = renderWithMode defaultMode
ppHsModule :: HsModule -> Doc
ppHsModule (HsModule mod _ mbExports imp decls _ _) =
topLevel (ppHsModuleHeader mod mbExports)
(map ppHsImportDecl imp ++ map ppHsDecl decls)
ppHsDecls :: [HsDecl] -> Doc
ppHsDecls ds = vcat $ map ppHsDecl ds
ppHsModuleHeader :: Module -> Maybe [HsExportSpec] -> Doc
ppHsModuleHeader (Module modName) mbExportList = mySep [
text "module",
text $ show modName,
maybePP (parenList . map ppHsExportSpec) mbExportList,
text "where"]
ppHsExportSpec :: HsExportSpec -> Doc
ppHsExportSpec e = f e where
f (HsEVar name) = ppHsQNameParen name
f (HsEAbs name) = ppHsQName name
f (HsEThingAll name) = ppHsQName name <> text"(..)"
f (HsEThingWith name nameList) = ppHsQName name <> (parenList . map ppHsQNameParen $ nameList)
f (HsEModuleContents (show -> name)) = text "module" <+> text name
f (HsEQualified ClassName e) = text "class" <+> ppHsExportSpec e
f (HsEQualified SortName e) = text "kind" <+> ppHsExportSpec e
f (HsEQualified TypeConstructor e) = text "type" <+> ppHsExportSpec e
f (HsEQualified DataConstructor e) = text "data" <+> ppHsExportSpec e
f (HsEQualified n e) = tshow n <+> ppHsExportSpec e
tshow = text . show
ppHsImportDecl (HsImportDecl pos (show -> mod) bool mbName mbSpecs) =
mySep [text "import",
if bool then text "qualified" else empty,
text mod,
maybePP (\(show -> n) -> text "as" <+> text n) mbName,
maybePP exports mbSpecs]
where
exports (b,specList)
| b = text "hiding" <+> (parenList . map ppHsExportSpec $ specList)
| otherwise = parenList . map ppHsExportSpec $ specList
ppHsTName (n,Nothing) = ppHsName n
ppHsTName (n,Just t) = parens (ppHsName n <+> text "::" <+> ppHsType t)
ppHsRule prules@HsRule {} = text (show (hsRuleString prules)) <+> text "forall" <+> vars <+> text "." $$ nest 4 rest where
vars = hsep (map ppHsTName $ hsRuleFreeVars prules)
rest = ppHsExp (hsRuleLeftExpr prules) <+> text "=" <+> ppHsExp (hsRuleRightExpr prules)
ppClassHead :: HsClassHead -> Doc
ppClassHead (HsClassHead c n ts) = ans c where
ans [] = f n ts
ans c = ppHsContext c <+> text "=>" <+> f n ts
f n ts = ppHsType (foldl HsTyApp (HsTyCon n) ts)
ppHsDecl :: HsDecl -> Doc
ppHsDecl (HsActionDecl _ p e) = ppHsPat p <+> text "<-" <+> ppHsExp e
ppHsDecl (HsDeclDeriving _ e) = text "derive instance" <+> ppClassHead e
ppHsDecl (HsPragmaRules rs@(HsRule { hsRuleIsMeta = False }:_)) = text "{-# RULES" $$ nest 4 (myVcat (map ppHsRule rs)) $$ text "#-}"
ppHsDecl (HsPragmaRules rs@(HsRule { hsRuleIsMeta = True }:_)) = text "{-# METARULES" $$ nest 4 (myVcat (map ppHsRule rs)) $$ text "#-}"
ppHsDecl prules@HsPragmaSpecialize {} = text "{-# SPECIALIZE ... #-}"
ppHsDecl fd@(HsForeignDecl _ _ n qt) = text "ForeignDecl" <+> ppHsName n <+> ppHsQualType qt <+> text (show fd)
ppHsDecl fd@(HsForeignExport _ _ n qt) = text "ForeignExport" <+> ppHsName n <+> ppHsQualType qt <+> text (show fd)
ppHsDecl (HsTypeDecl loc name nameList htype) =
mySep ( [text "type",ppHsName name]
++ map ppHsType nameList
++ [equals, ppHsType htype])
ppHsDecl HsDataDecl { .. } = ans where
ans = mySep ([declType, ppHsContext hsDeclContext, ppHsName hsDeclName]
++ map ppHsName hsDeclArgs)
<+> (myVcat (zipWith (<+>) (equals : repeat (char '|'))
(map ppHsConstr hsDeclCons))
$$$ ppHsDeriving hsDeclDerives)
declType = case hsDeclDeclType of
DeclTypeKind -> text "data kind"
DeclTypeData -> text "data"
DeclTypeNewtype -> text "newtype"
ppHsDecl (HsClassDecl pos qualType []) =
mySep [text "class", ppClassHead qualType]
ppHsDecl (HsClassDecl pos qualType declList) =
mySep [text "class", ppClassHead qualType, text "where"]
$$$ body classIndent (map ppHsDecl declList)
ppHsDecl (HsClassAliasDecl pos name args context classes declList) =
mySep ([text "class alias", ppHsName name] ++ map ppHsType args
++ [equals, ppHsContext context, text "=>", ppHsContext classes, text "where"])
$$$ body classIndent (map ppHsDecl declList)
ppHsDecl (HsInstDecl pos qualType []) =
mySep [text "instance", ppClassHead qualType]
ppHsDecl (HsInstDecl pos qualType declList) =
mySep [text "instance", ppClassHead qualType, text "where"]
$$$ body classIndent (map ppHsDecl declList)
ppHsDecl (HsDefaultDecl pos htype) =
text "default" <+> ppHsType htype
ppHsDecl (HsTypeSig pos nameList qualType) =
mySep ((punctuate comma . map ppHsNameParen $ nameList)
++ [text "::", ppHsQualType qualType])
ppHsDecl (HsFunBind matches)
= foldr ($$$) empty (map ppMatch matches)
ppHsDecl (HsPatBind pos pat rhs whereDecls)
= myFsep [ppHsPatOrOp pat, ppHsRhs rhs] $$$ ppWhere whereDecls
where
ppHsPatOrOp (HsPVar n) = ppHsNameParen n
ppHsPatOrOp p = ppHsPat p
ppHsDecl (HsInfixDecl pos assoc prec nameList) =
mySep ([ppAssoc assoc, int prec]
++ (punctuate comma . map ppHsNameInfix $ nameList))
where
ppAssoc HsAssocNone = text "infix"
ppAssoc HsAssocLeft = text "infixl"
ppAssoc HsAssocRight = text "infixr"
ppHsDecl (HsPragmaProps _ w ns) = text "{-# " <> text w <+> mySep (punctuate comma . map ppHsNameParen $ ns) <+> text "#-}"
ppHsDecl _ = error "ppHsDecl: unknown construct"
ppMatch (HsMatch pos f ps rhs whereDecls)
= myFsep (ppHsQNameParen f : map ppHsPat ps ++ [ppHsRhs rhs])
$$$ ppWhere whereDecls
ppWhere [] = empty
ppWhere l = nest 2 (text "where" $$$ body whereIndent (map ppHsDecl l))
mprintExists :: HsConDecl -> Doc
mprintExists hcd = case hsConDeclExists hcd of
[] -> empty
vs -> text "exists" <+> hsep (map (return . pprint) vs) <+> char '.'
ppHsConstr :: HsConDecl -> Doc
ppHsConstr cd@HsRecDecl { hsConDeclName = name, hsConDeclRecArg = fieldList } =
mprintExists cd <+> ppHsName name
<> (braceList . map ppField $ fieldList)
ppHsConstr cd@HsConDecl { hsConDeclName = name, hsConDeclConArg = typeList}
| isSymbolName name && length typeList == 2 =
let [l, r] = typeList in
mprintExists cd <+> myFsep [ppHsBangType l, ppHsName name, ppHsBangType r]
| otherwise = mprintExists cd <+> (mySep $ (ppHsName name) :
map ppHsBangType typeList)
ppField :: ([HsName],HsBangType) -> Doc
ppField (names, ty) = myFsepSimple $ (punctuate comma . map ppHsName $ names) ++
[text "::", ppHsBangType ty]
ppHsBangType :: HsBangType -> Doc
ppHsBangType (HsBangedTy ty) = char '!' <> ppHsTypeArg ty
ppHsBangType (HsUnBangedTy ty) = ppHsTypeArg ty
ppHsDeriving :: [HsName] -> Doc
ppHsDeriving [] = empty
ppHsDeriving [d] = text "deriving" <+> ppHsQName d
ppHsDeriving ds = text "deriving" <+> parenList (map ppHsQName ds)
ppHsQualType :: HsQualType -> Doc
ppHsQualType (HsQualType [] htype) = ppHsType htype
ppHsQualType (HsQualType context htype) =
myFsep [ ppHsContext context, text "=>", ppHsType htype]
parensIf :: Bool -> Doc -> Doc
parensIf True = parens
parensIf False = id
instance P.PPrint Doc HsType where
pprint = ppHsType
ppHsType :: HsType -> Doc
ppHsType = ppHsTypePrec 0
ppHsTypeArg :: HsType -> Doc
ppHsTypeArg = ppHsTypePrec 2
ppHsTypePrec :: Int -> HsType -> Doc
ppHsTypePrec p (HsTyFun a b) =
parensIf (p > 0) $
myFsep [ppHsTypePrec 1 a, text "->", ppHsType b]
ppHsTypePrec p (HsTyAssoc) = text "<assoc>"
ppHsTypePrec p (HsTyEq a b) =
parensIf (p > 0) $ myFsep [ppHsType a, text "=", ppHsType b]
ppHsTypePrec p (HsTyTuple l) = parenList . map ppHsType $ l
ppHsTypePrec p (HsTyUnboxedTuple l) = parenListzh . map ppHsType $ l
ppHsTypePrec p (HsTyApp (HsTyCon lcons) b ) | lcons == nameName tc_List = brackets $ ppHsType b
ppHsTypePrec p (HsTyApp a b) =
parensIf (p > 1) $ myFsep[ppHsType a, ppHsTypeArg b]
ppHsTypePrec p (HsTyVar name) = ppHsName name
ppHsTypePrec p (HsTyCon name) = ppHsQName name
ppHsTypePrec p HsTyForall { hsTypeVars = vs, hsTypeType = qt } = parensIf (p > 1) $ do
pp <- ppHsQualType qt
return $ DL.text "forall" DL.<+> DL.hsep (map pprint vs) DL.<+> DL.char '.' DL.<+> pp
ppHsTypePrec p HsTyExists { hsTypeVars = vs, hsTypeType = qt } = parensIf (p > 1) $ do
pp <- ppHsQualType qt
return $ DL.text "exists" DL.<+> DL.hsep (map pprint vs) DL.<+> DL.char '.' DL.<+> pp
ppHsTypePrec _ HsTyExpKind { hsTyLType = Located _ t, hsTyKind = k } = do
t <- ppHsType t
return $ DL.parens ( t DL.<+> DL.text "::" DL.<+> pprint k)
ppHsTypePrec _ _ = error "HsPretty.ppHsTypePrec: bad."
instance DL.DocLike d => P.PPrint d HsKind where
pprint (HsKind k) = pprint k
pprint (HsKindFn (HsKind k) t) = pprint k DL.<+> DL.text "->" DL.<+> pprint t
pprint (HsKindFn a b) = DL.parens (pprint a) DL.<+> DL.text "->" DL.<+> pprint b
ppHsRhs :: HsRhs -> Doc
ppHsRhs (HsUnGuardedRhs exp) = equals <+> ppHsExp exp
ppHsRhs (HsGuardedRhss guardList) =
myVcat . map ppHsGuardedRhs $ guardList
ppHsGuardedRhs :: HsGuardedRhs -> Doc
ppHsGuardedRhs (HsGuardedRhs pos guard body) =
myFsep [ char '|',
ppHsExp guard,
equals,
ppHsExp body]
ppHsLit :: HsLiteral -> Doc
ppHsLit (HsInt i) = integer i
ppHsLit (HsChar c) = text (show c)
ppHsLit (HsString s) = text (show s)
ppHsLit (HsFrac r) = double (fromRational r)
ppHsLit (HsCharPrim c) = text (show c) <> char '#'
ppHsLit (HsStringPrim s) = text (show s) <> char '#'
ppHsLit (HsIntPrim i) = integer i <> char '#'
ppHsLit (HsFloatPrim r) = float (fromRational r) <> char '#'
ppHsLit (HsDoublePrim r) = double (fromRational r) <> text "##"
ppHsLit (HsLitLit s) = text "''" <> text s <> text "''"
ppHsExp :: HsExp -> Doc
ppHsExp (HsLit l) = ppHsLit l
ppHsExp (HsInfixApp a op b) = myFsep[ppHsExp a, ppInfix op, ppHsExp b]
where
ppInfix (HsAsPat as (HsVar n)) | dump FD.Aspats = ppHsName as <> char '@' <> ppHsQNameInfix n
ppInfix (HsAsPat _ (HsVar n)) = ppHsQNameInfix n
ppInfix (HsAsPat as (HsCon n)) | dump FD.Aspats = ppHsName as <> char '@' <> ppHsQNameInfix n
ppInfix (HsAsPat _ (HsCon n)) = ppHsQNameInfix n
ppInfix (HsVar n) = ppHsQNameInfix n
ppInfix (HsCon n) = ppHsQNameInfix n
ppInfix n = error $ "illegal infix expression: " ++ show n
ppHsExp (HsNegApp e) = myFsep [char '-', ppHsExp e]
ppHsExp (HsApp a b) = myFsep [ppHsExp a, ppHsExp b]
ppHsExp HsError { hsExpString = msg } = text $ "<error:" ++ msg ++ ">"
ppHsExp (HsLambda _srcLoc expList body) = myFsep $
(((char '\\' ):) . map ppHsPat $ expList)
++ [text "->", ppHsExp body]
ppHsExp (HsLet expList letBody) =
myFsep [text "let" <+> body letIndent (map ppHsDecl expList),
text "in", ppHsExp letBody]
ppHsExp (HsIf cond thenexp elsexp) =
myFsep [text "if", ppHsExp cond,
text "then", ppHsExp thenexp,
text "else", ppHsExp elsexp]
ppHsExp (HsCase cond altList) = myFsep[text "case", ppHsExp cond, text "of"]
$$$ body caseIndent (map ppHsAlt altList)
ppHsExp (HsDo stmtList) = text "do" $$$ body doIndent (map ppHsStmt stmtList)
ppHsExp (HsVar name ) = ppHsQNameParen name
ppHsExp (HsCon name) = ppHsQNameParen name
ppHsExp (HsTuple expList) = parenList . map ppHsExp $ expList
ppHsExp (HsUnboxedTuple expList) = parenListzh . map ppHsExp $ expList
ppHsExp (HsParen exp) = parens . ppHsExp $ exp
ppHsExp (HsLeftSection v exp) | (HsVar name) <- dropAs v =
parens (ppHsExp exp <+> ppHsQNameInfix name)
ppHsExp (HsLeftSection v exp) | (HsCon name) <- dropAs v =
parens (ppHsExp exp <+> ppHsQNameInfix name)
ppHsExp (HsLeftSection _ _) = error "illegal left section"
ppHsExp (HsRightSection exp v) | (HsVar name) <- dropAs v =
parens (ppHsQNameInfix name <+> ppHsExp exp)
ppHsExp (HsRightSection exp v) | (HsCon name) <- dropAs v =
parens (ppHsQNameInfix name <+> ppHsExp exp)
ppHsExp (HsRightSection _ _) = error "illegal right section"
ppHsExp (HsRecConstr c fieldList) =
ppHsQName c
<> (braceList . map ppHsFieldUpdate $ fieldList)
ppHsExp (HsRecUpdate exp fieldList) =
ppHsExp exp
<> (braceList . map ppHsFieldUpdate $ fieldList)
ppHsExp (HsAsPat _ p) | not (dump FD.Aspats) = ppHsExp p
ppHsExp (HsAsPat name (HsIrrPat (Located _ exp))) =
myFsep[ppHsName name <> char '@', char '~' <> ppHsExp exp]
ppHsExp (HsAsPat name exp) = hcat[ppHsName name,char '@',ppHsExp exp]
ppHsExp (HsWildCard _) = char '_'
ppHsExp (HsIrrPat (Located _ exp)) = char '~' <> ppHsExp exp
ppHsExp (HsBangPat (Located _ exp)) = char '!' <> ppHsExp exp
ppHsExp (HsList list) =
bracketList . punctuate comma . map ppHsExp $ list
ppHsExp (HsEnumFrom exp) =
bracketList [ppHsExp exp,text ".."]
ppHsExp (HsEnumFromTo from to) =
bracketList [ppHsExp from, text "..", ppHsExp to]
ppHsExp (HsEnumFromThen from thenE) =
bracketList [ppHsExp from <> comma, ppHsExp thenE]
ppHsExp (HsEnumFromThenTo from thenE to) =
bracketList [ppHsExp from <> comma, ppHsExp thenE,
text "..", ppHsExp to]
ppHsExp (HsListComp exp stmtList) =
bracketList ([ppHsExp exp, char '|']
++ (punctuate comma . map ppHsStmt $ stmtList))
ppHsExp (HsExpTypeSig pos exp ty) =
myFsep[ppHsExp exp, text "::", ppHsQualType ty]
ppHsExp (HsLocatedExp (Located _ x)) = ppHsExp x
ppHsPat :: HsPat -> Doc
ppHsPat (HsPVar name) = ppHsNameParen name
ppHsPat (HsPLit lit) = ppHsLit lit
ppHsPat (HsPNeg p) = myFsep [char '-', ppHsPat p]
ppHsPat (HsPInfixApp a op b) = myFsep[ppHsPat a, ppHsQNameInfix op, ppHsPat b]
ppHsPat (HsPApp n ps) = myFsep (ppHsQName n : map ppHsPat ps)
ppHsPat (HsPTuple ps) = parenList . map ppHsPat $ ps
ppHsPat (HsPUnboxedTuple ps) = parenListzh . map ppHsPat $ ps
ppHsPat (HsPList ps) = bracketList . punctuate comma . map ppHsPat $ ps
ppHsPat (HsPParen p) = parens . ppHsPat $ p
ppHsPat (HsPRec c fields)
= ppHsQName c
<> (braceList . map ppHsPatField $ fields)
ppHsPat (HsPAsPat name (HsPIrrPat (Located _ pat))) =
myFsep[ppHsName name <> char '@', char '~' <> ppHsPat pat]
ppHsPat (HsPAsPat name pat) = hcat[ppHsName name,char '@',ppHsPat pat]
ppHsPat HsPWildCard = char '_'
ppHsPat (HsPIrrPat (Located _ pat)) = char '~' <> ppHsPat pat
ppHsPat ~(HsPBangPat (Located _ pat)) = char '!' <> ppHsPat pat
ppHsPatField (HsPFieldPat name pat) = myFsep[ppHsQName name, equals, ppHsPat pat]
ppHsAlt :: HsAlt -> Doc
ppHsAlt (HsAlt pos exp gAlts decls) =
ppHsPat exp <+> ppGAlts gAlts $$$ ppWhere decls
ppGAlts :: HsRhs -> Doc
ppGAlts (HsUnGuardedRhs exp) = text "->" <+> ppHsExp exp
ppGAlts (HsGuardedRhss altList) = myVcat . map ppGAlt $ altList
ppGAlt (HsGuardedRhs pos exp body) =
myFsep [char '|', ppHsExp exp, text "->", ppHsExp body]
ppHsStmt :: HsStmt -> Doc
ppHsStmt (HsGenerator _sloc exp from) =
ppHsPat exp <+> text "<-" <+> ppHsExp from
ppHsStmt (HsQualifier exp) = ppHsExp exp
ppHsStmt (HsLetStmt declList) = text "let"
$$$ body letIndent (map ppHsDecl declList)
ppHsFieldUpdate :: HsFieldUpdate -> Doc
ppHsFieldUpdate (HsFieldUpdate name exp) =
myFsep[ppHsQName name,equals,ppHsExp exp]
ppHsQName :: HsName -> Doc
ppHsQName n = text $ show n
ppHsName = ppHsQName
ppHsQNameParen :: HsName -> Doc
ppHsQNameParen name = parensIf (isSymbolName name) (ppHsQName name)
ppHsQNameInfix :: HsName -> Doc
ppHsQNameInfix name
| isSymbolName name = ppHsQName name
| otherwise = char '`' <> ppHsQName name <> char '`'
ppHsNameParen :: HsName -> Doc
ppHsNameParen name = parensIf (isSymbolName name) (ppHsName name)
ppHsNameInfix :: HsName -> Doc
ppHsNameInfix name
| isSymbolName name = ppHsName name
| otherwise = char '`' <> ppHsName name <> char '`'
isSymbolName :: HsName -> Bool
isSymbolName x | (_,_,c:_) <- nameParts (unRename x), isAlpha c || c `elem` "'_" = False
isSymbolName _ = True
ppHsContext :: HsContext -> Doc
ppHsContext [] = empty
ppHsContext context = parenList (map ppHsAsst context)
ppHsAsst :: HsAsst -> Doc
ppHsAsst (HsAsst a ts) = myFsep(ppHsQName a : map ppHsName ts)
ppHsAsst (HsAsstEq a b) = ppHsType a <+> char '=' <+> ppHsType b
maybePP :: (a -> Doc) -> Maybe a -> Doc
maybePP pp Nothing = empty
maybePP pp (Just a) = pp a
parenList :: [Doc] -> Doc
parenList = parens . myFsepSimple . punctuate comma
parenListzh :: [Doc] -> Doc
parenListzh = parenszh . myFsepSimple . punctuate comma
braceList :: [Doc] -> Doc
braceList = braces . myFsepSimple . punctuate comma
bracketList :: [Doc] -> Doc
bracketList = brackets . myFsepSimple
topLevel :: Doc -> [Doc] -> Doc
topLevel header dl = do
e <- fmap layout getPPEnv
case e of
PPOffsideRule -> header $$ vcat dl
PPSemiColon -> header $$ (braces . vcat . punctuate semi) dl
PPInLine -> header $$ (braces . vcat . punctuate semi) dl
PPNoLayout -> header <+> (braces . hsep . punctuate semi) dl
body :: (PPHsMode -> Int) -> [Doc] -> Doc
body f dl = do
e <- fmap layout getPPEnv
case e of PPOffsideRule -> indent
PPSemiColon -> indentExplicit
_ -> inline
where
inline = braces . hsep . punctuate semi $ dl
indent = do{i <-fmap f getPPEnv;nest i . vcat $ dl}
indentExplicit = do {i <- fmap f getPPEnv;
nest i . braces . vcat . punctuate semi $ dl}
($$$) :: Doc -> Doc -> Doc
a $$$ b = layoutChoice (a $$) (a <+>) b
mySep :: [Doc] -> Doc
mySep = layoutChoice mySep' hsep
where
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
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 b dl = do e <- getPPEnv
if layout e == PPOffsideRule ||
layout e == PPSemiColon
then a dl else b dl
instance P.PPrint P.Doc HsDecl where
pprint d = unDocM (ppHsDecl d) defaultMode
instance P.PPrint P.Doc HsExp where
pprint d = unDocM (ppHsExp d) defaultMode
instance P.PPrint P.Doc HsType where
pprint d = unDocM (ppHsType d) defaultMode
instance P.PPrint P.Doc HsQualType where
pprint d = unDocM (ppHsQualType d) defaultMode
instance P.PPrint P.Doc HsTyVarBind where
pprint d = P.text (show $ hsTyVarBindName d)
instance P.PPrint P.Doc HsPat where
pprint d = unDocM (ppHsPat d) defaultMode