    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Language.Haskell.Exts.Pretty
    -- Copyright   :  (c) Niklas Broberg 2004-2009,
    --                (c) The GHC Team, Noel Winstanley 1997-2000
    -- License     :  BSD-style (see the file LICENSE.txt)
    --
    -- Maintainer  :  Niklas Broberg, d00nibro@chalmers.se
    -- Stability   :  stable
    -- Portability :  portable
    --
    -- Pretty printer for Haskell with extensions.
    --
    -----------------------------------------------------------------------------

    module Language.Haskell.Exts.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.Exts.Syntax
    import qualified Language.Haskell.Exts.Annotated.Syntax as A
    import Language.Haskell.Exts.Annotated.Simplify
    import qualified Language.Haskell.Exts.ParseSyntax as P

    import Language.Haskell.Exts.SrcLoc

    import qualified Text.PrettyPrint as P
    import Data.List (intersperse)

    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
                    }

    -- | 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
                          }

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

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

    instance Monad (DocM s) where
            (>>=) = thenDocM
            (>>) = then_DocM
            return = retDocM

    {-# 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.Exts.Syntax" and "Language.Haskell.Exts.Annotated.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, ptext :: 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,quotes,doubleQuotes :: 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,colon,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,sep,cat,fsep,fcat :: [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 Module where
            pretty (Module pos m os mbWarn mbExports imp decls) =
                    markLine pos $
                    myVcat $ map pretty os ++
                        (if m == ModuleName "" then id
                         else \x -> [topLevel (ppModuleHeader m mbWarn mbExports) x])
                        (map pretty imp ++ map pretty decls)

    --------------------------  Module Header ------------------------------
    ppModuleHeader :: ModuleName -> Maybe WarningText -> Maybe [ExportSpec] -> Doc
    ppModuleHeader m mbWarn mbExportList = mySep [
            text "module",
            pretty m,
            maybePP ppWarnTxt mbWarn,
            maybePP (parenList . map pretty) mbExportList,
            text "where"]

    ppWarnTxt :: WarningText -> Doc
    ppWarnTxt (DeprText s) = mySep [text "{-# DEPRECATED", text s, text "#-}"]
    ppWarnTxt (WarnText s) = mySep [text "{-# WARNING",    text s, text "#-}"]

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

    instance Pretty ExportSpec where
            pretty (EVar name)                = pretty name
            pretty (EAbs name)                = pretty name
            pretty (EThingAll name)           = pretty name <> text "(..)"
            pretty (EThingWith name nameList) =
                    pretty name <> (parenList . map pretty $ nameList)
            pretty (EModuleContents m)        = text "module" <+> pretty m

    instance Pretty ImportDecl where
            pretty (ImportDecl pos m qual src mbPkg mbName mbSpecs) =
                    markLine pos $
                    mySep [text "import",
                           if src  then text "{-# SOURCE #-}" else empty,
                           if qual then text "qualified" else empty,
                           maybePP (\s -> text (show s)) mbPkg,
                           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 ImportSpec where
            pretty (IVar name)                = pretty name
            pretty (IAbs name)                = pretty name
            pretty (IThingAll name)           = pretty name <> text "(..)"
            pretty (IThingWith name nameList) =
                    pretty name <> (parenList . map pretty $ nameList)

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

            pretty (DataDecl loc don context name nameList constrList derives) =
                    blankline $
                    markLine loc $
                    mySep ( [pretty don, ppContext context, pretty name]
                            ++ map pretty nameList)
                            <+> (myVcat (zipWith (<+>) (equals : repeat (char '|'))
                                                       (map pretty constrList))
                            $$$ ppDeriving derives)

            pretty (GDataDecl loc don context name nameList optkind gadtList derives) =
                    blankline $
                    markLine loc $
                    mySep ( [pretty don, ppContext context, pretty name]
                            ++ map pretty nameList ++ ppOptKind optkind ++ [text "where"])
                            $$$ ppBody classIndent (map pretty gadtList)
                            $$$ ppDeriving derives

            pretty (TypeFamDecl loc name nameList optkind) =
                    blankline $
                    markLine loc $
                    mySep ([text "type", text "family", pretty name]
                            ++ map pretty nameList
                            ++ ppOptKind optkind)

            pretty (DataFamDecl loc context name nameList optkind) =
                    blankline $
                    markLine loc $
                    mySep ( [text "data", text "family", ppContext context, pretty name]
                            ++ map pretty nameList ++ ppOptKind optkind)

            pretty (TypeInsDecl loc ntype htype) =
                    blankline $
                    markLine loc $
                    mySep [text "type", text "instance", pretty ntype, equals, pretty htype]

            pretty (DataInsDecl loc don ntype constrList derives) =
                    blankline $
                    markLine loc $
                    mySep [pretty don, text "instance", pretty ntype]
                            <+> (myVcat (zipWith (<+>) (equals : repeat (char '|'))
                                                       (map pretty constrList))
                                  $$$ ppDeriving derives)

            pretty (GDataInsDecl loc don ntype optkind gadtList derives) =
                    blankline $
                    markLine loc $
                    mySep ( [pretty don, text "instance", pretty ntype]
                            ++ ppOptKind optkind ++ [text "where"])
                            $$$ ppBody classIndent (map pretty gadtList)
                            $$$ ppDeriving derives

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

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

            pretty (DerivDecl pos context name args) =
                    blankline $
                    markLine pos $
                    mySep ( [text "deriving", text "instance", ppContext context, pretty name]
                            ++ map ppAType args)
            pretty (DefaultDecl pos htypes) =
                    blankline $
                    markLine pos $
                    text "default" <+> parenList (map pretty htypes)

            pretty (SpliceDecl pos splice) =
                    blankline $
                    markLine pos $
                    pretty splice

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

            pretty (FunBind matches) = do
                    e <- fmap layout getPPEnv
                    case e of PPOffsideRule -> foldr ($$$) empty (map pretty matches)
                              _ -> foldr (\x y -> x <> semi <> y) empty (map pretty matches)

            pretty (PatBind pos pat optsig rhs whereBinds) =
                    markLine pos $
                    myFsep [pretty pat, maybePP ppSig optsig, pretty rhs] $$$ ppWhere whereBinds

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

            pretty (ForImp pos cconv saf str name typ) =
                    blankline $
                    markLine pos $
                    mySep [text "foreign import", pretty cconv, pretty saf,
                           text (show str), pretty name, text "::", pretty typ]

            pretty (ForExp pos cconv str name typ) =
                    blankline $
                    markLine pos $
                    mySep [text "foreign export", pretty cconv,
                           text (show str), pretty name, text "::", pretty typ]

            pretty (RulePragmaDecl pos rules) =
                    blankline $
                    markLine pos $
                    myVcat $ text "{-# RULES" : map pretty rules ++ [text " #-}"]

            pretty (DeprPragmaDecl pos deprs) =
                    blankline $
                    markLine pos $
                    myVcat $ text "{-# DEPRECATED" : map ppWarnDepr deprs ++ [text " #-}"]

            pretty (WarnPragmaDecl pos deprs) =
                    blankline $
                    markLine pos $
                    myVcat $ text "{-# WARNING" : map ppWarnDepr deprs ++ [text " #-}"]

            pretty (InlineSig pos inl activ name) =
                    blankline $
                    markLine pos $
                    mySep [text (if inl then "{-# INLINE" else "{-# NOINLINE"), pretty activ, pretty name, text "#-}"]

            pretty (InlineConlikeSig pos activ name) =
                    blankline $
                    markLine pos $
                    mySep [text "{-# INLINE_CONLIKE", pretty activ, pretty name, text "#-}"]

            pretty (SpecSig pos name types) =
                    blankline $
                    markLine pos $
                    mySep $ [text "{-# SPECIALISE", pretty name, text "::"]
                        ++ punctuate comma (map pretty types) ++ [text "#-}"]

            pretty (SpecInlineSig pos inl activ name types) =
                    blankline $
                    markLine pos $
                    mySep $ [text "{-# SPECIALISE", text (if inl then "INLINE" else "NOINLINE"),
                            pretty activ, pretty name, text "::"]
                            ++ (punctuate comma $ map pretty types) ++ [text "#-}"]

            pretty (InstSig pos context name args) =
                    blankline $
                    markLine pos $
                    mySep $ [text "{-# SPECIALISE", text "instance", ppContext context, pretty name]
                                ++ map ppAType args ++ [text "#-}"]

            pretty (AnnPragma pos ann) =
                    blankline $
                    markLine pos $
                    mySep $ [text "{-# ANN", pretty ann, text "#-}"]

    instance Pretty Annotation where
            pretty (Ann n e) = myFsep [pretty n, pretty e]
            pretty (TypeAnn n e) = myFsep [text "type", pretty n, pretty e]
            pretty (ModuleAnn e) = myFsep [text "module", pretty e]

    instance Pretty DataOrNew where
            pretty DataType = text "data"
            pretty NewType  = text "newtype"

    instance Pretty Assoc where
            pretty AssocNone  = text "infix"
            pretty AssocLeft  = text "infixl"
            pretty AssocRight = text "infixr"

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

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

    ppSig :: Type -> Doc
    ppSig t = text "::" <+> pretty t

    instance Pretty ClassDecl where
        pretty (ClsDecl decl) = pretty decl

        pretty (ClsDataFam loc context name nameList optkind) =
                    markLine loc $
                    mySep ( [text "data", ppContext context, pretty name]
                            ++ map pretty nameList ++ ppOptKind optkind)

        pretty (ClsTyFam loc name nameList optkind) =
                    markLine loc $
                    mySep ( [text "type", pretty name]
                            ++ map pretty nameList ++ ppOptKind optkind)

        pretty (ClsTyDef loc ntype htype) =
                    markLine loc $
                    mySep [text "type", pretty ntype, equals, pretty htype]

    instance Pretty InstDecl where
            pretty (InsDecl decl) = pretty decl

            pretty (InsType loc ntype htype) =
                    markLine loc $
                    mySep [text "type", pretty ntype, equals, pretty htype]

            pretty (InsData loc don ntype constrList derives) =
                    markLine loc $
                    mySep [pretty don, pretty ntype]
                            <+> (myVcat (zipWith (<+>) (equals : repeat (char '|'))
                                                       (map pretty constrList))
                                  $$$ ppDeriving derives)

            pretty (InsGData loc don ntype optkind gadtList derives) =
                    markLine loc $
                    mySep ( [pretty don, pretty ntype]
                            ++ ppOptKind optkind ++ [text "where"])
                            $$$ ppBody classIndent (map pretty gadtList)
                            $$$ ppDeriving derives

    --        pretty (InsInline loc inl activ name) =
    --                markLine loc $
    --                mySep [text (if inl then "{-# INLINE" else "{-# NOINLINE"), pretty activ, pretty name, text "#-}"]

    ------------------------- FFI stuff -------------------------------------
    instance Pretty Safety where
            pretty PlayRisky        = text "unsafe"
            pretty (PlaySafe b)     = text $ if b then "threadsafe" else "safe"

    instance Pretty CallConv where
            pretty StdCall  = text "stdcall"
            pretty CCall    = text "ccall"

    ------------------------- Pragmas ---------------------------------------
    ppWarnDepr :: ([Name], String) -> Doc
    ppWarnDepr (names, txt) = mySep $ (punctuate comma $ map pretty names) ++ [text $ show txt]

    instance Pretty Rule where
            pretty (Rule tag activ rvs rhs lhs) =
                mySep $ [text $ show tag, pretty activ,
                            maybePP ppRuleVars rvs,
                            pretty rhs, char '=', pretty lhs]

    ppRuleVars :: [RuleVar] -> Doc
    ppRuleVars []  = empty
    ppRuleVars rvs = mySep $ text "forall" : map pretty rvs ++ [char '.']

    instance Pretty Activation where
        pretty AlwaysActive    = empty
        pretty (ActiveFrom i)  = char '['  <> int i <> char ']'
        pretty (ActiveUntil i) = text "[~" <> int i <> char ']'

    instance Pretty RuleVar where
        pretty (RuleVar n) = pretty n
        pretty (TypedRuleVar n t) = mySep [pretty n, text "::", pretty t]

    instance Pretty ModulePragma where
        pretty (LanguagePragma _ ns) =
            myFsep $ text "{-# LANGUAGE" : punctuate (char ',') (map pretty ns) ++ [text "#-}"]
        pretty (OptionsPragma _ (Just tool) s) =
            myFsep $ [text "{-# OPTIONS_" <> pretty tool, text s, text "#-}"]
        pretty (OptionsPragma _ _ s) =
            myFsep $ [text "{-# OPTIONS", text s, text "#-}"]
        pretty (AnnModulePragma _ ann) =
            myFsep $ [text "{-# ANN", pretty ann, text "#-}"]

    instance Pretty Tool where
        pretty (UnknownTool s) = text s
        pretty t               = text $ show t

    ------------------------- Data & Newtype Bodies -------------------------
    instance Pretty QualConDecl where
            pretty (QualConDecl _pos tvs ctxt con) =
                    myFsep [ppForall (Just tvs), ppContext ctxt, pretty con]

    instance Pretty GadtDecl where
            pretty (GadtDecl _pos name ty) =
                    myFsep [pretty name, text "::", pretty ty]

    instance Pretty ConDecl where
            pretty (RecDecl name fieldList) =
                    pretty name <> (braceList . map ppField $ fieldList)

    {-        pretty (ConDecl name@(Symbol _) [l, r]) =
                    myFsep [prettyPrec prec_btype l, ppName name,
                            prettyPrec prec_btype r] -}
            pretty (ConDecl name typeList) =
                    mySep $ ppName name : map (prettyPrec prec_atype) typeList
            pretty (InfixConDecl l name r) =
                    myFsep [prettyPrec prec_btype l, ppNameInfix name,
                             prettyPrec prec_btype r]

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

    instance Pretty BangType where
            prettyPrec _ (BangedTy ty) = char '!' <> ppAType ty
            prettyPrec p (UnBangedTy ty) = prettyPrec p ty
            prettyPrec p (UnpackedTy ty) = text "{-# UNPACK #-}" <+> char '!' <> prettyPrec p ty

    ppDeriving :: [Deriving] -> Doc
    ppDeriving []  = empty
    ppDeriving [(d, [])] = text "deriving" <+> ppQName d
    ppDeriving ds  = text "deriving" <+> parenList (map ppDer ds)
        where ppDer :: (QName, [Type]) -> Doc
              ppDer (n, ts) = mySep (pretty n : map pretty ts)

    ------------------------- Types -------------------------
    ppBType :: Type -> Doc
    ppBType = prettyPrec prec_btype

    ppAType :: Type -> Doc
    ppAType = 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 Type where
            prettyPrec p (TyForall mtvs ctxt htype) = parensIf (p > 0) $
                    myFsep [ppForall mtvs, ppContext ctxt, pretty htype]
            prettyPrec p (TyFun a b) = parensIf (p > 0) $
                    myFsep [ppBType a, text "->", pretty b]
            prettyPrec _ (TyTuple bxd l) =
                    let ds = map pretty l
                     in case bxd of
                            Boxed   -> parenList ds
                            Unboxed -> hashParenList ds
            prettyPrec _ (TyList t)  = brackets $ pretty t
            prettyPrec p (TyApp a b) =
                    {-
                    | a == list_tycon = brackets $ pretty b         -- special case
                    | otherwise = -} parensIf (p > prec_btype) $
                                        myFsep [pretty a, ppAType b]
            prettyPrec _ (TyVar name) = pretty name
            prettyPrec _ (TyCon name) = pretty name
            prettyPrec _ (TyParen t) = parens (pretty t)
    --        prettyPrec _ (TyPred asst) = pretty asst
            prettyPrec _ (TyInfix a op b) = myFsep [pretty a, ppQNameInfix op, pretty b]
            prettyPrec _ (TyKind t k) = parens (myFsep [pretty t, text "::", pretty k])

    instance Pretty TyVarBind where
            pretty (KindedVar var kind) = parens $ myFsep [pretty var, text "::", pretty kind]
            pretty (UnkindedVar var)    = pretty var

    ppForall :: Maybe [TyVarBind] -> Doc
    ppForall Nothing   = empty
    ppForall (Just []) = empty
    ppForall (Just vs) =    myFsep (text "forall" : map pretty vs ++ [char '.'])

    ---------------------------- Kinds ----------------------------

    instance Pretty Kind where
            pretty KindStar      = text "*"
            pretty KindBang      = text "!"
            pretty (KindFn a b)  = myFsep [pretty a, text "->", pretty b]
            pretty (KindParen k) = parens $ pretty k
            pretty (KindVar n)   = pretty n

    ppOptKind :: Maybe Kind -> [Doc]
    ppOptKind Nothing  = []
    ppOptKind (Just k) = [text "::", pretty k]

    ------------------- Functional Dependencies -------------------
    instance Pretty FunDep where
            pretty (FunDep from to) =
                    myFsep $ map pretty from ++ [text "->"] ++ map pretty to

    ppFunDeps :: [FunDep] -> Doc
    ppFunDeps []  = empty
    ppFunDeps fds = myFsep $ (char '|':) . punctuate comma . map pretty $ fds

    ------------------------- Expressions -------------------------
    instance Pretty Rhs where
            pretty (UnGuardedRhs e) = equals <+> pretty e
            pretty (GuardedRhss guardList) = myVcat . map pretty $ guardList

    instance Pretty GuardedRhs where
            pretty (GuardedRhs _pos guards ppBody) =
                    myFsep $ [char '|'] ++ (punctuate comma . map pretty $ guards) ++ [equals, pretty ppBody]

    instance Pretty Literal where
            pretty (Int i)        = integer i
            pretty (Char c)       = text (show c)
            pretty (String s)     = text (show s)
            pretty (Frac r)       = double (fromRational r)
            -- GHC unboxed literals:
            pretty (PrimChar c)   = text (show c)           <> char '#'
            pretty (PrimString s) = text (show s)           <> char '#'
            pretty (PrimInt i)    = integer i               <> char '#'
            pretty (PrimWord w)   = integer w               <> text "##"
            pretty (PrimFloat r)  = float  (fromRational r) <> char '#'
            pretty (PrimDouble r) = double (fromRational r) <> text "##"

    instance Pretty Exp where
            prettyPrec _ (Lit l) = pretty l
            -- lambda stuff
            prettyPrec p (InfixApp a op b) = parensIf (p > 0) $ myFsep [pretty a, pretty op, pretty b]
            prettyPrec _ (NegApp e) = parens $ myFsep [char '-', pretty e]
            prettyPrec p (App a b) = parensIf (p > 0) $ myFsep [pretty a, prettyPrec 1 b]
            prettyPrec p (Lambda _loc expList ppBody) = parensIf (p > 0) $ myFsep $
                    char '\\' : map pretty expList ++ [text "->", pretty ppBody]
            -- keywords
            -- two cases for lets
            prettyPrec p (Let (BDecls declList) letBody) =
                    parensIf (p > 0) $ ppLetExp declList letBody
            prettyPrec p (Let (IPBinds bindList) letBody) =
                    parensIf (p > 0) $ ppLetExp bindList letBody

            prettyPrec p (If cond thenexp elsexp) = parensIf (p > 0) $
                    myFsep [text "if", pretty cond,
                            text "then", pretty thenexp,
                            text "else", pretty elsexp]
            prettyPrec p (Case cond altList) = parensIf (p > 0) $
                    myFsep [text "case", pretty cond, text "of"]
                    $$$ ppBody caseIndent (map pretty altList)
            prettyPrec p (Do stmtList) = parensIf (p > 0) $
                    text "do" $$$ ppBody doIndent (map pretty stmtList)
            prettyPrec p (MDo stmtList) = parensIf (p > 0) $
                    text "mdo" $$$ ppBody doIndent (map pretty stmtList)
            -- Constructors & Vars
            prettyPrec _ (Var name) = pretty name
            prettyPrec _ (IPVar ipname) = pretty ipname
            prettyPrec _ (Con name) = pretty name
            prettyPrec _ (Tuple expList) = parenList . map pretty $ expList
            prettyPrec _ (TupleSection mExpList) = parenList . map (maybePP pretty) $ mExpList
            -- weird stuff
            prettyPrec _ (Paren e) = parens . pretty $ e
            prettyPrec _ (LeftSection e op) = parens (pretty e <+> pretty op)
            prettyPrec _ (RightSection op e) = parens (pretty op <+> pretty e)
            prettyPrec _ (RecConstr c fieldList) =
                    pretty c <> (braceList . map pretty $ fieldList)
            prettyPrec _ (RecUpdate e fieldList) =
                    pretty e <> (braceList . map pretty $ fieldList)
            -- Lists
            prettyPrec _ (List list) =
                    bracketList . punctuate comma . map pretty $ list
            prettyPrec _ (EnumFrom e) =
                    bracketList [pretty e, text ".."]
            prettyPrec _ (EnumFromTo from to) =
                    bracketList [pretty from, text "..", pretty to]
            prettyPrec _ (EnumFromThen from thenE) =
                    bracketList [pretty from <> comma, pretty thenE, text ".."]
            prettyPrec _ (EnumFromThenTo from thenE to) =
                    bracketList [pretty from <> comma, pretty thenE,
                                 text "..", pretty to]
            prettyPrec _ (ListComp e qualList) =
                    bracketList ([pretty e, char '|']
                                 ++ (punctuate comma . map pretty $ qualList))
            prettyPrec _ (ParComp e qualLists) =
                    bracketList (intersperse (char '|') $
                                    pretty e : (punctuate comma . concatMap (map pretty) $ qualLists))
            prettyPrec p (ExpTypeSig _pos e ty) = parensIf (p > 0) $
                    myFsep [pretty e, text "::", pretty ty]
            -- Template Haskell
            prettyPrec _ (BracketExp b) = pretty b
            prettyPrec _ (SpliceExp s) = pretty s
            prettyPrec _ (TypQuote t)  = text "\'\'" <> pretty t
            prettyPrec _ (VarQuote x)  = text "\'" <> pretty x
            prettyPrec _ (QuasiQuote n qt) = text ("[$" ++ n ++ "|" ++ qt ++ "|]")
            -- Hsx
            prettyPrec _ (XTag _ n attrs mattr cs) =
                    let ax = maybe [] (return . pretty) mattr
                     in hcat $
                         (myFsep $ (char '<' <> pretty n): map pretty attrs ++ ax ++ [char '>']):
                            map pretty cs ++ [myFsep $ [text "</" <> pretty n, char '>']]
            prettyPrec _ (XETag _ n attrs mattr) =
                    let ax = maybe [] (return . pretty) mattr
                     in myFsep $ (char '<' <> pretty n): map pretty attrs ++ ax ++ [text "/>"]
            prettyPrec _ (XPcdata s) = text s
            prettyPrec _ (XExpTag e) =
                    myFsep $ [text "<%", pretty e, text "%>"]
            -- Pragmas
            prettyPrec p (CorePragma s e) = myFsep $ map text ["{-# CORE", show s, "#-}"] ++ [pretty e]
            prettyPrec _ (SCCPragma  s e) = myFsep $ map text ["{-# SCC",  show s, "#-}"] ++ [pretty e]
            prettyPrec _ (GenPragma  s (a,b) (c,d) e) =
                    myFsep $ [text "{-# GENERATED", text $ show s,
                                int a, char ':', int b, char '-',
                                int c, char ':', int d, text "#-}", pretty e]
            -- Arrows
            prettyPrec p (Proc _ pat e) = parensIf (p > 0) $ myFsep $ [text "proc", pretty pat, text "->", pretty e]
            prettyPrec p (LeftArrApp l r)      = parensIf (p > 0) $ myFsep $ [pretty l, text "-<",  pretty r]
            prettyPrec p (RightArrApp l r)     = parensIf (p > 0) $ myFsep $ [pretty l, text ">-",  pretty r]
            prettyPrec p (LeftArrHighApp l r)  = parensIf (p > 0) $ myFsep $ [pretty l, text "-<<", pretty r]
            prettyPrec p (RightArrHighApp l r) = parensIf (p > 0) $ myFsep $ [pretty l, text ">>-", pretty r]

    instance Pretty XAttr where
            pretty (XAttr n v) =
                    myFsep [pretty n, char '=', pretty v]

    instance Pretty XName where
            pretty (XName n) = text n
            pretty (XDomName d n) = text d <> char ':' <> text n

    --ppLetExp :: [Decl] -> Exp -> Doc
    ppLetExp l b = myFsep [text "let" <+> ppBody letIndent (map pretty l),
                            text "in", pretty b]

    ppWith binds = nest 2 (text "with" $$$ ppBody withIndent (map pretty binds))
    withIndent = whereIndent

    --------------------- Template Haskell -------------------------

    instance Pretty Bracket where
            pretty (ExpBracket e) = ppBracket "[|" e
            pretty (PatBracket p) = ppBracket "[p|" p
            pretty (TypeBracket t) = ppBracket "[t|" t
            pretty (DeclBracket d) =
                    myFsep $ text "[d|" : map pretty d ++ [text "|]"]

    ppBracket o x = myFsep [text o, pretty x, text "|]"]

    instance Pretty Splice where
            pretty (IdSplice s) = char '$' <> text s
            pretty (ParenSplice e) =
                    myFsep [text "$(", pretty e, char ')']

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

    instance Pretty Pat where
            prettyPrec _ (PVar name) = pretty name
            prettyPrec _ (PLit lit) = pretty lit
            prettyPrec _ (PNeg p) = myFsep [char '-', pretty p]
            prettyPrec p (PInfixApp a op b) = parensIf (p > 0) $
                    myFsep [pretty a, pretty (QConOp op), pretty b]
            prettyPrec p (PApp n ps) = parensIf (p > 1) $
                    myFsep (pretty n : map pretty ps)
            prettyPrec _ (PTuple ps) = parenList . map pretty $ ps
            prettyPrec _ (PList ps) =
                    bracketList . punctuate comma . map pretty $ ps
            prettyPrec _ (PParen p) = parens . pretty $ p
            prettyPrec _ (PRec c fields) =
                    pretty c <> (braceList . map pretty $ fields)
            -- special case that would otherwise be buggy
            prettyPrec _ (PAsPat name (PIrrPat pat)) =
                    myFsep [pretty name <> char '@', char '~' <> pretty pat]
            prettyPrec _ (PAsPat name pat) =
                    hcat [pretty name, char '@', pretty pat]
            prettyPrec _ PWildCard = char '_'
            prettyPrec _ (PIrrPat pat) = char '~' <> pretty pat
            prettyPrec _ (PatTypeSig _pos pat ty) =
                    myFsep [pretty pat, text "::", pretty ty]
            prettyPrec p (PViewPat e pat) = parensIf (p > 0) $
                    myFsep [pretty e, text "->", pretty pat]
            prettyPrec p (PNPlusK n k) = parensIf (p > 0) $
                    myFsep [pretty n, text "+", text $ show k]
            -- HaRP
            prettyPrec _ (PRPat rs) =
                    bracketList . punctuate comma . map pretty $ rs
            -- Hsx
            prettyPrec _ (PXTag _ n attrs mattr cp) =
                let ap = maybe [] (return . pretty) mattr
                 in hcat $ -- TODO: should not introduce blanks
                      (myFsep $ (char '<' <> pretty n): map pretty attrs ++ ap ++ [char '>']):
                        map pretty cp ++ [myFsep $ [text "</" <> pretty n, char '>']]
            prettyPrec _ (PXETag _ n attrs mattr) =
                    let ap = maybe [] (return . pretty) mattr
                     in myFsep $ (char '<' <> pretty n): map pretty attrs ++ ap ++ [text "/>"]
            prettyPrec _ (PXPcdata s) = text s
            prettyPrec _ (PXPatTag p) =
                    myFsep $ [text "<%", pretty p, text "%>"]
            prettyPrec _ (PXRPats ps) =
                    myFsep $ text "<[" : map pretty ps ++ [text "%>"]
            -- Generics
            prettyPrec _ (PExplTypeArg qn t) =
                    myFsep [pretty qn, text "{|", pretty t, text "|}"]
            -- BangPatterns
            prettyPrec _ (PBangPat p) = text "!" <> pretty p

    instance Pretty PXAttr where
            pretty (PXAttr n p) =
                    myFsep [pretty n, char '=', pretty p]

    instance Pretty PatField where
            pretty (PFieldPat name pat) =
                    myFsep [pretty name, equals, pretty pat]
            pretty (PFieldPun name) = pretty name
            pretty (PFieldWildcard) = text ".."

    --------------------- Regular Patterns -------------------------

    instance Pretty RPat where
            pretty (RPOp r op) = pretty r <> pretty op
            pretty (RPEither r1 r2) = parens . myFsep $
                    [pretty r1, char '|', pretty r2]
            pretty (RPSeq rs) =
                    myFsep $ text "(/" : map pretty rs ++ [text "/)"]
            pretty (RPGuard r gs) =
                    myFsep $ text "(|" : pretty r : char '|' : map pretty gs ++ [text "|)"]
            -- special case that would otherwise be buggy
            pretty (RPCAs n (RPPat (PIrrPat p))) =
                    myFsep [pretty n <> text "@:", char '~' <> pretty p]
            pretty (RPCAs n r) = hcat [pretty n, text "@:", pretty r]
            -- special case that would otherwise be buggy
            pretty (RPAs n (RPPat (PIrrPat p))) =
                    myFsep [pretty n <> text "@:", char '~' <> pretty p]
            pretty (RPAs n r) = hcat [pretty n, char '@', pretty r]
            pretty (RPPat p) = pretty p
            pretty (RPParen rp) = parens . pretty $ rp

    instance Pretty RPatOp where
            pretty RPStar  = char '*'
            pretty RPStarG = text "*!"
            pretty RPPlus  = char '+'
            pretty RPPlusG = text "+!"
            pretty RPOpt   = char '?'
            pretty RPOptG  = text "?!"

    ------------------------- Case bodies  -------------------------
    instance Pretty Alt where
            pretty (Alt _pos e gAlts binds) =
                    pretty e <+> pretty gAlts $$$ ppWhere binds

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

    instance Pretty GuardedAlt where
            pretty (GuardedAlt _pos guards body) =
                    myFsep $ char '|': (punctuate comma . map pretty $ guards) ++ [text "->", pretty body]

    ------------------------- Statements in monads, guards & list comprehensions -----
    instance Pretty Stmt where
            pretty (Generator _loc e from) =
                    pretty e <+> text "<-" <+> pretty from
            pretty (Qualifier e) = pretty e
            -- two cases for lets
            pretty (LetStmt (BDecls declList)) =
                    ppLetStmt declList
            pretty (LetStmt (IPBinds bindList)) =
                    ppLetStmt bindList
            pretty (RecStmt stmtList) =
                    text "rec" $$$ ppBody letIndent (map pretty stmtList)

    ppLetStmt l = text "let" $$$ ppBody letIndent (map pretty l)

    instance Pretty QualStmt where
            pretty (QualStmt s) = pretty s
            pretty (ThenTrans    f)    = myFsep $ [text "then", pretty f]
            pretty (ThenBy       f e)  = myFsep $ [text "then", pretty f, text "by", pretty e]
            pretty (GroupBy      e)    = myFsep $ [text "then", text "group", text "by", pretty e]
            pretty (GroupUsing   f)    = myFsep $ [text "then", text "group", text "using", pretty f]
            pretty (GroupByUsing e f)  = myFsep $ [text "then", text "group", text "by",
                                                    pretty e, text "using", pretty f]

    ------------------------- Record updates
    instance Pretty FieldUpdate where
            pretty (FieldUpdate name e) =
                    myFsep [pretty name, equals, pretty e]
            pretty (FieldPun name) = pretty name
            pretty (FieldWildcard) = text ".."

    ------------------------- Names -------------------------
    instance Pretty QOp where
            pretty (QVarOp n) = ppQNameInfix n
            pretty (QConOp n) = ppQNameInfix n

    ppQNameInfix :: QName -> Doc
    ppQNameInfix name
            | isSymbolName (getName name) = ppQName name
            | otherwise = char '`' <> ppQName name <> char '`'

    instance Pretty QName where
            pretty name = case name of
                    UnQual (Symbol ('#':_)) -> char '(' <+> ppQName name <+> char ')'
                    _ -> parensIf (isSymbolName (getName name)) (ppQName name)

    ppQName :: QName -> Doc
    ppQName (UnQual name) = ppName name
    ppQName (Qual m name) = pretty m <> char '.' <> ppName name
    ppQName (Special sym) = text (specialName sym)

    instance Pretty Op where
            pretty (VarOp n) = ppNameInfix n
            pretty (ConOp n) = ppNameInfix n

    ppNameInfix :: Name -> Doc
    ppNameInfix name
            | isSymbolName name = ppName name
            | otherwise = char '`' <> ppName name <> char '`'

    instance Pretty Name where
            pretty name = case name of
                    Symbol ('#':_) -> char '(' <+> ppName name <+> char ')'
                    _ -> parensIf (isSymbolName name) (ppName name)

    ppName :: Name -> Doc
    ppName (Ident s) = text s
    ppName (Symbol s) = text s

    instance Pretty IPName where
            pretty (IPDup s) = char '?' <> text s
            pretty (IPLin s) = char '%' <> text s

    instance Pretty IPBind where
            pretty (IPBind _loc ipname exp) =
                    myFsep [pretty ipname, equals, pretty exp]

    instance Pretty CName where
            pretty (VarName n) = pretty n
            pretty (ConName n) = pretty n

    instance Pretty SpecialCon where
            pretty sc = text $ specialName sc

    isSymbolName :: Name -> Bool
    isSymbolName (Symbol _) = True
    isSymbolName _ = False

    getName :: QName -> Name
    getName (UnQual s) = s
    getName (Qual _ s) = s
    getName (Special Cons) = Symbol ":"
    getName (Special FunCon) = Symbol "->"
    getName (Special s) = Ident (specialName s)

    specialName :: SpecialCon -> String
    specialName UnitCon = "()"
    specialName ListCon = "[]"
    specialName FunCon = "->"
    specialName (TupleCon b n) = "(" ++ hash ++ replicate (n-1) ',' ++ hash ++ ")"
        where hash = if b == Unboxed then "#" else ""
    specialName Cons = ":"

    ppContext :: Context -> Doc
    ppContext []      = empty
    ppContext context = mySep [parenList (map pretty context), text "=>"]

    -- hacked for multi-parameter type classes
    instance Pretty Asst where
            pretty (ClassA a ts)   = myFsep $ ppQName a : map ppAType ts
            pretty (InfixA a op b) = myFsep $ [pretty a, ppQNameInfix op, pretty b]
            pretty (IParam i t)    = myFsep $ [pretty i, text "::", pretty t]
            pretty (EqualP t1 t2)  = myFsep $ [pretty t1, text "~", pretty t2]

    -- Pretty print a source location, useful for printing out error messages
    instance Pretty SrcLoc where
      pretty srcLoc =
        return $ P.hsep [ colonFollow (P.text $ srcFilename srcLoc)
                        , colonFollow (P.int  $ srcLine     srcLoc)
                        , P.int $ srcColumn srcLoc
                        ]

    colonFollow p = P.hcat [ p, P.colon ]

    instance Pretty SrcSpan where
        pretty srcSpan =
            return $ P.hsep [ colonFollow (P.text $ srcSpanFilename srcSpan)
                            , P.hcat [ P.text "("
                                     , P.int $ srcSpanStartLine srcSpan
                                     , P.colon
                                     , P.int $ srcSpanStartColumn srcSpan
                                     , P.text ")"
                                     ]
                            , P.text "-"
                            , P.hcat [ P.text "("
                                     , P.int $ srcSpanEndLine srcSpan
                                     , P.colon
                                     , P.int $ srcSpanEndColumn srcSpan
                                     , P.text ")"
                                     ]
                            ]

    ---------------------------------------------------------------------
    -- Annotated version

    -------------------------  Pretty-Print a Module --------------------
    instance SrcInfo pos => Pretty (A.Module pos) where
            pretty (A.Module pos mbHead os imp decls) =
                    markLine pos $
                    myVcat $ map pretty os ++
                        (case mbHead of
                            Nothing -> id
                            Just h  -> \x -> [topLevel (pretty h) x])
                        (map pretty imp ++ map pretty decls)
            pretty (A.XmlPage pos _mn os n attrs mattr cs) =
                    markLine pos $
                    myVcat $ map pretty os ++
                        [let ax = maybe [] (return . pretty) mattr
                          in hcat $
                             (myFsep $ (char '<' <> pretty n): map pretty attrs ++ ax ++ [char '>']):
                                map pretty cs ++ [myFsep $ [text "</" <> pretty n, char '>']]]
            pretty (A.XmlHybrid pos mbHead os imp decls n attrs mattr cs) =
                    markLine pos $
                    myVcat $ map pretty os ++ [text "<%"] ++
                        (case mbHead of
                            Nothing -> id
                            Just h  -> \x -> [topLevel (pretty h) x])
                        (map pretty imp ++ map pretty decls ++
                            [let ax = maybe [] (return . pretty) mattr
                              in hcat $
                                 (myFsep $ (char '<' <> pretty n): map pretty attrs ++ ax ++ [char '>']):
                                    map pretty cs ++ [myFsep $ [text "</" <> pretty n, char '>']]])

    --------------------------  Module Header ------------------------------
    instance Pretty (A.ModuleHead l) where
        pretty (A.ModuleHead _ m mbWarn mbExportList) = mySep [
            text "module",
            pretty m,
            maybePP pretty mbWarn,
            maybePP pretty mbExportList,
            text "where"]

    instance Pretty (A.WarningText l) where
        pretty = ppWarnTxt. sWarningText

    instance Pretty (A.ModuleName l) where
            pretty = pretty . sModuleName

    instance Pretty (A.ExportSpecList l) where
            pretty (A.ExportSpecList _ especs)  = parenList $ map pretty especs

    instance Pretty (A.ExportSpec l) where
            pretty = pretty . sExportSpec

    instance SrcInfo pos => Pretty (A.ImportDecl pos) where
            pretty = pretty . sImportDecl

    instance Pretty (A.ImportSpecList l) where
            pretty (A.ImportSpecList _ b ispecs)  =
                (if b then text "hiding" else empty)
                    <+> parenList (map pretty ispecs)

    instance Pretty (A.ImportSpec l) where
            pretty = pretty . sImportSpec

    -------------------------  Declarations ------------------------------
    instance SrcInfo pos => Pretty (A.Decl pos) where
            pretty = pretty . sDecl

    instance Pretty (A.DeclHead l) where
        pretty (A.DHead l n tvs)       = mySep (pretty n : map pretty tvs)
        pretty (A.DHInfix l tva n tvb) = mySep [pretty tva, pretty n, pretty tvb]
        pretty (A.DHParen l dh)        = parens (pretty dh)

    instance Pretty (A.InstHead l) where
        pretty (A.IHead l qn ts)       = mySep (pretty qn : map pretty ts)
        pretty (A.IHInfix l ta qn tb)  = mySep [pretty ta, pretty qn, pretty tb]
        pretty (A.IHParen l ih)        = parens (pretty ih)

    instance Pretty (A.DataOrNew l) where
            pretty = pretty . sDataOrNew

    instance Pretty (A.Assoc l) where
            pretty = pretty . sAssoc

    instance SrcInfo pos => Pretty (A.Match pos) where
            pretty = pretty . sMatch

    instance SrcInfo loc => Pretty (A.ClassDecl loc) where
            pretty = pretty . sClassDecl

    instance SrcInfo loc => Pretty (A.InstDecl loc) where
            pretty = pretty . sInstDecl

    ------------------------- FFI stuff -------------------------------------
    instance Pretty (A.Safety l) where
            pretty = pretty . sSafety

    instance Pretty (A.CallConv l) where
            pretty = pretty . sCallConv

    ------------------------- Pragmas ---------------------------------------
    instance SrcInfo loc => Pretty (A.Rule loc) where
            pretty = pretty . sRule

    instance Pretty (A.Activation l) where
        pretty = pretty . sActivation

    instance Pretty (A.RuleVar l) where
        pretty = pretty . sRuleVar

    instance SrcInfo loc => Pretty (A.ModulePragma loc) where
        pretty (A.LanguagePragma _ ns) =
            myFsep $ text "{-# LANGUAGE" : punctuate (char ',') (map pretty ns) ++ [text "#-}"]
        pretty (A.OptionsPragma _ (Just tool) s) =
            myFsep $ [text "{-# OPTIONS_" <> pretty tool, text s, text "#-}"]
        pretty (A.OptionsPragma _ _ s) =
            myFsep $ [text "{-# OPTIONS", text s, text "#-}"]
        pretty (A.AnnModulePragma _ ann) =
            myFsep $ [text "{-# ANN", pretty ann, text "#-}"]

    instance SrcInfo loc => Pretty (A.Annotation loc) where
        pretty = pretty . sAnnotation

    ------------------------- Data & Newtype Bodies -------------------------
    instance Pretty (A.QualConDecl l) where
            pretty (A.QualConDecl _pos mtvs ctxt con) =
                    myFsep [ppForall (fmap (map sTyVarBind) mtvs), ppContext $ maybe [] sContext ctxt, pretty con]

    instance Pretty (A.GadtDecl l) where
            pretty (A.GadtDecl _pos name ty) =
                    myFsep [pretty name, text "::", pretty ty]

    instance Pretty (A.ConDecl l) where
            pretty = pretty . sConDecl

    instance Pretty (A.FieldDecl l) where
            pretty (A.FieldDecl _ names ty) =
                    myFsepSimple $ (punctuate comma . map pretty $ names) ++
                           [text "::", pretty ty]

    instance Pretty (A.BangType l) where
            pretty = pretty . sBangType

    instance Pretty (A.Deriving l) where
            pretty (A.Deriving _ []) = text "deriving" <+> parenList []
            pretty (A.Deriving _ [A.IHead _ d []]) = text "deriving" <+> pretty d
            pretty (A.Deriving _ ihs) = text "deriving" <+> parenList (map pretty ihs)

    ------------------------- Types -------------------------
    instance Pretty (A.Type l) where
            pretty = pretty . sType

    instance Pretty (A.TyVarBind l) where
            pretty = pretty . sTyVarBind

    ---------------------------- Kinds ----------------------------

    instance Pretty (A.Kind l) where
            pretty = pretty . sKind

    ------------------- Functional Dependencies -------------------
    instance Pretty (A.FunDep l) where
            pretty = pretty . sFunDep

    ------------------------- Expressions -------------------------
    instance SrcInfo loc => Pretty (A.Rhs loc) where
            pretty = pretty . sRhs

    instance SrcInfo loc => Pretty (A.GuardedRhs loc) where
            pretty = pretty . sGuardedRhs

    instance Pretty (A.Literal l) where
            pretty = pretty . sLiteral

    instance SrcInfo loc => Pretty (A.Exp loc) where
            pretty = pretty . sExp

    instance SrcInfo loc => Pretty (A.XAttr loc) where
            pretty = pretty . sXAttr

    instance Pretty (A.XName l) where
            pretty = pretty . sXName

    --------------------- Template Haskell -------------------------

    instance SrcInfo loc => Pretty (A.Bracket loc) where
            pretty = pretty . sBracket

    instance SrcInfo loc => Pretty (A.Splice loc) where
            pretty = pretty . sSplice

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

    instance SrcInfo loc => Pretty (A.Pat loc) where
            pretty = pretty . sPat

    instance SrcInfo loc => Pretty (A.PXAttr loc) where
            pretty = pretty . sPXAttr

    instance SrcInfo loc => Pretty (A.PatField loc) where
            pretty = pretty . sPatField

    --------------------- Regular Patterns -------------------------

    instance SrcInfo loc => Pretty (A.RPat loc) where
            pretty = pretty . sRPat

    instance Pretty (A.RPatOp l) where
            pretty = pretty . sRPatOp

    ------------------------- Case bodies  -------------------------
    instance SrcInfo loc => Pretty (A.Alt loc) where
            pretty = pretty . sAlt

    instance SrcInfo loc => Pretty (A.GuardedAlts loc) where
            pretty = pretty . sGuardedAlts

    instance SrcInfo loc => Pretty (A.GuardedAlt loc) where
            pretty = pretty . sGuardedAlt

    ------------------------- Statements in monads, guards & list comprehensions -----
    instance SrcInfo loc => Pretty (A.Stmt loc) where
            pretty = pretty . sStmt

    instance SrcInfo loc => Pretty (A.QualStmt loc) where
            pretty = pretty . sQualStmt

    ------------------------- Record updates
    instance SrcInfo loc => Pretty (A.FieldUpdate loc) where
            pretty = pretty . sFieldUpdate

    ------------------------- Names -------------------------
    instance Pretty (A.QOp l) where
            pretty = pretty . sQOp

    instance Pretty (A.QName l) where
            pretty = pretty . sQName

    instance Pretty (A.Op l) where
            pretty = pretty . sOp

    instance Pretty (A.Name l) where
            pretty = pretty . sName

    instance Pretty (A.IPName l) where
            pretty = pretty . sIPName

    instance SrcInfo loc => Pretty (A.IPBind loc) where
            pretty = pretty . sIPBind

    instance Pretty (A.CName l) where
            pretty = pretty . sCName

    instance Pretty (A.Context l) where
            pretty (A.CxEmpty _) = mySep [text "()", text "=>"]
            pretty (A.CxSingle _ asst) = mySep [pretty asst, text "=>"]
            pretty (A.CxTuple _ assts) = myFsep $ [parenList (map pretty assts), text "=>"]
            pretty (A.CxParen _ asst)  = parens (pretty asst)

    -- hacked for multi-parameter type classes
    instance Pretty (A.Asst l) where
            pretty = pretty . sAsst

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

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

    hashParenList :: [Doc] -> Doc
    hashParenList = hashParens . myFsepSimple . punctuate comma
      where hashParens = parens . hashes
            hashes = \doc -> char '#' <> doc <> char '#'

    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
             case e of PPOffsideRule -> indent
                       PPSemiColon   -> indentExplicit
                       _ -> flatBlock dl
                       where
                       indent  = do{i <-fmap f getPPEnv;nest i . vcat $ dl}
                       indentExplicit = do {i <- fmap f getPPEnv;
                               nest i . prettyBlock $ 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 :: SrcInfo s => s -> Doc -> Doc
    markLine loc doc = do
            e <- getPPEnv
            let y = startLine loc
            let line l =
                  text ("{-# LINE " ++ show l ++ " \"" ++ fileName loc ++ "\" #-}")
            if linePragmas e then layoutChoice (line y $$) (line (y+1) <+>) doc
                  else doc

    --------------------------------------------------------------------------------
    -- Pretty-printing of internal constructs, for error messages while parsing

    instance SrcInfo loc => Pretty (P.PExp loc) where
            pretty (P.Lit _ l) = pretty l
            pretty (P.InfixApp _ a op b) = myFsep [pretty a, pretty op, pretty b]
            pretty (P.NegApp _ e) = myFsep [char '-', pretty e]
            pretty (P.App _ a b) = myFsep [pretty a, pretty b]
            pretty (P.Lambda _loc expList ppBody) = myFsep $
                    char '\\' : map pretty expList ++ [text "->", pretty ppBody]
            pretty (P.Let _ (A.BDecls _ declList) letBody) =
                    ppLetExp declList letBody
            pretty (P.Let _ (A.IPBinds _ bindList) letBody) =
                    ppLetExp bindList letBody
            pretty (P.If _ cond thenexp elsexp) =
                    myFsep [text "if", pretty cond,
                            text "then", pretty thenexp,
                            text "else", pretty elsexp]
            pretty (P.Case _ cond altList) =
                    myFsep [text "case", pretty cond, text "of"]
                    $$$ ppBody caseIndent (map pretty altList)
            pretty (P.Do _ stmtList) =
                    text "do" $$$ ppBody doIndent (map pretty stmtList)
            pretty (P.MDo _ stmtList) =
                    text "mdo" $$$ ppBody doIndent (map pretty stmtList)
            pretty (P.Var _ name) = pretty name
            pretty (P.IPVar _ ipname) = pretty ipname
            pretty (P.Con _ name) = pretty name
            pretty (P.TupleSection _ mExpList) = parenList . map (maybePP pretty) $ mExpList
            pretty (P.Paren _ e) = parens . pretty $ e
            pretty (P.RecConstr _ c fieldList) =
                    pretty c <> (braceList . map pretty $ fieldList)
            pretty (P.RecUpdate _ e fieldList) =
                    pretty e <> (braceList . map pretty $ fieldList)
            pretty (P.List _ list) =
                    bracketList . punctuate comma . map pretty $ list
            pretty (P.EnumFrom _ e) =
                    bracketList [pretty e, text ".."]
            pretty (P.EnumFromTo _ from to) =
                    bracketList [pretty from, text "..", pretty to]
            pretty (P.EnumFromThen _ from thenE) =
                    bracketList [pretty from <> comma, pretty thenE, text ".."]
            pretty (P.EnumFromThenTo _ from thenE to) =
                    bracketList [pretty from <> comma, pretty thenE,
                                 text "..", pretty to]
            pretty (P.ParComp _ e qualLists) =
                    bracketList (intersperse (char '|') $
                                    pretty e : (punctuate comma . concatMap (map pretty) $ qualLists))
            pretty (P.ExpTypeSig _pos e ty) =
                    myFsep [pretty e, text "::", pretty ty]
            pretty (P.BracketExp _ b) = pretty b
            pretty (P.SpliceExp _ s) = pretty s
            pretty (P.TypQuote _ t)  = text "\'\'" <> pretty t
            pretty (P.VarQuote _ x)  = text "\'" <> pretty x
            pretty (P.QuasiQuote _ n qt) = text ("[$" ++ n ++ "|" ++ qt ++ "|]")
            pretty (P.XTag _ n attrs mattr cs) =
                    let ax = maybe [] (return . pretty) mattr
                     in hcat $
                         (myFsep $ (char '<' <> pretty n): map pretty attrs ++ ax ++ [char '>']):
                            map pretty cs ++ [myFsep $ [text "</" <> pretty n, char '>']]
            pretty (P.XETag _ n attrs mattr) =
                    let ax = maybe [] (return . pretty) mattr
                     in myFsep $ (char '<' <> pretty n): map pretty attrs ++ ax ++ [text "/>"]
            pretty (P.XPcdata _ s) = text s
            pretty (P.XExpTag _ e) =
                    myFsep $ [text "<%", pretty e, text "%>"]
            pretty (P.CorePragma _ s e) = myFsep $ map text ["{-# CORE", show s, "#-}"] ++ [pretty e]
            pretty (P.SCCPragma  _ s e) = myFsep $ map text ["{-# SCC",  show s, "#-}"] ++ [pretty e]
            pretty (P.GenPragma  _ s (a,b) (c,d) e) =
                    myFsep $ [text "{-# GENERATED", text $ show s,
                                int a, char ':', int b, char '-',
                                int c, char ':', int d, text "#-}", pretty e]
            pretty (P.Proc _ p e) = myFsep $ [text "proc", pretty p, text "->", pretty e]
            pretty (P.LeftArrApp _ l r)      = myFsep $ [pretty l, text "-<",  pretty r]
            pretty (P.RightArrApp _ l r)     = myFsep $ [pretty l, text ">-",  pretty r]
            pretty (P.LeftArrHighApp _ l r)  = myFsep $ [pretty l, text "-<<", pretty r]
            pretty (P.RightArrHighApp _ l r) = myFsep $ [pretty l, text ">>-", pretty r]
            pretty (P.AsPat _ name (P.IrrPat _ pat)) =
                    myFsep [pretty name <> char '@', char '~' <> pretty pat]
            pretty (P.AsPat _ name pat) =
                    hcat [pretty name, char '@', pretty pat]
            pretty (P.WildCard _) = char '_'
            pretty (P.IrrPat _ pat) = char '~' <> pretty pat
            pretty (P.PostOp _ e op) = pretty e <+> pretty op
            pretty (P.PreOp _ op e)  = pretty op <+> pretty e
            pretty (P.ViewPat _ e p) =
                    myFsep [pretty e, text "->", pretty p]
            pretty (P.SeqRP _ rs) = myFsep $ text "(/" : map pretty rs ++ [text "/)"]
            pretty (P.GuardRP _ r gs) =
                    myFsep $ text "(|" : pretty r : char '|' : map pretty gs ++ [text "|)"]
            pretty (P.EitherRP _ r1 r2) = parens . myFsep $ [pretty r1, char '|', pretty r2]
            pretty (P.CAsRP _ n (P.IrrPat _ e)) =
                    myFsep [pretty n <> text "@:", char '~' <> pretty e]
            pretty (P.CAsRP _ n r) = hcat [pretty n, text "@:", pretty r]
            pretty (P.XRPats _ ps) =
                    myFsep $ text "<[" : map pretty ps ++ [text "%>"]
            pretty (P.ExplTypeArg _ qn t) =
                    myFsep [pretty qn, text "{|", pretty t, text "|}"]
            pretty (P.BangPat _ e) = text "!" <> pretty e

    instance SrcInfo loc => Pretty (P.PFieldUpdate loc) where
            pretty (P.FieldUpdate _ name e) =
                    myFsep [pretty name, equals, pretty e]
            pretty (P.FieldPun _ name) = pretty name
            pretty (P.FieldWildcard _) = text ".."

    instance SrcInfo loc => Pretty (P.ParseXAttr loc) where
            pretty (P.XAttr _ n v) =
                    myFsep [pretty n, char '=', pretty v]

    instance SrcInfo loc => Pretty (P.PContext loc) where
            pretty (P.CxEmpty _) = mySep [text "()", text "=>"]
            pretty (P.CxSingle _ asst) = mySep [pretty asst, text "=>"]
            pretty (P.CxTuple _ assts) = myFsep $ [parenList (map pretty assts), text "=>"]
            pretty (P.CxParen _ asst)  = parens (pretty asst)

    instance SrcInfo loc => Pretty (P.PAsst loc) where
            pretty (P.ClassA _ a ts)   = myFsep $ ppQName (sQName a) : map (prettyPrec prec_atype) ts
            pretty (P.InfixA _ a op b) = myFsep $ [pretty a, ppQNameInfix (sQName op), pretty b]
            pretty (P.IParam _ i t)    = myFsep $ [pretty i, text "::", pretty t]
            pretty (P.EqualP _ t1 t2)  = myFsep $ [pretty t1, text "~", pretty t2]

    instance SrcInfo loc => Pretty (P.PType loc) where
            prettyPrec p (P.TyForall _ mtvs ctxt htype) = parensIf (p > 0) $
                    myFsep [ppForall (fmap (map sTyVarBind) mtvs), maybePP pretty ctxt, pretty htype]
            prettyPrec p (P.TyFun _ a b) = parensIf (p > 0) $
                    myFsep [prettyPrec prec_btype a, text "->", pretty b]
            prettyPrec _ (P.TyTuple _ bxd l) =
                    let ds = map pretty l
                     in case bxd of
                            Boxed   -> parenList ds
                            Unboxed -> hashParenList ds
            prettyPrec _ (P.TyList _ t)  = brackets $ pretty t
            prettyPrec p (P.TyApp _ a b) =
                    {-
                    | a == list_tycon = brackets $ pretty b         -- special case
                    | otherwise = -} parensIf (p > prec_btype) $
                                        myFsep [pretty a, prettyPrec prec_atype b]
            prettyPrec _ (P.TyVar _ name) = pretty name
            prettyPrec _ (P.TyCon _ name) = pretty name
            prettyPrec _ (P.TyParen _ t) = parens (pretty t)
            prettyPrec _ (P.TyPred _ asst) = pretty asst
            prettyPrec _ (P.TyInfix _ a op b) = myFsep [pretty a, ppQNameInfix (sQName op), pretty b]
            prettyPrec _ (P.TyKind _ t k) = parens (myFsep [pretty t, text "::", pretty k])