{-# 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 = forall st. Module st
newModule
    { moduleCmds :: ModuleT () LB [Command Pretty]
moduleCmds = forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"pretty")
            { help :: Cmd Pretty ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"pretty <expr>. Display haskell code in a pretty-printed manner"
            , process :: String -> Cmd Pretty ()
process = String -> Cmd Pretty ()
prettyCmd
            }
        ]
    }

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

prettyCmd :: String -> Cmd Pretty ()
prettyCmd :: String -> Cmd Pretty ()
prettyCmd String
rest =
    let code :: String
code = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
modPrefix1
        result :: [String]
result = case (String -> ParseResult Module
parseModule (String
modPrefix1 forall a. [a] -> [a] -> [a]
++ String
code forall a. [a] -> [a] -> [a]
++ String
"\n"), String -> ParseResult Module
parseModule (String
modPrefix2 forall a. [a] -> [a] -> [a]
++ String
code 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
                   (forall a. Show a => a -> String
show String
msg forall a. [a] -> [a] -> [a]
++ String
" at column " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
col forall a. Num a => a -> a -> a
- Int
prefLen1)) forall a. a -> [a] -> [a]
: []
    in forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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)   = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ 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)  = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s 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 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map Pat -> Int
patLen [Pat]
pats) forall a. Num a => a -> a -> a
+ Int
1)
            in if Int
l forall a. Ord a => a -> a -> Bool
> Int
16 then Int
defaultLen else Int
l
        makeMode :: Decl -> PPHsMode
makeMode Decl
decl = PPHsMode
defaultMode {
            doIndent :: Int
doIndent     = Int
3,
            caseIndent :: Int
caseIndent   = Int
4,
            onsideIndent :: Int
onsideIndent = Decl -> Int
declLen Decl
decl
        }
        makeModeExp :: p -> PPHsMode
makeModeExp p
_ = PPHsMode
defaultMode {
            doIndent :: Int
doIndent     = Int
3,
            caseIndent :: Int
caseIndent   = Int
4,
            onsideIndent :: Int
onsideIndent = Int
0
        }
        prettyDecl :: Decl -> String
prettyDecl (PatBind (PVar (Ident String
"__expr__")) (UnGuardedRhs Exp
e) Maybe Binds
Nothing) -- pretty printing an expression
                     = forall a. Pretty a => PPHsMode -> a -> String
prettyPrintWithMode (forall {p}. p -> PPHsMode
makeModeExp Exp
e) Exp
e
        prettyDecl Decl
d = 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 forall a b. (a -> b) -> [a] -> [b]
map (String
" "forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse String
"\n"
       -- . map show $ decls
       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Decl -> String
prettyDecl forall a b. (a -> b) -> a -> b
$ [Decl]
decls