    {-# LANGUAGE PatternSynonyms #-}
    {- | Pretty-Printing echo

    example:

    > @pretty fun x = case x of {3 -> "hello" ; 5 -> "world" ; _ -> "else"}

    > fun x
    >  = case x of
    >   3 -> "hello"
    >   5 -> "world"
    >   _ -> "else"

    (c) Johannes Ahlmann, 2005-12-13, released under GPL 2 -}

    module Lambdabot.Plugin.Haskell.Pretty (prettyPlugin) where

    import Lambdabot.Plugin

    import Data.List
    import qualified Language.Haskell.Exts.Simple as Hs
    import Language.Haskell.Exts.Simple hiding (Module, Pretty)

    type Pretty = ModuleT () LB

    prettyPlugin :: Module ()
    prettyPlugin :: Module ()
    prettyPlugin = Module ()
    forall st. Module st
    newModule
        { moduleCmds = return
            [ (command "pretty")
                { help = say "pretty <expr>. Display haskell code in a pretty-printed manner"
                , process = prettyCmd
                }
            ]
        }

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

    prettyCmd :: String -> Cmd Pretty ()
    prettyCmd :: String -> Cmd Pretty ()
    prettyCmd String
    rest =
        let code :: String
    code = (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile (Char -> String -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` String
    " \t>") String
    rest
            modPrefix1 :: String
    modPrefix1 = String
    "module Main where "
            modPrefix2 :: String
    modPrefix2 = String
    "module Main where __expr__ = "
            prefLen1 :: Int
    prefLen1 = String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    modPrefix1
            result :: [String]
    result = case (String -> ParseResult Module
    parseModule (String
    modPrefix1 String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    code String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n"), String -> ParseResult Module
    parseModule (String
    modPrefix2 String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    code String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n"))  of
                (ParseOk Module
    a, ParseResult Module
    _)            -> Module -> [String]
    doPretty Module
    a
                (ParseResult Module
    _, ParseOk Module
    a)            -> Module -> [String]
    doPretty Module
    a
                (ParseFailed SrcLoc
    locat String
    msg,ParseResult Module
    _) -> let (SrcLoc String
    _ Int
    _ Int
    col) = SrcLoc
    locat in
                       (String -> String
    forall a. Show a => a -> String
    show String
    msg String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " at column " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show (Int
    col Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    prefLen1)) String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : []
        in (String -> Cmd Pretty ()) -> [String] -> Cmd Pretty ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ String -> Cmd Pretty ()
    forall (m :: * -> *). Monad m => String -> Cmd m ()
    say [String]
    result -- XXX will this work? No, spaces are compressed.

    -- | calculates "desired" indentation and return pretty-printed declarations
    -- the indentation calculations are still pretty much rough guesswork.
    -- i'll have to figure out a way to do some _reliable_ pretty-printing!
    doPretty :: Hs.Module -> [String]
    doPretty :: Module -> [String]
    doPretty (Hs.Module Maybe ModuleHead
    _ [ModulePragma]
    _ [ImportDecl]
    _ [Decl]
    decls) =
        let defaultLen :: Int
    defaultLen = Int
    4
            declLen :: Decl -> Int
    declLen (FunBind [Match]
    mtches)   = [Int] -> Int
    forall a. Ord a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum ([Int] -> Int) -> [Int] -> Int
    forall a b. (a -> b) -> a -> b
    $ (Match -> Int) -> [Match] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map Match -> Int
    matchLen [Match]
    mtches
            declLen (PatBind Pat
    pat Rhs
    _ Maybe Binds
    _) = Pat -> Int
    patLen Pat
    pat
            declLen Decl
    _  = Int
    defaultLen
            patLen :: Pat -> Int
    patLen (PVar Name
    nm) = Name -> Int
    nameLen Name
    nm
            patLen  Pat
    _  = Int
    defaultLen
            nameLen :: Name -> Int
    nameLen (Ident String
    s)  = String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    s Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1
            nameLen Name
    _  = Int
    defaultLen
            matchLen :: Match -> Int
    matchLen (Match Name
    nm [Pat]
    pats Rhs
    _ Maybe Binds
    _) =
                let l :: Int
    l = (Name -> Int
    nameLen Name
    nm Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + [Int] -> Int
    forall a. Num a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum ((Pat -> Int) -> [Pat] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map Pat -> Int
    patLen [Pat]
    pats) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1)
                in if Int
    l Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    16 then Int
    defaultLen else Int
    l
            makeMode :: Decl -> PPHsMode
    makeMode Decl
    decl = PPHsMode
    defaultMode {
                doIndent     = 3,
                caseIndent   = 4,
                onsideIndent = declLen decl
            }
            makeModeExp :: p -> PPHsMode
    makeModeExp p
    _ = PPHsMode
    defaultMode {
                doIndent     = 3,
                caseIndent   = 4,
                onsideIndent = 0
            }
            prettyDecl :: Decl -> String
    prettyDecl (PatBind (PVar (Ident String
    "__expr__")) (UnGuardedRhs Exp
    e) Maybe Binds
    Nothing) -- pretty printing an expression
                         = PPHsMode -> Exp -> String
    forall a. Pretty a => PPHsMode -> a -> String
    prettyPrintWithMode (Exp -> PPHsMode
    forall {p}. p -> PPHsMode
    makeModeExp Exp
    e) Exp
    e
            prettyDecl Decl
    d = PPHsMode -> Decl -> String
    forall a. Pretty a => PPHsMode -> a -> String
    prettyPrintWithMode (Decl -> PPHsMode
    makeMode Decl
    d) Decl
    d
        -- TODO: prefixing with hashes is done, because i didn't find a way
        --   to disable the indentation filter of lambdabot only for this module...
        in (String -> String) -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (String
    " "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++) ([String] -> [String])
    -> ([Decl] -> [String]) -> [Decl] -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String]
    lines (String -> [String]) -> ([Decl] -> String) -> [Decl] -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([String] -> String) -> ([Decl] -> [String]) -> [Decl] -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    intersperse String
    "\n"
           -- . map show $ decls
           ([String] -> [String])
    -> ([Decl] -> [String]) -> [Decl] -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Decl -> String) -> [Decl] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map Decl -> String
    prettyDecl ([Decl] -> [String]) -> [Decl] -> [String]
    forall a b. (a -> b) -> a -> b
    $ [Decl]
    decls