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

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

prettyCmd :: String -> Cmd Pretty ()
prettyCmd :: String -> Cmd (ModuleT () LB) ()
prettyCmd String
rest =
    let code :: String
code = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> String -> 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 (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 (ModuleT () LB) ())
-> [String] -> Cmd (ModuleT () LB) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Cmd (ModuleT () LB) ()
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 (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 (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 (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 :: 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
                     = 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