{-# 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 = 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 "pretty")
{ help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "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 rest :: 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` " \t>") String
rest
modPrefix1 :: String
modPrefix1 = "module Main where "
modPrefix2 :: String
modPrefix2 = "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]
++ "\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]
++ "\n")) of
(ParseOk a :: Module
a, _) -> Module -> [String]
doPretty Module
a
(_, ParseOk a :: Module
a) -> Module -> [String]
doPretty Module
a
(ParseFailed locat :: SrcLoc
locat msg :: String
msg,_) -> let (SrcLoc _ _ col :: Int
col) = SrcLoc
locat in
(String -> String
forall a. Show a => a -> String
show String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ " 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
doPretty :: Hs.Module -> [String]
doPretty :: Module -> [String]
doPretty (Hs.Module _ _ _ decls :: [Decl]
decls) =
let defaultLen :: Int
defaultLen = 4
declLen :: Decl -> Int
declLen (FunBind mtches :: [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
pat _ _) = Pat -> Int
patLen Pat
pat
declLen _ = Int
defaultLen
patLen :: Pat -> Int
patLen (PVar nm :: Name
nm) = Name -> Int
nameLen Name
nm
patLen _ = Int
defaultLen
nameLen :: Name -> Int
nameLen (Ident s :: 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
+ 1
nameLen _ = Int
defaultLen
matchLen :: Match -> Int
matchLen (Match nm :: Name
nm pats :: [Pat]
pats _ _) =
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
+ 1)
in if Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 16 then Int
defaultLen else Int
l
makeMode :: Decl -> PPHsMode
makeMode decl :: Decl
decl = PPHsMode
defaultMode {
doIndent :: Int
doIndent = 3,
caseIndent :: Int
caseIndent = 4,
onsideIndent :: Int
onsideIndent = Decl -> Int
declLen Decl
decl
}
makeModeExp :: p -> PPHsMode
makeModeExp _ = PPHsMode
defaultMode {
doIndent :: Int
doIndent = 3,
caseIndent :: Int
caseIndent = 4,
onsideIndent :: Int
onsideIndent = 0
}
prettyDecl :: Decl -> String
prettyDecl (PatBind (PVar (Ident "__expr__")) (UnGuardedRhs e :: Exp
e) Nothing)
= PPHsMode -> Exp -> String
forall a. Pretty a => PPHsMode -> a -> String
prettyPrintWithMode (Exp -> PPHsMode
forall p. p -> PPHsMode
makeModeExp Exp
e) Exp
e
prettyDecl d :: Decl
d = PPHsMode -> Decl -> String
forall a. Pretty a => PPHsMode -> a -> String
prettyPrintWithMode (Decl -> PPHsMode
makeMode Decl
d) Decl
d
in (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (" "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 "\n"
([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