-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.Pretty
-- Copyright   :  (c) The GHC Team, Noel Winstanley 1997-2000
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Pretty printer for Haskell.
--
-----------------------------------------------------------------------------

module Language.Haskell.Pretty
  ( -- * Pretty printing
    Pretty,
    prettyPrintStyleMode,
    prettyPrintWithMode,
    prettyPrint,

    -- * Pretty-printing styles (from "Text.PrettyPrint.HughesPJ")
    P.Style(..),
    P.style,
    P.Mode(..),

    -- * Haskell formatting modes
    PPHsMode(..),
    Indent,
    PPLayout(..),
    defaultMode
  ) where

import           Language.Haskell.Syntax

import           Control.Monad           (ap)

import qualified Text.PrettyPrint        as P

infixl 5 $$$

-----------------------------------------------------------------------------

-- | Varieties of layout we can use.
data PPLayout = PPOffsideRule   -- ^ classical layout
              | PPSemiColon     -- ^ classical layout made explicit
              | PPInLine        -- ^ inline decls, with newlines between them
              | PPNoLayout      -- ^ everything on a single line
              deriving PPLayout -> PPLayout -> Bool
(PPLayout -> PPLayout -> Bool)
-> (PPLayout -> PPLayout -> Bool) -> Eq PPLayout
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PPLayout -> PPLayout -> Bool
$c/= :: PPLayout -> PPLayout -> Bool
== :: PPLayout -> PPLayout -> Bool
$c== :: PPLayout -> PPLayout -> Bool
Eq

type Indent = Int

-- | Pretty-printing parameters.
--
-- /Note:/ the 'onsideIndent' must be positive and less than all other indents.
data PPHsMode = PPHsMode {
                                -- | indentation of a class or instance
                PPHsMode -> Indent
classIndent  :: Indent,
                                -- | indentation of a @do@-expression
                PPHsMode -> Indent
doIndent     :: Indent,
                                -- | indentation of the body of a
                                -- @case@ expression
                PPHsMode -> Indent
caseIndent   :: Indent,
                                -- | indentation of the declarations in a
                                -- @let@ expression
                PPHsMode -> Indent
letIndent    :: Indent,
                                -- | indentation of the declarations in a
                                -- @where@ clause
                PPHsMode -> Indent
whereIndent  :: Indent,
                                -- | indentation added for continuation
                                -- lines that would otherwise be offside
                PPHsMode -> Indent
onsideIndent :: Indent,
                                -- | blank lines between statements?
                PPHsMode -> Bool
spacing      :: Bool,
                                -- | Pretty-printing style to use
                PPHsMode -> PPLayout
layout       :: PPLayout,
                                -- | add GHC-style @LINE@ pragmas to output?
                PPHsMode -> Bool
linePragmas  :: Bool,
                                -- | not implemented yet
                PPHsMode -> Bool
comments     :: Bool
                }

-- | The default mode: pretty-print using the offside rule and sensible
-- defaults.
defaultMode :: PPHsMode
defaultMode :: PPHsMode
defaultMode = PPHsMode :: Indent
-> Indent
-> Indent
-> Indent
-> Indent
-> Indent
-> Bool
-> PPLayout
-> Bool
-> Bool
-> PPHsMode
PPHsMode{
                      classIndent :: Indent
classIndent = 8,
                      doIndent :: Indent
doIndent = 3,
                      caseIndent :: Indent
caseIndent = 4,
                      letIndent :: Indent
letIndent = 4,
                      whereIndent :: Indent
whereIndent = 6,
                      onsideIndent :: Indent
onsideIndent = 2,
                      spacing :: Bool
spacing = Bool
True,
                      layout :: PPLayout
layout = PPLayout
PPOffsideRule,
                      linePragmas :: Bool
linePragmas = Bool
False,
                      comments :: Bool
comments = Bool
True
                      }

-- | Pretty printing monad
newtype DocM s a = DocM (s -> a)

instance Functor (DocM s) where
         fmap :: (a -> b) -> DocM s a -> DocM s b
fmap f :: a -> b
f xs :: DocM s a
xs = do a
x <- DocM s a
xs; b -> DocM s b
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f a
x)

-- | @since 1.0.2.0
instance Applicative (DocM s) where
        pure :: a -> DocM s a
pure = a -> DocM s a
forall a s. a -> DocM s a
retDocM
        <*> :: DocM s (a -> b) -> DocM s a -> DocM s b
(<*>) = DocM s (a -> b) -> DocM s a -> DocM s b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
        *> :: DocM s a -> DocM s b -> DocM s b
(*>) = DocM s a -> DocM s b -> DocM s b
forall s a b. DocM s a -> DocM s b -> DocM s b
then_DocM

instance Monad (DocM s) where
        >>= :: DocM s a -> (a -> DocM s b) -> DocM s b
(>>=) = DocM s a -> (a -> DocM s b) -> DocM s b
forall s a b. DocM s a -> (a -> DocM s b) -> DocM s b
thenDocM
        >> :: DocM s a -> DocM s b -> DocM s b
(>>) = DocM s a -> DocM s b -> DocM s b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

{-# INLINE thenDocM #-}
{-# INLINE then_DocM #-}
{-# INLINE retDocM #-}
{-# INLINE unDocM #-}
{-# INLINE getPPEnv #-}

thenDocM :: DocM s a -> (a -> DocM s b) -> DocM s b
thenDocM :: DocM s a -> (a -> DocM s b) -> DocM s b
thenDocM m :: DocM s a
m k :: a -> DocM s b
k = (s -> b) -> DocM s b
forall s a. (s -> a) -> DocM s a
DocM ((s -> b) -> DocM s b) -> (s -> b) -> DocM s b
forall a b. (a -> b) -> a -> b
$ (\s :: s
s -> case DocM s a -> s -> a
forall s a. DocM s a -> s -> a
unDocM DocM s a
m (s -> a) -> s -> a
forall a b. (a -> b) -> a -> b
$ s
s of a :: a
a -> DocM s b -> s -> b
forall s a. DocM s a -> s -> a
unDocM (a -> DocM s b
k a
a) (s -> b) -> s -> b
forall a b. (a -> b) -> a -> b
$ s
s)

then_DocM :: DocM s a -> DocM s b -> DocM s b
then_DocM :: DocM s a -> DocM s b -> DocM s b
then_DocM m :: DocM s a
m k :: DocM s b
k = (s -> b) -> DocM s b
forall s a. (s -> a) -> DocM s a
DocM ((s -> b) -> DocM s b) -> (s -> b) -> DocM s b
forall a b. (a -> b) -> a -> b
$ (\s :: s
s -> case DocM s a -> s -> a
forall s a. DocM s a -> s -> a
unDocM DocM s a
m (s -> a) -> s -> a
forall a b. (a -> b) -> a -> b
$ s
s of _ -> DocM s b -> s -> b
forall s a. DocM s a -> s -> a
unDocM DocM s b
k (s -> b) -> s -> b
forall a b. (a -> b) -> a -> b
$ s
s)

retDocM :: a -> DocM s a
retDocM :: a -> DocM s a
retDocM a :: a
a = (s -> a) -> DocM s a
forall s a. (s -> a) -> DocM s a
DocM (\_s :: s
_s -> a
a)

unDocM :: DocM s a -> (s -> a)
unDocM :: DocM s a -> s -> a
unDocM (DocM f :: s -> a
f) = s -> a
f

-- all this extra stuff, just for this one function.
getPPEnv :: DocM s s
getPPEnv :: DocM s s
getPPEnv = (s -> s) -> DocM s s
forall s a. (s -> a) -> DocM s a
DocM s -> s
forall a. a -> a
id

-- So that pp code still looks the same
-- this means we lose some generality though

-- | The document type produced by these pretty printers uses a 'PPHsMode'
-- environment.
type Doc = DocM PPHsMode P.Doc

-- | Things that can be pretty-printed, including all the syntactic objects
-- in "Language.Haskell.Syntax".
class Pretty a where
        -- | Pretty-print something in isolation.
        pretty :: a -> Doc
        -- | Pretty-print something in a precedence context.
        prettyPrec :: Int -> a -> Doc
        pretty = Indent -> a -> Doc
forall a. Pretty a => Indent -> a -> Doc
prettyPrec 0
        prettyPrec _ = a -> Doc
forall a. Pretty a => a -> Doc
pretty

-- The pretty printing combinators

empty :: Doc
empty :: Doc
empty = Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
P.empty

nest :: Int -> Doc -> Doc
nest :: Indent -> Doc -> Doc
nest i :: Indent
i m :: Doc
m = Doc
m Doc -> (Doc -> Doc) -> Doc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (Doc -> Doc) -> Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Indent -> Doc -> Doc
P.nest Indent
i


-- Literals

text :: String -> Doc
text :: String -> Doc
text = Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (String -> Doc) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
P.text
-- ptext = return . P.text

char :: Char -> Doc
char :: Char -> Doc
char = Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (Char -> Doc) -> Char -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Doc
P.char

int :: Int -> Doc
int :: Indent -> Doc
int = Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (Indent -> Doc) -> Indent -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Indent -> Doc
P.int

integer :: Integer -> Doc
integer :: Integer -> Doc
integer = Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (Integer -> Doc) -> Integer -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Doc
P.integer

float :: Float -> Doc
float :: Float -> Doc
float = Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (Float -> Doc) -> Float -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Doc
P.float

double :: Double -> Doc
double :: Double -> Doc
double = Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (Double -> Doc) -> Double -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Doc
P.double

-- rational :: Rational -> Doc
-- rational = return . P.rational

-- Simple Combining Forms

parens, brackets, braces :: Doc -> Doc
parens :: Doc -> Doc
parens d :: Doc
d = Doc
d Doc -> (Doc -> Doc) -> Doc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (Doc -> Doc) -> Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
P.parens
brackets :: Doc -> Doc
brackets d :: Doc
d = Doc
d Doc -> (Doc -> Doc) -> Doc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (Doc -> Doc) -> Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
P.brackets
braces :: Doc -> Doc
braces d :: Doc
d = Doc
d Doc -> (Doc -> Doc) -> Doc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (Doc -> Doc) -> Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
P.braces
-- quotes d = d >>= return . P.quotes
-- doubleQuotes d = d >>= return . P.doubleQuotes

parensIf :: Bool -> Doc -> Doc
parensIf :: Bool -> Doc -> Doc
parensIf True  = Doc -> Doc
parens
parensIf False = Doc -> Doc
forall a. a -> a
id

-- Constants

semi,comma,space,equals :: Doc
semi :: Doc
semi = Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
P.semi
comma :: Doc
comma = Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
P.comma
-- colon = return P.colon
space :: Doc
space = Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
P.space
equals :: Doc
equals = Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
P.equals

-- lparen,rparen,lbrack,rbrack,lbrace,rbrace :: Doc
-- lparen = return  P.lparen
-- rparen = return  P.rparen
-- lbrack = return  P.lbrack
-- rbrack = return  P.rbrack
-- lbrace = return  P.lbrace
-- rbrace = return  P.rbrace

-- Combinators

(<<>>),(<+>),($$) :: Doc -> Doc -> Doc
aM :: Doc
aM <<>> :: Doc -> Doc -> Doc
<<>> bM :: Doc
bM = do{Doc
a<-Doc
aM;Doc
b<-Doc
bM;Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc
a Doc -> Doc -> Doc
P.<> Doc
b)}
aM :: Doc
aM <+> :: Doc -> Doc -> Doc
<+> bM :: Doc
bM = do{Doc
a<-Doc
aM;Doc
b<-Doc
bM;Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc
a Doc -> Doc -> Doc
P.<+> Doc
b)}
aM :: Doc
aM $$ :: Doc -> Doc -> Doc
$$ bM :: Doc
bM = do{Doc
a<-Doc
aM;Doc
b<-Doc
bM;Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc
a Doc -> Doc -> Doc
P.$$ Doc
b)}
-- aM $+$ bM = do{a<-aM;b<-bM;return (a P.$+$ b)}

hcat,hsep,vcat,fsep :: [Doc] -> Doc
hcat :: [Doc] -> Doc
hcat dl :: [Doc]
dl = [Doc] -> DocM PPHsMode [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Doc]
dl DocM PPHsMode [Doc] -> ([Doc] -> Doc) -> Doc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
P.hcat
hsep :: [Doc] -> Doc
hsep dl :: [Doc]
dl = [Doc] -> DocM PPHsMode [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Doc]
dl DocM PPHsMode [Doc] -> ([Doc] -> Doc) -> Doc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
P.hsep
vcat :: [Doc] -> Doc
vcat dl :: [Doc]
dl = [Doc] -> DocM PPHsMode [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Doc]
dl DocM PPHsMode [Doc] -> ([Doc] -> Doc) -> Doc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
P.vcat
-- sep dl = sequence dl >>= return . P.sep
-- cat dl = sequence dl >>= return . P.cat
fsep :: [Doc] -> Doc
fsep dl :: [Doc]
dl = [Doc] -> DocM PPHsMode [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Doc]
dl DocM PPHsMode [Doc] -> ([Doc] -> Doc) -> Doc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Doc -> Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
P.fsep
-- fcat dl = sequence dl >>= return . P.fcat

-- Some More

-- hang :: Doc -> Int -> Doc -> Doc
-- hang dM i rM = do{d<-dM;r<-rM;return $ P.hang d i r}

-- Yuk, had to cut-n-paste this one from Pretty.hs
punctuate :: Doc -> [Doc] -> [Doc]
punctuate :: Doc -> [Doc] -> [Doc]
punctuate _ []     = []
punctuate p :: Doc
p (d1 :: Doc
d1:ds :: [Doc]
ds) = Doc -> [Doc] -> [Doc]
go Doc
d1 [Doc]
ds
                   where
                     go :: Doc -> [Doc] -> [Doc]
go d :: Doc
d []     = [Doc
d]
                     go d :: Doc
d (e :: Doc
e:es :: [Doc]
es) = (Doc
d Doc -> Doc -> Doc
<<>> Doc
p) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: Doc -> [Doc] -> [Doc]
go Doc
e [Doc]
es

-- | render the document with a given style and mode.
renderStyleMode :: P.Style -> PPHsMode -> Doc -> String
renderStyleMode :: Style -> PPHsMode -> Doc -> String
renderStyleMode ppStyle :: Style
ppStyle ppMode :: PPHsMode
ppMode d :: Doc
d = Style -> Doc -> String
P.renderStyle Style
ppStyle (Doc -> String) -> (PPHsMode -> Doc) -> PPHsMode -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> PPHsMode -> Doc
forall s a. DocM s a -> s -> a
unDocM Doc
d (PPHsMode -> String) -> PPHsMode -> String
forall a b. (a -> b) -> a -> b
$ PPHsMode
ppMode

-- --- | render the document with a given mode.
-- renderWithMode :: PPHsMode -> Doc -> String
-- renderWithMode = renderStyleMode P.style

-- -- | render the document with 'defaultMode'.
-- render :: Doc -> String
-- render = renderWithMode defaultMode

-- | pretty-print with a given style and mode.
prettyPrintStyleMode :: Pretty a => P.Style -> PPHsMode -> a -> String
prettyPrintStyleMode :: Style -> PPHsMode -> a -> String
prettyPrintStyleMode ppStyle :: Style
ppStyle ppMode :: PPHsMode
ppMode = Style -> PPHsMode -> Doc -> String
renderStyleMode Style
ppStyle PPHsMode
ppMode (Doc -> String) -> (a -> Doc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc
forall a. Pretty a => a -> Doc
pretty

-- | pretty-print with the default style and a given mode.
prettyPrintWithMode :: Pretty a => PPHsMode -> a -> String
prettyPrintWithMode :: PPHsMode -> a -> String
prettyPrintWithMode = Style -> PPHsMode -> a -> String
forall a. Pretty a => Style -> PPHsMode -> a -> String
prettyPrintStyleMode Style
P.style

-- | pretty-print with the default style and 'defaultMode'.
prettyPrint :: Pretty a => a -> String
prettyPrint :: a -> String
prettyPrint = PPHsMode -> a -> String
forall a. Pretty a => PPHsMode -> a -> String
prettyPrintWithMode PPHsMode
defaultMode

-- fullRenderWithMode :: PPHsMode -> P.Mode -> Int -> Float ->
--                       (P.TextDetails -> a -> a) -> a -> Doc -> a
-- fullRenderWithMode ppMode m i f fn e mD =
--                    P.fullRender m i f fn e $ (unDocM mD) ppMode
--
--
-- fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> a)
--               -> a -> Doc -> a
-- fullRender = fullRenderWithMode defaultMode

-------------------------  Pretty-Print a Module --------------------
instance Pretty HsModule where
        pretty :: HsModule -> Doc
pretty (HsModule pos :: SrcLoc
pos m :: Module
m mbExports :: Maybe [HsExportSpec]
mbExports imp :: [HsImportDecl]
imp decls :: [HsDecl]
decls) =
                SrcLoc -> Doc -> Doc
markLine SrcLoc
pos (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                Doc -> [Doc] -> Doc
topLevel (Module -> Maybe [HsExportSpec] -> Doc
ppHsModuleHeader Module
m Maybe [HsExportSpec]
mbExports)
                         ((HsImportDecl -> Doc) -> [HsImportDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsImportDecl -> Doc
forall a. Pretty a => a -> Doc
pretty [HsImportDecl]
imp [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (HsDecl -> Doc) -> [HsDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsDecl -> Doc
forall a. Pretty a => a -> Doc
pretty [HsDecl]
decls)

--------------------------  Module Header ------------------------------
ppHsModuleHeader :: Module -> Maybe [HsExportSpec] ->  Doc
ppHsModuleHeader :: Module -> Maybe [HsExportSpec] -> Doc
ppHsModuleHeader m :: Module
m mbExportList :: Maybe [HsExportSpec]
mbExportList = [Doc] -> Doc
mySep [
        String -> Doc
text "module",
        Module -> Doc
forall a. Pretty a => a -> Doc
pretty Module
m,
        ([HsExportSpec] -> Doc) -> Maybe [HsExportSpec] -> Doc
forall a. (a -> Doc) -> Maybe a -> Doc
maybePP ([Doc] -> Doc
parenList ([Doc] -> Doc)
-> ([HsExportSpec] -> [Doc]) -> [HsExportSpec] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsExportSpec -> Doc) -> [HsExportSpec] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsExportSpec -> Doc
forall a. Pretty a => a -> Doc
pretty) Maybe [HsExportSpec]
mbExportList,
        String -> Doc
text "where"]

instance Pretty Module where
        pretty :: Module -> Doc
pretty (Module modName :: String
modName) = String -> Doc
text String
modName

instance Pretty HsExportSpec where
        pretty :: HsExportSpec -> Doc
pretty (HsEVar name :: HsQName
name)                = HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
name
        pretty (HsEAbs name :: HsQName
name)                = HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
name
        pretty (HsEThingAll name :: HsQName
name)           = HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
name Doc -> Doc -> Doc
<<>> String -> Doc
text "(..)"
        pretty (HsEThingWith name :: HsQName
name nameList :: [HsCName]
nameList) =
                HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
name Doc -> Doc -> Doc
<<>> ([Doc] -> Doc
parenList ([Doc] -> Doc) -> ([HsCName] -> [Doc]) -> [HsCName] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsCName -> Doc) -> [HsCName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsCName -> Doc
forall a. Pretty a => a -> Doc
pretty ([HsCName] -> Doc) -> [HsCName] -> Doc
forall a b. (a -> b) -> a -> b
$ [HsCName]
nameList)
        pretty (HsEModuleContents m :: Module
m)       = String -> Doc
text "module" Doc -> Doc -> Doc
<+> Module -> Doc
forall a. Pretty a => a -> Doc
pretty Module
m

instance Pretty HsImportDecl where
        pretty :: HsImportDecl -> Doc
pretty (HsImportDecl pos :: SrcLoc
pos m :: Module
m qual :: Bool
qual mbName :: Maybe Module
mbName mbSpecs :: Maybe (Bool, [HsImportSpec])
mbSpecs) =
                SrcLoc -> Doc -> Doc
markLine SrcLoc
pos (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
mySep [String -> Doc
text "import",
                       if Bool
qual then String -> Doc
text "qualified" else Doc
empty,
                       Module -> Doc
forall a. Pretty a => a -> Doc
pretty Module
m,
                       (Module -> Doc) -> Maybe Module -> Doc
forall a. (a -> Doc) -> Maybe a -> Doc
maybePP (\m' :: Module
m' -> String -> Doc
text "as" Doc -> Doc -> Doc
<+> Module -> Doc
forall a. Pretty a => a -> Doc
pretty Module
m') Maybe Module
mbName,
                       ((Bool, [HsImportSpec]) -> Doc)
-> Maybe (Bool, [HsImportSpec]) -> Doc
forall a. (a -> Doc) -> Maybe a -> Doc
maybePP (Bool, [HsImportSpec]) -> Doc
forall a. Pretty a => (Bool, [a]) -> Doc
exports Maybe (Bool, [HsImportSpec])
mbSpecs]
            where
                exports :: (Bool, [a]) -> Doc
exports (b :: Bool
b,specList :: [a]
specList) =
                        if Bool
b then String -> Doc
text "hiding" Doc -> Doc -> Doc
<+> Doc
specs else Doc
specs
                    where specs :: Doc
specs = [Doc] -> Doc
parenList ([Doc] -> Doc) -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Pretty a => a -> Doc
pretty ([a] -> Doc) -> [a] -> Doc
forall a b. (a -> b) -> a -> b
$ [a]
specList

instance Pretty HsImportSpec where
        pretty :: HsImportSpec -> Doc
pretty (HsIVar name :: HsName
name)                = HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name
        pretty (HsIAbs name :: HsName
name)                = HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name
        pretty (HsIThingAll name :: HsName
name)           = HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name Doc -> Doc -> Doc
<<>> String -> Doc
text "(..)"
        pretty (HsIThingWith name :: HsName
name nameList :: [HsCName]
nameList) =
                HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name Doc -> Doc -> Doc
<<>> ([Doc] -> Doc
parenList ([Doc] -> Doc) -> ([HsCName] -> [Doc]) -> [HsCName] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsCName -> Doc) -> [HsCName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsCName -> Doc
forall a. Pretty a => a -> Doc
pretty ([HsCName] -> Doc) -> [HsCName] -> Doc
forall a b. (a -> b) -> a -> b
$ [HsCName]
nameList)

-------------------------  Declarations ------------------------------
instance Pretty HsDecl where
        pretty :: HsDecl -> Doc
pretty (HsTypeDecl loc :: SrcLoc
loc name :: HsName
name nameList :: [HsName]
nameList htype :: HsType
htype) =
                Doc -> Doc
blankline (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                SrcLoc -> Doc -> Doc
markLine SrcLoc
loc (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
mySep ( [String -> Doc
text "type", HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name]
                        [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (HsName -> Doc) -> [HsName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsName -> Doc
forall a. Pretty a => a -> Doc
pretty [HsName]
nameList
                        [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc
equals, HsType -> Doc
forall a. Pretty a => a -> Doc
pretty HsType
htype])

        pretty (HsDataDecl loc :: SrcLoc
loc context :: HsContext
context name :: HsName
name nameList :: [HsName]
nameList constrList :: [HsConDecl]
constrList derives :: [HsQName]
derives) =
                Doc -> Doc
blankline (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                SrcLoc -> Doc -> Doc
markLine SrcLoc
loc (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
mySep ( [String -> Doc
text "data", HsContext -> Doc
ppHsContext HsContext
context, HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name]
                        [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (HsName -> Doc) -> [HsName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsName -> Doc
forall a. Pretty a => a -> Doc
pretty [HsName]
nameList)
                        Doc -> Doc -> Doc
<+> ([Doc] -> Doc
myVcat ((Doc -> Doc -> Doc) -> [Doc] -> [Doc] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Doc -> Doc -> Doc
(<+>) (Doc
equals Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: Doc -> [Doc]
forall a. a -> [a]
repeat (Char -> Doc
char '|'))
                                                   ((HsConDecl -> Doc) -> [HsConDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsConDecl -> Doc
forall a. Pretty a => a -> Doc
pretty [HsConDecl]
constrList))
                        Doc -> Doc -> Doc
$$$ [HsQName] -> Doc
ppHsDeriving [HsQName]
derives)

        pretty (HsNewTypeDecl pos :: SrcLoc
pos context :: HsContext
context name :: HsName
name nameList :: [HsName]
nameList constr :: HsConDecl
constr derives :: [HsQName]
derives) =
                Doc -> Doc
blankline (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                SrcLoc -> Doc -> Doc
markLine SrcLoc
pos (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
mySep ( [String -> Doc
text "newtype", HsContext -> Doc
ppHsContext HsContext
context, HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name]
                        [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (HsName -> Doc) -> [HsName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsName -> Doc
forall a. Pretty a => a -> Doc
pretty [HsName]
nameList)
                        Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> (HsConDecl -> Doc
forall a. Pretty a => a -> Doc
pretty HsConDecl
constr Doc -> Doc -> Doc
$$$ [HsQName] -> Doc
ppHsDeriving [HsQName]
derives)

        --m{spacing=False}
        -- special case for empty class declaration
        pretty (HsClassDecl pos :: SrcLoc
pos context :: HsContext
context name :: HsName
name nameList :: [HsName]
nameList []) =
                Doc -> Doc
blankline (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                SrcLoc -> Doc -> Doc
markLine SrcLoc
pos (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
mySep ( [String -> Doc
text "class", HsContext -> Doc
ppHsContext HsContext
context, HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name]
                        [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (HsName -> Doc) -> [HsName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsName -> Doc
forall a. Pretty a => a -> Doc
pretty [HsName]
nameList)
        pretty (HsClassDecl pos :: SrcLoc
pos context :: HsContext
context name :: HsName
name nameList :: [HsName]
nameList declList :: [HsDecl]
declList) =
                Doc -> Doc
blankline (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                SrcLoc -> Doc -> Doc
markLine SrcLoc
pos (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
mySep ( [String -> Doc
text "class", HsContext -> Doc
ppHsContext HsContext
context, HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name]
                        [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (HsName -> Doc) -> [HsName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsName -> Doc
forall a. Pretty a => a -> Doc
pretty [HsName]
nameList [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [String -> Doc
text "where"])
                Doc -> Doc -> Doc
$$$ (PPHsMode -> Indent) -> [Doc] -> Doc
ppBody PPHsMode -> Indent
classIndent ((HsDecl -> Doc) -> [HsDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsDecl -> Doc
forall a. Pretty a => a -> Doc
pretty [HsDecl]
declList)

        -- m{spacing=False}
        -- special case for empty instance declaration
        pretty (HsInstDecl pos :: SrcLoc
pos context :: HsContext
context name :: HsQName
name args :: [HsType]
args []) =
                Doc -> Doc
blankline (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                SrcLoc -> Doc -> Doc
markLine SrcLoc
pos (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
mySep ( [String -> Doc
text "instance", HsContext -> Doc
ppHsContext HsContext
context, HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
name]
                        [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (HsType -> Doc) -> [HsType] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsType -> Doc
ppHsAType [HsType]
args)
        pretty (HsInstDecl pos :: SrcLoc
pos context :: HsContext
context name :: HsQName
name args :: [HsType]
args declList :: [HsDecl]
declList) =
                Doc -> Doc
blankline (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                SrcLoc -> Doc -> Doc
markLine SrcLoc
pos (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
mySep ( [String -> Doc
text "instance", HsContext -> Doc
ppHsContext HsContext
context, HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
name]
                        [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (HsType -> Doc) -> [HsType] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsType -> Doc
ppHsAType [HsType]
args [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [String -> Doc
text "where"])
                Doc -> Doc -> Doc
$$$ (PPHsMode -> Indent) -> [Doc] -> Doc
ppBody PPHsMode -> Indent
classIndent ((HsDecl -> Doc) -> [HsDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsDecl -> Doc
forall a. Pretty a => a -> Doc
pretty [HsDecl]
declList)

        pretty (HsDefaultDecl pos :: SrcLoc
pos htypes :: [HsType]
htypes) =
                Doc -> Doc
blankline (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                SrcLoc -> Doc -> Doc
markLine SrcLoc
pos (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                String -> Doc
text "default" Doc -> Doc -> Doc
<+> [Doc] -> Doc
parenList ((HsType -> Doc) -> [HsType] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsType -> Doc
forall a. Pretty a => a -> Doc
pretty [HsType]
htypes)

        pretty (HsTypeSig pos :: SrcLoc
pos nameList :: [HsName]
nameList qualType :: HsQualType
qualType) =
                Doc -> Doc
blankline (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                SrcLoc -> Doc -> Doc
markLine SrcLoc
pos (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
mySep ((Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([HsName] -> [Doc]) -> [HsName] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsName -> Doc) -> [HsName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsName -> Doc
forall a. Pretty a => a -> Doc
pretty ([HsName] -> [Doc]) -> [HsName] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [HsName]
nameList)
                      [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [String -> Doc
text "::", HsQualType -> Doc
forall a. Pretty a => a -> Doc
pretty HsQualType
qualType])

        pretty (HsForeignImport pos :: SrcLoc
pos conv :: String
conv safety :: HsSafety
safety entity :: String
entity name :: HsName
name ty :: HsType
ty) =
                Doc -> Doc
blankline (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                SrcLoc -> Doc -> Doc
markLine SrcLoc
pos (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
mySep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [String -> Doc
text "foreign", String -> Doc
text "import", String -> Doc
text String
conv, HsSafety -> Doc
forall a. Pretty a => a -> Doc
pretty HsSafety
safety] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++
                        (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
entity then [] else [String -> Doc
text (String -> String
forall a. Show a => a -> String
show String
entity)]) [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++
                        [HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name, String -> Doc
text "::", HsType -> Doc
forall a. Pretty a => a -> Doc
pretty HsType
ty]

        pretty (HsForeignExport pos :: SrcLoc
pos conv :: String
conv entity :: String
entity name :: HsName
name ty :: HsType
ty) =
                Doc -> Doc
blankline (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                SrcLoc -> Doc -> Doc
markLine SrcLoc
pos (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
mySep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [String -> Doc
text "foreign", String -> Doc
text "export", String -> Doc
text String
conv] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++
                        (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
entity then [] else [String -> Doc
text (String -> String
forall a. Show a => a -> String
show String
entity)]) [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++
                        [HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name, String -> Doc
text "::", HsType -> Doc
forall a. Pretty a => a -> Doc
pretty HsType
ty]

        pretty (HsFunBind matches :: [HsMatch]
matches) =
                [Doc] -> Doc
ppBindings ((HsMatch -> Doc) -> [HsMatch] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsMatch -> Doc
forall a. Pretty a => a -> Doc
pretty [HsMatch]
matches)

        pretty (HsPatBind pos :: SrcLoc
pos pat :: HsPat
pat rhs :: HsRhs
rhs whereDecls :: [HsDecl]
whereDecls) =
                SrcLoc -> Doc -> Doc
markLine SrcLoc
pos (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
myFsep [HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty HsPat
pat, HsRhs -> Doc
forall a. Pretty a => a -> Doc
pretty HsRhs
rhs] Doc -> Doc -> Doc
$$$ [HsDecl] -> Doc
ppWhere [HsDecl]
whereDecls

        pretty (HsInfixDecl pos :: SrcLoc
pos assoc :: HsAssoc
assoc prec :: Indent
prec opList :: [HsOp]
opList) =
                Doc -> Doc
blankline (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                SrcLoc -> Doc -> Doc
markLine SrcLoc
pos (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
mySep ([HsAssoc -> Doc
forall a. Pretty a => a -> Doc
pretty HsAssoc
assoc, Indent -> Doc
int Indent
prec]
                       [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([HsOp] -> [Doc]) -> [HsOp] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsOp -> Doc) -> [HsOp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsOp -> Doc
forall a. Pretty a => a -> Doc
pretty ([HsOp] -> [Doc]) -> [HsOp] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [HsOp]
opList))

instance Pretty HsAssoc where
        pretty :: HsAssoc -> Doc
pretty HsAssocNone  = String -> Doc
text "infix"
        pretty HsAssocLeft  = String -> Doc
text "infixl"
        pretty HsAssocRight = String -> Doc
text "infixr"

instance Pretty HsSafety where
        pretty :: HsSafety -> Doc
pretty HsSafe   = String -> Doc
text "safe"
        pretty HsUnsafe = String -> Doc
text "unsafe"

instance Pretty HsMatch where
        pretty :: HsMatch -> Doc
pretty (HsMatch pos :: SrcLoc
pos f :: HsName
f ps :: [HsPat]
ps rhs :: HsRhs
rhs whereDecls :: [HsDecl]
whereDecls) =
                SrcLoc -> Doc -> Doc
markLine SrcLoc
pos (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
myFsep ([Doc]
lhs [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [HsRhs -> Doc
forall a. Pretty a => a -> Doc
pretty HsRhs
rhs])
                Doc -> Doc -> Doc
$$$ [HsDecl] -> Doc
ppWhere [HsDecl]
whereDecls
            where
                lhs :: [Doc]
lhs = case [HsPat]
ps of
                        l :: HsPat
l:r :: HsPat
r:ps' :: [HsPat]
ps' | HsName -> Bool
isSymbolName HsName
f ->
                                let hd :: [Doc]
hd = [HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty HsPat
l, HsName -> Doc
ppHsName HsName
f, HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty HsPat
r] in
                                if [HsPat] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsPat]
ps' then [Doc]
hd
                                else Doc -> Doc
parens ([Doc] -> Doc
myFsep [Doc]
hd) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (HsPat -> Doc) -> [HsPat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Indent -> HsPat -> Doc
forall a. Pretty a => Indent -> a -> Doc
prettyPrec 2) [HsPat]
ps'
                        _ -> HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
f Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (HsPat -> Doc) -> [HsPat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Indent -> HsPat -> Doc
forall a. Pretty a => Indent -> a -> Doc
prettyPrec 2) [HsPat]
ps

ppWhere :: [HsDecl] -> Doc
ppWhere :: [HsDecl] -> Doc
ppWhere [] = Doc
empty
ppWhere l :: [HsDecl]
l  = Indent -> Doc -> Doc
nest 2 (String -> Doc
text "where" Doc -> Doc -> Doc
$$$ (PPHsMode -> Indent) -> [Doc] -> Doc
ppBody PPHsMode -> Indent
whereIndent ((HsDecl -> Doc) -> [HsDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsDecl -> Doc
forall a. Pretty a => a -> Doc
pretty [HsDecl]
l))

------------------------- Data & Newtype Bodies -------------------------
instance Pretty HsConDecl where
        pretty :: HsConDecl -> Doc
pretty (HsRecDecl _pos :: SrcLoc
_pos name :: HsName
name fieldList :: [([HsName], HsBangType)]
fieldList) =
                HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name Doc -> Doc -> Doc
<<>> ([Doc] -> Doc
braceList ([Doc] -> Doc)
-> ([([HsName], HsBangType)] -> [Doc])
-> [([HsName], HsBangType)]
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([HsName], HsBangType) -> Doc)
-> [([HsName], HsBangType)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([HsName], HsBangType) -> Doc
ppField ([([HsName], HsBangType)] -> Doc)
-> [([HsName], HsBangType)] -> Doc
forall a b. (a -> b) -> a -> b
$ [([HsName], HsBangType)]
fieldList)

        pretty (HsConDecl _pos :: SrcLoc
_pos name :: HsName
name@(HsSymbol _) [l :: HsBangType
l, r :: HsBangType
r]) =
                [Doc] -> Doc
myFsep [Indent -> HsBangType -> Doc
forall a. Pretty a => Indent -> a -> Doc
prettyPrec Indent
prec_btype HsBangType
l, HsName -> Doc
ppHsName HsName
name,
                        Indent -> HsBangType -> Doc
forall a. Pretty a => Indent -> a -> Doc
prettyPrec Indent
prec_btype HsBangType
r]
        pretty (HsConDecl _pos :: SrcLoc
_pos name :: HsName
name typeList :: [HsBangType]
typeList) =
                [Doc] -> Doc
mySep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ HsName -> Doc
ppHsName HsName
name Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (HsBangType -> Doc) -> [HsBangType] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Indent -> HsBangType -> Doc
forall a. Pretty a => Indent -> a -> Doc
prettyPrec Indent
prec_atype) [HsBangType]
typeList

ppField :: ([HsName],HsBangType) -> Doc
ppField :: ([HsName], HsBangType) -> Doc
ppField (names :: [HsName]
names, ty :: HsBangType
ty) =
        [Doc] -> Doc
myFsepSimple ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([HsName] -> [Doc]) -> [HsName] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsName -> Doc) -> [HsName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsName -> Doc
forall a. Pretty a => a -> Doc
pretty ([HsName] -> [Doc]) -> [HsName] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [HsName]
names) [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++
                       [String -> Doc
text "::", HsBangType -> Doc
forall a. Pretty a => a -> Doc
pretty HsBangType
ty]

instance Pretty HsBangType where
        prettyPrec :: Indent -> HsBangType -> Doc
prettyPrec _ (HsBangedTy ty :: HsType
ty)   = Char -> Doc
char '!' Doc -> Doc -> Doc
<<>> HsType -> Doc
ppHsAType HsType
ty
        prettyPrec p :: Indent
p (HsUnBangedTy ty :: HsType
ty) = Indent -> HsType -> Doc
forall a. Pretty a => Indent -> a -> Doc
prettyPrec Indent
p HsType
ty

ppHsDeriving :: [HsQName] -> Doc
ppHsDeriving :: [HsQName] -> Doc
ppHsDeriving []  = Doc
empty
ppHsDeriving [d :: HsQName
d] = String -> Doc
text "deriving" Doc -> Doc -> Doc
<+> HsQName -> Doc
ppHsQName HsQName
d
ppHsDeriving ds :: [HsQName]
ds  = String -> Doc
text "deriving" Doc -> Doc -> Doc
<+> [Doc] -> Doc
parenList ((HsQName -> Doc) -> [HsQName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsQName -> Doc
ppHsQName [HsQName]
ds)

------------------------- Types -------------------------
instance Pretty HsQualType where
        pretty :: HsQualType -> Doc
pretty (HsQualType context :: HsContext
context htype :: HsType
htype) =
                [Doc] -> Doc
myFsep [HsContext -> Doc
ppHsContext HsContext
context, HsType -> Doc
forall a. Pretty a => a -> Doc
pretty HsType
htype]

ppHsBType :: HsType -> Doc
ppHsBType :: HsType -> Doc
ppHsBType = Indent -> HsType -> Doc
forall a. Pretty a => Indent -> a -> Doc
prettyPrec Indent
prec_btype

ppHsAType :: HsType -> Doc
ppHsAType :: HsType -> Doc
ppHsAType = Indent -> HsType -> Doc
forall a. Pretty a => Indent -> a -> Doc
prettyPrec Indent
prec_atype

-- precedences for types
prec_btype, prec_atype :: Int
prec_btype :: Indent
prec_btype = 1  -- left argument of ->,
                -- or either argument of an infix data constructor
prec_atype :: Indent
prec_atype = 2  -- argument of type or data constructor, or of a class

instance Pretty HsType where
        prettyPrec :: Indent -> HsType -> Doc
prettyPrec p :: Indent
p (HsTyFun a :: HsType
a b :: HsType
b) = Bool -> Doc -> Doc
parensIf (Indent
p Indent -> Indent -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
myFsep [HsType -> Doc
ppHsBType HsType
a, String -> Doc
text "->", HsType -> Doc
forall a. Pretty a => a -> Doc
pretty HsType
b]
        prettyPrec _ (HsTyTuple l :: [HsType]
l) = [Doc] -> Doc
parenList ([Doc] -> Doc) -> ([HsType] -> [Doc]) -> [HsType] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsType -> Doc) -> [HsType] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsType -> Doc
forall a. Pretty a => a -> Doc
pretty ([HsType] -> Doc) -> [HsType] -> Doc
forall a b. (a -> b) -> a -> b
$ [HsType]
l
        prettyPrec p :: Indent
p (HsTyApp a :: HsType
a b :: HsType
b)
                | HsType
a HsType -> HsType -> Bool
forall a. Eq a => a -> a -> Bool
== HsType
list_tycon = Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ HsType -> Doc
forall a. Pretty a => a -> Doc
pretty HsType
b         -- special case
                | Bool
otherwise = Bool -> Doc -> Doc
parensIf (Indent
p Indent -> Indent -> Bool
forall a. Ord a => a -> a -> Bool
> Indent
prec_btype) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                        [Doc] -> Doc
myFsep [HsType -> Doc
forall a. Pretty a => a -> Doc
pretty HsType
a, HsType -> Doc
ppHsAType HsType
b]
        prettyPrec _ (HsTyVar name :: HsName
name) = HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name
        prettyPrec _ (HsTyCon name :: HsQName
name) = HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
name

------------------------- Expressions -------------------------
instance Pretty HsRhs where
        pretty :: HsRhs -> Doc
pretty (HsUnGuardedRhs e :: HsExp
e)        = Doc
equals Doc -> Doc -> Doc
<+> HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e
        pretty (HsGuardedRhss guardList :: [HsGuardedRhs]
guardList) = [Doc] -> Doc
myVcat ([Doc] -> Doc)
-> ([HsGuardedRhs] -> [Doc]) -> [HsGuardedRhs] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsGuardedRhs -> Doc) -> [HsGuardedRhs] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsGuardedRhs -> Doc
forall a. Pretty a => a -> Doc
pretty ([HsGuardedRhs] -> Doc) -> [HsGuardedRhs] -> Doc
forall a b. (a -> b) -> a -> b
$ [HsGuardedRhs]
guardList

instance Pretty HsGuardedRhs where
        pretty :: HsGuardedRhs -> Doc
pretty (HsGuardedRhs _pos :: SrcLoc
_pos guard :: HsExp
guard body :: HsExp
body) =
                [Doc] -> Doc
myFsep [Char -> Doc
char '|', HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
guard, Doc
equals, HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
body]

instance Pretty HsLiteral where
        pretty :: HsLiteral -> Doc
pretty (HsInt i :: Integer
i)        = Integer -> Doc
integer Integer
i
        pretty (HsChar c :: Char
c)       = String -> Doc
text (Char -> String
forall a. Show a => a -> String
show Char
c)
        pretty (HsString s :: String
s)     = String -> Doc
text (String -> String
forall a. Show a => a -> String
show String
s)
        pretty (HsFrac r :: Rational
r)       = Double -> Doc
double (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r)
        -- GHC unboxed literals:
        pretty (HsCharPrim c :: Char
c)   = String -> Doc
text (Char -> String
forall a. Show a => a -> String
show Char
c)           Doc -> Doc -> Doc
<<>> Char -> Doc
char '#'
        pretty (HsStringPrim s :: String
s) = String -> Doc
text (String -> String
forall a. Show a => a -> String
show String
s)           Doc -> Doc -> Doc
<<>> Char -> Doc
char '#'
        pretty (HsIntPrim i :: Integer
i)    = Integer -> Doc
integer Integer
i               Doc -> Doc -> Doc
<<>> Char -> Doc
char '#'
        pretty (HsFloatPrim r :: Rational
r)  = Float -> Doc
float  (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
r) Doc -> Doc -> Doc
<<>> Char -> Doc
char '#'
        pretty (HsDoublePrim r :: Rational
r) = Double -> Doc
double (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r) Doc -> Doc -> Doc
<<>> String -> Doc
text "##"

instance Pretty HsExp where
        pretty :: HsExp -> Doc
pretty (HsLit l :: HsLiteral
l) = HsLiteral -> Doc
forall a. Pretty a => a -> Doc
pretty HsLiteral
l
        -- lambda stuff
        pretty (HsInfixApp a :: HsExp
a op :: HsQOp
op b :: HsExp
b) = [Doc] -> Doc
myFsep [HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
a, HsQOp -> Doc
forall a. Pretty a => a -> Doc
pretty HsQOp
op, HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
b]
        pretty (HsNegApp e :: HsExp
e) = [Doc] -> Doc
myFsep [Char -> Doc
char '-', HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e]
        pretty (HsApp a :: HsExp
a b :: HsExp
b) = [Doc] -> Doc
myFsep [HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
a, HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
b]
        pretty (HsLambda _loc :: SrcLoc
_loc expList :: [HsPat]
expList body :: HsExp
body) = [Doc] -> Doc
myFsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
                Char -> Doc
char '\\' Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (HsPat -> Doc) -> [HsPat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty [HsPat]
expList [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [String -> Doc
text "->", HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
body]
        -- keywords
        pretty (HsLet expList :: [HsDecl]
expList letBody :: HsExp
letBody) =
                [Doc] -> Doc
myFsep [String -> Doc
text "let" Doc -> Doc -> Doc
<+> (PPHsMode -> Indent) -> [Doc] -> Doc
ppBody PPHsMode -> Indent
letIndent ((HsDecl -> Doc) -> [HsDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsDecl -> Doc
forall a. Pretty a => a -> Doc
pretty [HsDecl]
expList),
                        String -> Doc
text "in", HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
letBody]
        pretty (HsIf cond :: HsExp
cond thenexp :: HsExp
thenexp elsexp :: HsExp
elsexp) =
                [Doc] -> Doc
myFsep [String -> Doc
text "if", HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
cond,
                        String -> Doc
text "then", HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
thenexp,
                        String -> Doc
text "else", HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
elsexp]
        pretty (HsCase cond :: HsExp
cond altList :: [HsAlt]
altList) =
                [Doc] -> Doc
myFsep [String -> Doc
text "case", HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
cond, String -> Doc
text "of"]
                Doc -> Doc -> Doc
$$$ (PPHsMode -> Indent) -> [Doc] -> Doc
ppBody PPHsMode -> Indent
caseIndent ((HsAlt -> Doc) -> [HsAlt] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsAlt -> Doc
forall a. Pretty a => a -> Doc
pretty [HsAlt]
altList)
        pretty (HsDo stmtList :: [HsStmt]
stmtList) =
                String -> Doc
text "do" Doc -> Doc -> Doc
$$$ (PPHsMode -> Indent) -> [Doc] -> Doc
ppBody PPHsMode -> Indent
doIndent ((HsStmt -> Doc) -> [HsStmt] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsStmt -> Doc
forall a. Pretty a => a -> Doc
pretty [HsStmt]
stmtList)
        -- Constructors & Vars
        pretty (HsVar name :: HsQName
name) = HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
name
        pretty (HsCon name :: HsQName
name) = HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
name
        pretty (HsTuple expList :: [HsExp]
expList) = [Doc] -> Doc
parenList ([Doc] -> Doc) -> ([HsExp] -> [Doc]) -> [HsExp] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsExp -> Doc) -> [HsExp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty ([HsExp] -> Doc) -> [HsExp] -> Doc
forall a b. (a -> b) -> a -> b
$ [HsExp]
expList
        -- weird stuff
        pretty (HsParen e :: HsExp
e) = Doc -> Doc
parens (Doc -> Doc) -> (HsExp -> Doc) -> HsExp -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty (HsExp -> Doc) -> HsExp -> Doc
forall a b. (a -> b) -> a -> b
$ HsExp
e
        pretty (HsLeftSection e :: HsExp
e op :: HsQOp
op) = Doc -> Doc
parens (HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e Doc -> Doc -> Doc
<+> HsQOp -> Doc
forall a. Pretty a => a -> Doc
pretty HsQOp
op)
        pretty (HsRightSection op :: HsQOp
op e :: HsExp
e) = Doc -> Doc
parens (HsQOp -> Doc
forall a. Pretty a => a -> Doc
pretty HsQOp
op Doc -> Doc -> Doc
<+> HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e)
        pretty (HsRecConstr c :: HsQName
c fieldList :: [HsFieldUpdate]
fieldList) =
                HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
c Doc -> Doc -> Doc
<<>> ([Doc] -> Doc
braceList ([Doc] -> Doc)
-> ([HsFieldUpdate] -> [Doc]) -> [HsFieldUpdate] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsFieldUpdate -> Doc) -> [HsFieldUpdate] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsFieldUpdate -> Doc
forall a. Pretty a => a -> Doc
pretty ([HsFieldUpdate] -> Doc) -> [HsFieldUpdate] -> Doc
forall a b. (a -> b) -> a -> b
$ [HsFieldUpdate]
fieldList)
        pretty (HsRecUpdate e :: HsExp
e fieldList :: [HsFieldUpdate]
fieldList) =
                HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e Doc -> Doc -> Doc
<<>> ([Doc] -> Doc
braceList ([Doc] -> Doc)
-> ([HsFieldUpdate] -> [Doc]) -> [HsFieldUpdate] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsFieldUpdate -> Doc) -> [HsFieldUpdate] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsFieldUpdate -> Doc
forall a. Pretty a => a -> Doc
pretty ([HsFieldUpdate] -> Doc) -> [HsFieldUpdate] -> Doc
forall a b. (a -> b) -> a -> b
$ [HsFieldUpdate]
fieldList)
        -- patterns
        -- special case that would otherwise be buggy
        pretty (HsAsPat name :: HsName
name (HsIrrPat e :: HsExp
e)) =
                [Doc] -> Doc
myFsep [HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name Doc -> Doc -> Doc
<<>> Char -> Doc
char '@', Char -> Doc
char '~' Doc -> Doc -> Doc
<<>> HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e]
        pretty (HsAsPat name :: HsName
name e :: HsExp
e) = [Doc] -> Doc
hcat [HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name, Char -> Doc
char '@', HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e]
        pretty HsWildCard = Char -> Doc
char '_'
        pretty (HsIrrPat e :: HsExp
e) = Char -> Doc
char '~' Doc -> Doc -> Doc
<<>> HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e
        -- Lists
        pretty (HsList list :: [HsExp]
list) =
                [Doc] -> Doc
bracketList ([Doc] -> Doc) -> ([HsExp] -> [Doc]) -> [HsExp] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([HsExp] -> [Doc]) -> [HsExp] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsExp -> Doc) -> [HsExp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty ([HsExp] -> Doc) -> [HsExp] -> Doc
forall a b. (a -> b) -> a -> b
$ [HsExp]
list
        pretty (HsEnumFrom e :: HsExp
e) =
                [Doc] -> Doc
bracketList [HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e, String -> Doc
text ".."]
        pretty (HsEnumFromTo from :: HsExp
from to :: HsExp
to) =
                [Doc] -> Doc
bracketList [HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
from, String -> Doc
text "..", HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
to]
        pretty (HsEnumFromThen from :: HsExp
from thenE :: HsExp
thenE) =
                [Doc] -> Doc
bracketList [HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
from Doc -> Doc -> Doc
<<>> Doc
comma, HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
thenE, String -> Doc
text ".."]
        pretty (HsEnumFromThenTo from :: HsExp
from thenE :: HsExp
thenE to :: HsExp
to) =
                [Doc] -> Doc
bracketList [HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
from Doc -> Doc -> Doc
<<>> Doc
comma, HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
thenE,
                             String -> Doc
text "..", HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
to]
        pretty (HsListComp e :: HsExp
e stmtList :: [HsStmt]
stmtList) =
                [Doc] -> Doc
bracketList ([HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e, Char -> Doc
char '|']
                             [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([HsStmt] -> [Doc]) -> [HsStmt] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsStmt -> Doc) -> [HsStmt] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsStmt -> Doc
forall a. Pretty a => a -> Doc
pretty ([HsStmt] -> [Doc]) -> [HsStmt] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [HsStmt]
stmtList))
        pretty (HsExpTypeSig _pos :: SrcLoc
_pos e :: HsExp
e ty :: HsQualType
ty) =
                [Doc] -> Doc
myFsep [HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e, String -> Doc
text "::", HsQualType -> Doc
forall a. Pretty a => a -> Doc
pretty HsQualType
ty]

------------------------- Patterns -----------------------------

instance Pretty HsPat where
        prettyPrec :: Indent -> HsPat -> Doc
prettyPrec _ (HsPVar name :: HsName
name) = HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name
        prettyPrec _ (HsPLit lit :: HsLiteral
lit) = HsLiteral -> Doc
forall a. Pretty a => a -> Doc
pretty HsLiteral
lit
        prettyPrec _ (HsPNeg p :: HsPat
p) = [Doc] -> Doc
myFsep [Char -> Doc
char '-', HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty HsPat
p]
        prettyPrec p :: Indent
p (HsPInfixApp a :: HsPat
a op :: HsQName
op b :: HsPat
b) = Bool -> Doc -> Doc
parensIf (Indent
p Indent -> Indent -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
myFsep [HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty HsPat
a, HsQOp -> Doc
forall a. Pretty a => a -> Doc
pretty (HsQName -> HsQOp
HsQConOp HsQName
op), HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty HsPat
b]
        prettyPrec p :: Indent
p (HsPApp n :: HsQName
n ps :: [HsPat]
ps) = Bool -> Doc -> Doc
parensIf (Indent
p Indent -> Indent -> Bool
forall a. Ord a => a -> a -> Bool
> 1) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
myFsep (HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
n Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (HsPat -> Doc) -> [HsPat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty [HsPat]
ps)
        prettyPrec _ (HsPTuple ps :: [HsPat]
ps) = [Doc] -> Doc
parenList ([Doc] -> Doc) -> ([HsPat] -> [Doc]) -> [HsPat] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsPat -> Doc) -> [HsPat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty ([HsPat] -> Doc) -> [HsPat] -> Doc
forall a b. (a -> b) -> a -> b
$ [HsPat]
ps
        prettyPrec _ (HsPList ps :: [HsPat]
ps) =
                [Doc] -> Doc
bracketList ([Doc] -> Doc) -> ([HsPat] -> [Doc]) -> [HsPat] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([HsPat] -> [Doc]) -> [HsPat] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsPat -> Doc) -> [HsPat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty ([HsPat] -> Doc) -> [HsPat] -> Doc
forall a b. (a -> b) -> a -> b
$ [HsPat]
ps
        prettyPrec _ (HsPParen p :: HsPat
p) = Doc -> Doc
parens (Doc -> Doc) -> (HsPat -> Doc) -> HsPat -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty (HsPat -> Doc) -> HsPat -> Doc
forall a b. (a -> b) -> a -> b
$ HsPat
p
        prettyPrec _ (HsPRec c :: HsQName
c fields :: [HsPatField]
fields) =
                HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
c Doc -> Doc -> Doc
<<>> ([Doc] -> Doc
braceList ([Doc] -> Doc) -> ([HsPatField] -> [Doc]) -> [HsPatField] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsPatField -> Doc) -> [HsPatField] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsPatField -> Doc
forall a. Pretty a => a -> Doc
pretty ([HsPatField] -> Doc) -> [HsPatField] -> Doc
forall a b. (a -> b) -> a -> b
$ [HsPatField]
fields)
        -- special case that would otherwise be buggy
        prettyPrec _ (HsPAsPat name :: HsName
name (HsPIrrPat pat :: HsPat
pat)) =
                [Doc] -> Doc
myFsep [HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name Doc -> Doc -> Doc
<<>> Char -> Doc
char '@', Char -> Doc
char '~' Doc -> Doc -> Doc
<<>> HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty HsPat
pat]
        prettyPrec _ (HsPAsPat name :: HsName
name pat :: HsPat
pat) =
                [Doc] -> Doc
hcat [HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name, Char -> Doc
char '@', HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty HsPat
pat]
        prettyPrec _ HsPWildCard = Char -> Doc
char '_'
        prettyPrec _ (HsPIrrPat pat :: HsPat
pat) = Char -> Doc
char '~' Doc -> Doc -> Doc
<<>> HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty HsPat
pat

instance Pretty HsPatField where
        pretty :: HsPatField -> Doc
pretty (HsPFieldPat name :: HsQName
name pat :: HsPat
pat) =
                [Doc] -> Doc
myFsep [HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
name, Doc
equals, HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty HsPat
pat]

------------------------- Case bodies  -------------------------
instance Pretty HsAlt where
        pretty :: HsAlt -> Doc
pretty (HsAlt _pos :: SrcLoc
_pos e :: HsPat
e gAlts :: HsGuardedAlts
gAlts decls :: [HsDecl]
decls) =
                [Doc] -> Doc
myFsep [HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty HsPat
e, HsGuardedAlts -> Doc
forall a. Pretty a => a -> Doc
pretty HsGuardedAlts
gAlts] Doc -> Doc -> Doc
$$$ [HsDecl] -> Doc
ppWhere [HsDecl]
decls

instance Pretty HsGuardedAlts where
        pretty :: HsGuardedAlts -> Doc
pretty (HsUnGuardedAlt e :: HsExp
e)      = String -> Doc
text "->" Doc -> Doc -> Doc
<+> HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e
        pretty (HsGuardedAlts altList :: [HsGuardedAlt]
altList) = [Doc] -> Doc
myVcat ([Doc] -> Doc)
-> ([HsGuardedAlt] -> [Doc]) -> [HsGuardedAlt] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsGuardedAlt -> Doc) -> [HsGuardedAlt] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsGuardedAlt -> Doc
forall a. Pretty a => a -> Doc
pretty ([HsGuardedAlt] -> Doc) -> [HsGuardedAlt] -> Doc
forall a b. (a -> b) -> a -> b
$ [HsGuardedAlt]
altList

instance Pretty HsGuardedAlt where
        pretty :: HsGuardedAlt -> Doc
pretty (HsGuardedAlt _pos :: SrcLoc
_pos e :: HsExp
e body :: HsExp
body) =
                [Doc] -> Doc
myFsep [Char -> Doc
char '|', HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e, String -> Doc
text "->", HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
body]

------------------------- Statements in monads & list comprehensions -----
instance Pretty HsStmt where
        pretty :: HsStmt -> Doc
pretty (HsGenerator _loc :: SrcLoc
_loc e :: HsPat
e from :: HsExp
from) =
                HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty HsPat
e Doc -> Doc -> Doc
<+> String -> Doc
text "<-" Doc -> Doc -> Doc
<+> HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
from
        pretty (HsQualifier e :: HsExp
e) = HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e
        pretty (HsLetStmt declList :: [HsDecl]
declList) =
                String -> Doc
text "let" Doc -> Doc -> Doc
$$$ (PPHsMode -> Indent) -> [Doc] -> Doc
ppBody PPHsMode -> Indent
letIndent ((HsDecl -> Doc) -> [HsDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsDecl -> Doc
forall a. Pretty a => a -> Doc
pretty [HsDecl]
declList)

------------------------- Record updates
instance Pretty HsFieldUpdate where
        pretty :: HsFieldUpdate -> Doc
pretty (HsFieldUpdate name :: HsQName
name e :: HsExp
e) =
                [Doc] -> Doc
myFsep [HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
name, Doc
equals, HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e]

------------------------- Names -------------------------
instance Pretty HsQOp where
        pretty :: HsQOp -> Doc
pretty (HsQVarOp n :: HsQName
n) = HsQName -> Doc
ppHsQNameInfix HsQName
n
        pretty (HsQConOp n :: HsQName
n) = HsQName -> Doc
ppHsQNameInfix HsQName
n

ppHsQNameInfix :: HsQName -> Doc
ppHsQNameInfix :: HsQName -> Doc
ppHsQNameInfix name :: HsQName
name
        | HsName -> Bool
isSymbolName (HsQName -> HsName
getName HsQName
name) = HsQName -> Doc
ppHsQName HsQName
name
        | Bool
otherwise = Char -> Doc
char '`' Doc -> Doc -> Doc
<<>> HsQName -> Doc
ppHsQName HsQName
name Doc -> Doc -> Doc
<<>> Char -> Doc
char '`'

instance Pretty HsQName where
        pretty :: HsQName -> Doc
pretty name :: HsQName
name = Bool -> Doc -> Doc
parensIf (HsName -> Bool
isSymbolName (HsQName -> HsName
getName HsQName
name)) (HsQName -> Doc
ppHsQName HsQName
name)

ppHsQName :: HsQName -> Doc
ppHsQName :: HsQName -> Doc
ppHsQName (UnQual name :: HsName
name) = HsName -> Doc
ppHsName HsName
name
ppHsQName (Qual m :: Module
m name :: HsName
name) = Module -> Doc
forall a. Pretty a => a -> Doc
pretty Module
m Doc -> Doc -> Doc
<<>> Char -> Doc
char '.' Doc -> Doc -> Doc
<<>> HsName -> Doc
ppHsName HsName
name
ppHsQName (Special sym :: HsSpecialCon
sym) = String -> Doc
text (HsSpecialCon -> String
specialName HsSpecialCon
sym)

instance Pretty HsOp where
        pretty :: HsOp -> Doc
pretty (HsVarOp n :: HsName
n) = HsName -> Doc
ppHsNameInfix HsName
n
        pretty (HsConOp n :: HsName
n) = HsName -> Doc
ppHsNameInfix HsName
n

ppHsNameInfix :: HsName -> Doc
ppHsNameInfix :: HsName -> Doc
ppHsNameInfix name :: HsName
name
        | HsName -> Bool
isSymbolName HsName
name = HsName -> Doc
ppHsName HsName
name
        | Bool
otherwise = Char -> Doc
char '`' Doc -> Doc -> Doc
<<>> HsName -> Doc
ppHsName HsName
name Doc -> Doc -> Doc
<<>> Char -> Doc
char '`'

instance Pretty HsName where
        pretty :: HsName -> Doc
pretty name :: HsName
name = Bool -> Doc -> Doc
parensIf (HsName -> Bool
isSymbolName HsName
name) (HsName -> Doc
ppHsName HsName
name)

ppHsName :: HsName -> Doc
ppHsName :: HsName -> Doc
ppHsName (HsIdent s :: String
s)  = String -> Doc
text String
s
ppHsName (HsSymbol s :: String
s) = String -> Doc
text String
s

instance Pretty HsCName where
        pretty :: HsCName -> Doc
pretty (HsVarName n :: HsName
n) = HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
n
        pretty (HsConName n :: HsName
n) = HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
n

isSymbolName :: HsName -> Bool
isSymbolName :: HsName -> Bool
isSymbolName (HsSymbol _) = Bool
True
isSymbolName _            = Bool
False

getName :: HsQName -> HsName
getName :: HsQName -> HsName
getName (UnQual s :: HsName
s)         = HsName
s
getName (Qual _ s :: HsName
s)         = HsName
s
getName (Special HsCons)   = String -> HsName
HsSymbol ":"
getName (Special HsFunCon) = String -> HsName
HsSymbol "->"
getName (Special s :: HsSpecialCon
s)        = String -> HsName
HsIdent (HsSpecialCon -> String
specialName HsSpecialCon
s)

specialName :: HsSpecialCon -> String
specialName :: HsSpecialCon -> String
specialName HsUnitCon      = "()"
specialName HsListCon      = "[]"
specialName HsFunCon       = "->"
specialName (HsTupleCon n :: Indent
n) = "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Indent -> Char -> String
forall a. Indent -> a -> [a]
replicate (Indent
nIndent -> Indent -> Indent
forall a. Num a => a -> a -> a
-1) ',' String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
specialName HsCons         = ":"

ppHsContext :: HsContext -> Doc
ppHsContext :: HsContext -> Doc
ppHsContext []      = Doc
empty
ppHsContext context :: HsContext
context = [Doc] -> Doc
mySep [[Doc] -> Doc
parenList ((HsAsst -> Doc) -> HsContext -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsAsst -> Doc
ppHsAsst HsContext
context), String -> Doc
text "=>"]

-- hacked for multi-parameter type classes

ppHsAsst :: HsAsst -> Doc
ppHsAsst :: HsAsst -> Doc
ppHsAsst (a :: HsQName
a,ts :: [HsType]
ts) = [Doc] -> Doc
myFsep (HsQName -> Doc
ppHsQName HsQName
a Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (HsType -> Doc) -> [HsType] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map HsType -> Doc
ppHsAType [HsType]
ts)

------------------------- pp utils -------------------------
maybePP :: (a -> Doc) -> Maybe a -> Doc
maybePP :: (a -> Doc) -> Maybe a -> Doc
maybePP _ Nothing   = Doc
empty
maybePP pp :: a -> Doc
pp (Just a :: a
a) = a -> Doc
pp a
a

parenList :: [Doc] -> Doc
parenList :: [Doc] -> Doc
parenList = Doc -> Doc
parens (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
myFsepSimple ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma

braceList :: [Doc] -> Doc
braceList :: [Doc] -> Doc
braceList = Doc -> Doc
braces (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
myFsepSimple ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma

bracketList :: [Doc] -> Doc
bracketList :: [Doc] -> Doc
bracketList = Doc -> Doc
brackets (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
myFsepSimple

-- Wrap in braces and semicolons, with an extra space at the start in
-- case the first doc begins with "-", which would be scanned as {-
flatBlock :: [Doc] -> Doc
flatBlock :: [Doc] -> Doc
flatBlock = Doc -> Doc
braces (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc
space Doc -> Doc -> Doc
<<>>) (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
hsep ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
semi

-- Same, but put each thing on a separate line
prettyBlock :: [Doc] -> Doc
prettyBlock :: [Doc] -> Doc
prettyBlock = Doc -> Doc
braces (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc
space Doc -> Doc -> Doc
<<>>) (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
semi

-- Monadic PP Combinators -- these examine the env

blankline :: Doc -> Doc
blankline :: Doc -> Doc
blankline dl :: Doc
dl = do{PPHsMode
e<-DocM PPHsMode PPHsMode
forall s. DocM s s
getPPEnv;if PPHsMode -> Bool
spacing PPHsMode
e Bool -> Bool -> Bool
&& PPHsMode -> PPLayout
layout PPHsMode
e PPLayout -> PPLayout -> Bool
forall a. Eq a => a -> a -> Bool
/= PPLayout
PPNoLayout
                              then Doc
space Doc -> Doc -> Doc
$$ Doc
dl else Doc
dl}
topLevel :: Doc -> [Doc] -> Doc
topLevel :: Doc -> [Doc] -> Doc
topLevel header :: Doc
header dl :: [Doc]
dl = do
         PPLayout
e <- (PPHsMode -> PPLayout)
-> DocM PPHsMode PPHsMode -> DocM PPHsMode PPLayout
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PPHsMode -> PPLayout
layout DocM PPHsMode PPHsMode
forall s. DocM s s
getPPEnv
         case PPLayout
e of
             PPOffsideRule -> Doc
header Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat [Doc]
dl
             PPSemiColon   -> Doc
header Doc -> Doc -> Doc
$$ [Doc] -> Doc
prettyBlock [Doc]
dl
             PPInLine      -> Doc
header Doc -> Doc -> Doc
$$ [Doc] -> Doc
prettyBlock [Doc]
dl
             PPNoLayout    -> Doc
header Doc -> Doc -> Doc
<+> [Doc] -> Doc
flatBlock [Doc]
dl

ppBody :: (PPHsMode -> Int) -> [Doc] -> Doc
ppBody :: (PPHsMode -> Indent) -> [Doc] -> Doc
ppBody f :: PPHsMode -> Indent
f dl :: [Doc]
dl = do
        PPLayout
e <- (PPHsMode -> PPLayout)
-> DocM PPHsMode PPHsMode -> DocM PPHsMode PPLayout
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PPHsMode -> PPLayout
layout DocM PPHsMode PPHsMode
forall s. DocM s s
getPPEnv
        Indent
i <- (PPHsMode -> Indent)
-> DocM PPHsMode PPHsMode -> DocM PPHsMode Indent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PPHsMode -> Indent
f DocM PPHsMode PPHsMode
forall s. DocM s s
getPPEnv
        case PPLayout
e of
            PPOffsideRule -> Indent -> Doc -> Doc
nest Indent
i (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc]
dl
            PPSemiColon   -> Indent -> Doc -> Doc
nest Indent
i (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
prettyBlock ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc]
dl
            _             -> [Doc] -> Doc
flatBlock [Doc]
dl

ppBindings :: [Doc] -> Doc
ppBindings :: [Doc] -> Doc
ppBindings dl :: [Doc]
dl = do
        PPLayout
e <- (PPHsMode -> PPLayout)
-> DocM PPHsMode PPHsMode -> DocM PPHsMode PPLayout
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PPHsMode -> PPLayout
layout DocM PPHsMode PPHsMode
forall s. DocM s s
getPPEnv
        case PPLayout
e of
            PPOffsideRule -> [Doc] -> Doc
vcat [Doc]
dl
            PPSemiColon   -> [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
semi ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc]
dl
            _             -> [Doc] -> Doc
hsep ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
semi ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc]
dl

($$$) :: Doc -> Doc -> Doc
a :: Doc
a $$$ :: Doc -> Doc -> Doc
$$$ b :: Doc
b = (Doc -> Doc) -> (Doc -> Doc) -> Doc -> Doc
forall a. (a -> Doc) -> (a -> Doc) -> a -> Doc
layoutChoice (Doc
a Doc -> Doc -> Doc
$$) (Doc
a Doc -> Doc -> Doc
<+>) Doc
b

mySep :: [Doc] -> Doc
mySep :: [Doc] -> Doc
mySep = ([Doc] -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall a. (a -> Doc) -> (a -> Doc) -> a -> Doc
layoutChoice [Doc] -> Doc
mySep' [Doc] -> Doc
hsep
        where
        -- ensure paragraph fills with indentation.
        mySep' :: [Doc] -> Doc
mySep' [x :: Doc
x]    = Doc
x
        mySep' (x :: Doc
x:xs :: [Doc]
xs) = Doc
x Doc -> Doc -> Doc
<+> [Doc] -> Doc
fsep [Doc]
xs
        mySep' []     = String -> Doc
forall a. HasCallStack => String -> a
error "Internal error: mySep"

myVcat :: [Doc] -> Doc
myVcat :: [Doc] -> Doc
myVcat = ([Doc] -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall a. (a -> Doc) -> (a -> Doc) -> a -> Doc
layoutChoice [Doc] -> Doc
vcat [Doc] -> Doc
hsep

myFsepSimple :: [Doc] -> Doc
myFsepSimple :: [Doc] -> Doc
myFsepSimple = ([Doc] -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall a. (a -> Doc) -> (a -> Doc) -> a -> Doc
layoutChoice [Doc] -> Doc
fsep [Doc] -> Doc
hsep

-- same, except that continuation lines are indented,
-- which is necessary to avoid triggering the offside rule.
myFsep :: [Doc] -> Doc
myFsep :: [Doc] -> Doc
myFsep = ([Doc] -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall a. (a -> Doc) -> (a -> Doc) -> a -> Doc
layoutChoice [Doc] -> Doc
fsep' [Doc] -> Doc
hsep
        where   fsep' :: [Doc] -> Doc
fsep' [] = Doc
empty
                fsep' (d :: Doc
d:ds :: [Doc]
ds) = do
                        PPHsMode
e <- DocM PPHsMode PPHsMode
forall s. DocM s s
getPPEnv
                        let n :: Indent
n = PPHsMode -> Indent
onsideIndent PPHsMode
e
                        Indent -> Doc -> Doc
nest Indent
n ([Doc] -> Doc
fsep (Indent -> Doc -> Doc
nest (-Indent
n) Doc
dDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ds))

layoutChoice :: (a -> Doc) -> (a -> Doc) -> a -> Doc
layoutChoice :: (a -> Doc) -> (a -> Doc) -> a -> Doc
layoutChoice a :: a -> Doc
a b :: a -> Doc
b dl :: a
dl = do PPHsMode
e <- DocM PPHsMode PPHsMode
forall s. DocM s s
getPPEnv
                         if PPHsMode -> PPLayout
layout PPHsMode
e PPLayout -> PPLayout -> Bool
forall a. Eq a => a -> a -> Bool
== PPLayout
PPOffsideRule Bool -> Bool -> Bool
||
                            PPHsMode -> PPLayout
layout PPHsMode
e PPLayout -> PPLayout -> Bool
forall a. Eq a => a -> a -> Bool
== PPLayout
PPSemiColon
                          then a -> Doc
a a
dl else a -> Doc
b a
dl

-- Prefix something with a LINE pragma, if requested.
-- GHC's LINE pragma actually sets the current line number to n-1, so
-- that the following line is line n.  But if there's no newline before
-- the line we're talking about, we need to compensate by adding 1.

markLine :: SrcLoc -> Doc -> Doc
markLine :: SrcLoc -> Doc -> Doc
markLine loc :: SrcLoc
loc doc :: Doc
doc = do
        PPHsMode
e <- DocM PPHsMode PPHsMode
forall s. DocM s s
getPPEnv
        let y :: Indent
y = SrcLoc -> Indent
srcLine SrcLoc
loc
        let line :: a -> Doc
line l :: a
l =
              String -> Doc
text ("{-# LINE " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ " \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SrcLoc -> String
srcFilename SrcLoc
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\" #-}")
        if PPHsMode -> Bool
linePragmas PPHsMode
e then (Doc -> Doc) -> (Doc -> Doc) -> Doc -> Doc
forall a. (a -> Doc) -> (a -> Doc) -> a -> Doc
layoutChoice (Indent -> Doc
forall a. Show a => a -> Doc
line Indent
y Doc -> Doc -> Doc
$$) (Indent -> Doc
forall a. Show a => a -> Doc
line (Indent
yIndent -> Indent -> Indent
forall a. Num a => a -> a -> a
+1) Doc -> Doc -> Doc
<+>) Doc
doc
              else Doc
doc