{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Floskell.Pretty where
import Control.Applicative ( (<|>) )
import Control.Monad
( forM_, guard, replicateM_, unless, void, when )
import Control.Monad.State.Strict ( get, gets, modify )
import Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL
import Data.List ( groupBy, sortBy, sortOn )
import Data.Maybe ( catMaybes, fromMaybe )
import qualified Floskell.Buffer as Buffer
import Floskell.Config
import Floskell.Printers
import Floskell.Types
import Language.Haskell.Exts.Comments ( Comment(..) )
import qualified Language.Haskell.Exts.Pretty as HSE
import Language.Haskell.Exts.SrcLoc
( SrcSpan(..), noSrcSpan, srcInfoSpan )
import Language.Haskell.Exts.Syntax
run :: (a -> a -> Bool) -> [a] -> ([a], [a])
run _ [] = ([], [])
run _ [ x ] = ([ x ], [])
run eq (x : y : xs)
| eq x y = let (ys, zs) = run eq (y : xs) in (x : ys, zs)
| otherwise = ([ x ], y : xs)
runs :: (a -> a -> Bool) -> [a] -> [[a]]
runs _ [] = []
runs eq xs = let (ys, zs) = run eq xs in ys : runs eq zs
stopImportModule :: TabStop
stopImportModule = TabStop "import-module"
stopImportSpec :: TabStop
stopImportSpec = TabStop "import-spec"
stopRecordField :: TabStop
stopRecordField = TabStop "record"
stopRhs :: TabStop
stopRhs = TabStop "rhs"
flattenApp :: Annotated ast
=> (ast NodeInfo -> Maybe (ast NodeInfo, ast NodeInfo))
-> ast NodeInfo
-> [ast NodeInfo]
flattenApp fn = go . amap (\info -> info { nodeInfoComments = [] })
where
go x = case fn x of
Just (lhs, rhs) -> let lhs' = go $ copyComments Before x lhs
rhs' = go $ copyComments After x rhs
in
lhs' ++ rhs'
Nothing -> [ x ]
flattenInfix
:: (Annotated ast1, Annotated ast2)
=> (ast1 NodeInfo -> Maybe (ast1 NodeInfo, ast2 NodeInfo, ast1 NodeInfo))
-> ast1 NodeInfo
-> (ast1 NodeInfo, [(ast2 NodeInfo, ast1 NodeInfo)])
flattenInfix fn = go . amap (\info -> info { nodeInfoComments = [] })
where
go x = case fn x of
Just (lhs, op, rhs) ->
let (lhs', ops) = go $ copyComments Before x lhs
(lhs'', ops') = go $ copyComments After x rhs
in
(lhs', ops ++ (op, lhs'') : ops')
Nothing -> (x, [])
type PrettyPrinter f = f NodeInfo -> Printer ()
prettyHSE :: HSE.Pretty (ast NodeInfo) => PrettyPrinter ast
prettyHSE ast = string $ HSE.prettyPrint ast
class Pretty ast where
prettyPrint :: PrettyPrinter ast
default prettyPrint :: HSE.Pretty (ast NodeInfo) => PrettyPrinter ast
prettyPrint = prettyHSE
pretty :: (Annotated ast, Pretty ast) => PrettyPrinter ast
pretty ast = do
printComments Before ast
prettyPrint ast
printComments After ast
prettyOnside :: (Annotated ast, Pretty ast) => PrettyPrinter ast
prettyOnside ast = do
eol <- gets psEolComment
when eol newline
nl <- gets psNewline
if nl
then do
printComments Before ast
onside $ prettyPrint ast
printComments After ast
else onside $ pretty ast
noNodeInfo :: NodeInfo
noNodeInfo = NodeInfo noSrcSpan []
compareAST :: (Functor ast, Ord (ast ()))
=> ast NodeInfo
-> ast NodeInfo
-> Ordering
compareAST a b = void a `compare` void b
filterComments :: Annotated a
=> (Maybe Location -> Bool)
-> a NodeInfo
-> [ComInfo]
filterComments f = filter (f . comInfoLocation) . nodeInfoComments . ann
copyComments :: (Annotated ast1, Annotated ast2)
=> Location
-> ast1 NodeInfo
-> ast2 NodeInfo
-> ast2 NodeInfo
copyComments loc from to = amap updateComments to
where
updateComments info =
info { nodeInfoComments = oldComments ++ newComments }
oldComments = filterComments (/= Just loc) to
newComments = filterComments (== Just loc) from
printComment :: Maybe SrcSpan -> Comment -> Printer ()
printComment mayNodespan (Comment inline cspan str) = do
case mayNodespan of
Just nodespan -> do
let neededSpaces = srcSpanStartColumn cspan
- max 1 (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 })
printComments :: Annotated ast => Location -> ast NodeInfo -> Printer ()
printComments loc' ast = do
let correctLocation comment = comInfoLocation comment == Just loc'
commentsWithLocation = filter correctLocation (nodeInfoComments info)
comments = map comInfoComment commentsWithLocation
unless (null comments) $ do
nl <- gets psNewline
onside' <- gets psOnside
when nl $ modify $ \s -> s { psOnside = 0 }
when (loc' == Before && not nl) newline
forM_ comments $ printComment (Just $ srcInfoSpan $ nodeInfoSpan info)
eol <- gets psEolComment
when (loc' == Before && eol && onside' > 0) newline
when nl $ modify $ \s -> s { psOnside = onside' }
where
info = ann ast
opName :: QOp a -> ByteString
opName op = case op of
(QVarOp _ qname) -> opName' qname
(QConOp _ qname) -> opName' qname
opName' :: QName a -> ByteString
opName' (Qual _ _ (Ident _ _)) = "``"
opName' (Qual _ _ (Symbol _ _)) = ""
opName' (UnQual _ (Ident _ _)) = "``"
opName' (UnQual _ (Symbol _ str)) = BS8.pack str
opName' (Special _ (FunCon _)) = "->"
opName' (Special _ (Cons _)) = ":"
opName' (Special _ _) = ""
lineDelta :: Annotated ast => ast NodeInfo -> ast NodeInfo -> Int
lineDelta prev next = nextLine - prevLine
where
prevLine = maximum (prevNodeLine : prevCommentLines)
nextLine = minimum (nextNodeLine : nextCommentLines)
prevNodeLine = srcSpanEndLine $ annSrcSpan prev
nextNodeLine = srcSpanStartLine $ annSrcSpan next
annSrcSpan = srcInfoSpan . nodeInfoSpan . ann
prevCommentLines = map (srcSpanEndLine . commentSrcSpan) $
filterComments (== Just After) prev
nextCommentLines = map (srcSpanStartLine . commentSrcSpan) $
filterComments (== Just Before) next
commentSrcSpan = (\(Comment _ sp _) -> sp) . comInfoComment
linedFn :: Annotated ast
=> (ast NodeInfo -> Printer ())
-> [ast NodeInfo]
-> Printer ()
linedFn fn xs = do
preserveP <- getOption cfgOptionPreserveVerticalSpace
if preserveP
then case xs of
x : xs' -> do
cut $ fn x
forM_ (zip xs xs') $ \(prev, cur) -> do
replicateM_ (min 2 (max 1 $ lineDelta prev cur)) newline
cut $ fn cur
[] -> return ()
else inter newline $ map (cut . fn) xs
lined :: (Annotated ast, Pretty ast) => [ast NodeInfo] -> Printer ()
lined = linedFn pretty
linedOnside :: (Annotated ast, Pretty ast) => [ast NodeInfo] -> Printer ()
linedOnside = linedFn prettyOnside
listVinternal :: (Annotated ast, Pretty ast)
=> LayoutContext
-> ByteString
-> [ast NodeInfo]
-> Printer ()
listVinternal ctx sep xs = aligned $ do
ws <- getConfig (cfgOpWs ctx sep . cfgOp)
nl <- gets psNewline
col <- getNextColumn
let correction = if wsLinebreak After ws || length xs < 2
then 0
else BS.length sep + if wsSpace After ws then 1 else 0
extraIndent = if nl then correction else 0
itemCol = col + fromIntegral extraIndent
sepCol = itemCol - fromIntegral correction
case xs of
[] -> newline
(x : xs') -> column itemCol $ do
cut $ do
printCommentsSimple Before x
cut . onside $ prettyPrint x
printCommentsSimple After x
forM_ xs' $ \x' -> do
printComments Before x'
column sepCol $ operatorV ctx sep
cut . onside $ prettyPrint x'
printComments After x'
where
printCommentsSimple loc ast =
let comments = map comInfoComment $ filterComments (== Just loc) ast
in
forM_ comments $
printComment (Just . srcInfoSpan . nodeInfoSpan $ ann ast)
listH :: (Annotated ast, Pretty ast)
=> LayoutContext
-> ByteString
-> ByteString
-> ByteString
-> [ast NodeInfo]
-> Printer ()
listH _ open close _ [] = do
write open
write close
listH ctx open close sep xs =
groupH ctx open close . inter (operatorH ctx sep) $ map pretty xs
listV :: (Annotated ast, Pretty ast)
=> LayoutContext
-> ByteString
-> ByteString
-> ByteString
-> [ast NodeInfo]
-> Printer ()
listV ctx open close sep xs = groupV ctx open close $ do
ws <- getConfig (cfgOpWs ctx sep . cfgOp)
ws' <- getConfig (cfgGroupWs ctx open . cfgGroup)
unless (wsLinebreak Before ws' || wsSpace After ws' || wsLinebreak After ws
|| not (wsSpace After ws))
space
listVinternal ctx sep xs
list :: (Annotated ast, Pretty ast)
=> LayoutContext
-> ByteString
-> ByteString
-> ByteString
-> [ast NodeInfo]
-> Printer ()
list ctx open close sep xs = oneline hor <|> ver
where
hor = listH ctx open close sep xs
ver = listV ctx open close sep xs
listH' :: (Annotated ast, Pretty ast)
=> LayoutContext
-> ByteString
-> [ast NodeInfo]
-> Printer ()
listH' ctx sep = inter (operatorH ctx sep) . map pretty
listV' :: (Annotated ast, Pretty ast)
=> LayoutContext
-> ByteString
-> [ast NodeInfo]
-> Printer ()
listV' = listVinternal
list' :: (Annotated ast, Pretty ast)
=> LayoutContext
-> ByteString
-> [ast NodeInfo]
-> Printer ()
list' ctx sep xs = oneline hor <|> ver
where
hor = listH' ctx sep xs
ver = listV' ctx sep xs
listAutoWrap :: (Annotated ast, Pretty ast)
=> LayoutContext
-> ByteString
-> ByteString
-> ByteString
-> [ast NodeInfo]
-> Printer ()
listAutoWrap _ open close _ [] = do
write open
write close
listAutoWrap ctx open close sep (x : xs) =
aligned . groupH ctx open close . aligned $ do
ws <- getConfig (cfgOpWs ctx sep . cfgOp)
let correction = if wsLinebreak After ws
then 0
else BS.length sep + if wsSpace After ws then 1 else 0
col <- getNextColumn
pretty x
forM_ xs $ \x' -> do
printComments Before x'
cut $ do
column (col - fromIntegral correction) $ operator ctx sep
prettyPrint x'
printComments After x'
measure :: Printer a -> Printer (Maybe Int)
measure p = do
s <- get
let s' = s { psBuffer = Buffer.empty, psEolComment = False }
return $ case execPrinter (oneline p) s' of
Nothing -> Nothing
Just (_, s'') -> Just . fromIntegral . (\x -> x - psIndentLevel s)
. BL.length . Buffer.toLazyByteString $ psBuffer s''
measureDecl :: Decl NodeInfo -> Printer (Maybe [Int])
measureDecl (PatBind _ pat _ Nothing) = fmap (: []) <$> measure (pretty pat)
measureDecl (FunBind _ matches) = sequence <$> traverse measureMatch matches
where
measureMatch (Match _ name pats _ Nothing) = measure $ do
pretty name
space
inter space $ map pretty pats
measureMatch (InfixMatch _ pat name pats _ Nothing) = measure $ do
pretty pat
pretty $ VarOp noNodeInfo name
inter space $ map pretty pats
measureMatch _ = return Nothing
measureDecl _ = return Nothing
measureClassDecl :: ClassDecl NodeInfo -> Printer (Maybe [Int])
measureClassDecl (ClsDecl _ decl) = measureDecl decl
measureClassDecl _ = return Nothing
measureInstDecl :: InstDecl NodeInfo -> Printer (Maybe [Int])
measureInstDecl (InsDecl _ decl) = measureDecl decl
measureInstDecl _ = return Nothing
measureAlt :: Alt NodeInfo -> Printer (Maybe [Int])
measureAlt (Alt _ pat _ Nothing) = fmap (: []) <$> measure (pretty pat)
measureAlt _ = return Nothing
withComputedTabStop :: TabStop
-> (AlignConfig -> Bool)
-> (a -> Printer (Maybe [Int]))
-> [a]
-> Printer b
-> Printer b
withComputedTabStop name predicate fn xs p = do
enabled <- getConfig (predicate . cfgAlign)
(limAbs, limRel) <- getConfig (cfgAlignLimits . cfgAlign)
mtabss <- sequence <$> traverse fn xs
let tab = do
tabss <- mtabss
let tabs = concat tabss
maxtab = maximum tabs
mintab = minimum tabs
delta = maxtab - mintab
diff = delta * 100 `div` maxtab
guard enabled
guard $ delta <= limAbs || diff <= limRel
return maxtab
withTabStops [ (name, tab) ] p
moduleName :: ModuleName a -> String
moduleName (ModuleName _ s) = s
nameLength :: Name a -> Int
nameLength (Ident _ i) = length i
nameLength (Symbol _ s) = 2 + length s
qnameLength :: QName a -> Int
qnameLength (Qual _ mname name) = length (moduleName mname) + nameLength name
+ 1
qnameLength (UnQual _ name) = nameLength name
qnameLength (Special _ con) = case con of
UnitCon _ -> 2
ListCon _ -> 2
FunCon _ -> 2
TupleCon _ boxed n -> 2 + n + case boxed of
Boxed -> 2
Unboxed -> 0
Cons _ -> 1
UnboxedSingleCon _ -> 5
ExprHole _ -> 1
prettyPragmas :: [ModulePragma NodeInfo] -> Printer ()
prettyPragmas ps = do
splitP <- getOption cfgOptionSplitLanguagePragmas
sortP <- getOption cfgOptionSortPragmas
let ps' = if splitP then concatMap splitPragma ps else ps
let ps'' = if sortP then sortBy compareAST ps' else ps'
inter blankline . map lined $ groupBy sameType ps''
where
splitPragma (LanguagePragma anno langs) =
map (LanguagePragma anno . (: [])) langs
splitPragma p = [ p ]
sameType LanguagePragma{} LanguagePragma{} = True
sameType OptionsPragma{} OptionsPragma{} = True
sameType AnnModulePragma{} AnnModulePragma{} = True
sameType _ _ = False
prettyImports :: [ImportDecl NodeInfo] -> Printer ()
prettyImports is = do
sortP <- getOption cfgOptionSortImports
alignModuleP <- getConfig (cfgAlignImportModule . cfgAlign)
alignSpecP <- getConfig (cfgAlignImportSpec . cfgAlign)
let maxNameLength = maximum $ map (length . moduleName . importModule) is
alignModule = if alignModuleP then Just 16 else Nothing
alignSpec = if alignSpecP
then Just (fromMaybe 0 alignModule + 1 + maxNameLength)
else Nothing
withTabStops [ (stopImportModule, alignModule)
, (stopImportSpec, alignSpec)
] $ if sortP
then inter blankline . map lined . groupBy samePrefix $
sortOn (moduleName . importModule) is
else lined is
where
samePrefix left right = prefix left == prefix right
prefix = takeWhile (/= '.') . moduleName . importModule
skipBlank :: Annotated ast
=> (ast NodeInfo -> ast NodeInfo -> Bool)
-> ast NodeInfo
-> ast NodeInfo
-> Bool
skipBlank skip a b = skip a b && null (comments After a)
&& null (comments Before b)
where
comments loc = filterComments (== Just loc)
skipBlankAfterDecl :: Decl a -> Bool
skipBlankAfterDecl a = case a of
TypeSig{} -> True
DeprPragmaDecl{} -> True
WarnPragmaDecl{} -> True
AnnPragma{} -> True
MinimalPragma{} -> True
InlineSig{} -> True
InlineConlikeSig{} -> True
SpecSig{} -> True
SpecInlineSig{} -> True
InstSig{} -> True
PatSynSig{} -> True
_ -> False
skipBlankDecl :: Decl NodeInfo -> Decl NodeInfo -> Bool
skipBlankDecl = skipBlank $ \a _ -> skipBlankAfterDecl a
skipBlankClassDecl :: ClassDecl NodeInfo -> ClassDecl NodeInfo -> Bool
skipBlankClassDecl = skipBlank $ \a _ -> case a of
(ClsDecl _ decl) -> skipBlankAfterDecl decl
ClsTyDef{} -> True
ClsDefSig{} -> True
_ -> False
skipBlankInstDecl :: InstDecl NodeInfo -> InstDecl NodeInfo -> Bool
skipBlankInstDecl = skipBlank $ \a _ -> case a of
(InsDecl _ decl) -> skipBlankAfterDecl decl
_ -> False
prettyDecls :: (Annotated ast, Pretty ast)
=> (ast NodeInfo -> ast NodeInfo -> Bool)
-> [ast NodeInfo]
-> Printer ()
prettyDecls fn = inter blankline . map lined . runs fn
prettySimpleDecl :: (Annotated ast1, Pretty ast1, Annotated ast2, Pretty ast2)
=> ast1 NodeInfo
-> ByteString
-> ast2 NodeInfo
-> Printer ()
prettySimpleDecl lhs op rhs = withLayout cfgLayoutDeclaration flex vertical
where
flex = do
pretty lhs
operator Declaration op
pretty rhs
vertical = do
pretty lhs
operatorV Declaration op
pretty rhs
prettyConDecls :: (Annotated ast, Pretty ast) => [ast NodeInfo] -> Printer ()
prettyConDecls condecls = withLayout cfgLayoutConDecls flex vertical
where
flex = listH' Declaration "|" condecls
vertical = listV' Declaration "|" condecls
prettyForall :: (Annotated ast, Pretty ast) => [ast NodeInfo] -> Printer ()
prettyForall vars = do
write "forall "
inter space $ map pretty vars
operator Type "."
prettyTypesig :: (Annotated ast, Pretty ast)
=> LayoutContext
-> [ast NodeInfo]
-> Type NodeInfo
-> Printer ()
prettyTypesig ctx names ty = withLayout cfgLayoutTypesig flex vertical
where
flex = do
inter comma $ map pretty names
atTabStop stopRecordField
operator ctx "::"
pretty ty
vertical = do
inter comma $ map pretty names
atTabStop stopRecordField
alignOnOperator ctx "::" $ pretty' ty
pretty' (TyForall _ mtyvarbinds mcontext ty') = do
forM_ mtyvarbinds $ \tyvarbinds -> do
write "forall "
inter space $ map pretty tyvarbinds
withOperatorFormattingV Type "." (write "." >> space) id
forM_ mcontext $ \context -> do
case context of
(CxSingle _ asst) -> pretty asst
(CxTuple _ assts) -> list Type "(" ")" "," assts
(CxEmpty _) -> write "()"
operatorV Type "=>"
pretty' ty'
pretty' (TyFun _ ty' ty'') = do
pretty ty'
operatorV Type "->"
pretty' ty''
pretty' ty' = pretty ty'
prettyApp :: (Annotated ast1, Annotated ast2, Pretty ast1, Pretty ast2)
=> ast1 NodeInfo
-> [ast2 NodeInfo]
-> Printer ()
prettyApp fn args = withLayout cfgLayoutApp flex vertical
where
flex = do
pretty fn
forM_ args $ \arg -> cut $ do
spaceOrNewline
pretty arg
vertical = do
pretty fn
withIndent cfgIndentApp $ linedOnside args
prettyInfixApp :: (Annotated ast, Pretty ast, HSE.Pretty (op NodeInfo))
=> (op NodeInfo -> ByteString)
-> LayoutContext
-> (ast NodeInfo, [(op NodeInfo, ast NodeInfo)])
-> Printer ()
prettyInfixApp nameFn ctx (lhs, args) =
withLayout cfgLayoutInfixApp flex vertical
where
flex = do
pretty lhs
forM_ args $ \(op, arg) -> cut $ do
withOperatorFormatting ctx (nameFn op) (prettyHSE op) id
pretty arg
vertical = do
pretty lhs
forM_ args $ \(op, arg) -> do
withOperatorFormattingV ctx (nameFn op) (prettyHSE op) id
pretty arg
prettyRecord :: (Annotated ast1, Pretty ast1, Annotated ast2, Pretty ast2)
=> (ast2 NodeInfo -> Printer (Maybe Int))
-> LayoutContext
-> ast1 NodeInfo
-> [ast2 NodeInfo]
-> Printer ()
prettyRecord len ctx name fields = withLayout cfgLayoutRecord flex vertical
where
flex = do
withOperatorFormattingH ctx "record" (pretty name) id
groupH ctx "{" "}" $ inter (operatorH ctx ",") $
map prettyOnside fields
vertical = do
withOperatorFormatting ctx "record" (pretty name) id
groupV ctx "{" "}" $ withComputedTabStop stopRecordField
cfgAlignRecordFields
(fmap (fmap pure) . len)
fields $
listVinternal ctx "," fields
prettyRecordFields :: (Annotated ast, Pretty ast)
=> (ast NodeInfo -> Printer (Maybe Int))
-> LayoutContext
-> [ast NodeInfo]
-> Printer ()
prettyRecordFields len ctx fields = withLayout cfgLayoutRecord flex vertical
where
flex = groupH ctx "{" "}" $ inter (operatorH ctx ",") $
map prettyOnside fields
vertical = groupV ctx "{" "}" $
withComputedTabStop stopRecordField
cfgAlignRecordFields
(fmap (fmap pure) . len)
fields $ listVinternal ctx "," fields
prettyPragma :: ByteString -> Printer () -> Printer ()
prettyPragma name = prettyPragma' name . Just
prettyPragma' :: ByteString -> Maybe (Printer ()) -> Printer ()
prettyPragma' name mp = do
write "{-# "
write name
mayM_ mp $ withPrefix space aligned
write " #-}"
instance Pretty Module where
prettyPrint (Module _ mhead pragmas imports decls) = inter blankline $
catMaybes [ ifNotEmpty prettyPragmas pragmas
, pretty <$> mhead
, ifNotEmpty prettyImports imports
, ifNotEmpty (prettyDecls skipBlankDecl) decls
]
where
ifNotEmpty f xs = if null xs then Nothing else Just (f xs)
prettyPrint ast@XmlPage{} = prettyHSE ast
prettyPrint ast@XmlHybrid{} = prettyHSE ast
instance Pretty ModuleHead where
prettyPrint (ModuleHead _ name mwarning mexports) = do
depend "module" $ do
pretty name
mayM_ mwarning $ withPrefix spaceOrNewline pretty
mayM_ mexports pretty
write " where"
instance Pretty WarningText where
prettyPrint (DeprText _ s) = write "{-# DEPRECATED " >> string (show s)
>> write " #-}"
prettyPrint (WarnText _ s) = write "{-# WARNING " >> string (show s)
>> write " #-}"
instance Pretty ExportSpecList where
prettyPrint (ExportSpecList _ exports) =
withLayout cfgLayoutExportSpecList flex vertical
where
flex = do
space
listAutoWrap Other "(" ")" "," exports
vertical = withIndent cfgIndentExportSpecList $
listV Other "(" ")" "," exports
instance Pretty ExportSpec
instance Pretty ImportDecl where
prettyPrint ImportDecl{..} = do
inter space . map write $
filter (not . BS.null)
[ "import"
, if importSrc then "{-# SOURCE #-}" else ""
, if importSafe then "safe" else ""
, if importQualified then "qualified" else ""
]
atTabStop stopImportModule
space
string $ moduleName importModule
mayM_ importAs $ \name -> do
atTabStop stopImportSpec
write " as "
pretty name
mayM_ importSpecs pretty
instance Pretty ImportSpecList where
prettyPrint (ImportSpecList _ hiding specs) = do
sortP <- getOption cfgOptionSortImportLists
let specs' = if sortP then sortOn HSE.prettyPrint specs else specs
atTabStop stopImportSpec
withLayout cfgLayoutImportSpecList (flex specs') (vertical specs')
where
flex imports = do
when hiding $ write " hiding"
space
listAutoWrap Other "(" ")" "," imports
vertical imports = withIndent cfgIndentImportSpecList $ do
when hiding $ write "hiding "
listAutoWrap Other "(" ")" "," imports
instance Pretty ImportSpec
instance Pretty Assoc
instance Pretty Decl where
prettyPrint (TypeDecl _ declhead ty) =
depend "type" $ prettySimpleDecl declhead "=" ty
prettyPrint (TypeFamDecl _ declhead mresultsig minjectivityinfo) =
depend "type family" $ do
pretty declhead
mayM_ mresultsig pretty
mayM_ minjectivityinfo pretty
prettyPrint (ClosedTypeFamDecl _
declhead
mresultsig
minjectivityinfo
typeeqns) = depend "type family" $ do
pretty declhead
mayM_ mresultsig pretty
mayM_ minjectivityinfo pretty
write " where"
newline
linedOnside typeeqns
prettyPrint (DataDecl _ dataornew mcontext declhead qualcondecls derivings) = do
depend' (pretty dataornew) $ do
mapM_ pretty mcontext
pretty declhead
unless (null qualcondecls) $
withLayout cfgLayoutDeclaration flex vertical
mapM_ pretty derivings
where
flex = do
operator Declaration "="
prettyConDecls qualcondecls
vertical = do
operatorV Declaration "="
prettyConDecls qualcondecls
prettyPrint (GDataDecl _
dataornew
mcontext
declhead
mkind
gadtdecls
derivings) = do
depend' (pretty dataornew) $ do
mapM_ pretty mcontext
pretty declhead
mayM_ mkind $ \kind -> do
operator Declaration "::"
pretty kind
write " where"
newline
linedOnside gadtdecls
mapM_ pretty derivings
prettyPrint (DataFamDecl _ mcontext declhead mresultsig) =
depend "data family" $ do
mapM_ pretty mcontext
pretty declhead
mapM_ pretty mresultsig
prettyPrint (TypeInsDecl _ ty ty') =
depend "type instance" $ prettySimpleDecl ty "=" ty'
prettyPrint (DataInsDecl _ dataornew ty qualcondecls derivings) = do
depend' (pretty dataornew >> write " instance") $ do
pretty ty
withLayout cfgLayoutDeclaration flex vertical
mapM_ pretty derivings
where
flex = do
operator Declaration "="
prettyConDecls qualcondecls
vertical = do
operatorV Declaration "="
prettyConDecls qualcondecls
prettyPrint (GDataInsDecl _ dataornew ty mkind gadtdecls derivings) = do
depend' (pretty dataornew >> write " instance") $ do
pretty ty
mayM_ mkind $ \kind -> do
operator Declaration "::"
pretty kind
write " where"
newline
linedOnside gadtdecls
mapM_ pretty derivings
prettyPrint (ClassDecl _ mcontext declhead fundeps mclassdecls) = do
depend "class" $ do
mapM_ pretty mcontext
pretty declhead
unless (null fundeps) $ do
operator Declaration "|"
list' Declaration "," fundeps
mayM_ mclassdecls $ \decls -> do
write " where"
withIndent cfgIndentClass $ withComputedTabStop stopRhs
cfgAlignClass
measureClassDecl
decls $
prettyDecls skipBlankClassDecl decls
prettyPrint (InstDecl _ moverlap instrule minstdecls) = do
depend "instance" $ do
mapM_ pretty moverlap
pretty instrule
mayM_ minstdecls $ \decls -> do
write " where"
withIndent cfgIndentClass $
withComputedTabStop stopRhs cfgAlignClass measureInstDecl decls $
prettyDecls skipBlankInstDecl decls
prettyPrint (DerivDecl _ mderivstrategy moverlap instrule) =
depend "deriving" $ do
mayM_ mderivstrategy $ withPostfix space pretty
write "instance "
mayM_ moverlap $ withPostfix space pretty
pretty instrule
prettyPrint (InfixDecl _ assoc mint ops) = onside $ do
pretty assoc
mayM_ mint $ withPrefix space (int . fromIntegral)
space
inter comma $ map prettyHSE ops
prettyPrint (DefaultDecl _ types) = do
write "default "
listAutoWrap Other "(" ")" "," types
prettyPrint (SpliceDecl _ expr) = pretty expr
prettyPrint (TypeSig _ names ty) =
onside $ prettyTypesig Declaration names ty
prettyPrint (PatSynSig _ names mtyvarbinds mcontext mcontext' ty) =
depend "pattern" $ do
inter comma $ map pretty names
operator Declaration "::"
mapM_ prettyForall mtyvarbinds
mayM_ mcontext pretty
mayM_ mcontext' pretty
pretty ty
prettyPrint (FunBind _ matches) = linedOnside matches
prettyPrint (PatBind _ pat rhs mbinds) = do
onside $ do
pretty pat
atTabStop stopRhs
pretty rhs
mapM_ pretty mbinds
prettyPrint (PatSyn _ pat pat' patternsyndirection) = do
depend "pattern" $ prettySimpleDecl pat sep pat'
case patternsyndirection of
ExplicitBidirectional _ decls -> pretty (BDecls noNodeInfo decls)
_ -> return ()
where
sep = case patternsyndirection of
ImplicitBidirectional -> "="
ExplicitBidirectional _ _ -> "<-"
Unidirectional -> "<-"
prettyPrint (ForImp _ callconv msafety mstring name ty) =
depend "foreign import" $ do
pretty callconv
mayM_ msafety $ withPrefix space pretty
mayM_ mstring $ withPrefix space (string . show)
space
prettyTypesig Declaration [ name ] ty
prettyPrint (ForExp _ callconv mstring name ty) =
depend "foreign export" $ do
pretty callconv
mayM_ mstring $ withPrefix space (string . show)
space
prettyTypesig Declaration [ name ] ty
prettyPrint (RulePragmaDecl _ rules) =
if null rules
then prettyPragma' "RULES" Nothing
else prettyPragma "RULES" $ mapM_ pretty rules
prettyPrint (DeprPragmaDecl _ deprecations) =
if null deprecations
then prettyPragma' "DEPRECATED" Nothing
else prettyPragma "DEPRECATED" $ forM_ deprecations $
\(names, str) -> do
unless (null names) $ do
inter comma $ map pretty names
space
string (show str)
prettyPrint (WarnPragmaDecl _ warnings) =
if null warnings
then prettyPragma' "WARNING" Nothing
else prettyPragma "WARNING" $ forM_ warnings $ \(names, str) -> do
unless (null names) $ do
inter comma $ map pretty names
space
string (show str)
prettyPrint (InlineSig _ inline mactivation qname) = prettyPragma name $ do
mayM_ mactivation $ withPostfix space pretty
pretty qname
where
name = if inline then "INLINE" else "NOINLINE"
prettyPrint (InlineConlikeSig _ mactivation qname) =
prettyPragma "INLINE CONLIKE" $ do
mayM_ mactivation $ withPostfix space pretty
pretty qname
prettyPrint (SpecSig _ mactivation qname types) =
prettyPragma "SPECIALISE" $ do
mayM_ mactivation $ withPostfix space pretty
pretty qname
operator Declaration "::"
inter comma $ map pretty types
prettyPrint (SpecInlineSig _ inline mactivation qname types) =
prettyPragma name $ do
mayM_ mactivation $ withPostfix space pretty
pretty qname
operator Declaration "::"
inter comma $ map pretty types
where
name = if inline then "SPECIALISE INLINE" else "SPECIALISE NOINLINE"
prettyPrint (InstSig _ instrule) =
prettyPragma "SPECIALISE instance" $ pretty instrule
prettyPrint (AnnPragma _ annotation) =
prettyPragma "ANN" $ pretty annotation
prettyPrint (MinimalPragma _ mbooleanformula) =
prettyPragma "MINIMAL" $ mapM_ pretty mbooleanformula
prettyPrint decl = prettyHSE decl
instance Pretty DeclHead where
prettyPrint (DHead _ name) = pretty name
prettyPrint (DHInfix _ tyvarbind name) = do
pretty tyvarbind
pretty $ VarOp noNodeInfo name
prettyPrint (DHParen _ declhead) = parens $ pretty declhead
prettyPrint (DHApp _ declhead tyvarbind) = depend' (pretty declhead) $
pretty tyvarbind
instance Pretty InstRule where
prettyPrint (IRule _ mtyvarbinds mcontext insthead) = do
mapM_ prettyForall mtyvarbinds
mapM_ pretty mcontext
pretty insthead
prettyPrint (IParen _ instrule) = parens $ pretty instrule
instance Pretty InstHead where
prettyPrint (IHCon _ qname) = pretty qname
prettyPrint (IHInfix _ ty qname) = do
pretty ty
space
pretty qname
prettyPrint (IHParen _ insthead) = parens $ pretty insthead
prettyPrint (IHApp _ insthead ty) = depend' (pretty insthead) $ pretty ty
instance Pretty Binds where
prettyPrint (BDecls _ decls) = withIndentBy cfgIndentWhere $ do
write "where"
withIndent cfgIndentWhereBinds $
withComputedTabStop stopRhs cfgAlignWhere measureDecl decls $
prettyDecls skipBlankDecl decls
prettyPrint (IPBinds _ ipbinds) = withIndentBy cfgIndentWhere $ do
write "where"
withIndent cfgIndentWhereBinds $ linedOnside ipbinds
instance Pretty IPBind where
prettyPrint (IPBind _ ipname expr) = prettySimpleDecl ipname "=" expr
instance Pretty InjectivityInfo where
prettyPrint (InjectivityInfo _ name names) = do
operator Declaration "|"
pretty name
operator Declaration "->"
inter space $ map pretty names
instance Pretty ResultSig where
prettyPrint (KindSig _ kind) =
withLayout cfgLayoutDeclaration flex vertical
where
flex = do
operator Declaration "::"
pretty kind
vertical = do
operatorV Declaration "::"
pretty kind
prettyPrint (TyVarSig _ tyvarbind) =
withLayout cfgLayoutDeclaration flex vertical
where
flex = do
operator Declaration "="
pretty tyvarbind
vertical = do
operatorV Declaration "="
pretty tyvarbind
instance Pretty ClassDecl where
prettyPrint (ClsDecl _ decl) = pretty decl
prettyPrint (ClsDataFam _ mcontext declhead mresultsig) = depend "data" $ do
mapM_ pretty mcontext
pretty declhead
mayM_ mresultsig pretty
prettyPrint (ClsTyFam _ declhead mresultsig minjectivityinfo) =
depend "type" $ do
pretty declhead
mayM_ mresultsig pretty
mapM_ pretty minjectivityinfo
prettyPrint (ClsTyDef _ typeeqn) = depend "type" $ pretty typeeqn
prettyPrint (ClsDefSig _ name ty) =
depend "default" $ prettyTypesig Declaration [ name ] ty
instance Pretty InstDecl where
prettyPrint (InsDecl _ decl) = pretty decl
prettyPrint (InsType _ ty ty') =
depend "type" $ prettySimpleDecl ty "=" ty'
prettyPrint (InsData _ dataornew ty qualcondecls derivings) =
depend' (pretty dataornew) $ do
pretty ty
unless (null qualcondecls) $
withLayout cfgLayoutDeclaration flex vertical
mapM_ pretty derivings
where
flex = do
operator Declaration "="
prettyConDecls qualcondecls
vertical = do
operatorV Declaration "="
prettyConDecls qualcondecls
prettyPrint (InsGData _ dataornew ty mkind gadtdecls derivings) = do
depend' (pretty dataornew) $ do
pretty ty
mayM_ mkind $ \kind -> do
operator Declaration "::"
pretty kind
write " where"
newline
lined gadtdecls
mapM_ pretty derivings
instance Pretty Deriving where
prettyPrint (Deriving _ mderivstrategy instrules) =
withIndentBy cfgIndentDeriving $ do
write "deriving "
mayM_ mderivstrategy $ withPostfix space pretty
case instrules of
[ i@IRule{} ] -> pretty i
[ IParen _ i ] -> listAutoWrap Other "(" ")" "," [ i ]
_ -> listAutoWrap Other "(" ")" "," instrules
instance Pretty ConDecl where
prettyPrint (ConDecl _ name types) = do
pretty name
unless (null types) $ do
space
oneline hor <|> ver
where
hor = inter space $ map pretty types
ver = aligned $ linedOnside types
prettyPrint (InfixConDecl _ ty name ty') = do
pretty ty
pretty $ ConOp noNodeInfo name
pretty ty'
prettyPrint (RecDecl _ name fielddecls) =
prettyRecord len Declaration name fielddecls
where
len (FieldDecl _ names _) = measure $ inter comma $ map pretty names
instance Pretty FieldDecl where
prettyPrint (FieldDecl _ names ty) = prettyTypesig Declaration names ty
instance Pretty QualConDecl where
prettyPrint (QualConDecl _ mtyvarbinds mcontext condecl) = do
mapM_ prettyForall mtyvarbinds
mapM_ pretty mcontext
pretty condecl
instance Pretty GadtDecl where
prettyPrint (GadtDecl _ name mfielddecls ty) = do
pretty name
operator Declaration "::"
mayM_ mfielddecls $ \decls -> do
prettyRecordFields len Declaration decls
operator Type "->"
pretty ty
where
len (FieldDecl _ names _) = measure $ inter comma $ map pretty names
instance Pretty Match where
prettyPrint (Match _ name pats rhs mbinds) = do
onside $ do
pretty name
unless (null pats) $ do
space
inter space $ map pretty pats
atTabStop stopRhs
pretty rhs
mapM_ pretty mbinds
prettyPrint (InfixMatch _ pat name pats rhs mbinds) = do
onside $ do
pretty pat
pretty $ VarOp noNodeInfo name
inter space $ map pretty pats
atTabStop stopRhs
pretty rhs
mapM_ pretty mbinds
instance Pretty Rhs where
prettyPrint (UnGuardedRhs _ expr) =
cut $ withLayout cfgLayoutDeclaration flex vertical
where
flex = do
operator Declaration "="
pretty expr
vertical = do
operatorV Declaration "="
pretty expr
prettyPrint (GuardedRhss _ guardedrhss) =
withIndent cfgIndentMultiIf $ linedOnside guardedrhss
instance Pretty GuardedRhs where
prettyPrint (GuardedRhs _ stmts expr) =
withLayout cfgLayoutDeclaration flex vertical
where
flex = do
operatorSectionR Pattern "|" $ write "|"
inter comma $ map pretty stmts
operator Declaration "="
pretty expr
vertical = do
operatorSectionR Pattern "|" $ write "|"
inter comma $ map pretty stmts
operatorV Declaration "="
pretty expr
instance Pretty Context where
prettyPrint (CxSingle _ asst) = do
pretty asst
operator Type "=>"
prettyPrint (CxTuple _ assts) = do
list Type "(" ")" "," assts
operator Type "=>"
prettyPrint (CxEmpty _) = do
write "()"
operator Type "=>"
instance Pretty FunDep where
prettyPrint (FunDep _ names names') = do
inter space $ map pretty names
operator Declaration "->"
inter space $ map pretty names'
instance Pretty Asst where
prettyPrint (ClassA _ qname types) = do
pretty qname
space
inter space $ map pretty types
prettyPrint (AppA _ name types) = do
pretty name
space
inter space $ map pretty types
prettyPrint (InfixA _ ty qname ty') = do
pretty ty
pretty $ QVarOp noNodeInfo qname
pretty ty'
prettyPrint (IParam _ ipname ty) = prettyTypesig Declaration [ ipname ] ty
prettyPrint (EqualP _ ty ty') = do
pretty ty
operator Type "~"
pretty ty'
prettyPrint (ParenA _ asst) = parens $ pretty asst
prettyPrint (WildCardA _ mname) = do
write "_"
mapM_ pretty mname
instance Pretty Type where
prettyPrint (TyForall _ mtyvarbinds mcontext ty) = do
mapM_ prettyForall mtyvarbinds
mapM_ pretty mcontext
pretty ty
prettyPrint (TyFun _ ty ty') = do
pretty ty
operator Type "->"
pretty ty'
prettyPrint (TyTuple _ boxed tys) = case boxed of
Unboxed -> list Type "(#" "#)" "," tys
Boxed -> list Type "(" ")" "," tys
prettyPrint (TyUnboxedSum _ tys) = list Type "(#" "#)" "|" tys
prettyPrint (TyList _ ty) = group Type "[" "]" $ pretty ty
prettyPrint (TyParArray _ ty) = group Type "[:" ":]" $ pretty ty
prettyPrint (TyApp _ ty ty') = do
pretty ty
space
pretty ty'
prettyPrint (TyVar _ name) = pretty name
prettyPrint (TyCon _ qname) = pretty qname
prettyPrint (TyParen _ ty) = parens $ pretty ty
prettyPrint (TyInfix _ ty op ty') = do
pretty ty
withOperatorFormatting Type opname (prettyHSE op) id
pretty ty'
where
opname = opName' $ case op of
PromotedName _ qname -> qname
UnpromotedName _ qname -> qname
prettyPrint (TyKind _ ty kind) = do
pretty ty
operator Type "::"
pretty kind
prettyPrint t@(TyPromoted _ _promoted) = prettyHSE t
prettyPrint (TyEquals _ ty ty') = do
pretty ty
operator Type "~"
pretty ty'
prettyPrint (TySplice _ splice) = pretty splice
prettyPrint (TyBang _ bangtype unpackedness ty) = do
pretty unpackedness
pretty bangtype
pretty ty
prettyPrint t@(TyWildCard _ _mname) = prettyHSE t
prettyPrint (TyQuasiQuote _ str str') = do
write "["
string str
write "|"
string str'
write "|]"
instance Pretty Kind where
prettyPrint (KindStar _) = write "*"
prettyPrint (KindFn _ kind kind') = do
pretty kind
operator Type "->"
pretty kind'
prettyPrint (KindParen _ kind) = parens $ pretty kind
prettyPrint (KindVar _ qname) = pretty qname
prettyPrint (KindApp _ kind kind') = do
pretty kind
space
pretty kind'
prettyPrint (KindTuple _ kinds) = list Type "'(" ")" "," kinds
prettyPrint (KindList _ kind) = group Type "'[" "]" $ pretty kind
instance Pretty TyVarBind where
prettyPrint (KindedVar _ name kind) = parens $ do
pretty name
operator Type "::"
pretty kind
prettyPrint (UnkindedVar _ name) = pretty name
instance Pretty TypeEqn where
prettyPrint (TypeEqn _ ty ty') = do
pretty ty
operator Type "="
pretty ty'
instance Pretty Exp where
prettyPrint (Var _ qname) = pretty qname
prettyPrint (OverloadedLabel _ str) = do
write "#"
string str
prettyPrint (IPVar _ ipname) = pretty ipname
prettyPrint (Con _ qname) = pretty qname
prettyPrint (Lit _ literal) = pretty literal
prettyPrint e@(InfixApp _ _ qop _) =
prettyInfixApp opName Expression $ flattenInfix flattenInfixApp e
where
flattenInfixApp (InfixApp _ lhs qop' rhs) =
if compareAST qop qop' == EQ
then Just (lhs, qop', rhs)
else Nothing
flattenInfixApp _ = Nothing
prettyPrint e@App{} = case flattenApp flatten e of
fn : args -> prettyApp fn args
[] -> error "impossible"
where
flatten (App _ fn arg) = Just (fn, arg)
flatten _ = Nothing
prettyPrint (NegApp _ expr) = do
write "-"
pretty expr
prettyPrint (Lambda _ pats expr) = do
write "\\"
maybeSpace
inter space $ map pretty pats
operator Expression "->"
pretty expr
where
maybeSpace = case pats of
PIrrPat{} : _ -> space
PBangPat{} : _ -> space
_ -> return ()
prettyPrint (Let _ binds expr) = withLayout cfgLayoutLet flex vertical
where
flex = do
write "let "
prettyOnside (CompactBinds binds)
spaceOrNewline
write "in "
prettyOnside expr
vertical = withIndentFlat cfgIndentLet "let" $ do
withIndent cfgIndentLetBinds $ pretty (CompactBinds binds)
newline
write "in"
withIndent cfgIndentLetIn $ pretty expr
prettyPrint (If _ expr expr' expr'') = withLayout cfgLayoutIf flex vertical
where
flex = do
write "if "
prettyOnside expr
spaceOrNewline
write "then "
prettyOnside expr'
spaceOrNewline
write "else "
prettyOnside expr''
vertical = withIndentFlat cfgIndentIf "if " $ do
prettyOnside expr
newline
write "then "
prettyOnside expr'
newline
write "else "
prettyOnside expr''
prettyPrint (MultiIf _ guardedrhss) = do
write "if"
withIndent cfgIndentMultiIf . linedOnside $ map GuardedAlt guardedrhss
prettyPrint (Case _ expr alts) = do
write "case "
pretty expr
write " of"
if null alts
then write " { }"
else withIndent cfgIndentCase $
withComputedTabStop stopRhs cfgAlignCase measureAlt alts $
lined alts
prettyPrint (Do _ stmts) = do
write "do"
withIndent cfgIndentDo $ linedOnside stmts
prettyPrint (MDo _ stmts) = do
write "mdo"
withIndent cfgIndentDo $ linedOnside stmts
prettyPrint (Tuple _ boxed exprs) = case boxed of
Boxed -> list Expression "(" ")" "," exprs
Unboxed -> list Expression "(#" "#)" "," exprs
prettyPrint (UnboxedSum _ before after expr) = group Expression "(#" "#)"
. inter space $ replicate before (write "|") ++ [ pretty expr ]
++ replicate after (write "|")
prettyPrint (TupleSection _ boxed mexprs) = case boxed of
Boxed -> list Expression "(" ")" "," $ map MayAst mexprs
Unboxed -> list Expression "(#" "#)" "," $ map MayAst mexprs
prettyPrint (List _ exprs) = list Expression "[" "]" "," exprs
prettyPrint (ParArray _ exprs) = list Expression "[:" ":]" "," exprs
prettyPrint (Paren _ expr) = parens $ pretty expr
prettyPrint (LeftSection _ expr qop) = parens $ do
pretty expr
operatorSectionL Expression (opName qop) $ prettyHSE qop
prettyPrint (RightSection _ qop expr) = parens $ do
operatorSectionR Expression (opName qop) $ prettyHSE qop
pretty expr
prettyPrint (RecConstr _ qname fieldupdates) =
prettyRecord len Expression qname fieldupdates
where
len (FieldUpdate _ n _) = measure $ pretty n
len (FieldPun _ n) = measure $ pretty n
len (FieldWildcard _) = measure $ write ".."
prettyPrint (RecUpdate _ expr fieldupdates) =
prettyRecord len Expression expr fieldupdates
where
len (FieldUpdate _ n _) = measure $ pretty n
len (FieldPun _ n) = measure $ pretty n
len (FieldWildcard _) = measure $ write ".."
prettyPrint (EnumFrom _ expr) = group Expression "[" "]" $ do
pretty expr
operatorSectionL Expression ".." $ write ".."
prettyPrint (EnumFromTo _ expr expr') = group Expression "[" "]" $ do
pretty expr
operator Expression ".."
pretty expr'
prettyPrint (EnumFromThen _ expr expr') = group Expression "[" "]" $ do
pretty expr
comma
pretty expr'
operatorSectionL Expression ".." $ write ".."
prettyPrint (EnumFromThenTo _ expr expr' expr'') =
group Expression "[" "]" $ do
pretty expr
comma
pretty expr'
operator Expression ".."
pretty expr''
prettyPrint (ParArrayFromTo _ expr expr') = group Expression "[:" ":]" $ do
pretty expr
operator Expression ".."
pretty expr'
prettyPrint (ParArrayFromThenTo _ expr expr' expr'') =
group Expression "[:" ":]" $ do
pretty expr
comma
pretty expr'
operator Expression ".."
pretty expr''
prettyPrint (ListComp _ expr qualstmts) =
withLayout cfgLayoutListComp flex vertical
where
flex = group Expression "[" "]" $ do
prettyOnside expr
operator Expression "|"
list' Expression "," qualstmts
vertical = groupV Expression "[" "]" $ do
prettyOnside expr
operatorV Expression "|"
listV' Expression "," qualstmts
prettyPrint (ParComp _ expr qualstmtss) =
withLayout cfgLayoutListComp flex vertical
where
flex = group Expression "[" "]" $ do
prettyOnside expr
forM_ qualstmtss $ \qualstmts -> cut $ do
operator Expression "|"
list' Expression "," qualstmts
vertical = groupV Expression "[" "]" $ do
prettyOnside expr
forM_ qualstmtss $ \qualstmts -> cut $ do
operatorV Expression "|"
listV' Expression "," qualstmts
prettyPrint (ParArrayComp _ expr qualstmtss) =
withLayout cfgLayoutListComp flex vertical
where
flex = group Expression "[:" ":]" $ do
prettyOnside expr
forM_ qualstmtss $ \qualstmts -> cut $ do
operator Expression "|"
list' Expression "," qualstmts
vertical = groupV Expression "[:" ":]" $ do
prettyOnside expr
forM_ qualstmtss $ \qualstmts -> cut $ do
operatorV Expression "|"
listV' Expression "," qualstmts
prettyPrint (ExpTypeSig _ expr typ) = prettyTypesig Expression [ expr ] typ
prettyPrint (VarQuote _ qname) = do
write "'"
pretty qname
prettyPrint (TypQuote _ qname) = do
write "''"
pretty qname
prettyPrint (BracketExp _ bracket) = pretty bracket
prettyPrint (SpliceExp _ splice) = pretty splice
prettyPrint (QuasiQuote _ str str') = do
write "["
string str
write "|"
string str'
write "|]"
prettyPrint (TypeApp _ typ) = do
write "@"
pretty typ
prettyPrint (XTag _ xname xattrs mexpr exprs) = do
write "<"
pretty xname
forM_ xattrs $ withPrefix space pretty
mayM_ mexpr $ withPrefix space pretty
write ">"
mapM_ pretty exprs
write "</"
pretty xname
write ">"
prettyPrint (XETag _ xname xattrs mexpr) = do
write "<"
pretty xname
forM_ xattrs $ withPrefix space pretty
mayM_ mexpr $ withPrefix space pretty
write "/>"
prettyPrint (XPcdata _ str) = string str
prettyPrint (XExpTag _ expr) = do
write "<% "
pretty expr
write " %>"
prettyPrint (XChildTag _ exprs) = do
write "<%>"
inter space $ map pretty exprs
write "</%>"
prettyPrint (CorePragma _ str expr) = do
prettyPragma "CORE" . string $ show str
space
pretty expr
prettyPrint (SCCPragma _ str expr) = do
prettyPragma "SCC" . string $ show str
space
pretty expr
prettyPrint (GenPragma _ str (a, b) (c, d) expr) = do
prettyPragma "GENERATED" $
inter space
[ string $ show str
, int $ fromIntegral a
, write ":"
, int $ fromIntegral b
, write "-"
, int $ fromIntegral c
, write ":"
, int $ fromIntegral d
]
space
pretty expr
prettyPrint (Proc _ pat expr) = do
write "proc "
pretty pat
operator Expression "->"
pretty expr
prettyPrint (LeftArrApp _ expr expr') = do
pretty expr
operator Expression "-<"
pretty expr'
prettyPrint (RightArrApp _ expr expr') = do
pretty expr
operator Expression ">-"
pretty expr'
prettyPrint (LeftArrHighApp _ expr expr') = do
pretty expr
operator Expression "-<<"
pretty expr'
prettyPrint (RightArrHighApp _ expr expr') = do
pretty expr
operator Expression ">>-"
pretty expr'
prettyPrint (LCase _ alts) = do
write "\\case"
if null alts
then write " { }"
else withIndent cfgIndentCase $
withComputedTabStop stopRhs cfgAlignCase measureAlt alts $
lined alts
instance Pretty Alt where
prettyPrint (Alt _ pat rhs mbinds) = do
onside $ do
pretty pat
atTabStop stopRhs
pretty $ GuardedAlts rhs
mapM_ pretty mbinds
instance Pretty XAttr where
prettyPrint (XAttr _ xname expr) = do
pretty xname
operator Expression "="
pretty expr
instance Pretty Pat where
prettyPrint (PVar _ name) = pretty name
prettyPrint (PLit _ sign literal) = do
case sign of
Signless _ -> return ()
Negative _ -> write "-"
pretty literal
prettyPrint (PNPlusK _ name integer) = do
pretty name
operator Pattern "+"
int integer
prettyPrint p@(PInfixApp _ _ qname _) =
prettyInfixApp opName Pattern $ flattenInfix flattenPInfixApp p
where
flattenPInfixApp (PInfixApp _ lhs qname' rhs) =
if compareAST qname qname' == EQ
then Just (lhs, QConOp noNodeInfo qname', rhs)
else Nothing
flattenPInfixApp _ = Nothing
prettyPrint (PApp _ qname pats) = prettyApp qname pats
prettyPrint (PTuple _ boxed pats) = case boxed of
Boxed -> list Pattern "(" ")" "," pats
Unboxed -> list Pattern "(#" "#)" "," pats
prettyPrint (PUnboxedSum _ before after pat) = group Pattern "(#" "#)"
. inter space $ replicate before (write "|") ++ [ pretty pat ]
++ replicate after (write "|")
prettyPrint (PList _ pats) = list Pattern "[" "]" "," pats
prettyPrint (PParen _ pat) = parens $ pretty pat
prettyPrint (PRec _ qname patfields) = do
withOperatorFormatting Pattern "record" (pretty qname) id
list Pattern "{" "}" "," patfields
prettyPrint (PAsPat _ name pat) = do
pretty name
operator Pattern "@"
pretty pat
prettyPrint (PWildCard _) = write "_"
prettyPrint (PIrrPat _ pat) = do
write "~"
pretty pat
prettyPrint (PatTypeSig _ pat ty) = prettyTypesig Pattern [ pat ] ty
prettyPrint (PViewPat _ expr pat) = do
pretty expr
operator Pattern "->"
pretty pat
prettyPrint (PRPat _ rpats) = list Pattern "[" "]" "," rpats
prettyPrint (PXTag _ xname pxattrs mpat pats) = do
write "<"
pretty xname
forM_ pxattrs $ withPrefix space pretty
mayM_ mpat $ withPrefix space pretty
write ">"
mapM_ pretty pats
write "<"
pretty xname
write ">"
prettyPrint (PXETag _ xname pxattrs mpat) = do
write "<"
pretty xname
forM_ pxattrs $ withPrefix space pretty
mayM_ mpat $ withPrefix space pretty
write "/>"
prettyPrint (PXPcdata _ str) = string str
prettyPrint (PXPatTag _ pat) = do
write "<%"
pretty pat
write "%>"
prettyPrint (PXRPats _ rpats) = do
write "<["
inter space $ map pretty rpats
write "%>"
prettyPrint (PSplice _ splice) = pretty splice
prettyPrint (PQuasiQuote _ str str') = do
write "[$"
string str
write "|"
string str'
write "|]"
prettyPrint (PBangPat _ pat) = do
write "!"
pretty pat
instance Pretty PatField where
prettyPrint (PFieldPat _ qname pat) = do
pretty qname
operator Pattern "="
pretty pat
prettyPrint (PFieldPun _ qname) = pretty qname
prettyPrint (PFieldWildcard _) = write ".."
instance Pretty PXAttr where
prettyPrint (PXAttr _ xname pat) = do
pretty xname
operator Pattern "="
pretty pat
instance Pretty Literal where
prettyPrint (Char _ _ str) = do
write "'"
string str
write "'"
prettyPrint (String _ _ str) = do
write "\""
string str
write "\""
prettyPrint (Int _ _ str) = string str
prettyPrint (Frac _ _ str) = string str
prettyPrint (PrimInt _ _ str) = do
string str
write "#"
prettyPrint (PrimWord _ _ str) = do
string str
write "##"
prettyPrint (PrimFloat _ _ str) = do
string str
write "#"
prettyPrint (PrimDouble _ _ str) = do
string str
write "##"
prettyPrint (PrimChar _ _ str) = do
write "'"
string str
write "'#"
prettyPrint (PrimString _ _ str) = do
write "\""
string str
write "\"#"
instance Pretty QualStmt where
prettyPrint (QualStmt _ stmt) = pretty stmt
prettyPrint (ThenTrans _ expr) = do
write "then "
pretty expr
prettyPrint (ThenBy _ expr expr') = do
write "then "
pretty expr
write " by "
pretty expr'
prettyPrint (GroupBy _ expr) = do
write "then group by "
pretty expr
prettyPrint (GroupUsing _ expr) = do
write "then group using "
pretty expr
prettyPrint (GroupByUsing _ expr expr') = do
write "then group by "
pretty expr
write " using "
pretty expr'
instance Pretty Stmt where
prettyPrint (Generator _ pat expr) = do
pretty pat
operator Expression "<-"
pretty expr
prettyPrint (Qualifier _ expr@If{}) = do
cfg <- getConfig (cfgIndentIf . cfgIndent)
case cfg of
Align -> do
write ""
indented $ pretty expr
_ -> pretty expr
prettyPrint (Qualifier _ expr) = pretty expr
prettyPrint (LetStmt _ binds) = do
write "let "
pretty $ CompactBinds binds
prettyPrint (RecStmt _ stmts) = do
write "rec "
aligned $ linedOnside stmts
instance Pretty FieldUpdate where
prettyPrint (FieldUpdate _ qname expr) = do
pretty qname
atTabStop stopRecordField
operator Expression "="
pretty expr
prettyPrint (FieldPun _ qname) = pretty qname
prettyPrint (FieldWildcard _) = write ".."
instance Pretty QOp where
prettyPrint qop =
withOperatorFormatting Expression (opName qop) (prettyHSE qop) id
instance Pretty Op where
prettyPrint (VarOp l name) = prettyPrint (QVarOp l (UnQual noNodeInfo name))
prettyPrint (ConOp l name) = prettyPrint (QConOp l (UnQual noNodeInfo name))
instance Pretty Bracket where
prettyPrint (ExpBracket _ expr) = group Expression "[|" "|]" $ pretty expr
prettyPrint (PatBracket _ pat) = group Expression "[p|" "|]" $ pretty pat
prettyPrint (TypeBracket _ ty) = group Expression "[t|" "|]" $ pretty ty
prettyPrint (DeclBracket _ decls) =
group Expression "[d|" "|]" . aligned $ lined decls
instance Pretty Splice where
prettyPrint (IdSplice _ str) = do
write "$"
string str
prettyPrint (ParenSplice _ expr) = group Expression "$(" ")" $ pretty expr
instance Pretty ModulePragma where
prettyPrint (LanguagePragma _ names) =
prettyPragma "LANGUAGE" . inter comma $ map pretty names
prettyPrint (OptionsPragma _ mtool str) = prettyPragma name $
string (trim str)
where
name = case mtool of
Just tool -> "OPTIONS_" `mappend` BS8.pack (HSE.prettyPrint tool)
Nothing -> "OPTIONS"
trim = reverse . dropWhile (== ' ') . reverse . dropWhile (== ' ')
prettyPrint (AnnModulePragma _ annotation) =
prettyPragma "ANN" $ pretty annotation
instance Pretty Rule where
prettyPrint (Rule _ str mactivation mrulevars expr expr') = do
string (show str)
space
mayM_ mactivation $ withPostfix space pretty
mapM_ prettyForall mrulevars
pretty expr
operator Expression "="
pretty expr'
instance Pretty RuleVar where
prettyPrint (RuleVar _ name) = pretty name
prettyPrint (TypedRuleVar _ name ty) =
parens $ prettyTypesig Declaration [ name ] ty
instance Pretty Activation where
prettyPrint (ActiveFrom _ pass) = brackets . int $ fromIntegral pass
prettyPrint (ActiveUntil _ pass) = brackets $ do
write "~"
int $ fromIntegral pass
instance Pretty Annotation where
prettyPrint (Ann _ name expr) = do
pretty name
space
pretty expr
prettyPrint (TypeAnn _ name expr) = do
write "type "
pretty name
space
pretty expr
prettyPrint (ModuleAnn _ expr) = do
write "module "
pretty expr
instance Pretty BooleanFormula where
prettyPrint (VarFormula _ name) = pretty name
prettyPrint (AndFormula _ booleanformulas) =
inter comma $ map pretty booleanformulas
prettyPrint (OrFormula _ booleanformulas) =
inter (operator Expression "|") $ map pretty booleanformulas
prettyPrint (ParenFormula _ booleanformula) = parens $ pretty booleanformula
instance Pretty DerivStrategy
instance Pretty DataOrNew
instance Pretty BangType
instance Pretty Unpackedness
instance Pretty RPat
instance Pretty ModuleName
instance Pretty QName
instance Pretty Name
instance Pretty IPName
instance Pretty XName
instance Pretty Safety
instance Pretty CallConv
instance Pretty Overlap
newtype GuardedAlt l = GuardedAlt (GuardedRhs l)
deriving ( Functor, Annotated )
instance Pretty GuardedAlt where
prettyPrint (GuardedAlt (GuardedRhs _ stmts expr)) = cut $ do
operatorSectionR Pattern "|" $ write "|"
inter comma $ map pretty stmts
operator Expression "->"
pretty expr
newtype GuardedAlts l = GuardedAlts (Rhs l)
deriving ( Functor, Annotated )
instance Pretty GuardedAlts where
prettyPrint (GuardedAlts (UnGuardedRhs _ expr)) = cut $ do
operator Expression "->"
pretty expr
prettyPrint (GuardedAlts (GuardedRhss _ guardedrhss)) =
withIndent cfgIndentMultiIf $ linedOnside $ map GuardedAlt guardedrhss
newtype CompactBinds l = CompactBinds (Binds l)
deriving ( Functor, Annotated )
instance Pretty CompactBinds where
prettyPrint (CompactBinds (BDecls _ decls)) = aligned $
withComputedTabStop stopRhs cfgAlignLetBinds measureDecl decls $
lined decls
prettyPrint (CompactBinds (IPBinds _ ipbinds)) =
aligned $ linedOnside ipbinds
newtype MayAst a l = MayAst (Maybe (a l))
instance Functor a => Functor (MayAst a) where
fmap _ (MayAst Nothing) = MayAst Nothing
fmap f (MayAst (Just x)) = MayAst . Just $ fmap f x
instance Annotated a => Annotated (MayAst a) where
ann (MayAst Nothing) = undefined
ann (MayAst (Just x)) = ann x
amap _ (MayAst Nothing) = MayAst Nothing
amap f (MayAst (Just x)) = MayAst . Just $ amap f x
instance (Annotated a, Pretty a) => Pretty (MayAst a) where
prettyPrint (MayAst x) = mapM_ pretty x