Permalink
Fetching contributors…
Cannot retrieve contributors at this time
2171 lines (2027 sloc) 66.8 KB
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
-- | Pretty printing.
module HIndent.Pretty
(pretty)
where
import Control.Applicative
import Control.Monad.State.Strict hiding (state)
import qualified Data.ByteString.Builder as S
import Data.Foldable (for_, forM_, traverse_)
import Data.Int
import Data.List
import Data.Maybe
import Data.Monoid ((<>))
import Data.Typeable
import HIndent.Types
import qualified Language.Haskell.Exts as P
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.Exts.Syntax
import Prelude hiding (exp)
--------------------------------------------------------------------------------
-- * Pretty printing class
-- | Pretty printing class.
class (Annotated ast,Typeable ast) => Pretty ast where
prettyInternal :: ast NodeInfo -> Printer ()
-- | Pretty print including comments.
pretty :: (Pretty ast,Show (ast NodeInfo))
=> ast NodeInfo -> Printer ()
pretty a = do
mapM_
(\c' -> do
case c' of
CommentBeforeLine _ c -> do
case c of
EndOfLine s -> write ("--" ++ s)
MultiLine s -> write ("{-" ++ s ++ "-}")
newline
_ -> return ())
comments
prettyInternal a
mapM_
(\(i, c') -> do
case c' of
CommentSameLine spn c -> do
col <- gets psColumn
if col == 0
then do
-- write comment keeping original indentation
let col' = fromIntegral $ srcSpanStartColumn spn - 1
column col' $ writeComment c
else do
space
writeComment c
CommentAfterLine spn c -> do
when (i == 0) newline
-- write comment keeping original indentation
let col = fromIntegral $ srcSpanStartColumn spn - 1
column col $ writeComment c
_ -> return ())
(zip [0 :: Int ..] comments)
where
comments = nodeInfoComments (ann a)
writeComment =
\case
EndOfLine cs -> do
write ("--" ++ cs)
modify
(\s ->
s
{ psEolComment = True
})
MultiLine cs -> do
write ("{-" ++ cs ++ "-}")
modify
(\s ->
s
{ psEolComment = True
})
-- | Pretty print using HSE's own printer. The 'P.Pretty' class here
-- is HSE's.
pretty' :: (Pretty ast,P.Pretty (ast SrcSpanInfo))
=> ast NodeInfo -> Printer ()
pretty' = write . P.prettyPrint . fmap nodeInfoSpan
--------------------------------------------------------------------------------
-- * Combinators
-- | Increase indentation level by n spaces for the given printer.
indented :: Int64 -> Printer a -> Printer a
indented i p =
do level <- gets psIndentLevel
modify (\s -> s {psIndentLevel = level + i})
m <- p
modify (\s -> s {psIndentLevel = level})
return m
indentedBlock :: Printer a -> Printer a
indentedBlock p =
do indentSpaces <- getIndentSpaces
indented indentSpaces p
-- | Print all the printers separated by spaces.
spaced :: [Printer ()] -> Printer ()
spaced = inter space
-- | Print all the printers separated by commas.
commas :: [Printer ()] -> Printer ()
commas = inter (write ", ")
-- | Print all the printers separated by sep.
inter :: Printer () -> [Printer ()] -> Printer ()
inter sep ps =
foldr
(\(i,p) next ->
depend
(do p
if i < length ps
then sep
else return ())
next)
(return ())
(zip [1 ..] ps)
-- | Print all the printers separated by newlines.
lined :: [Printer ()] -> Printer ()
lined ps = sequence_ (intersperse newline ps)
-- | Print all the printers separated newlines and optionally a line
-- prefix.
prefixedLined :: String -> [Printer ()] -> Printer ()
prefixedLined pref ps' =
case ps' of
[] -> return ()
(p:ps) ->
do p
indented (fromIntegral
(length pref *
(-1)))
(mapM_ (\p' ->
do newline
depend (write pref) p')
ps)
-- | Set the (newline-) indent level to the given column for the given
-- printer.
column :: Int64 -> Printer a -> Printer a
column i p =
do level <- gets psIndentLevel
modify (\s -> s {psIndentLevel = i})
m <- p
modify (\s -> s {psIndentLevel = level})
return m
-- | Output a newline.
newline :: Printer ()
newline =
do write "\n"
modify (\s -> s {psNewline = True})
-- | Set the context to a case context, where RHS is printed with -> .
withCaseContext :: Bool -> Printer a -> Printer a
withCaseContext bool pr =
do original <- gets psInsideCase
modify (\s -> s {psInsideCase = bool})
result <- pr
modify (\s -> s {psInsideCase = original})
return result
-- | Get the current RHS separator, either = or -> .
rhsSeparator :: Printer ()
rhsSeparator =
do inCase <- gets psInsideCase
if inCase
then write "->"
else write "="
-- | Make the latter's indentation depend upon the end column of the
-- former.
depend :: Printer () -> Printer b -> Printer b
depend maker dependent =
do state' <- get
maker
st <- get
col <- gets psColumn
if psLine state' /= psLine st || psColumn state' /= psColumn st
then column col dependent
else dependent
-- | Wrap.
wrap :: String -> String -> Printer a -> Printer a
wrap open close p = depend (write open) $ p <* write close
-- | Wrap in parens.
parens :: Printer a -> Printer a
parens = wrap "(" ")"
-- | Wrap in braces.
braces :: Printer a -> Printer a
braces = wrap "{" "}"
-- | Wrap in brackets.
brackets :: Printer a -> Printer a
brackets = wrap "[" "]"
-- | Write a space.
space :: Printer ()
space = write " "
-- | Write a comma.
comma :: Printer ()
comma = write ","
-- | Write an integral.
int :: Integer -> Printer ()
int = write . show
-- | Write out a string, updating the current position information.
write :: String -> Printer ()
write x =
do eol <- gets psEolComment
hardFail <- gets psHardLimit
let addingNewline = eol && x /= "\n"
when addingNewline newline
state <- get
let writingNewline = x == "\n"
out :: String
out =
if psNewline state && not writingNewline
then (replicate (fromIntegral (psIndentLevel state))
' ') <>
x
else x
psColumn' =
if additionalLines > 0
then fromIntegral (length (concat (take 1 (reverse srclines))))
else psColumn state + fromIntegral (length out)
when
hardFail
(guard
(additionalLines == 0 &&
(psColumn' <= configMaxColumns (psConfig state))))
modify (\s ->
s {psOutput = psOutput state <> S.stringUtf8 out
,psNewline = False
,psLine = psLine state + fromIntegral additionalLines
,psEolComment= False
,psColumn = psColumn'})
where srclines = lines x
additionalLines =
length (filter (== '\n') x)
-- | Write a string.
string :: String -> Printer ()
string = write
-- | Indent spaces, e.g. 2.
getIndentSpaces :: Printer Int64
getIndentSpaces =
gets (configIndentSpaces . psConfig)
-- | Play with a printer and then restore the state to what it was
-- before.
sandbox :: Printer a -> Printer (a,PrintState)
sandbox p =
do orig <- get
a <- p
new <- get
put orig
return (a,new)
-- | Render a type with a context, or not.
withCtx :: (Pretty ast,Show (ast NodeInfo))
=> Maybe (ast NodeInfo) -> Printer b -> Printer b
withCtx Nothing m = m
withCtx (Just ctx) m =
do pretty ctx
write " =>"
newline
m
-- | Maybe render an overlap definition.
maybeOverlap :: Maybe (Overlap NodeInfo) -> Printer ()
maybeOverlap =
maybe (return ())
(\p ->
pretty p >>
space)
-- | Swing the second printer below and indented with respect to the first.
swing :: Printer () -> Printer b -> Printer ()
swing a b =
do orig <- gets psIndentLevel
a
mst <- fitsOnOneLine (do space
b)
case mst of
Just st -> put st
Nothing -> do newline
indentSpaces <- getIndentSpaces
_ <- column (orig + indentSpaces) b
return ()
-- | Swing the second printer below and indented with respect to the first by
-- the specified amount.
swingBy :: Int64 -> Printer() -> Printer b -> Printer b
swingBy i a b =
do orig <- gets psIndentLevel
a
newline
column (orig + i) b
--------------------------------------------------------------------------------
-- * Instances
instance Pretty Context where
prettyInternal ctx@(CxTuple _ asserts) = do
mst <- fitsOnOneLine (parens (inter (comma >> space) (map pretty asserts)))
case mst of
Nothing -> context ctx
Just st -> put st
prettyInternal ctx = context ctx
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 -> do
let horVariant = do
pretty qname
space
braces $ commas $ map pretty fields
verVariant =
depend (pretty qname >> space) $ do
case fields of
[] -> write "{}"
[field] -> braces $ pretty field
_ -> do
depend (write "{") $
prefixedLined "," $ map (depend space . pretty) fields
newline
write "}"
horVariant `ifFitsOnOneLineOrElse` verVariant
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 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
-- | Pretty infix application of a name (identifier or symbol).
prettyInfixName :: Name NodeInfo -> Printer ()
prettyInfixName (Ident _ n) = do write "`"; string n; write "`";
prettyInfixName (Symbol _ s) = string s
-- | Pretty print a name for being an infix operator.
prettyInfixOp :: QName NodeInfo -> Printer ()
prettyInfixOp x =
case x of
Qual _ mn n ->
case n of
Ident _ i -> do write "`"; pretty mn; write "."; string i; write "`";
Symbol _ s -> do pretty mn; write "."; string s;
UnQual _ n -> prettyInfixName n
Special _ s -> pretty s
prettyQuoteName :: Name NodeInfo -> Printer ()
prettyQuoteName x =
case x of
Ident _ i -> string i
Symbol _ s -> string ("(" ++ s ++ ")")
prettyQuoteQName :: QName NodeInfo -> Printer ()
prettyQuoteQName x =
case x of
Qual _ mn n ->
case n of
Ident _ i -> do pretty mn; write "."; string i;
Symbol _ s -> do write "("; pretty mn; write "."; string s; write ")";
UnQual _ n ->
case n of
Ident _ i -> string i
Symbol _ s -> do write "("; string s; write ")";
Special _ s -> pretty s
instance Pretty Type where
prettyInternal = typ
instance Pretty Exp where
prettyInternal = exp
-- | Render an expression.
exp :: Exp NodeInfo -> Printer ()
-- | Do after lambda should swing.
exp (Lambda _ pats (Do l stmts)) =
do
mst <-
fitsOnOneLine
(do write "\\"
spaced (map pretty pats)
write " -> "
pretty (Do l stmts))
case mst of
Nothing -> swing (do write "\\"
spaced (map pretty pats)
write " -> do")
(lined (map pretty stmts))
Just st -> put st
-- | Space out tuples.
exp (Tuple _ boxed exps) = do
let horVariant = parensHorB boxed $ inter (write ", ") (map pretty exps)
verVariant = parensVerB boxed $ prefixedLined "," (map (depend space . pretty) exps)
mst <- fitsOnOneLine horVariant
case mst of
Nothing -> verVariant
Just st -> put st
where
parensHorB Boxed = parens
parensHorB Unboxed = wrap "(# " " #)"
parensVerB Boxed = parens
parensVerB Unboxed = wrap "(#" "#)"
-- | Space out tuples.
exp (TupleSection _ boxed mexps) = do
let horVariant = parensHorB boxed $ inter (write ", ") (map (maybe (return ()) pretty) mexps)
verVariant =
parensVerB boxed $ prefixedLined "," (map (maybe (return ()) (depend space . pretty)) mexps)
mst <- fitsOnOneLine horVariant
case mst of
Nothing -> verVariant
Just st -> put st
where
parensHorB Boxed = parens
parensHorB Unboxed = wrap "(# " " #)"
parensVerB Boxed = parens
parensVerB Unboxed = wrap "(#" "#)"
exp (UnboxedSum{}) = error "FIXME: No implementation for UnboxedSum."
-- | Infix apps, same algorithm as ChrisDone at the moment.
exp e@(InfixApp _ a op b) =
infixApp e a op b Nothing
-- | If bodies are indented 4 spaces. Handle also do-notation.
exp (If _ if' then' else') =
do depend (write "if ")
(pretty if')
newline
indentSpaces <- getIndentSpaces
indented indentSpaces
(do branch "then " then'
newline
branch "else " else')
-- Special handling for do.
where branch str e =
case e of
Do _ stmts ->
do write str
write "do"
newline
indentSpaces <- getIndentSpaces
indented indentSpaces (lined (map pretty stmts))
_ ->
depend (write str)
(pretty e)
-- | Render on one line, or otherwise render the op with the arguments
-- listed line by line.
exp (App _ op arg) = do
let flattened = flatten op ++ [arg]
mst <- fitsOnOneLine (spaced (map pretty flattened))
case mst of
Nothing -> do
let (f:args) = flattened
col <- gets psColumn
spaces <- getIndentSpaces
pretty f
col' <- gets psColumn
let diff = col' - col - if col == 0 then spaces else 0
if diff + 1 <= spaces
then space
else newline
spaces' <- getIndentSpaces
indented spaces' (lined (map pretty args))
Just st -> put st
where
flatten (App label' op' arg') = flatten op' ++ [amap (addComments label') arg']
flatten x = [x]
addComments n1 n2 =
n2
{ nodeInfoComments = nub (nodeInfoComments n2 ++ nodeInfoComments n1)
}
-- | Space out commas in list.
exp (List _ es) =
do mst <- fitsOnOneLine p
case mst of
Nothing -> do
depend
(write "[")
(prefixedLined "," (map (depend space . pretty) es))
newline
write "]"
Just st -> put st
where p =
brackets (inter (write ", ")
(map pretty es))
exp (RecUpdate _ exp' updates) = recUpdateExpr (pretty exp') updates
exp (RecConstr _ qname updates) = recUpdateExpr (pretty qname) updates
exp (Let _ binds e) =
depend (write "let ")
(do pretty binds
newline
indented (-3) (depend (write "in ")
(pretty e)))
exp (ListComp _ e qstmt) = do
let horVariant = brackets $ do
pretty e
write " | "
commas $ map pretty qstmt
verVariant = do
write "[ "
pretty e
newline
depend (write "| ") $ prefixedLined ", " $ map pretty qstmt
newline
write "]"
horVariant `ifFitsOnOneLineOrElse` verVariant
exp (ParComp _ e qstmts) = do
let horVariant = brackets $ do
pretty e
for_ qstmts $ \qstmt -> do
write " | "
commas $ map pretty qstmt
verVariant = do
depend (write "[ ") $ pretty e
newline
for_ qstmts $ \qstmt -> do
depend (write "| ") $ prefixedLined ", " $ map pretty qstmt
newline
write "]"
horVariant `ifFitsOnOneLineOrElse` verVariant
exp (TypeApp _ t) = do
write "@"
pretty t
exp (NegApp _ e) =
depend (write "-")
(pretty e)
exp (Lambda _ ps e) = do
write "\\"
spaced [ do case (i, x) of
(0, PIrrPat {}) -> space
(0, PBangPat {}) -> space
_ -> return ()
pretty x
| (i, x) <- zip [0 :: Int ..] ps
]
swing (write " ->") $ pretty e
exp (Paren _ e) = parens (pretty e)
exp (Case _ e alts) =
do depend (write "case ")
(do pretty e
write " of")
if null alts
then write " {}"
else do newline
indentedBlock (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 (LeftSection _ e op) =
parens (depend (do pretty e
space)
(pretty op))
exp (RightSection _ e op) =
parens (depend (do pretty e
space)
(pretty op))
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 (ExpTypeSig _ e t) =
depend (do pretty e
write " :: ")
(pretty t)
exp (VarQuote _ x) =
depend (write "'")
(prettyQuoteQName x)
exp (TypQuote _ x) =
depend (write "''")
(prettyQuoteQName 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"
if null alts
then write " {}"
else do newline
indentedBlock (lined (map (withCaseContext True . pretty) alts))
exp (MultiIf _ alts) =
withCaseContext
True
(depend
(write "if ")
(lined
(map
(\p -> do
write "| "
prettyG p)
alts)))
where
prettyG (GuardedRhs _ stmts e) = do
indented
1
(do (lined (map
(\(i,p) -> do
unless (i == 1)
space
pretty p
unless (i == length stmts)
(write ","))
(zip [1..] stmts))))
swing (write " " >> rhsSeparator) (pretty e)
exp (Lit _ lit) = prettyInternal lit
exp (Var _ q) = case q of
Special _ Cons{} -> parens (pretty q)
Qual _ _ (Symbol _ _) -> parens (pretty q)
UnQual _ (Symbol _ _) -> parens (pretty q)
_ -> pretty q
exp (IPVar _ q) = pretty q
exp (Con _ q) = case q of
Special _ Cons{} -> parens (pretty q)
Qual _ _ (Symbol _ _) -> parens (pretty q)
UnQual _ (Symbol _ _) -> parens (pretty q)
_ -> pretty q
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@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 (OverloadedLabel _ label) = string ('#' : label)
instance Pretty IPName where
prettyInternal = pretty'
instance Pretty Stmt where
prettyInternal =
stmt
instance Pretty QualStmt where
prettyInternal x =
case x of
QualStmt _ s -> pretty s
ThenTrans _ s -> do
write "then "
pretty s
ThenBy _ s t -> do
write "then "
pretty s
write " by "
pretty t
GroupBy _ s -> do
write "then group by "
pretty s
GroupUsing _ s -> do
write "then group using "
pretty s
GroupByUsing _ s t -> do
write "then group by "
pretty s
write " using "
pretty t
instance Pretty Decl where
prettyInternal = decl'
-- | Render a declaration.
decl :: Decl NodeInfo -> Printer ()
decl (InstDecl _ moverlap dhead decls) =
do depend (write "instance ")
(depend (maybeOverlap moverlap)
(depend (pretty dhead)
(unless (null (fromMaybe [] decls))
(write " where"))))
unless (null (fromMaybe [] decls))
(do newline
indentedBlock (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 classHead ctx dhead fundeps decls
unless (null (fromMaybe [] decls))
(do newline
indentedBlock (lined (map pretty (fromMaybe [] decls))))
decl (TypeDecl _ typehead typ') = do
write "type "
pretty typehead
ifFitsOnOneLineOrElse
(depend (write " = ") (pretty typ'))
(do newline
indentedBlock (depend (write " = ") (pretty typ')))
decl (TypeFamDecl _ declhead result injectivity) = do
write "type family "
pretty declhead
case result of
Just r -> do
space
let sep = case r of
KindSig _ _ -> "::"
TyVarSig _ _ -> "="
write sep
space
pretty r
Nothing -> return ()
case injectivity of
Just i -> do
space
pretty i
Nothing -> return ()
decl (ClosedTypeFamDecl _ declhead result injectivity instances) = do
write "type family "
pretty declhead
for_ result $ \r -> do
space
let sep = case r of
KindSig _ _ -> "::"
TyVarSig _ _ -> "="
write sep
space
pretty r
for_ injectivity $ \i -> do
space
pretty i
space
write "where"
newline
indentedBlock (lined (map pretty instances))
decl (DataDecl _ dataornew ctx dhead condecls mderivs) =
do depend (do pretty dataornew
space)
(withCtx ctx
(do pretty dhead
case condecls of
[] -> return ()
[x] -> singleCons x
xs -> multiCons xs))
indentSpaces <- getIndentSpaces
forM_ mderivs $ \deriv -> newline >> column indentSpaces (pretty deriv)
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 _ dataornew ctx dhead mkind condecls mderivs) =
do depend (pretty dataornew >> space)
(withCtx ctx
(do pretty dhead
case mkind of
Nothing -> return ()
Just kind -> do write " :: "
pretty kind
write " where"))
indentedBlock $ do
case condecls of
[] -> return ()
_ -> do
newline
lined (map pretty condecls)
forM_ mderivs $ \deriv -> newline >> pretty deriv
decl (InlineSig _ inline active name) = do
write "{-# "
unless inline $ write "NO"
write "INLINE "
case active of
Nothing -> return ()
Just (ActiveFrom _ x) -> write ("[" ++ show x ++ "] ")
Just (ActiveUntil _ x) -> write ("[~" ++ show x ++ "] ")
prettyQuoteQName name
write " #-}"
decl (MinimalPragma _ (Just formula)) =
wrap "{-# " " #-}" $ do
depend (write "MINIMAL ") $ pretty formula
decl (ForImp _ callconv maybeSafety maybeName name ty) = do
string "foreign import "
pretty' callconv >> space
case maybeSafety of
Just safety -> pretty' safety >> space
Nothing -> return ()
case maybeName of
Just namestr -> string (show namestr) >> space
Nothing -> return ()
pretty' name
tyline <- fitsOnOneLine $ do string " :: "
pretty' ty
case tyline of
Just line -> put line
Nothing -> do newline
indentedBlock $ do string ":: "
pretty' ty
decl (ForExp _ callconv maybeName name ty) = do
string "foreign export "
pretty' callconv >> space
case maybeName of
Just namestr -> string (show namestr) >> space
Nothing -> return ()
pretty' name
tyline <- fitsOnOneLine $ do string " :: "
pretty' ty
case tyline of
Just line -> put line
Nothing -> do newline
indentedBlock $ do string ":: "
pretty' ty
decl x' = pretty' x'
classHead
:: Maybe (Context NodeInfo)
-> DeclHead NodeInfo
-> [FunDep NodeInfo]
-> Maybe [ClassDecl NodeInfo]
-> Printer ()
classHead ctx dhead fundeps decls = shortHead `ifFitsOnOneLineOrElse` longHead
where
shortHead =
depend
(write "class ")
(withCtx ctx $
depend
(pretty dhead)
(depend (unless (null fundeps) (write " | " >> commas (map pretty fundeps)))
(unless (null (fromMaybe [] decls)) (write " where"))))
longHead = do
depend (write "class ") (withCtx ctx $ pretty dhead)
newline
indentedBlock $ do
unless (null fundeps) $ do
depend (write "| ") (prefixedLined ", " $ map pretty fundeps)
newline
unless (null (fromMaybe [] decls)) (write "where")
instance Pretty TypeEqn where
prettyInternal (TypeEqn _ in_ out_) = do
pretty in_
write " = "
pretty out_
instance Pretty Deriving where
prettyInternal (Deriving _ strategy heads) =
depend (write "deriving" >> space >> writeStrategy) $ do
let heads' =
if length heads == 1
then map stripParens heads
else heads
maybeDerives <- fitsOnOneLine $ parens (commas (map pretty heads'))
case maybeDerives of
Nothing -> formatMultiLine heads'
Just derives -> put derives
where
writeStrategy = case strategy of
Nothing -> return ()
Just st -> pretty st >> space
stripParens (IParen _ iRule) = stripParens iRule
stripParens x = x
formatMultiLine derives = do
depend (write "( ") $ prefixedLined ", " (map pretty derives)
newline
write ")"
instance Pretty DerivStrategy where
prettyInternal x =
case x of
DerivStock _ -> return ()
DerivAnyclass _ -> write "anyclass"
DerivNewtype _ -> write "newtype"
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
indentedBlock (depend (write "where ")
(pretty binds))
instance Pretty Asst where
prettyInternal x =
case x of
ClassA _ name types -> spaced (pretty name : map pretty types)
i@InfixA {} -> pretty' i
IParam _ name ty -> do
pretty name
write " :: "
pretty ty
EqualP _ a b -> do
pretty a
write " ~ "
pretty b
ParenA _ asst -> parens (pretty asst)
AppA _ name tys ->
spaced (pretty name : map pretty tys)
WildCardA _ name ->
case name of
Nothing -> write "_"
Just n -> do
write "_"
pretty n
instance Pretty BangType where
prettyInternal x =
case x of
BangedTy _ -> write "!"
LazyTy _ -> write "~"
NoStrictAnnot _ -> return ()
instance Pretty Unpackedness where
prettyInternal (Unpack _) = write "{-# UNPACK #-}"
prettyInternal (NoUnpack _) = write "{-# NOUNPACK #-}"
prettyInternal (NoUnpackPragma _) = return ()
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 ")
(withCtx ctx
(do pretty h
(case mkind of
Nothing -> return ()
Just kind ->
do write " :: "
pretty kind)))
ClsTyFam _ h mkind minj ->
depend (write "type ")
(depend (pretty h)
(depend (traverse_ (\kind -> write " :: " >> pretty kind) mkind)
(traverse_ pretty minj)))
ClsTyDef _ (TypeEqn _ 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 =
conDecl x
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 =
guardedRhs
instance Pretty InjectivityInfo where
prettyInternal x = pretty' x
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 = match
{-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
indentedBlock (depend (write "where ")
(pretty binds))
InfixMatch _ pat1 name pats rhs' mbinds ->
do depend (do pretty pat1
space
prettyInfixName name)
(do space
spaced (map pretty pats))
withCaseContext False (pretty rhs')
case mbinds of
Nothing -> return ()
Just binds ->
do newline
indentedBlock (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 (reverse (fromMaybe [] tyvars)))
write ". "))
(withCtx ctx
(pretty d))
instance Pretty GadtDecl where
prettyInternal (GadtDecl _ name fields t) =
horVar `ifFitsOnOneLineOrElse` verVar
where
fields' p =
case fromMaybe [] fields of
[] -> return ()
fs -> do
depend (write "{") $ do
prefixedLined "," (map (depend space . pretty) fs)
write "}"
p
horVar =
depend (pretty name >> write " :: ") $ do
fields' (write " -> ")
declTy t
verVar = do
pretty name
newline
indentedBlock $
depend (write ":: ") $ do
fields' $ do
newline
indented (-3) (write "-> ")
declTy t
instance Pretty Rhs where
prettyInternal =
rhs
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 -> do write "forall "
spaced (map pretty xs)
write ". "
case mctx of
Nothing -> pretty ihead
Just ctx -> do
mst <- fitsOnOneLine (do pretty ctx
write " => "
pretty ihead
write " where")
case mst of
Nothing -> withCtx mctx (pretty ihead)
Just {} -> do
pretty ctx
write " => "
pretty ihead
instance Pretty InstHead where
prettyInternal x =
case x of
-- Base cases
IHCon _ name -> pretty name
IHInfix _ typ' name ->
depend (pretty typ')
(do space
prettyInfixOp name)
-- Recursive application
IHApp _ ihead typ' ->
depend (pretty ihead)
(do space
pretty typ')
-- Wrapping in parens
IHParen _ h -> parens (pretty h)
instance Pretty DeclHead where
prettyInternal x =
case x of
DHead _ name -> prettyQuoteName name
DHParen _ h -> parens (pretty h)
DHInfix _ var name ->
do pretty var
space
prettyInfixName name
DHApp _ dhead var ->
depend (pretty dhead)
(do space
pretty var)
instance Pretty Overlap where
prettyInternal (Overlap _) = write "{-# OVERLAP #-}"
prettyInternal (Overlapping _) = write "{-# OVERLAPPING #-}"
prettyInternal (Overlaps _) = write "{-# OVERLAPS #-}"
prettyInternal (Overlappable _) = write "{-# OVERLAPPABLE #-}"
prettyInternal (NoOverlap _) = write "{-# NO_OVERLAP #-}"
prettyInternal (Incoherent _) = write "{-# INCOHERENT #-}"
instance Pretty Sign where
prettyInternal (Signless _) = return ()
prettyInternal (Negative _) = write "-"
instance Pretty CallConv where
prettyInternal = pretty'
instance Pretty Safety where
prettyInternal = pretty'
--------------------------------------------------------------------------------
-- * Unimplemented or incomplete printers
instance Pretty Module where
prettyInternal x =
case x of
Module _ mayModHead pragmas imps decls ->
do inter (do newline
newline)
(mapMaybe (\(isNull,r) ->
if isNull
then Nothing
else Just r)
[(null pragmas,inter newline (map pretty pragmas))
,(case mayModHead of
Nothing -> (True,return ())
Just modHead -> (False,pretty modHead))
,(null imps,formatImports imps)
,(null decls
,interOf newline
(map (\case
r@TypeSig{} -> (1,pretty r)
r@InlineSig{} -> (1, pretty r)
r -> (2,pretty r))
decls))])
newline
where interOf i ((c,p):ps) =
case ps of
[] -> p
_ ->
do p
replicateM_ c i
interOf i ps
interOf _ [] = return ()
XmlPage{} -> error "FIXME: No implementation for XmlPage."
XmlHybrid{} -> error "FIXME: No implementation for XmlHybrid."
-- | Format imports, preserving empty newlines between groups.
formatImports :: [ImportDecl NodeInfo] -> Printer ()
formatImports =
sequence_ .
intersperse (newline >> newline) .
map formatImportGroup . groupAdjacentBy atNextLine
where
atNextLine import1 import2 =
let end1 = srcSpanEndLine (srcInfoSpan (nodeInfoSpan (ann import1)))
start2 = srcSpanStartLine (srcInfoSpan (nodeInfoSpan (ann import2)))
in start2 - end1 <= 1
formatImportGroup imps = do
shouldSortImports <- gets $ configSortImports . psConfig
let imps1 =
if shouldSortImports
then sortImports imps
else imps
sequence_ . intersperse newline $ map formatImport imps1
moduleVisibleName idecl =
let ModuleName _ name = importModule idecl
in name
formatImport = pretty
sortImports imps = sortOn moduleVisibleName . map sortImportSpecsOnImport $ imps
sortImportSpecsOnImport imp = imp { importSpecs = fmap sortImportSpecs (importSpecs imp) }
sortImportSpecs (ImportSpecList l hiding specs) = ImportSpecList l hiding sortedSpecs
where
sortedSpecs = sortBy importSpecCompare . map sortCNames $ specs
sortCNames (IThingWith l2 name cNames) = IThingWith l2 name . sortBy cNameCompare $ cNames
sortCNames is = is
groupAdjacentBy :: (a -> a -> Bool) -> [a] -> [[a]]
groupAdjacentBy _ [] = []
groupAdjacentBy adj items = xs : groupAdjacentBy adj rest
where
(xs, rest) = spanAdjacentBy adj items
spanAdjacentBy :: (a -> a -> Bool) -> [a] -> ([a], [a])
spanAdjacentBy _ [] = ([], [])
spanAdjacentBy _ [x] = ([x], [])
spanAdjacentBy adj (x:xs@(y:_))
| adj x y =
let (xs', rest') = spanAdjacentBy adj xs
in (x : xs', rest')
| otherwise = ([x], xs)
importSpecCompare :: ImportSpec l -> ImportSpec l -> Ordering
importSpecCompare (IAbs _ _ (Ident _ s1)) (IAbs _ _ (Ident _ s2)) = compare s1 s2
importSpecCompare (IAbs _ _ (Ident _ _)) (IAbs _ _ (Symbol _ _)) = GT
importSpecCompare (IAbs _ _ (Ident _ s1)) (IThingAll _ (Ident _ s2)) = compare s1 s2
importSpecCompare (IAbs _ _ (Ident _ _)) (IThingAll _ (Symbol _ _)) = GT
importSpecCompare (IAbs _ _ (Ident _ s1)) (IThingWith _ (Ident _ s2) _) = compare s1 s2
importSpecCompare (IAbs _ _ (Ident _ _)) (IThingWith _ (Symbol _ _) _) = GT
importSpecCompare (IAbs _ _ (Symbol _ _)) (IAbs _ _ (Ident _ _)) = LT
importSpecCompare (IAbs _ _ (Symbol _ s1)) (IAbs _ _ (Symbol _ s2)) = compare s1 s2
importSpecCompare (IAbs _ _ (Symbol _ _)) (IThingAll _ (Ident _ _)) = LT
importSpecCompare (IAbs _ _ (Symbol _ s1)) (IThingAll _ (Symbol _ s2)) = compare s1 s2
importSpecCompare (IAbs _ _ (Symbol _ _)) (IThingWith _ (Ident _ _) _) = LT
importSpecCompare (IAbs _ _ (Symbol _ s1)) (IThingWith _ (Symbol _ s2) _) = compare s1 s2
importSpecCompare (IAbs _ _ _) (IVar _ _) = LT
importSpecCompare (IThingAll _ (Ident _ s1)) (IAbs _ _ (Ident _ s2)) = compare s1 s2
importSpecCompare (IThingAll _ (Ident _ _)) (IAbs _ _ (Symbol _ _)) = GT
importSpecCompare (IThingAll _ (Ident _ s1)) (IThingAll _ (Ident _ s2)) = compare s1 s2
importSpecCompare (IThingAll _ (Ident _ _)) (IThingAll _ (Symbol _ _)) = GT
importSpecCompare (IThingAll _ (Ident _ s1)) (IThingWith _ (Ident _ s2) _) = compare s1 s2
importSpecCompare (IThingAll _ (Ident _ _)) (IThingWith _ (Symbol _ _) _) = GT
importSpecCompare (IThingAll _ (Symbol _ _)) (IAbs _ _ (Ident _ _)) = LT
importSpecCompare (IThingAll _ (Symbol _ s1)) (IAbs _ _ (Symbol _ s2)) = compare s1 s2
importSpecCompare (IThingAll _ (Symbol _ _)) (IThingAll _ (Ident _ _)) = LT
importSpecCompare (IThingAll _ (Symbol _ s1)) (IThingAll _ (Symbol _ s2)) = compare s1 s2
importSpecCompare (IThingAll _ (Symbol _ _)) (IThingWith _ (Ident _ _) _) = LT
importSpecCompare (IThingAll _ (Symbol _ s1)) (IThingWith _ (Symbol _ s2) _) = compare s1 s2
importSpecCompare (IThingAll _ _) (IVar _ _) = LT
importSpecCompare (IThingWith _ (Ident _ s1) _) (IAbs _ _ (Ident _ s2)) = compare s1 s2
importSpecCompare (IThingWith _ (Ident _ _) _) (IAbs _ _ (Symbol _ _)) = GT
importSpecCompare (IThingWith _ (Ident _ s1) _) (IThingAll _ (Ident _ s2)) = compare s1 s2
importSpecCompare (IThingWith _ (Ident _ _) _) (IThingAll _ (Symbol _ _)) = GT
importSpecCompare (IThingWith _ (Ident _ s1) _) (IThingWith _ (Ident _ s2) _) = compare s1 s2
importSpecCompare (IThingWith _ (Ident _ _) _) (IThingWith _ (Symbol _ _) _) = GT
importSpecCompare (IThingWith _ (Symbol _ _) _) (IAbs _ _ (Ident _ _)) = LT
importSpecCompare (IThingWith _ (Symbol _ s1) _) (IAbs _ _ (Symbol _ s2)) = compare s1 s2
importSpecCompare (IThingWith _ (Symbol _ _) _) (IThingAll _ (Ident _ _)) = LT
importSpecCompare (IThingWith _ (Symbol _ s1) _) (IThingAll _ (Symbol _ s2)) = compare s1 s2
importSpecCompare (IThingWith _ (Symbol _ _) _) (IThingWith _ (Ident _ _) _) = LT
importSpecCompare (IThingWith _ (Symbol _ s1) _) (IThingWith _ (Symbol _ s2) _) = compare s1 s2
importSpecCompare (IThingWith _ _ _) (IVar _ _) = LT
importSpecCompare (IVar _ (Ident _ s1)) (IVar _ (Ident _ s2)) = compare s1 s2
importSpecCompare (IVar _ (Ident _ _)) (IVar _ (Symbol _ _)) = GT
importSpecCompare (IVar _ (Symbol _ _)) (IVar _ (Ident _ _)) = LT
importSpecCompare (IVar _ (Symbol _ s1)) (IVar _ (Symbol _ s2)) = compare s1 s2
importSpecCompare (IVar _ _) _ = GT
cNameCompare :: CName l -> CName l -> Ordering
cNameCompare (VarName _ (Ident _ s1)) (VarName _ (Ident _ s2)) = compare s1 s2
cNameCompare (VarName _ (Ident _ _)) (VarName _ (Symbol _ _)) = GT
cNameCompare (VarName _ (Ident _ s1)) (ConName _ (Ident _ s2)) = compare s1 s2
cNameCompare (VarName _ (Ident _ _)) (ConName _ (Symbol _ _)) = GT
cNameCompare (VarName _ (Symbol _ _)) (VarName _ (Ident _ _)) = LT
cNameCompare (VarName _ (Symbol _ s1)) (VarName _ (Symbol _ s2)) = compare s1 s2
cNameCompare (VarName _ (Symbol _ _)) (ConName _ (Ident _ _)) = LT
cNameCompare (VarName _ (Symbol _ s1)) (ConName _ (Symbol _ s2)) = compare s1 s2
cNameCompare (ConName _ (Ident _ s1)) (VarName _ (Ident _ s2)) = compare s1 s2
cNameCompare (ConName _ (Ident _ _)) (VarName _ (Symbol _ _)) = GT
cNameCompare (ConName _ (Ident _ s1)) (ConName _ (Ident _ s2)) = compare s1 s2
cNameCompare (ConName _ (Ident _ _)) (ConName _ (Symbol _ _)) = GT
cNameCompare (ConName _ (Symbol _ _)) (VarName _ (Ident _ _)) = LT
cNameCompare (ConName _ (Symbol _ s1)) (VarName _ (Symbol _ s2)) = compare s1 s2
cNameCompare (ConName _ (Symbol _ _)) (ConName _ (Ident _ _)) = LT
cNameCompare (ConName _ (Symbol _ s1)) (ConName _ (Symbol _ s2)) = compare s1 s2
instance Pretty Bracket where
prettyInternal x =
case x of
ExpBracket _ p ->
brackets
(depend
(write "|")
(do pretty p
write "|"))
PatBracket _ p ->
brackets
(depend
(write "p|")
(do pretty p
write "|"))
TypeBracket _ ty ->
brackets
(depend
(write "t|")
(do pretty ty
write "|"))
d@(DeclBracket _ _) -> pretty' d
instance Pretty IPBind where
prettyInternal x =
case x of
IPBind _ name expr -> do
pretty name
space
write "="
space
pretty expr
instance Pretty BooleanFormula where
prettyInternal (VarFormula _ i@(Ident _ _)) = pretty' i
prettyInternal (VarFormula _ (Symbol _ s)) = write "(" >> string s >> write ")"
prettyInternal (AndFormula _ fs) = do
maybeFormulas <- fitsOnOneLine $ inter (write ", ") $ map pretty fs
case maybeFormulas of
Nothing -> prefixedLined ", " (map pretty fs)
Just formulas -> put formulas
prettyInternal (OrFormula _ fs) = do
maybeFormulas <- fitsOnOneLine $ inter (write " | ") $ map pretty fs
case maybeFormulas of
Nothing -> prefixedLined "| " (map pretty fs)
Just formulas -> put formulas
prettyInternal (ParenFormula _ f) = parens $ pretty f
--------------------------------------------------------------------------------
-- * Fallback printers
instance Pretty DataOrNew where
prettyInternal = pretty'
instance Pretty FunDep where
prettyInternal = pretty'
instance Pretty Kind where
prettyInternal = pretty'
instance Pretty ResultSig where
prettyInternal (KindSig _ kind) = pretty kind
prettyInternal (TyVarSig _ tyVarBind) = pretty tyVarBind
instance Pretty Literal where
prettyInternal (String _ _ rep) = do
write "\""
string rep
write "\""
prettyInternal (Char _ _ rep) = do
write "'"
string rep
write "'"
prettyInternal (PrimString _ _ rep) = do
write "\""
string rep
write "\"#"
prettyInternal (PrimChar _ _ rep) = do
write "'"
string rep
write "'#"
-- We print the original notation (because HSE doesn't track Hex
-- vs binary vs decimal notation).
prettyInternal (Int _l _i originalString) =
string originalString
prettyInternal (Frac _l _r originalString) =
string originalString
prettyInternal x = pretty' x
instance Pretty Name where
prettyInternal x = case x of
Ident _ _ -> pretty' x -- Identifiers.
Symbol _ s -> string s -- Symbols
instance Pretty QName where
prettyInternal =
\case
Qual _ m n -> do
pretty m
write "."
pretty n
UnQual _ n -> pretty n
Special _ c -> pretty c
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 "(##)"
ExprHole _ -> write "_"
instance Pretty QOp where
prettyInternal = pretty'
instance Pretty TyVarBind where
prettyInternal = pretty'
instance Pretty ModuleHead where
prettyInternal (ModuleHead _ name mwarnings mexports) =
do write "module "
pretty name
maybe (return ()) pretty mwarnings
maybe (return ())
(\exports ->
do newline
indentSpaces <- getIndentSpaces
indented indentSpaces (pretty exports))
mexports
write " where"
instance Pretty ModulePragma where
prettyInternal = pretty'
instance Pretty ImportDecl where
prettyInternal (ImportDecl _ name qualified source safe mpkg mas mspec) = do
write "import"
when source $ write " {-# SOURCE #-}"
when safe $ write " safe"
when qualified $ write " qualified"
case mpkg of
Nothing -> return ()
Just pkg -> space >> write ("\"" ++ pkg ++ "\"")
space
pretty name
case mas of
Nothing -> return ()
Just asName -> do
space
write "as "
pretty asName
case mspec of
Nothing -> return ()
Just spec -> pretty spec
instance Pretty ModuleName where
prettyInternal (ModuleName _ name) =
write name
instance Pretty ImportSpecList where
prettyInternal (ImportSpecList _ hiding spec) = do
when hiding $ write " hiding"
let verVar = do
space
parens (commas (map pretty spec))
let horVar = do
newline
indentedBlock
(do depend (write "( ") (prefixedLined ", " (map pretty spec))
newline
write ")")
verVar `ifFitsOnOneLineOrElse` horVar
instance Pretty ImportSpec where
prettyInternal = pretty'
instance Pretty WarningText where
prettyInternal (DeprText _ s) =
write "{-# DEPRECATED " >> string s >> write " #-}"
prettyInternal (WarnText _ s) =
write "{-# WARNING " >> string s >> write " #-}"
instance Pretty ExportSpecList where
prettyInternal (ExportSpecList _ es) = do
depend (write "(")
(prefixedLined "," (map pretty es))
newline
write ")"
instance Pretty ExportSpec where
prettyInternal x = string " " >> pretty' x
-- Do statements need to handle infix expression indentation specially because
-- do x *
-- y
-- is two invalid statements, not one valid infix op.
stmt :: Stmt NodeInfo -> Printer ()
stmt (Qualifier _ e@(InfixApp _ a op b)) =
do col <- fmap (psColumn . snd)
(sandbox (write ""))
infixApp e a op b (Just col)
stmt (Generator _ p e) =
do indentSpaces <- getIndentSpaces
pretty p
indented indentSpaces
(dependOrNewline
(write " <-")
space
e
pretty)
stmt 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 _ es ->
depend (write "rec ")
(lined (map pretty es))
-- | Make the right hand side dependent if it fits on one line,
-- otherwise send it to the next line.
dependOrNewline
:: Printer ()
-> Printer ()
-> Exp NodeInfo
-> (Exp NodeInfo -> Printer ())
-> Printer ()
dependOrNewline left prefix right f =
do msg <- fitsOnOneLine renderDependent
case msg of
Nothing -> do left
newline
(f right)
Just st -> put st
where renderDependent = depend left (do prefix; f right)
-- | Handle do and case specially and also space out guards more.
rhs :: Rhs NodeInfo -> Printer ()
rhs (UnGuardedRhs _ (Do _ dos)) =
do inCase <- gets psInsideCase
write (if inCase then " -> " else " = ")
indentSpaces <- getIndentSpaces
let indentation | inCase = indentSpaces
| otherwise = max 2 indentSpaces
swingBy indentation
(write "do")
(lined (map pretty dos))
rhs (UnGuardedRhs _ e) = do
msg <-
fitsOnOneLine
(do write " "
rhsSeparator
write " "
pretty e)
case msg of
Nothing -> swing (write " " >> rhsSeparator) (pretty e)
Just st -> put st
rhs (GuardedRhss _ gas) =
do newline
n <- getIndentSpaces
indented n
(lined (map (\p ->
do write "|"
pretty p)
gas))
-- | Implement dangling right-hand-sides.
guardedRhs :: GuardedRhs NodeInfo -> Printer ()
-- | Handle do specially.
guardedRhs (GuardedRhs _ stmts (Do _ dos)) =
do indented 1
(do prefixedLined
","
(map (\p ->
do space
pretty p)
stmts))
inCase <- gets psInsideCase
write (if inCase then " -> " else " = ")
swing (write "do")
(lined (map pretty dos))
guardedRhs (GuardedRhs _ stmts e) = do
mst <- fitsOnOneLine printStmts
case mst of
Just st -> do
put st
mst' <-
fitsOnOneLine
(do write " "
rhsSeparator
write " "
pretty e)
case mst' of
Just st' -> put st'
Nothing -> swingIt
Nothing -> do
printStmts
swingIt
where
printStmts =
indented
1
(do prefixedLined
","
(map
(\p -> do
space
pretty p)
stmts))
swingIt = swing (write " " >> rhsSeparator) (pretty e)
match :: Match NodeInfo -> Printer ()
match (Match _ name pats rhs' mbinds) =
do depend (do case name of
Ident _ _ ->
pretty name
Symbol _ _ ->
do write "("
pretty name
write ")"
space)
(spaced (map pretty pats))
withCaseContext False (pretty rhs')
for_ mbinds bindingGroup
match (InfixMatch _ pat1 name pats rhs' mbinds) =
do depend (do pretty pat1
space
prettyInfixName name)
(do space
spaced (map pretty pats))
withCaseContext False (pretty rhs')
for_ mbinds bindingGroup
-- | Format contexts with spaces and commas between class constraints.
context :: Context NodeInfo -> Printer ()
context ctx =
case ctx of
CxSingle _ a -> pretty a
CxTuple _ as -> do
depend (write "( ") $ prefixedLined ", " (map pretty as)
newline
write ")"
CxEmpty _ -> parens (return ())
typ :: Type NodeInfo -> Printer ()
typ (TyTuple _ Boxed types) = do
let horVar = parens $ inter (write ", ") (map pretty types)
let verVar = parens $ prefixedLined "," (map (depend space . pretty) types)
horVar `ifFitsOnOneLineOrElse` verVar
typ (TyTuple _ Unboxed types) = do
let horVar = wrap "(# " " #)" $ inter (write ", ") (map pretty types)
let verVar = wrap "(#" " #)" $ prefixedLined "," (map (depend space . pretty) types)
horVar `ifFitsOnOneLineOrElse` verVar
typ (TyForall _ mbinds ctx ty) =
depend (case mbinds of
Nothing -> return ()
Just ts ->
do write "forall "
spaced (map pretty ts)
write ". ")
(do indentSpaces <- getIndentSpaces
withCtx ctx (indented indentSpaces (pretty ty)))
typ (TyFun _ a b) =
depend (do pretty a
write " -> ")
(pretty b)
typ (TyList _ t) = brackets (pretty t)
typ (TyParArray _ t) =
brackets (do write ":"
pretty t
write ":")
typ (TyApp _ f a) = spaced [pretty f, pretty a]
typ (TyVar _ n) = pretty n
typ (TyCon _ p) =
case p of
Qual _ _ name ->
case name of
Ident _ _ -> pretty p
Symbol _ _ -> parens (pretty p)
UnQual _ name ->
case name of
Ident _ _ -> pretty p
Symbol _ _ -> parens (pretty p)
Special _ con ->
case con of
FunCon _ -> parens (pretty p)
_ -> pretty p
typ (TyParen _ e) = parens (pretty e)
typ (TyInfix _ a promotedop b) = do
-- Apply special rules to line-break operators.
let isLineBreak' op =
case op of
PromotedName _ op' -> isLineBreak op'
UnpromotedName _ op' -> isLineBreak op'
prettyInfixOp' op =
case op of
PromotedName _ op' -> write "'" >> prettyInfixOp op'
UnpromotedName _ op' -> prettyInfixOp op'
linebreak <- isLineBreak' promotedop
if linebreak
then do pretty a
newline
prettyInfixOp' promotedop
space
pretty b
else do pretty a
space
prettyInfixOp' promotedop
space
pretty b
typ (TyKind _ ty k) =
parens (do pretty ty
write " :: "
pretty k)
typ (TyBang _ bangty unpackty right) =
do pretty unpackty
pretty bangty
pretty right
typ (TyEquals _ left right) =
do pretty left
write " ~ "
pretty right
typ (TyPromoted _ (PromotedList _ _ ts)) =
do write "'["
unless (null ts) $ write " "
commas (map pretty ts)
write "]"
typ (TyPromoted _ (PromotedTuple _ ts)) =
do write "'("
unless (null ts) $ write " "
commas (map pretty ts)
write ")"
typ (TyPromoted _ (PromotedCon _ _ tname)) =
do write "'"
pretty tname
typ (TyPromoted _ (PromotedString _ _ raw)) = do
do write "\""
string raw
write "\""
typ ty@TyPromoted{} = pretty' ty
typ (TySplice _ splice) = pretty splice
typ (TyWildCard _ name) =
case name of
Nothing -> write "_"
Just n ->
do write "_"
pretty n
typ (TyQuasiQuote _ n s) =
brackets (depend (do string n
write "|")
(do string s
write "|"))
typ (TyUnboxedSum{}) = error "FIXME: No implementation for TyUnboxedSum."
prettyTopName :: Name NodeInfo -> Printer ()
prettyTopName x@Ident{} = pretty x
prettyTopName x@Symbol{} = parens $ pretty x
-- | Specially format records. Indent where clauses only 2 spaces.
decl' :: Decl NodeInfo -> Printer ()
-- | Pretty print type signatures like
--
-- foo :: (Show x, Read x)
-- => (Foo -> Bar)
-- -> Maybe Int
-- -> (Char -> X -> Y)
-- -> IO ()
--
decl' (TypeSig _ names ty') = do
mst <- fitsOnOneLine (depend (do commas (map prettyTopName names)
write " :: ")
(declTy ty'))
case mst of
Nothing -> do
commas (map prettyTopName names)
indentSpaces <- getIndentSpaces
if allNamesLength >= indentSpaces
then do write " ::"
newline
indented indentSpaces (depend (write " ") (declTy ty'))
else (depend (write " :: ") (declTy ty'))
Just st -> put st
where
nameLength (Ident _ s) = length s
nameLength (Symbol _ s) = length s + 2
allNamesLength = fromIntegral $ sum (map nameLength names) + 2 * (length names - 1)
decl' (PatBind _ pat rhs' mbinds) =
withCaseContext False $
do pretty pat
pretty rhs'
for_ mbinds bindingGroup
-- | Handle records specially for a prettier display (see guide).
decl' (DataDecl _ dataornew ctx dhead [con] mderivs)
| isRecord con =
do depend (do pretty dataornew
space)
(withCtx ctx
(do pretty dhead
singleCons con))
forM_ mderivs $ \deriv -> space >> pretty deriv
where singleCons x =
depend (write " =")
((depend space . qualConDecl) x)
decl' e = decl e
declTy :: Type NodeInfo -> Printer ()
declTy dty =
case dty of
TyForall _ mbinds mctx ty ->
case mbinds of
Nothing -> do
case mctx of
Nothing -> prettyTy False ty
Just ctx -> do
mst <- fitsOnOneLine (do pretty ctx
depend (write " => ") (prettyTy False ty))
case mst of
Nothing -> do
pretty ctx
newline
indented (-3) (depend (write "=> ") (prettyTy True ty))
Just st -> put st
Just ts -> do
write "forall "
spaced (map pretty ts)
write "."
case mctx of
Nothing -> do
mst <- fitsOnOneLine (space >> prettyTy False ty)
case mst of
Nothing -> do
newline
prettyTy True ty
Just st -> put st
Just ctx -> do
mst <- fitsOnOneLine (space >> pretty ctx)
case mst of
Nothing -> do
newline
pretty ctx
newline
indented (-3) (depend (write "=> ") (prettyTy True ty))
Just st -> do
put st
newline
indented (-3) (depend (write "=> ") (prettyTy True ty))
_ -> prettyTy False dty
where
collapseFaps (TyFun _ arg result) = arg : collapseFaps result
collapseFaps e = [e]
prettyTy breakLine ty = do
if breakLine
then
case collapseFaps ty of
[] -> pretty ty
tys -> prefixedLined "-> " (map pretty tys)
else do
mst <- fitsOnOneLine (pretty ty)
case mst of
Nothing ->
case collapseFaps ty of
[] -> pretty ty
tys -> prefixedLined "-> " (map pretty tys)
Just st -> put st
-- | Use special record display, used by 'dataDecl' in a record scenario.
qualConDecl :: QualConDecl NodeInfo -> Printer ()
qualConDecl (QualConDecl _ tyvars ctx d) =
depend (unless (null (fromMaybe [] tyvars))
(do write "forall "
spaced (map pretty (fromMaybe [] tyvars))
write ". "))
(withCtx ctx (recDecl d))
-- | Fields are preceded with a space.
conDecl :: ConDecl NodeInfo -> Printer ()
conDecl (RecDecl _ name fields) =
depend (do pretty name
write " ")
(do depend (write "{")
(prefixedLined ","
(map (depend space . pretty) fields))
write " }")
conDecl (ConDecl _ name bangty) =
depend (do prettyQuoteName name
unless (null bangty) space)
(lined (map pretty bangty))
conDecl (InfixConDecl _ a f b) =
inter space [pretty a, pretty f, pretty b]
-- | Record decls are formatted like: Foo
-- { bar :: X
-- }
recDecl :: ConDecl NodeInfo -> Printer ()
recDecl (RecDecl _ name fields) =
do pretty name
indentSpaces <- getIndentSpaces
newline
column indentSpaces
(do depend (write "{")
(prefixedLined ","
(map (depend space . pretty) fields))
newline
write "}")
recDecl r = prettyInternal r
recUpdateExpr :: Printer () -> [FieldUpdate NodeInfo] -> Printer ()
recUpdateExpr expWriter updates = do
ifFitsOnOneLineOrElse hor $ do
expWriter
newline
indentedBlock (updatesHor `ifFitsOnOneLineOrElse` updatesVer)
where
hor = do
expWriter
space
updatesHor
updatesHor = braces $ commas $ map pretty updates
updatesVer = do
depend (write "{ ") $ prefixedLined ", " $ map pretty updates
newline
write "}"
--------------------------------------------------------------------------------
-- Predicates
-- | Is the decl a record?
isRecord :: QualConDecl t -> Bool
isRecord (QualConDecl _ _ _ RecDecl{}) = True
isRecord _ = False
-- | If the given operator is an element of line breaks in configuration.
isLineBreak :: QName NodeInfo -> Printer Bool
isLineBreak (UnQual _ (Symbol _ s)) = do
breaks <- gets (configLineBreaks . psConfig)
return $ s `elem` breaks
isLineBreak _ = return False
-- | Does printing the given thing overflow column limit? (e.g. 80)
fitsOnOneLine :: Printer a -> Printer (Maybe PrintState)
fitsOnOneLine p =
do st <- get
put st { psHardLimit = True}
ok <- fmap (const True) p <|> return False
st' <- get
put st
return (if ok
then Just st' { psHardLimit = psHardLimit st }
else Nothing)
-- | If first printer fits, use it, else use the second one.
ifFitsOnOneLineOrElse :: Printer a -> Printer a -> Printer a
ifFitsOnOneLineOrElse a b = do
stOrig <- get
put stOrig{psHardLimit = True}
res <- fmap Just a <|> return Nothing
case res of
Just r -> do
modify $ \st -> st{psHardLimit = psHardLimit stOrig}
return r
Nothing -> do
put stOrig
b
bindingGroup :: Binds NodeInfo -> Printer ()
bindingGroup binds =
do newline
indented 2
(do write "where"
newline
indented 2 (pretty binds))
infixApp :: Exp NodeInfo
-> Exp NodeInfo
-> QOp NodeInfo
-> Exp NodeInfo
-> Maybe Int64
-> Printer ()
infixApp e a op b indent =
hor `ifFitsOnOneLineOrElse` ver
where
hor =
spaced
[ case link of
OpChainExp e' -> pretty e'
OpChainLink qop -> pretty qop
| link <- flattenOpChain e
]
ver = do
prettyWithIndent a
beforeRhs <- case a of
Do _ _ -> do
indentSpaces <- getIndentSpaces
column (fromMaybe 0 indent + indentSpaces + 3) (newline >> pretty op) -- 3 = "do "
return space
_ -> space >> pretty op >> return newline
case b of
Lambda{} -> space >> pretty b
LCase{} -> space >> pretty b
Do _ stmts -> swing (write " do") $ lined (map pretty stmts)
_ -> do
beforeRhs
case indent of
Nothing -> do
col <- fmap (psColumn . snd)
(sandbox (write ""))
-- force indent for top-level template haskell expressions, #473.
if col == 0
then do indentSpaces <- getIndentSpaces
column indentSpaces (prettyWithIndent b)
else prettyWithIndent b
Just col -> do
indentSpaces <- getIndentSpaces
column (col + indentSpaces) (prettyWithIndent b)
prettyWithIndent e' =
case e' of
InfixApp _ a' op' b' -> infixApp e' a' op' b' indent
_ -> pretty e'
-- | A link in a chain of operator applications.
data OpChainLink l
= OpChainExp (Exp l)
| OpChainLink (QOp l)
deriving (Show)
-- | Flatten a tree of InfixApp expressions into a chain of operator
-- links.
flattenOpChain :: Exp l -> [OpChainLink l]
flattenOpChain (InfixApp _ left op right) =
flattenOpChain left <>
[OpChainLink op] <>
flattenOpChain right
flattenOpChain e = [OpChainExp e]