-----------------------------------------------------------------------------
-- |
-- 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 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.
                classIndent  :: Indent,
                                -- | Indentation of a @do@-expression.
                doIndent     :: Indent,
                                -- | Indentation of the body of a
                                -- @case@ expression.
                caseIndent   :: Indent,
                                -- | Indentation of the declarations in a
                                -- @let@ expression.
                letIndent    :: Indent,
                                -- | Indentation of the declarations in a
                                -- @where@ clause.
                whereIndent  :: Indent,
                                -- | Indentation added for continuation
                                -- lines that would otherwise be offside.
                onsideIndent :: Indent,
                                -- | Blank lines between statements?
                spacing      :: Bool,
                                -- | Pretty-printing style to use.
                layout       :: PPLayout,
                                -- | Add GHC-style @LINE@ pragmas to output?
                linePragmas  :: Bool,
                                -- | (not implemented yet)
                comments     :: Bool
                }

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

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

instance Functor (DocM s) where
         fmap f xs = do x <- xs; return (f x)

-- | @since 1.0.2.0
instance App.Applicative (DocM s) where
        pure = retDocM
        (<*>) = ap
        (*>) = then_DocM

instance Monad (DocM s) where
        (>>=) = thenDocM
        (>>) = (*>)
        return = pure

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

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

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

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

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

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

-- The pretty printing combinators

empty :: Doc
empty = return P.empty

nest :: Int -> Doc -> Doc
nest i m = m >>= return . P.nest i


-- Literals

text :: String -> Doc
text = return . P.text
-- ptext = return . P.text

char :: Char -> Doc
char = return . P.char

int :: Int -> Doc
int = return . P.int

integer :: Integer -> Doc
integer = return . P.integer

float :: Float -> Doc
float = return . P.float

double :: Double -> Doc
double = return . P.double

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

-- Simple Combining Forms

parens, brackets, braces :: Doc -> Doc
parens d = d >>= return . P.parens
brackets d = d >>= return . P.brackets
braces d = d >>= return . P.braces
-- quotes d = d >>= return . P.quotes
-- doubleQuotes d = d >>= return . P.doubleQuotes

parensIf :: Bool -> Doc -> Doc
parensIf True  = parens
parensIf False = id

-- Constants

semi,comma,space,equals :: Doc
semi = return P.semi
comma = return P.comma
-- colon = return P.colon
space = return P.space
equals = return 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 <<>> bM = do{a<-aM;b<-bM;return (a P.<> b)}
aM <+> bM = do{a<-aM;b<-bM;return (a P.<+> b)}
aM $$ bM = do{a<-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 dl = sequence dl >>= return . P.hcat
hsep dl = sequence dl >>= return . P.hsep
vcat dl = sequence dl >>= return . P.vcat
-- sep dl = sequence dl >>= return . P.sep
-- cat dl = sequence dl >>= return . P.cat
fsep dl = sequence dl >>= return . 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 _ []     = []
punctuate p (d1:ds) = go d1 ds
                   where
                     go d []     = [d]
                     go d (e:es) = (d <<>> p) : go e es

-- | render the document with a given style and mode.
renderStyleMode :: P.Style -> PPHsMode -> Doc -> String
renderStyleMode ppStyle ppMode d = P.renderStyle ppStyle . unDocM d $ 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 ppStyle ppMode = renderStyleMode ppStyle ppMode . pretty

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

-- | pretty-print with the default style and 'defaultMode'.
prettyPrint :: Pretty a => a -> String
prettyPrint = prettyPrintWithMode 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 pos m mbExports imp decls) =
                markLine pos $
                topLevel (ppHsModuleHeader m mbExports)
                         (map pretty imp ++ map pretty decls)

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

instance Pretty Module where
        pretty (Module modName) = text modName

instance Pretty HsExportSpec where
        pretty (HsEVar name)                = pretty name
        pretty (HsEAbs name)                = pretty name
        pretty (HsEThingAll name)           = pretty name <<>> text "(..)"
        pretty (HsEThingWith name nameList) =
                pretty name <<>> (parenList . map pretty $ nameList)
        pretty (HsEModuleContents m)       = text "module" <+> pretty m

instance Pretty HsImportDecl where
        pretty (HsImportDecl pos m qual mbName mbSpecs) =
                markLine pos $
                mySep [text "import",
                       if qual then text "qualified" else empty,
                       pretty m,
                       maybePP (\m' -> text "as" <+> pretty m') mbName,
                       maybePP exports mbSpecs]
            where
                exports (b,specList) =
                        if b then text "hiding" <+> specs else specs
                    where specs = parenList . map pretty $ specList

instance Pretty HsImportSpec where
        pretty (HsIVar name)                = pretty name
        pretty (HsIAbs name)                = pretty name
        pretty (HsIThingAll name)           = pretty name <<>> text "(..)"
        pretty (HsIThingWith name nameList) =
                pretty name <<>> (parenList . map pretty $ nameList)

-------------------------  Declarations ------------------------------
instance Pretty HsDecl where
        pretty (HsTypeDecl loc name nameList htype) =
                blankline $
                markLine loc $
                mySep ( [text "type", pretty name]
                        ++ map pretty nameList
                        ++ [equals, pretty htype])

        pretty (HsDataDecl loc context name nameList constrList derives) =
                blankline $
                markLine loc $
                mySep ( [text "data", ppHsContext context, pretty name]
                        ++ map pretty nameList)
                        <+> (myVcat (zipWith (<+>) (equals : repeat (char '|'))
                                                   (map pretty constrList))
                        $$$ ppHsDeriving derives)

        pretty (HsNewTypeDecl pos context name nameList constr derives) =
                blankline $
                markLine pos $
                mySep ( [text "newtype", ppHsContext context, pretty name]
                        ++ map pretty nameList)
                        <+> equals <+> (pretty constr $$$ ppHsDeriving derives)

        --m{spacing=False}
        -- special case for empty class declaration
        pretty (HsClassDecl pos context name nameList []) =
                blankline $
                markLine pos $
                mySep ( [text "class", ppHsContext context, pretty name]
                        ++ map pretty nameList)
        pretty (HsClassDecl pos context name nameList declList) =
                blankline $
                markLine pos $
                mySep ( [text "class", ppHsContext context, pretty name]
                        ++ map pretty nameList ++ [text "where"])
                $$$ ppBody classIndent (map pretty declList)

        -- m{spacing=False}
        -- special case for empty instance declaration
        pretty (HsInstDecl pos context name args []) =
                blankline $
                markLine pos $
                mySep ( [text "instance", ppHsContext context, pretty name]
                        ++ map ppHsAType args)
        pretty (HsInstDecl pos context name args declList) =
                blankline $
                markLine pos $
                mySep ( [text "instance", ppHsContext context, pretty name]
                        ++ map ppHsAType args ++ [text "where"])
                $$$ ppBody classIndent (map pretty declList)

        pretty (HsDefaultDecl pos htypes) =
                blankline $
                markLine pos $
                text "default" <+> parenList (map pretty htypes)

        pretty (HsTypeSig pos nameList qualType) =
                blankline $
                markLine pos $
                mySep ((punctuate comma . map pretty $ nameList)
                      ++ [text "::", pretty qualType])

        pretty (HsForeignImport pos conv safety entity name ty) =
                blankline $
                markLine pos $
                mySep $ [text "foreign", text "import", text conv, pretty safety] ++
                        (if null entity then [] else [text (show entity)]) ++
                        [pretty name, text "::", pretty ty]

        pretty (HsForeignExport pos conv entity name ty) =
                blankline $
                markLine pos $
                mySep $ [text "foreign", text "export", text conv] ++
                        (if null entity then [] else [text (show entity)]) ++
                        [pretty name, text "::", pretty ty]

        pretty (HsFunBind matches) =
                ppBindings (map pretty matches)

        pretty (HsPatBind pos pat rhs whereDecls) =
                markLine pos $
                myFsep [pretty pat, pretty rhs] $$$ ppWhere whereDecls

        pretty (HsInfixDecl pos assoc prec opList) =
                blankline $
                markLine pos $
                mySep ([pretty assoc, int prec]
                       ++ (punctuate comma . map pretty $ opList))

instance Pretty HsAssoc where
        pretty HsAssocNone  = text "infix"
        pretty HsAssocLeft  = text "infixl"
        pretty HsAssocRight = text "infixr"

instance Pretty HsSafety where
        pretty HsSafe   = text "safe"
        pretty HsUnsafe = text "unsafe"

instance Pretty HsMatch where
        pretty (HsMatch pos f ps rhs whereDecls) =
                markLine pos $
                myFsep (lhs ++ [pretty rhs])
                $$$ ppWhere whereDecls
            where
                lhs = case ps of
                        l:r:ps' | isSymbolName f ->
                                let hd = [pretty l, ppHsName f, pretty r] in
                                if null ps' then hd
                                else parens (myFsep hd) : map (prettyPrec 2) ps'
                        _ -> pretty f : map (prettyPrec 2) ps

ppWhere :: [HsDecl] -> Doc
ppWhere [] = empty
ppWhere l  = nest 2 (text "where" $$$ ppBody whereIndent (map pretty l))

------------------------- Data & Newtype Bodies -------------------------
instance Pretty HsConDecl where
        pretty (HsRecDecl _pos name fieldList) =
                pretty name <<>> (braceList . map ppField $ fieldList)

        pretty (HsConDecl _pos name@(HsSymbol _) [l, r]) =
                myFsep [prettyPrec prec_btype l, ppHsName name,
                        prettyPrec prec_btype r]
        pretty (HsConDecl _pos name typeList) =
                mySep $ ppHsName name : map (prettyPrec prec_atype) typeList

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

instance Pretty HsBangType where
        prettyPrec _ (HsBangedTy ty)   = char '!' <<>> ppHsAType ty
        prettyPrec p (HsUnBangedTy ty) = prettyPrec p ty

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

------------------------- Types -------------------------
instance Pretty HsQualType where
        pretty (HsQualType context htype) =
                myFsep [ppHsContext context, pretty htype]

ppHsBType :: HsType -> Doc
ppHsBType = prettyPrec prec_btype

ppHsAType :: HsType -> Doc
ppHsAType = prettyPrec prec_atype

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

instance Pretty HsType where
        prettyPrec p (HsTyFun a b) = parensIf (p > 0) $
                myFsep [ppHsBType a, text "->", pretty b]
        prettyPrec _ (HsTyTuple l) = parenList . map pretty $ l
        prettyPrec p (HsTyApp a b)
                | a == list_tycon = brackets $ pretty b         -- special case
                | otherwise = parensIf (p > prec_btype) $
                        myFsep [pretty a, ppHsAType b]
        prettyPrec _ (HsTyVar name) = pretty name
        prettyPrec _ (HsTyCon name) = pretty name

------------------------- Expressions -------------------------
instance Pretty HsRhs where
        pretty (HsUnGuardedRhs e)        = equals <+> pretty e
        pretty (HsGuardedRhss guardList) = myVcat . map pretty $ guardList

instance Pretty HsGuardedRhs where
        pretty (HsGuardedRhs _pos guard body) =
                myFsep [char '|', pretty guard, equals, pretty body]

instance Pretty HsLiteral where
        pretty (HsInt i)        = integer i
        pretty (HsChar c)       = text (show c)
        pretty (HsString s)     = text (show s)
        pretty (HsFrac r)       = double (fromRational r)
        -- GHC unboxed literals:
        pretty (HsCharPrim c)   = text (show c)           <<>> char '#'
        pretty (HsStringPrim s) = text (show s)           <<>> char '#'
        pretty (HsIntPrim i)    = integer i               <<>> char '#'
        pretty (HsFloatPrim r)  = float  (fromRational r) <<>> char '#'
        pretty (HsDoublePrim r) = double (fromRational r) <<>> text "##"

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

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

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

instance Pretty HsPatField where
        pretty (HsPFieldPat name pat) =
                myFsep [pretty name, equals, pretty pat]

------------------------- Case bodies  -------------------------
instance Pretty HsAlt where
        pretty (HsAlt _pos e gAlts decls) =
                myFsep [pretty e, pretty gAlts] $$$ ppWhere decls

instance Pretty HsGuardedAlts where
        pretty (HsUnGuardedAlt e)      = text "->" <+> pretty e
        pretty (HsGuardedAlts altList) = myVcat . map pretty $ altList

instance Pretty HsGuardedAlt where
        pretty (HsGuardedAlt _pos e body) =
                myFsep [char '|', pretty e, text "->", pretty body]

------------------------- Statements in monads & list comprehensions -----
instance Pretty HsStmt where
        pretty (HsGenerator _loc e from) =
                pretty e <+> text "<-" <+> pretty from
        pretty (HsQualifier e) = pretty e
        pretty (HsLetStmt declList) =
                text "let" $$$ ppBody letIndent (map pretty declList)

------------------------- Record updates
instance Pretty HsFieldUpdate where
        pretty (HsFieldUpdate name e) =
                myFsep [pretty name, equals, pretty e]

------------------------- Names -------------------------
instance Pretty HsQOp where
        pretty (HsQVarOp n) = ppHsQNameInfix n
        pretty (HsQConOp n) = ppHsQNameInfix n

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

instance Pretty HsQName where
        pretty name = parensIf (isSymbolName (getName name)) (ppHsQName name)

ppHsQName :: HsQName -> Doc
ppHsQName (UnQual name) = ppHsName name
ppHsQName (Qual m name) = pretty m <<>> char '.' <<>> ppHsName name
ppHsQName (Special sym) = text (specialName sym)

instance Pretty HsOp where
        pretty (HsVarOp n) = ppHsNameInfix n
        pretty (HsConOp n) = ppHsNameInfix n

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

instance Pretty HsName where
        pretty name = parensIf (isSymbolName name) (ppHsName name)

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

instance Pretty HsCName where
        pretty (HsVarName n) = pretty n
        pretty (HsConName n) = pretty n

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

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

specialName :: HsSpecialCon -> String
specialName HsUnitCon      = "()"
specialName HsListCon      = "[]"
specialName HsFunCon       = "->"
specialName (HsTupleCon n) = "(" ++ replicate (n-1) ',' ++ ")"
specialName HsCons         = ":"

ppHsContext :: HsContext -> Doc
ppHsContext []      = empty
ppHsContext context = mySep [parenList (map ppHsAsst context), text "=>"]

-- hacked for multi-parameter type classes

ppHsAsst :: HsAsst -> Doc
ppHsAsst (a,ts) = myFsep (ppHsQName a : map ppHsAType ts)

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

parenList :: [Doc] -> Doc
parenList = parens . myFsepSimple . punctuate comma

braceList :: [Doc] -> Doc
braceList = braces . myFsepSimple . punctuate comma

bracketList :: [Doc] -> Doc
bracketList = brackets . 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 = braces . (space <<>>) . hsep . punctuate semi

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

-- Monadic PP Combinators -- these examine the env

blankline :: Doc -> Doc
blankline dl = do{e<-getPPEnv;if spacing e && layout e /= PPNoLayout
                              then space $$ dl else dl}
topLevel :: Doc -> [Doc] -> Doc
topLevel header dl = do
         e <- fmap layout getPPEnv
         case e of
             PPOffsideRule -> header $$ vcat dl
             PPSemiColon   -> header $$ prettyBlock dl
             PPInLine      -> header $$ prettyBlock dl
             PPNoLayout    -> header <+> flatBlock dl

ppBody :: (PPHsMode -> Int) -> [Doc] -> Doc
ppBody f dl = do
        e <- fmap layout getPPEnv
        i <- fmap f getPPEnv
        case e of
            PPOffsideRule -> nest i . vcat $ dl
            PPSemiColon   -> nest i . prettyBlock $ dl
            _             -> flatBlock dl

ppBindings :: [Doc] -> Doc
ppBindings dl = do
        e <- fmap layout getPPEnv
        case e of
            PPOffsideRule -> vcat dl
            PPSemiColon   -> vcat . punctuate semi $ dl
            _             -> hsep . punctuate semi $ dl

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

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

myVcat :: [Doc] -> Doc
myVcat = layoutChoice vcat hsep

myFsepSimple :: [Doc] -> Doc
myFsepSimple = layoutChoice fsep hsep

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

layoutChoice :: (a -> Doc) -> (a -> Doc) -> a -> Doc
layoutChoice a b dl = do e <- 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 loc doc = do
        e <- getPPEnv
        let y = srcLine loc
        let line l =
              text ("{-# LINE " ++ show l ++ " \"" ++ srcFilename loc ++ "\" #-}")
        if linePragmas e then layoutChoice (line y $$) (line (y+1) <+>) doc
              else doc