-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.Pretty
-- Copyright   :  (c) The GHC Team, Noel Winstanley 1997-2000
-- License     :  BSD-3-Clause
--
-- Maintainer  :  Andreas Abel
-- Stability   :  stable
-- 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.Applicative as App (Applicative (..))
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
$c== :: PPLayout -> PPLayout -> Bool
== :: PPLayout -> PPLayout -> Bool
$c/= :: PPLayout -> PPLayout -> Bool
/= :: 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 -> Int
classIndent  :: Indent,
                                -- | Indentation of a @do@-expression.
                PPHsMode -> Int
doIndent     :: Indent,
                                -- | Indentation of the body of a
                                -- @case@ expression.
                PPHsMode -> Int
caseIndent   :: Indent,
                                -- | Indentation of the declarations in a
                                -- @let@ expression.
                PPHsMode -> Int
letIndent    :: Indent,
                                -- | Indentation of the declarations in a
                                -- @where@ clause.
                PPHsMode -> Int
whereIndent  :: Indent,
                                -- | Indentation added for continuation
                                -- lines that would otherwise be offside.
                PPHsMode -> Int
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{
                      classIndent :: Int
classIndent = Int
8,
                      doIndent :: Int
doIndent = Int
3,
                      caseIndent :: Int
caseIndent = Int
4,
                      letIndent :: Int
letIndent = Int
4,
                      whereIndent :: Int
whereIndent = Int
6,
                      onsideIndent :: Int
onsideIndent = Int
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 :: forall a b. (a -> b) -> DocM s a -> DocM s b
fmap a -> b
f DocM s a
xs = do x <- DocM s a
xs; return (f x)

-- | @since 1.0.2.0
instance App.Applicative (DocM s) where
        pure :: forall a. a -> DocM s a
pure = a -> DocM s a
forall a s. a -> DocM s a
retDocM
        <*> :: forall a b. 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
        *> :: forall a b. 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
        >>= :: forall a b. 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
        >> :: forall a b. DocM s a -> DocM s b -> DocM s b
(>>) = DocM s a -> DocM s b -> DocM s b
forall a b. DocM s a -> DocM s b -> DocM s b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
        return :: forall a. a -> DocM s a
return = a -> DocM s a
forall a. a -> DocM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

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

thenDocM :: DocM s a -> (a -> DocM s b) -> DocM s b
thenDocM :: forall s a b. DocM s a -> (a -> DocM s b) -> DocM s b
thenDocM DocM s a
m 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 -> 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 -> 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 :: forall s a b. DocM s a -> DocM s b -> DocM s b
then_DocM DocM s a
m 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 -> 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
_ -> 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 :: forall a s. a -> DocM s a
retDocM a
a = (s -> a) -> DocM s a
forall s a. (s -> a) -> DocM s a
DocM (\s
_s -> a
a)

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

-- all this extra stuff, just for this one function.
getPPEnv :: DocM s s
getPPEnv :: forall s. 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 = Int -> a -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
0
        prettyPrec Int
_ = a -> Doc
forall a. Pretty a => a -> Doc
pretty

-- The pretty printing combinators

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

nest :: Int -> Doc -> Doc
nest :: Int -> Doc -> Doc
nest Int
i Doc
m = Doc
m Doc -> (Doc -> Doc) -> Doc
forall a b.
DocM PPHsMode a -> (a -> DocM PPHsMode b) -> DocM PPHsMode b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Doc -> Doc
forall a. a -> DocM PPHsMode a
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
. Int -> Doc -> Doc
P.nest Int
i


-- Literals

text :: String -> Doc
text :: String -> Doc
text = Doc -> Doc
forall a. a -> DocM PPHsMode a
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 a. a -> DocM PPHsMode a
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 :: Int -> Doc
int = Doc -> Doc
forall a. a -> DocM PPHsMode a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (Int -> Doc) -> Int -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc
P.int

integer :: Integer -> Doc
integer :: Integer -> Doc
integer = Doc -> Doc
forall a. a -> DocM PPHsMode a
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 a. a -> DocM PPHsMode a
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 a. a -> DocM PPHsMode a
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 Doc
d = Doc
d Doc -> (Doc -> Doc) -> Doc
forall a b.
DocM PPHsMode a -> (a -> DocM PPHsMode b) -> DocM PPHsMode b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Doc -> Doc
forall a. a -> DocM PPHsMode a
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 Doc
d = Doc
d Doc -> (Doc -> Doc) -> Doc
forall a b.
DocM PPHsMode a -> (a -> DocM PPHsMode b) -> DocM PPHsMode b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Doc -> Doc
forall a. a -> DocM PPHsMode a
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 Doc
d = Doc
d Doc -> (Doc -> Doc) -> Doc
forall a b.
DocM PPHsMode a -> (a -> DocM PPHsMode b) -> DocM PPHsMode b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Doc -> Doc
forall a. a -> DocM PPHsMode a
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 Bool
True  = Doc -> Doc
parens
parensIf Bool
False = Doc -> Doc
forall a. a -> a
id

-- Constants

semi,comma,space,equals :: Doc
semi :: Doc
semi = Doc -> Doc
forall a. a -> DocM PPHsMode a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
P.semi
comma :: Doc
comma = Doc -> Doc
forall a. a -> DocM PPHsMode a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
P.comma
-- colon = return P.colon
space :: Doc
space = Doc -> Doc
forall a. a -> DocM PPHsMode a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
P.space
equals :: Doc
equals = Doc -> Doc
forall a. a -> DocM PPHsMode a
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
Doc
aM <<>> :: Doc -> Doc -> Doc
<<>> Doc
bM = do{a<-Doc
aM;b<-bM;return (a P.<> b)}
Doc
aM <+> :: Doc -> Doc -> Doc
<+> Doc
bM = do{a<-Doc
aM;b<-bM;return (a P.<+> b)}
Doc
aM $$ :: Doc -> Doc -> Doc
$$ Doc
bM = do{a<-Doc
aM;b<-bM;return (a P.$$ b)}
-- aM $+$ bM = do{a<-aM;b<-bM;return (a P.$+$ b)}

hcat,hsep,vcat,fsep :: [Doc] -> Doc
hcat :: [Doc] -> Doc
hcat [Doc]
dl = [Doc] -> DocM PPHsMode [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Doc]
dl DocM PPHsMode [Doc] -> ([Doc] -> Doc) -> Doc
forall a b.
DocM PPHsMode a -> (a -> DocM PPHsMode b) -> DocM PPHsMode b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Doc -> Doc
forall a. a -> DocM PPHsMode a
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 [Doc]
dl = [Doc] -> DocM PPHsMode [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Doc]
dl DocM PPHsMode [Doc] -> ([Doc] -> Doc) -> Doc
forall a b.
DocM PPHsMode a -> (a -> DocM PPHsMode b) -> DocM PPHsMode b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Doc -> Doc
forall a. a -> DocM PPHsMode a
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 [Doc]
dl = [Doc] -> DocM PPHsMode [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Doc]
dl DocM PPHsMode [Doc] -> ([Doc] -> Doc) -> Doc
forall a b.
DocM PPHsMode a -> (a -> DocM PPHsMode b) -> DocM PPHsMode b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Doc -> Doc
forall a. a -> DocM PPHsMode a
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 [Doc]
dl = [Doc] -> DocM PPHsMode [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Doc]
dl DocM PPHsMode [Doc] -> ([Doc] -> Doc) -> Doc
forall a b.
DocM PPHsMode a -> (a -> DocM PPHsMode b) -> DocM PPHsMode b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Doc -> Doc
forall a. a -> DocM PPHsMode a
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 Doc
_ []     = []
punctuate Doc
p (Doc
d1:[Doc]
ds) = Doc -> [Doc] -> [Doc]
go Doc
d1 [Doc]
ds
                   where
                     go :: Doc -> [Doc] -> [Doc]
go Doc
d []     = [Doc
d]
                     go Doc
d (Doc
e:[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 Style
ppStyle PPHsMode
ppMode 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 :: forall a. Pretty a => Style -> PPHsMode -> a -> String
prettyPrintStyleMode Style
ppStyle 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 :: forall a. Pretty a => 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 :: forall a. Pretty a => 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 SrcLoc
pos Module
m Maybe [HsExportSpec]
mbExports [HsImportDecl]
imp [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 Module
m Maybe [HsExportSpec]
mbExportList = [Doc] -> Doc
mySep [
        String -> Doc
text String
"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 String
"where"]

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

instance Pretty HsExportSpec where
        pretty :: HsExportSpec -> Doc
pretty (HsEVar HsQName
name)                = HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
name
        pretty (HsEAbs HsQName
name)                = HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
name
        pretty (HsEThingAll HsQName
name)           = HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
name Doc -> Doc -> Doc
<<>> String -> Doc
text String
"(..)"
        pretty (HsEThingWith HsQName
name [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 Module
m)       = String -> Doc
text String
"module" Doc -> Doc -> Doc
<+> Module -> Doc
forall a. Pretty a => a -> Doc
pretty Module
m

instance Pretty HsImportDecl where
        pretty :: HsImportDecl -> Doc
pretty (HsImportDecl SrcLoc
pos Module
m Bool
qual Maybe Module
mbName 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 String
"import",
                       if Bool
qual then String -> Doc
text String
"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 (\Module
m' -> String -> Doc
text String
"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 (Bool
b,[a]
specList) =
                        if Bool
b then String -> Doc
text String
"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 HsName
name)                = HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name
        pretty (HsIAbs HsName
name)                = HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name
        pretty (HsIThingAll HsName
name)           = HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name Doc -> Doc -> Doc
<<>> String -> Doc
text String
"(..)"
        pretty (HsIThingWith HsName
name [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 SrcLoc
loc HsName
name [HsName]
nameList 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 String
"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 SrcLoc
loc HsContext
context HsName
name [HsName]
nameList [HsConDecl]
constrList [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 String
"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 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 SrcLoc
pos HsContext
context HsName
name [HsName]
nameList HsConDecl
constr [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 String
"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 SrcLoc
pos HsContext
context HsName
name [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 String
"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 SrcLoc
pos HsContext
context HsName
name [HsName]
nameList [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 String
"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 String
"where"])
                Doc -> Doc -> Doc
$$$ (PPHsMode -> Int) -> [Doc] -> Doc
ppBody PPHsMode -> Int
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 SrcLoc
pos HsContext
context HsQName
name [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 String
"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 SrcLoc
pos HsContext
context HsQName
name [HsType]
args [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 String
"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 String
"where"])
                Doc -> Doc -> Doc
$$$ (PPHsMode -> Int) -> [Doc] -> Doc
ppBody PPHsMode -> Int
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 SrcLoc
pos [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 String
"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 SrcLoc
pos [HsName]
nameList 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 String
"::", HsQualType -> Doc
forall a. Pretty a => a -> Doc
pretty HsQualType
qualType])

        pretty (HsForeignImport SrcLoc
pos String
conv HsSafety
safety String
entity HsName
name 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 String
"foreign", String -> Doc
text String
"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 a. [a] -> 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 String
"::", HsType -> Doc
forall a. Pretty a => a -> Doc
pretty HsType
ty]

        pretty (HsForeignExport SrcLoc
pos String
conv String
entity HsName
name 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 String
"foreign", String -> Doc
text String
"export", String -> Doc
text String
conv] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++
                        (if String -> Bool
forall a. [a] -> 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 String
"::", HsType -> Doc
forall a. Pretty a => a -> Doc
pretty HsType
ty]

        pretty (HsFunBind [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 SrcLoc
pos HsPat
pat HsRhs
rhs [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 SrcLoc
pos HsAssoc
assoc Int
prec [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, Int -> Doc
int Int
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 HsAssoc
HsAssocNone  = String -> Doc
text String
"infix"
        pretty HsAssoc
HsAssocLeft  = String -> Doc
text String
"infixl"
        pretty HsAssoc
HsAssocRight = String -> Doc
text String
"infixr"

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

instance Pretty HsMatch where
        pretty :: HsMatch -> Doc
pretty (HsMatch SrcLoc
pos HsName
f [HsPat]
ps HsRhs
rhs [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
                        HsPat
l:HsPat
r:[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 a. [a] -> 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 (Int -> HsPat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
2) [HsPat]
ps'
                        [HsPat]
_ -> 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 (Int -> HsPat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
2) [HsPat]
ps

ppWhere :: [HsDecl] -> Doc
ppWhere :: [HsDecl] -> Doc
ppWhere [] = Doc
empty
ppWhere [HsDecl]
l  = Int -> Doc -> Doc
nest Int
2 (String -> Doc
text String
"where" Doc -> Doc -> Doc
$$$ (PPHsMode -> Int) -> [Doc] -> Doc
ppBody PPHsMode -> Int
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 SrcLoc
_pos HsName
name [([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 SrcLoc
_pos name :: HsName
name@(HsSymbol String
_) [HsBangType
l, HsBangType
r]) =
                [Doc] -> Doc
myFsep [Int -> HsBangType -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
prec_btype HsBangType
l, HsName -> Doc
ppHsName HsName
name,
                        Int -> HsBangType -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
prec_btype HsBangType
r]
        pretty (HsConDecl SrcLoc
_pos HsName
name [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 (Int -> HsBangType -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
prec_atype) [HsBangType]
typeList

ppField :: ([HsName],HsBangType) -> Doc
ppField :: ([HsName], HsBangType) -> Doc
ppField ([HsName]
names, 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 String
"::", HsBangType -> Doc
forall a. Pretty a => a -> Doc
pretty HsBangType
ty]

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

ppHsDeriving :: [HsQName] -> Doc
ppHsDeriving :: [HsQName] -> Doc
ppHsDeriving []  = Doc
empty
ppHsDeriving [HsQName
d] = String -> Doc
text String
"deriving" Doc -> Doc -> Doc
<+> HsQName -> Doc
ppHsQName HsQName
d
ppHsDeriving [HsQName]
ds  = String -> Doc
text String
"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 HsContext
context 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 = Int -> HsType -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
prec_btype

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

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

instance Pretty HsType where
        prettyPrec :: Int -> HsType -> Doc
prettyPrec Int
p (HsTyFun HsType
a HsType
b) = Bool -> Doc -> Doc
parensIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
myFsep [HsType -> Doc
ppHsBType HsType
a, String -> Doc
text String
"->", HsType -> Doc
forall a. Pretty a => a -> Doc
pretty HsType
b]
        prettyPrec Int
_ (HsTyTuple [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 Int
p (HsTyApp HsType
a 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 (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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 Int
_ (HsTyVar HsName
name) = HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name
        prettyPrec Int
_ (HsTyCon HsQName
name) = HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
name

------------------------- Expressions -------------------------
instance Pretty HsRhs where
        pretty :: HsRhs -> Doc
pretty (HsUnGuardedRhs HsExp
e)        = Doc
equals Doc -> Doc -> Doc
<+> HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e
        pretty (HsGuardedRhss [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 SrcLoc
_pos HsExp
guard HsExp
body) =
                [Doc] -> Doc
myFsep [Char -> Doc
char 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 Integer
i)        = Integer -> Doc
integer Integer
i
        pretty (HsChar Char
c)       = String -> Doc
text (Char -> String
forall a. Show a => a -> String
show Char
c)
        pretty (HsString String
s)     = String -> Doc
text (String -> String
forall a. Show a => a -> String
show String
s)
        pretty (HsFrac Rational
r)       = Double -> Doc
double (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r)
        -- GHC unboxed literals:
        pretty (HsCharPrim Char
c)   = String -> Doc
text (Char -> String
forall a. Show a => a -> String
show Char
c)           Doc -> Doc -> Doc
<<>> Char -> Doc
char Char
'#'
        pretty (HsStringPrim String
s) = String -> Doc
text (String -> String
forall a. Show a => a -> String
show String
s)           Doc -> Doc -> Doc
<<>> Char -> Doc
char Char
'#'
        pretty (HsIntPrim Integer
i)    = Integer -> Doc
integer Integer
i               Doc -> Doc -> Doc
<<>> Char -> Doc
char Char
'#'
        pretty (HsFloatPrim Rational
r)  = Float -> Doc
float  (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
r) Doc -> Doc -> Doc
<<>> Char -> Doc
char Char
'#'
        pretty (HsDoublePrim Rational
r) = Double -> Doc
double (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r) Doc -> Doc -> Doc
<<>> String -> Doc
text String
"##"

instance Pretty HsExp where
        pretty :: HsExp -> Doc
pretty (HsLit HsLiteral
l) = HsLiteral -> Doc
forall a. Pretty a => a -> Doc
pretty HsLiteral
l
        -- lambda stuff
        pretty (HsInfixApp HsExp
a HsQOp
op 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 HsExp
e) = [Doc] -> Doc
myFsep [Char -> Doc
char Char
'-', HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e]
        pretty (HsApp HsExp
a 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 SrcLoc
_loc [HsPat]
expList HsExp
body) = [Doc] -> Doc
myFsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
                Char -> Doc
char 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 String
"->", HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
body]
        -- keywords
        pretty (HsLet [HsDecl]
expList HsExp
letBody) =
                [Doc] -> Doc
myFsep [String -> Doc
text String
"let" Doc -> Doc -> Doc
<+> (PPHsMode -> Int) -> [Doc] -> Doc
ppBody PPHsMode -> Int
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 String
"in", HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
letBody]
        pretty (HsIf HsExp
cond HsExp
thenexp HsExp
elsexp) =
                [Doc] -> Doc
myFsep [String -> Doc
text String
"if", HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
cond,
                        String -> Doc
text String
"then", HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
thenexp,
                        String -> Doc
text String
"else", HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
elsexp]
        pretty (HsCase HsExp
cond [HsAlt]
altList) =
                [Doc] -> Doc
myFsep [String -> Doc
text String
"case", HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
cond, String -> Doc
text String
"of"]
                Doc -> Doc -> Doc
$$$ (PPHsMode -> Int) -> [Doc] -> Doc
ppBody PPHsMode -> Int
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 [HsStmt]
stmtList) =
                String -> Doc
text String
"do" Doc -> Doc -> Doc
$$$ (PPHsMode -> Int) -> [Doc] -> Doc
ppBody PPHsMode -> Int
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 HsQName
name) = HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
name
        pretty (HsCon HsQName
name) = HsQName -> Doc
forall a. Pretty a => a -> Doc
pretty HsQName
name
        pretty (HsTuple [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 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 HsExp
e 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 HsQOp
op 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 HsQName
c [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 HsExp
e [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 HsName
name (HsIrrPat HsExp
e)) =
                [Doc] -> Doc
myFsep [HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name Doc -> Doc -> Doc
<<>> Char -> Doc
char Char
'@', Char -> Doc
char Char
'~' Doc -> Doc -> Doc
<<>> HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e]
        pretty (HsAsPat HsName
name HsExp
e) = [Doc] -> Doc
hcat [HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name, Char -> Doc
char Char
'@', HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e]
        pretty HsExp
HsWildCard = Char -> Doc
char Char
'_'
        pretty (HsIrrPat HsExp
e) = Char -> Doc
char Char
'~' Doc -> Doc -> Doc
<<>> HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e
        -- Lists
        pretty (HsList [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 HsExp
e) =
                [Doc] -> Doc
bracketList [HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e, String -> Doc
text String
".."]
        pretty (HsEnumFromTo HsExp
from HsExp
to) =
                [Doc] -> Doc
bracketList [HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
from, String -> Doc
text String
"..", HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
to]
        pretty (HsEnumFromThen HsExp
from 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 String
".."]
        pretty (HsEnumFromThenTo HsExp
from HsExp
thenE 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 String
"..", HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
to]
        pretty (HsListComp HsExp
e [HsStmt]
stmtList) =
                [Doc] -> Doc
bracketList ([HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e, Char -> Doc
char 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 SrcLoc
_pos HsExp
e HsQualType
ty) =
                [Doc] -> Doc
myFsep [HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e, String -> Doc
text String
"::", HsQualType -> Doc
forall a. Pretty a => a -> Doc
pretty HsQualType
ty]

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

instance Pretty HsPat where
        prettyPrec :: Int -> HsPat -> Doc
prettyPrec Int
_ (HsPVar HsName
name) = HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name
        prettyPrec Int
_ (HsPLit HsLiteral
lit) = HsLiteral -> Doc
forall a. Pretty a => a -> Doc
pretty HsLiteral
lit
        prettyPrec Int
_ (HsPNeg HsPat
p) = [Doc] -> Doc
myFsep [Char -> Doc
char Char
'-', HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty HsPat
p]
        prettyPrec Int
p (HsPInfixApp HsPat
a HsQName
op HsPat
b) = Bool -> Doc -> Doc
parensIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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 Int
p (HsPApp HsQName
n [HsPat]
ps) = Bool -> Doc -> Doc
parensIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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 Int
_ (HsPTuple [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 Int
_ (HsPList [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 Int
_ (HsPParen 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 Int
_ (HsPRec HsQName
c [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 Int
_ (HsPAsPat HsName
name (HsPIrrPat HsPat
pat)) =
                [Doc] -> Doc
myFsep [HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name Doc -> Doc -> Doc
<<>> Char -> Doc
char Char
'@', Char -> Doc
char Char
'~' Doc -> Doc -> Doc
<<>> HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty HsPat
pat]
        prettyPrec Int
_ (HsPAsPat HsName
name HsPat
pat) =
                [Doc] -> Doc
hcat [HsName -> Doc
forall a. Pretty a => a -> Doc
pretty HsName
name, Char -> Doc
char Char
'@', HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty HsPat
pat]
        prettyPrec Int
_ HsPat
HsPWildCard = Char -> Doc
char Char
'_'
        prettyPrec Int
_ (HsPIrrPat HsPat
pat) = Char -> Doc
char Char
'~' Doc -> Doc -> Doc
<<>> HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty HsPat
pat

instance Pretty HsPatField where
        pretty :: HsPatField -> Doc
pretty (HsPFieldPat HsQName
name 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 SrcLoc
_pos HsPat
e HsGuardedAlts
gAlts [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 HsExp
e)      = String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e
        pretty (HsGuardedAlts [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 SrcLoc
_pos HsExp
e HsExp
body) =
                [Doc] -> Doc
myFsep [Char -> Doc
char Char
'|', HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e, String -> Doc
text String
"->", 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 SrcLoc
_loc HsPat
e HsExp
from) =
                HsPat -> Doc
forall a. Pretty a => a -> Doc
pretty HsPat
e Doc -> Doc -> Doc
<+> String -> Doc
text String
"<-" Doc -> Doc -> Doc
<+> HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
from
        pretty (HsQualifier HsExp
e) = HsExp -> Doc
forall a. Pretty a => a -> Doc
pretty HsExp
e
        pretty (HsLetStmt [HsDecl]
declList) =
                String -> Doc
text String
"let" Doc -> Doc -> Doc
$$$ (PPHsMode -> Int) -> [Doc] -> Doc
ppBody PPHsMode -> Int
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 HsQName
name 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 HsQName
n) = HsQName -> Doc
ppHsQNameInfix HsQName
n
        pretty (HsQConOp HsQName
n) = HsQName -> Doc
ppHsQNameInfix HsQName
n

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

instance Pretty HsQName where
        pretty :: HsQName -> Doc
pretty 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 HsName
name) = HsName -> Doc
ppHsName HsName
name
ppHsQName (Qual Module
m HsName
name) = Module -> Doc
forall a. Pretty a => a -> Doc
pretty Module
m Doc -> Doc -> Doc
<<>> Char -> Doc
char Char
'.' Doc -> Doc -> Doc
<<>> HsName -> Doc
ppHsName HsName
name
ppHsQName (Special HsSpecialCon
sym) = String -> Doc
text (HsSpecialCon -> String
specialName HsSpecialCon
sym)

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

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

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

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

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

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

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

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

ppHsContext :: HsContext -> Doc
ppHsContext :: HsContext -> Doc
ppHsContext []      = Doc
empty
ppHsContext 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 String
"=>"]

-- hacked for multi-parameter type classes

ppHsAsst :: HsAsst -> Doc
ppHsAsst :: HsAsst -> Doc
ppHsAsst (HsQName
a,[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 :: forall a. (a -> Doc) -> Maybe a -> Doc
maybePP a -> Doc
_ Maybe a
Nothing   = Doc
empty
maybePP a -> Doc
pp (Just 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 Doc
dl = do{e<-DocM PPHsMode PPHsMode
forall s. DocM s s
getPPEnv;if spacing e && layout e /= PPNoLayout
                              then space $$ dl else dl}
topLevel :: Doc -> [Doc] -> Doc
topLevel :: Doc -> [Doc] -> Doc
topLevel Doc
header [Doc]
dl = do
         e <- (PPHsMode -> PPLayout)
-> DocM PPHsMode PPHsMode -> DocM PPHsMode PPLayout
forall a b. (a -> b) -> DocM PPHsMode a -> DocM PPHsMode b
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 e of
             PPLayout
PPOffsideRule -> Doc
header Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat [Doc]
dl
             PPLayout
PPSemiColon   -> Doc
header Doc -> Doc -> Doc
$$ [Doc] -> Doc
prettyBlock [Doc]
dl
             PPLayout
PPInLine      -> Doc
header Doc -> Doc -> Doc
$$ [Doc] -> Doc
prettyBlock [Doc]
dl
             PPLayout
PPNoLayout    -> Doc
header Doc -> Doc -> Doc
<+> [Doc] -> Doc
flatBlock [Doc]
dl

ppBody :: (PPHsMode -> Int) -> [Doc] -> Doc
ppBody :: (PPHsMode -> Int) -> [Doc] -> Doc
ppBody PPHsMode -> Int
f [Doc]
dl = do
        e <- (PPHsMode -> PPLayout)
-> DocM PPHsMode PPHsMode -> DocM PPHsMode PPLayout
forall a b. (a -> b) -> DocM PPHsMode a -> DocM PPHsMode b
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
        i <- fmap f getPPEnv
        case e of
            PPLayout
PPOffsideRule -> Int -> Doc -> Doc
nest Int
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
            PPLayout
PPSemiColon   -> Int -> Doc -> Doc
nest Int
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
            PPLayout
_             -> [Doc] -> Doc
flatBlock [Doc]
dl

ppBindings :: [Doc] -> Doc
ppBindings :: [Doc] -> Doc
ppBindings [Doc]
dl = do
        e <- (PPHsMode -> PPLayout)
-> DocM PPHsMode PPHsMode -> DocM PPHsMode PPLayout
forall a b. (a -> b) -> DocM PPHsMode a -> DocM PPHsMode b
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 e of
            PPLayout
PPOffsideRule -> [Doc] -> Doc
vcat [Doc]
dl
            PPLayout
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
            PPLayout
_             -> [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
Doc
a $$$ :: Doc -> Doc -> Doc
$$$ 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' [Doc
x]    = Doc
x
        mySep' (Doc
x:[Doc]
xs) = Doc
x Doc -> Doc -> Doc
<+> [Doc] -> Doc
fsep [Doc]
xs
        mySep' []     = String -> Doc
forall a. HasCallStack => String -> a
error String
"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' (Doc
d:[Doc]
ds) = do
                        e <- DocM PPHsMode PPHsMode
forall s. DocM s s
getPPEnv
                        let n = PPHsMode -> Int
onsideIndent PPHsMode
e
                        nest n (fsep (nest (-n) d:ds))

layoutChoice :: (a -> Doc) -> (a -> Doc) -> a -> Doc
layoutChoice :: forall a. (a -> Doc) -> (a -> Doc) -> a -> Doc
layoutChoice a -> Doc
a a -> Doc
b a
dl = do e <- DocM PPHsMode PPHsMode
forall s. DocM s s
getPPEnv
                         if layout e == PPOffsideRule ||
                            layout e == PPSemiColon
                          then a dl else b 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 SrcLoc
loc Doc
doc = do
        e <- DocM PPHsMode PPHsMode
forall s. DocM s s
getPPEnv
        let y = SrcLoc -> Int
srcLine SrcLoc
loc
        let line a
l =
              String -> Doc
text (String
"{-# 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 -> String
forall a. [a] -> [a] -> [a]
++ SrcLoc -> String
srcFilename SrcLoc
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" #-}")
        if linePragmas e then layoutChoice (line y $$) (line (y+1) <+>) doc
              else doc