{-# LANGUAGE PatternSynonyms #-}
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
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)
= 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
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"
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