module HIndent.Pretty
(
Pretty
, pretty
, prettyNoExt
,getState
,putState
,modifyState
, write
, newline
, space
, comma
, int
, string
, maybeCtx
, printComment
, printComments
, withCaseContext
, rhsSeparator
, inter
, spaced
, lined
, prefixedLined
, commas
, parens
, brackets
, braces
, indented
, column
, getColumn
, getLineNum
, depend
, dependBind
, swing
, getIndentSpaces
, getColumnLimit
, nullBinds
, sandbox
, pretty'
)
where
import Control.Monad.Trans.Maybe
import Data.Functor.Identity
import HIndent.Types
import Language.Haskell.Exts.Comments
import Control.Monad.State.Strict hiding (state)
import Data.Int
import Data.List
import Data.Maybe
import Data.Monoid hiding (Alt)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as T
import Data.Text.Lazy.Builder.Int
import Data.Typeable
import qualified Language.Haskell.Exts.Annotated as P
import Language.Haskell.Exts.Annotated.Syntax
import Language.Haskell.Exts.SrcLoc
import Prelude hiding (exp)
class (Annotated ast,Typeable ast) => Pretty ast where
prettyInternal :: MonadState (PrintState s) m => ast NodeInfo -> m ()
pretty :: (Pretty ast,MonadState (PrintState s) m)
=> ast NodeInfo -> m ()
pretty a =
do st <- get
case st of
PrintState{psExtenders = es,psUserState = s} ->
do
printComments Before a
depend
(case listToMaybe (mapMaybe (makePrinter s) es) of
Just (Printer m) ->
modify (\s ->
fromMaybe s
(runIdentity (runMaybeT (execStateT m s))))
Nothing -> prettyNoExt a)
(printComments After a)
where makePrinter s (Extender f) =
case cast a of
Just v -> Just (f v)
Nothing -> Nothing
makePrinter s (CatchAll f) = f s a
prettyNoExt :: (Pretty ast,MonadState (PrintState s) m)
=> ast NodeInfo -> m ()
prettyNoExt = prettyInternal
printComments :: (Pretty ast,MonadState (PrintState s) m)
=> ComInfoLocation -> ast NodeInfo -> m ()
printComments loc' ast =
forM_ comments $ \comment ->
when (comInfoLocation comment == Just loc') $ do
hasNewline <- gets psNewline
when (not hasNewline && loc' == Before) newline
printComment (Just $ srcInfoSpan $ nodeInfoSpan info) comment
where info = ann ast
comments = nodeInfoComments info
printComment :: MonadState (PrintState s) m => Maybe SrcSpan -> ComInfo -> m ()
printComment mayNodespan (ComInfo (Comment inline cspan str) _) =
do
case mayNodespan of
Just nodespan ->
do let neededSpaces = srcSpanStartColumn cspan
srcSpanEndColumn nodespan
replicateM_ neededSpaces space
Nothing -> return ()
if inline
then do write "{-"
string str
write "-}"
when (1 == srcSpanStartColumn cspan) $
modify (\s -> s {psEolComment = True})
else do write "--"
string str
modify (\s ->
s {psEolComment = True})
pretty' :: (Pretty ast,P.Pretty (ast SrcSpanInfo),Functor ast,MonadState (PrintState s) m)
=> ast NodeInfo -> m ()
pretty' = write . T.fromText . T.pack . P.prettyPrint . fmap nodeInfoSpan
getState :: Printer s s
getState = gets psUserState
putState :: s -> Printer s ()
putState s' = modifyState (const s')
modifyState :: (s -> s) -> Printer s ()
modifyState f = modify (\s -> s {psUserState = f (psUserState s)})
indented :: MonadState (PrintState s) m => Int64 -> m a -> m a
indented i p =
do level <- gets psIndentLevel
modify (\s -> s {psIndentLevel = level + i})
m <- p
modify (\s -> s {psIndentLevel = level})
return m
spaced :: MonadState (PrintState s) m => [m ()] -> m ()
spaced = inter space
commas :: MonadState (PrintState s) m => [m ()] -> m ()
commas = inter comma
inter :: MonadState (PrintState s) m => m () -> [m ()] -> m ()
inter sep ps =
foldr (\(i,p) next ->
depend (do p
if i < length ps
then sep
else return ())
next)
(return ())
(zip [1 ..] ps)
lined :: MonadState (PrintState s) m => [m ()] -> m ()
lined ps = sequence_ (intersperse newline ps)
prefixedLined :: MonadState (PrintState s) m => Text -> [m ()] -> m ()
prefixedLined pref ps' =
case ps' of
[] -> return ()
(p:ps) ->
do p
indented (fromIntegral
(T.length pref *
(1)))
(mapM_ (\p' ->
do newline
depend (write (T.fromText pref)) p')
ps)
column :: MonadState (PrintState s) m => Int64 -> m a -> m a
column i p =
do level <- gets psIndentLevel
modify (\s -> s {psIndentLevel = i})
m <- p
modify (\s -> s {psIndentLevel = level})
return m
getColumn :: MonadState (PrintState s) m => m Int64
getColumn = gets psColumn
getLineNum :: MonadState (PrintState s) m => m Int64
getLineNum = gets psLine
newline :: MonadState (PrintState s) m => m ()
newline =
do write "\n"
modify (\s -> s {psNewline = True})
withCaseContext :: MonadState (PrintState s) m
=> Bool -> m a -> m a
withCaseContext bool pr =
do original <- gets psInsideCase
modify (\s -> s {psInsideCase = bool})
result <- pr
modify (\s -> s {psInsideCase = original})
return result
rhsSeparator :: MonadState (PrintState s) m
=> m ()
rhsSeparator =
do inCase <- gets psInsideCase
if inCase
then write "->"
else write "="
depend :: MonadState (PrintState s) m => m () -> m b -> m b
depend maker dependent =
do state' <- get
maker
st <- get
col <- gets psColumn
if state' /= st
then column col dependent
else dependent
dependBind :: MonadState (PrintState s) m => m a -> (a -> m b) -> m b
dependBind maker dependent =
do state' <- get
v <- maker
st <- get
col <- gets psColumn
if state' /= st
then column col (dependent v)
else (dependent v)
parens :: MonadState (PrintState s) m => m a -> m a
parens p =
depend (write "(")
(do v <- p
write ")"
return v)
braces :: MonadState (PrintState s) m => m a -> m a
braces p =
depend (write "{")
(do v <- p
write "}"
return v)
brackets :: MonadState (PrintState s) m => m a -> m a
brackets p =
depend (write "[")
(do v <- p
write "]"
return v)
space :: MonadState (PrintState s) m => m ()
space = write " "
comma :: MonadState (PrintState s) m => m ()
comma = write ","
int :: (Integral n, MonadState (PrintState s) m)
=> n -> m ()
int = write . decimal
write :: MonadState (PrintState s) m => Builder -> m ()
write x =
do eol <- gets psEolComment
when (eol && x /= "\n") newline
state <- get
let clearEmpty =
configClearEmptyLines (psConfig state)
writingNewline = x == "\n"
out =
if psNewline state &&
not (clearEmpty && writingNewline)
then T.fromText
(T.replicate (fromIntegral (psIndentLevel state))
" ") <>
x
else x
out' = T.toLazyText out
modify (\s ->
s {psOutput = psOutput state <> out
,psNewline = False
,psEolComment = False
,psLine = psLine state + additionalLines
,psColumn =
if additionalLines > 0
then LT.length (LT.concat (take 1 (reverse srclines)))
else psColumn state + LT.length out'})
where x' = T.toLazyText x
srclines = LT.lines x'
additionalLines =
LT.length (LT.filter (== '\n') x')
string :: MonadState (PrintState s) m =>String -> m ()
string = write . T.fromText . T.pack
getIndentSpaces :: MonadState (PrintState s) m => m Int64
getIndentSpaces =
gets (configIndentSpaces . psConfig)
getColumnLimit :: MonadState (PrintState s) m => m Int64
getColumnLimit =
gets (configMaxColumns . psConfig)
sandbox :: MonadState s m
=> m a -> m (a,s)
sandbox p =
do orig <- get
a <- p
new <- get
put orig
return (a,new)
nullBinds :: Binds NodeInfo -> Bool
nullBinds (BDecls _ x) = null x
nullBinds (IPBinds _ x) = null x
maybeCtx :: MonadState (PrintState s) m => Maybe (Context NodeInfo) -> m ()
maybeCtx =
maybe (return ())
(\p ->
pretty p >>
write " => ")
maybeOverlap :: MonadState (PrintState s) m => Maybe (Overlap NodeInfo) -> m ()
maybeOverlap =
maybe (return ())
(\p ->
pretty p >>
space)
swing :: MonadState (PrintState s) m => m () -> m b -> m b
swing a b =
do orig <- gets psIndentLevel
a
newline
indentSpaces <- getIndentSpaces
column (orig + indentSpaces) b
instance Pretty Context where
prettyInternal ctx =
case ctx of
CxSingle _ a -> pretty a
CxTuple _ as ->
parens (commas (map pretty as))
CxEmpty _ -> parens (return ())
instance Pretty Pat where
prettyInternal x =
case x of
PLit _ sign l -> pretty sign >> pretty l
PNPlusK _ n k ->
depend (do pretty n
write "+")
(int k)
PInfixApp _ a op b ->
case op of
Special{} ->
depend (pretty a)
(depend (prettyInfixOp op)
(pretty b))
_ ->
depend (do pretty a
space)
(depend (do prettyInfixOp op
space)
(pretty b))
PApp _ f args ->
depend (do pretty f
unless (null args) space)
(spaced (map pretty args))
PTuple _ boxed pats ->
depend (write (case boxed of
Unboxed -> "(#"
Boxed -> "("))
(do commas (map pretty pats)
write (case boxed of
Unboxed -> "#)"
Boxed -> ")"))
PList _ ps ->
brackets (commas (map pretty ps))
PParen _ e -> parens (pretty e)
PRec _ qname fields ->
depend (pretty qname)
(braces (commas (map pretty fields)))
PAsPat _ n p ->
depend (do pretty n
write "@")
(pretty p)
PWildCard _ -> write "_"
PIrrPat _ p ->
depend (write "~")
(pretty p)
PatTypeSig _ p ty ->
depend (do pretty p
write " :: ")
(pretty ty)
PViewPat _ e p ->
depend (do pretty e
write " -> ")
(pretty p)
PQuasiQuote _ name str ->
brackets (depend (do write "$"
string name
write "|")
(string str))
PBangPat _ p ->
depend (write "!")
(pretty p)
PRPat{} -> pretty' x
PXTag{} -> pretty' x
PXETag{} -> pretty' x
PXPcdata{} -> pretty' x
PXPatTag{} -> pretty' x
PXRPats{} -> pretty' x
PVar{} -> pretty' x
prettyInfixOp :: MonadState (PrintState s) m => QName NodeInfo -> m ()
prettyInfixOp x =
case x of
Qual{} -> pretty' x
UnQual _ n ->
case n of
Ident _ i -> string ("`" ++ i ++ "`")
Symbol _ s -> string s
Special _ s -> pretty s
instance Pretty Type where
prettyInternal x =
case x of
TyForall _ mbinds ctx ty ->
depend (case mbinds of
Nothing -> return ()
Just ts ->
do write "forall "
spaced (map pretty ts)
write ". ")
(depend (maybeCtx ctx)
(pretty ty))
TyFun _ a b ->
depend (do pretty a
write " -> ")
(pretty b)
TyTuple _ boxed tys ->
depend (write (case boxed of
Unboxed -> "(#"
Boxed -> "("))
(do commas (map pretty tys)
write (case boxed of
Unboxed -> "#)"
Boxed -> ")"))
TyList _ t -> brackets (pretty t)
TyParArray _ t ->
brackets (do write ":"
pretty t
write ":")
TyApp _ f a -> spaced [pretty f,pretty a]
TyVar _ n -> pretty n
TyCon _ p -> pretty p
TyParen _ e -> parens (pretty e)
TyInfix _ a op b ->
depend (do pretty a
space)
(depend (do pretty op
space)
(pretty b))
TyKind _ ty k ->
parens (do pretty ty
write " :: "
pretty k)
TyBang _ bangty right ->
do pretty bangty
pretty right
TyEquals _ left right ->
do pretty left
write " == "
pretty right
TyPromoted{} ->
error "FIXME: No implementation for TyPromoted."
TySplice{} ->
error "FIXME: No implementation for TySplice."
instance Pretty Exp where
prettyInternal = exp
exp :: MonadState (PrintState s) m => Exp NodeInfo -> m ()
exp (InfixApp _ a op b) =
depend (do pretty a
space
pretty op
space)
(do pretty b)
exp (App _ op a) =
swing (do pretty f)
(lined (map pretty args))
where (f,args) = flatten op [a]
flatten :: Exp NodeInfo
-> [Exp NodeInfo]
-> (Exp NodeInfo,[Exp NodeInfo])
flatten (App _ f' a') b =
flatten f' (a' : b)
flatten f' as = (f',as)
exp (NegApp _ e) =
depend (write "-")
(pretty e)
exp (Lambda _ ps e) =
depend (write "\\")
(do spaced (map pretty ps)
swing (write " -> ")
(pretty e))
exp (Let _ binds e) =
do depend (write "let ")
(pretty binds)
newline
depend (write "in ")
(pretty e)
exp (If _ p t e) =
do depend (write "if ")
(do pretty p
newline
depend (write "then ")
(pretty t)
newline
depend (write "else ")
(pretty e))
exp (Paren _ e) = parens (pretty e)
exp (Case _ e alts) =
do depend (write "case ")
(do pretty e
write " of")
newline
indentSpaces <- getIndentSpaces
indented indentSpaces (lined (map (withCaseContext True . pretty) alts))
exp (Do _ stmts) =
depend (write "do ")
(lined (map pretty stmts))
exp (MDo _ stmts) =
depend (write "mdo ")
(lined (map pretty stmts))
exp (Tuple _ boxed exps) =
depend (write (case boxed of
Unboxed -> "(#"
Boxed -> "("))
(do prefixedLined ","
(map pretty exps)
write (case boxed of
Unboxed -> "#)"
Boxed -> ")"))
exp (TupleSection _ boxed mexps) =
depend (write (case boxed of
Unboxed -> "(#"
Boxed -> "("))
(do commas (map (maybe (return ()) pretty) mexps)
write (case boxed of
Unboxed -> "#)"
Boxed -> ")"))
exp (List _ es) =
brackets (prefixedLined ","
(map pretty es))
exp (LeftSection _ e op) =
parens (depend (do pretty e
space)
(pretty op))
exp (RightSection _ e op) =
parens (depend (do pretty e
space)
(pretty op))
exp (RecConstr _ n fs) =
do indentSpaces <- getIndentSpaces
depend (do pretty n
space)
(braces (prefixedLined ","
(map (indented indentSpaces . pretty) fs)))
exp (RecUpdate _ n fs) =
do indentSpaces <- getIndentSpaces
depend (do pretty n
space)
(braces (prefixedLined ","
(map (indented indentSpaces . pretty) fs)))
exp (EnumFrom _ e) =
brackets (do pretty e
write " ..")
exp (EnumFromTo _ e f) =
brackets (depend (do pretty e
write " .. ")
(pretty f))
exp (EnumFromThen _ e t) =
brackets (depend (do pretty e
write ",")
(do pretty t
write " .."))
exp (EnumFromThenTo _ e t f) =
brackets (depend (do pretty e
write ",")
(depend (do pretty t
write " .. ")
(pretty f)))
exp (ListComp _ e qstmt) =
brackets (depend (do pretty e
unless (null qstmt)
(write " |"))
(do space
prefixedLined
","
(map (\(i,x) ->
depend (if i == 0
then return ()
else space)
(pretty x))
(zip [0 :: Integer ..] qstmt))))
exp (ExpTypeSig _ e t) =
depend (do pretty e
write " :: ")
(pretty t)
exp (VarQuote _ x) =
depend (write "'")
(pretty x)
exp (TypQuote _ x) =
depend (write "''")
(pretty x)
exp (BracketExp _ b) = pretty b
exp (SpliceExp _ s) = pretty s
exp (QuasiQuote _ n s) =
brackets (depend (do string n
write "|")
(do string s
write "|"))
exp (LCase _ alts) =
do write "\\case"
indentSpaces <- getIndentSpaces
newline
indented indentSpaces (lined (map (withCaseContext True . pretty) alts))
exp (MultiIf _ alts) =
depend (write "if ")
(lined (map (\p ->
do write "| "
pretty p)
alts))
exp x@XTag{} = pretty' x
exp x@XETag{} = pretty' x
exp x@XPcdata{} = pretty' x
exp x@XExpTag{} = pretty' x
exp x@XChildTag{} = pretty' x
exp x@Var{} = pretty' x
exp x@IPVar{} = pretty' x
exp x@Con{} = pretty' x
exp x@Lit{} = pretty' x
exp x@CorePragma{} = pretty' x
exp x@SCCPragma{} = pretty' x
exp x@GenPragma{} = pretty' x
exp x@Proc{} = pretty' x
exp x@LeftArrApp{} = pretty' x
exp x@RightArrApp{} = pretty' x
exp x@LeftArrHighApp{} = pretty' x
exp x@RightArrHighApp{} = pretty' x
exp x@ParArray{} = pretty' x
exp x@ParArrayFromTo{} = pretty' x
exp x@ParArrayFromThenTo{} = pretty' x
exp x@ParArrayComp{} = pretty' x
exp ParComp{} =
error "FIXME: No implementation for ParComp."
instance Pretty Stmt where
prettyInternal x =
case x of
Generator _ p e ->
depend (do pretty p
write " <- ")
(pretty e)
Qualifier _ e -> pretty e
LetStmt _ binds ->
depend (write "let ")
(pretty binds)
RecStmt{} ->
error "FIXME: No implementation for RecStmt."
instance Pretty QualStmt where
prettyInternal x =
case x of
QualStmt _ s -> pretty s
ThenTrans{} ->
error "FIXME: No implementation for ThenTrans."
ThenBy{} ->
error "FIXME: No implementation for ThenBy."
GroupBy{} ->
error "FIXME: No implementation for GroupBy."
GroupUsing{} ->
error "FIXME: No implementation for GroupUsing."
GroupByUsing{} ->
error "FIXME: No implementation for GroupByUsing."
instance Pretty Decl where
prettyInternal = decl
decl :: MonadState (PrintState s) m => Decl NodeInfo -> m ()
decl (PatBind _ pat rhs mbinds) =
do pretty pat
withCaseContext False (pretty rhs)
indentSpaces <- getIndentSpaces
case mbinds of
Nothing -> return ()
Just binds ->
do newline
indented indentSpaces
(depend (write "where ")
(pretty binds))
decl (InstDecl _ moverlap dhead decls) =
do indentSpaces <- getIndentSpaces
depend (write "instance ")
(depend (maybeOverlap moverlap)
(depend (pretty dhead)
(unless (null (fromMaybe [] decls))
(write " where"))))
unless (null (fromMaybe [] decls))
(do newline
indented indentSpaces (lined (map pretty (fromMaybe [] decls))))
decl (SpliceDecl _ e) = pretty e
decl (TypeSig _ names ty) =
depend (do inter (write ", ")
(map pretty names)
write " :: ")
(pretty ty)
decl (FunBind _ matches) =
lined (map pretty matches)
decl (ClassDecl _ ctx dhead fundeps decls) =
do depend (write "class ")
(depend (maybeCtx ctx)
(depend (do pretty dhead
space)
(depend (unless (null fundeps)
(do write " | "
commas (map pretty fundeps)))
(unless (null (fromMaybe [] decls))
(write " where")))))
unless (null (fromMaybe [] decls))
(do newline
indentSpaces <- getIndentSpaces
indented indentSpaces (lined (map pretty (fromMaybe [] decls))))
decl (TypeDecl _ typehead typ) =
depend (write "type ")
(depend (pretty typehead)
(depend (write " = ")
(pretty typ)))
decl TypeFamDecl{} =
error "FIXME: No implementation for TypeFamDecl."
decl (DataDecl _ dataornew ctx dhead condecls mderivs) =
do depend (do pretty dataornew
space)
(depend (maybeCtx ctx)
(do pretty dhead
case condecls of
[] -> return ()
[x] -> singleCons x
xs -> multiCons xs))
indentSpaces <- getIndentSpaces
case mderivs of
Nothing -> return ()
Just derivs ->
do newline
column indentSpaces (pretty derivs)
where singleCons x =
do write " ="
indentSpaces <- getIndentSpaces
column indentSpaces
(do newline
pretty x)
multiCons xs =
do newline
indentSpaces <- getIndentSpaces
column indentSpaces
(depend (write "=")
(prefixedLined "|"
(map (depend space . pretty) xs)))
decl GDataDecl{} =
error "FIXME: No implementation for GDataDecl."
decl DataFamDecl{} =
error "FIXME: No implementation for DataFamDecl."
decl TypeInsDecl{} =
error "FIXME: No implementation for TypeInsDecl."
decl DataInsDecl{} =
error "FIXME: No implementation for DataInsDecl."
decl GDataInsDecl{} =
error "FIXME: No implementation for GDataInsDecl."
decl DerivDecl{} =
error "FIXME: No implementation for DerivDecl."
decl ForImp{} =
error "FIXME: No implementation for ForImp."
decl ForExp{} =
error "FIXME: No implementation for ForExp."
decl RulePragmaDecl{} =
error "FIXME: No implementation for RulePragmaDecl."
decl DeprPragmaDecl{} =
error "FIXME: No implementation for DeprPragmaDecl."
decl InlineSig{} =
error "FIXME: No implementation for InlineSig."
decl InlineConlikeSig{} =
error "FIXME: No implementation for InlineConlikeSig."
decl SpecSig{} =
error "FIXME: No implementation for SpecSig."
decl SpecInlineSig{} =
error "FIXME: No implementation for SpecInlineSig."
decl InstSig{} =
error "FIXME: No implementation for InstSig."
decl ClosedTypeFamDecl{} =
error "FIXME: No implementation for ClosedTypeFamDecl."
decl x@WarnPragmaDecl{} = pretty' x
decl x@MinimalPragma{} = pretty' x
decl x@AnnPragma{} = pretty' x
decl x@InfixDecl{} = pretty' x
decl x@DefaultDecl{} = pretty' x
instance Pretty Deriving where
prettyInternal (Deriving _ heads) =
do write "deriving"
space
parens (commas (map pretty heads))
instance Pretty Alt where
prettyInternal x =
case x of
Alt _ p galts mbinds ->
do pretty p
pretty galts
case mbinds of
Nothing -> return ()
Just binds ->
do newline
indentSpaces <- getIndentSpaces
indented indentSpaces
(depend (write "where ")
(pretty binds))
instance Pretty Asst where
prettyInternal x =
case x of
ClassA _ name types ->
spaced (pretty name :
map pretty types)
InfixA{} ->
error "FIXME: No implementation for InfixA."
IParam{} ->
error "FIXME: No implementation for IParam."
EqualP _ a b ->
do pretty a
write " ~ "
pretty b
ParenA _ asst -> parens $ pretty asst
VarA _ var -> pretty var
instance Pretty BangType where
prettyInternal x =
case x of
BangedTy _ -> write "!"
UnpackedTy _ -> write "{-# UNPACK #-} !"
instance Pretty Binds where
prettyInternal x =
case x of
BDecls _ ds -> lined (map pretty ds)
IPBinds _ i -> lined (map pretty i)
instance Pretty ClassDecl where
prettyInternal x =
case x of
ClsDecl _ d -> pretty d
ClsDataFam _ ctx h mkind ->
depend (write "data ")
(depend (maybeCtx ctx)
(do pretty h
(case mkind of
Nothing ->
return ()
Just kind ->
do write " :: "
pretty kind)))
ClsTyFam _ h mkind ->
depend (write "type ")
(depend (pretty h)
(case mkind of
Nothing -> return ()
Just kind ->
do write " :: "
pretty kind))
ClsTyDef _ this that ->
do write "type "
pretty this
write " = "
pretty that
ClsDefSig _ name ty ->
do write "default "
pretty name
write " :: "
pretty ty
instance Pretty ConDecl where
prettyInternal x =
case x of
ConDecl _ name bangty ->
depend (do pretty name
space)
(lined (map pretty bangty))
InfixConDecl l a f b ->
pretty (ConDecl l f [a,b])
RecDecl _ name fields ->
depend (do pretty name
write " ")
(do depend (write "{")
(prefixedLined ","
(map pretty fields))
write "}")
instance Pretty FieldDecl where
prettyInternal (FieldDecl _ names ty) =
depend (do commas (map pretty names)
write " :: ")
(pretty ty)
instance Pretty FieldUpdate where
prettyInternal x =
case x of
FieldUpdate _ n e ->
swing (do pretty n
write " = ")
(pretty e)
FieldPun _ n -> pretty n
FieldWildcard _ -> write ".."
instance Pretty GuardedRhs where
prettyInternal x =
case x of
GuardedRhs _ stmts e ->
do indented 1
(do prefixedLined
","
(map (\p ->
do space
pretty p)
stmts))
swing (write " " >> rhsSeparator >> write " ")
(pretty e)
instance Pretty InstDecl where
prettyInternal i =
case i of
InsDecl _ d -> pretty d
InsType _ name ty ->
depend (do write "type "
pretty name
write " = ")
(pretty ty)
_ -> pretty' i
instance Pretty Match where
prettyInternal x =
case x of
Match _ name pats rhs mbinds ->
do depend (do pretty name
space)
(spaced (map pretty pats))
withCaseContext False (pretty rhs)
case mbinds of
Nothing -> return ()
Just binds ->
do newline
indentSpaces <- getIndentSpaces
indented indentSpaces
(depend (write "where ")
(pretty binds))
InfixMatch _ pat1 name pats rhs mbinds ->
do depend (do pretty pat1
space
case name of
Ident _ i ->
string ("`" ++ i ++ "`")
Symbol _ s -> string s)
(do space
spaced (map pretty pats))
withCaseContext False (pretty rhs)
case mbinds of
Nothing -> return ()
Just binds ->
do newline
indentSpaces <- getIndentSpaces
indented indentSpaces
(depend (write "where ")
(pretty binds))
instance Pretty PatField where
prettyInternal x =
case x of
PFieldPat _ n p ->
depend (do pretty n
write " = ")
(pretty p)
PFieldPun _ n -> pretty n
PFieldWildcard _ -> write ".."
instance Pretty QualConDecl where
prettyInternal x =
case x of
QualConDecl _ tyvars ctx d ->
depend (unless (null (fromMaybe [] tyvars))
(do write "forall "
spaced (map pretty (fromMaybe [] tyvars))
write ". "))
(depend (maybeCtx ctx)
(pretty d))
instance Pretty Rhs where
prettyInternal x =
case x of
UnGuardedRhs _ e -> do
(swing (write " " >> rhsSeparator >> write " ")
(pretty e))
GuardedRhss _ gas ->
do newline
indented 2
(lined (map (\p ->
do write "|"
pretty p)
gas))
instance Pretty Splice where
prettyInternal x =
case x of
IdSplice _ str ->
do write "$"
string str
ParenSplice _ e ->
depend (write "$")
(parens (pretty e))
instance Pretty InstRule where
prettyInternal (IParen _ rule) = parens $ pretty rule
prettyInternal (IRule _ mvarbinds mctx ihead) =
do case mvarbinds of
Nothing -> return ()
Just xs -> spaced (map pretty xs)
depend (maybeCtx mctx)
(pretty ihead)
instance Pretty InstHead where
prettyInternal x =
case x of
IHCon _ name -> pretty name
IHInfix _ typ name ->
depend (pretty typ)
(do space
prettyInfixOp name)
IHApp _ ihead typ ->
depend (pretty ihead)
(do space
pretty typ)
IHParen _ h -> parens (pretty h)
instance Pretty DeclHead where
prettyInternal x =
case x of
DHead _ name -> pretty name
DHParen _ h -> parens (pretty h)
DHInfix _ var name ->
do pretty var
space
write "`"
pretty name
write "`"
DHApp _ dhead var ->
depend (pretty dhead)
(do space
pretty var)
instance Pretty SpecialCon where
prettyInternal s =
case s of
UnitCon _ -> write "()"
ListCon _ -> write "[]"
FunCon _ -> write "->"
TupleCon _ Boxed i ->
string ("(" ++
replicate (i 1) ',' ++
")")
TupleCon _ Unboxed i ->
string ("(#" ++
replicate (i 1) ',' ++
"#)")
Cons _ -> write ":"
UnboxedSingleCon _ -> write "(##)"
instance Pretty Overlap where
prettyInternal (Overlap _) = write "{-# OVERLAP #-}"
prettyInternal (NoOverlap _) = write "{-# NO_OVERLAP #-}"
prettyInternal (Incoherent _) = write "{-# INCOHERENT #-}"
instance Pretty Sign where
prettyInternal (Signless _) = return ()
prettyInternal (Negative _) = write "-"
instance Pretty Module where
prettyInternal x =
case x of
Module _ mayModHead pragmas imps decls ->
do case mayModHead of
Nothing -> return ()
Just modHead -> do
pretty modHead
unless (null pragmas && null imps && null decls) $ newline
inter newline (map pretty pragmas)
inter newline (map pretty imps)
inter newline (map pretty decls)
XmlPage{} ->
error "FIXME: No implementation for XmlPage."
XmlHybrid{} ->
error "FIXME: No implementation for XmlHybrid."
instance Pretty Bracket where
prettyInternal x =
case x of
ExpBracket _ p ->
brackets (depend (write "|")
(do pretty p
write "|"))
PatBracket _ _ ->
error "FIXME: No implementation for PatBracket."
TypeBracket _ _ ->
error "FIXME: No implementation for TypeBracket."
DeclBracket _ _ ->
error "FIXME: No implementation for DeclBracket."
instance Pretty IPBind where
prettyInternal x =
case x of
IPBind _ _ _ ->
error "FIXME: No implementation for IPBind."
instance Pretty DataOrNew where
prettyInternal = pretty'
instance Pretty FunDep where
prettyInternal = pretty'
instance Pretty Kind where
prettyInternal = pretty'
instance Pretty Literal where
prettyInternal = pretty'
instance Pretty Name where
prettyInternal = pretty'
instance Pretty QName where
prettyInternal = pretty'
instance Pretty QOp where
prettyInternal = pretty'
instance Pretty TyVarBind where
prettyInternal = pretty'
instance Pretty ModuleHead where
prettyInternal = pretty'
instance Pretty ModulePragma where
prettyInternal = pretty'
instance Pretty ImportDecl where
prettyInternal = pretty'
instance Pretty ModuleName where
prettyInternal (ModuleName _ name) =
write (T.fromString name)
instance Pretty ImportSpecList where
prettyInternal = pretty'
instance Pretty ImportSpec where
prettyInternal = pretty'
instance Pretty WarningText where
prettyInternal = pretty'
instance Pretty ExportSpecList where
prettyInternal = pretty'
instance Pretty ExportSpec where
prettyInternal = pretty'