{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleContexts #-}
module Lambdabot.Plugin.Haskell.Djinn (djinnPlugin) where
import Lambdabot.Config.Haskell
import Lambdabot.Logging
import Lambdabot.Plugin
import Lambdabot.Util
import Control.Exception.Lifted as E
import Control.Monad
import Control.Monad.Trans
import Data.Char
import Data.List
import Data.Maybe
import System.Process (readProcess)
import Text.Regex.TDFA
type DjinnEnv = ([Decl] , [Decl])
type Djinn = ModuleT (Maybe DjinnEnv) LB
type Decl = String
djinnPlugin :: Module (Maybe DjinnEnv)
djinnPlugin :: Module (Maybe DjinnEnv)
djinnPlugin = forall st. Module st
newModule
{ moduleSerialize :: Maybe (Serial (Maybe DjinnEnv))
moduleSerialize = forall a. Maybe a
Nothing
, moduleDefState :: LB (Maybe DjinnEnv)
moduleDefState = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
, moduleInit :: ModuleT (Maybe DjinnEnv) LB ()
moduleInit = forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (m :: * -> *).
MonadLB m =>
[String] -> String -> m (Either [String] String)
djinn [] String
"")
, moduleCmds :: ModuleT (Maybe DjinnEnv) LB [Command Djinn]
moduleCmds = forall (m :: * -> *) a. Monad m => a -> m a
return
[ (String -> Command Identity
command String
"djinn")
{ help :: Cmd Djinn ()
help = 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
"djinn <type>."
, String
"Generates Haskell code from a type."
, String
"https://github.com/augustss/djinn"
]
, process :: String -> Cmd Djinn ()
process = forall (m :: * -> *).
Monad m =>
(String -> Cmd m ()) -> String -> Cmd m ()
rejectingCmds String -> Cmd Djinn ()
djinnCmd
}
, (String -> Command Identity
command String
"djinn-add")
{ help :: Cmd Djinn ()
help = do
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"djinn-add <expr>."
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Define a new function type or type synonym"
, process :: String -> Cmd Djinn ()
process = forall (m :: * -> *).
Monad m =>
(String -> Cmd m ()) -> String -> Cmd m ()
rejectingCmds String -> Cmd Djinn ()
djinnAddCmd
}
, (String -> Command Identity
command String
"djinn-del")
{ help :: Cmd Djinn ()
help = do
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"djinn-del <ident>."
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Remove a symbol from the environment"
, process :: String -> Cmd Djinn ()
process = forall (m :: * -> *).
Monad m =>
(String -> Cmd m ()) -> String -> Cmd m ()
rejectingCmds String -> Cmd Djinn ()
djinnDelCmd
}
, (String -> Command Identity
command String
"djinn-env")
{ help :: Cmd Djinn ()
help = do
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"djinn-env."
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Show the current djinn environment"
, process :: String -> Cmd Djinn ()
process = forall a b. a -> b -> a
const Cmd Djinn ()
djinnEnvCmd
}
, (String -> Command Identity
command String
"djinn-names")
{ help :: Cmd Djinn ()
help = do
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"djinn-names."
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Show the current djinn environment, compactly."
, process :: String -> Cmd Djinn ()
process = forall a b. a -> b -> a
const Cmd Djinn ()
djinnNamesCmd
}
, (String -> Command Identity
command String
"djinn-clr")
{ help :: Cmd Djinn ()
help = do
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"djinn-clr."
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Reset the djinn environment"
, process :: String -> Cmd Djinn ()
process = forall a b. a -> b -> a
const Cmd Djinn ()
djinnClrCmd
}
, (String -> Command Identity
command String
"djinn-ver")
{ help :: Cmd Djinn ()
help = do
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"djinn-ver."
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Show current djinn version"
, process :: String -> Cmd Djinn ()
process = forall a b. a -> b -> a
const Cmd Djinn ()
djinnVerCmd
}
]
}
getSavedEnv :: Djinn DjinnEnv
getSavedEnv :: Djinn DjinnEnv
getSavedEnv = forall (m :: * -> *) a.
MonadLBState m =>
(LBState m -> (LBState m -> m ()) -> m a) -> m a
withMS forall a b. (a -> b) -> a -> b
$ \LBState Djinn
st LBState Djinn -> ModuleT (Maybe DjinnEnv) LB ()
write ->
case LBState Djinn
st of
Just DjinnEnv
env -> forall (m :: * -> *) a. Monad m => a -> m a
return DjinnEnv
env
Maybe DjinnEnv
LBState Djinn
Nothing -> do
Either [String] DjinnEnv
st' <- forall (m :: * -> *).
MonadLB m =>
DjinnEnv -> m (Either [String] DjinnEnv)
getDjinnEnv ([],[])
let newMS :: ([String], [a])
newMS = (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const []) forall a b. (a, b) -> b
snd Either [String] DjinnEnv
st', [])
LBState Djinn -> ModuleT (Maybe DjinnEnv) LB ()
write (forall a. a -> Maybe a
Just forall {a}. ([String], [a])
newMS)
forall (m :: * -> *) a. Monad m => a -> m a
return forall {a}. ([String], [a])
newMS
getUserEnv :: Djinn [Decl]
getUserEnv :: Djinn [String]
getUserEnv = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Djinn DjinnEnv
getSavedEnv
rejectingCmds :: Monad m => ([Char] -> Cmd m ()) -> [Char] -> Cmd m ()
rejectingCmds :: forall (m :: * -> *).
Monad m =>
(String -> Cmd m ()) -> String -> Cmd m ()
rejectingCmds String -> Cmd m ()
action String
args
| forall a. Int -> [a] -> [a]
take Int
1 (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
args) forall a. Eq a => a -> a -> Bool
== String
":"
= forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Invalid command"
| Bool
otherwise = String -> Cmd m ()
action String
args
djinnCmd :: [Char] -> Cmd Djinn ()
djinnCmd :: String -> Cmd Djinn ()
djinnCmd String
s = do
[String]
env <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Djinn [String]
getUserEnv
Either [String] String
e <- forall (m :: * -> *).
MonadLB m =>
[String] -> String -> m (Either [String] String)
djinn [String]
env forall a b. (a -> b) -> a -> b
$ String
":set +sorted\nf ? " forall a. [a] -> [a] -> [a]
++ forall {source1}. RegexLike Regex source1 => source1 -> source1
dropForall String
s
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). Monad m => String -> Cmd m ()
say forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id ([String] -> [String]
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) Either [String] String
e
where
dropForall :: source1 -> source1
dropForall source1
t = forall b a. b -> (a -> b) -> Maybe a -> b
maybe source1
t forall a. MatchResult a -> a
mrAfter (source1
t forall source source1 target (m :: * -> *).
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target, MonadFail m) =>
source1 -> source -> m target
=~~ String
re)
re :: String
re = String
"^forall [[:alnum:][:space:]]+\\."
parse :: [String] -> [String]
parse :: [String] -> [String]
parse [String]
x = if forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
x forall a. Ord a => a -> a -> Bool
< Int
2
then [String
"No output from Djinn; installed?"]
else forall a. [a] -> [a]
tail [String]
x
djinnAddCmd :: [Char] -> Cmd Djinn ()
djinnAddCmd :: String -> Cmd Djinn ()
djinnAddCmd String
s = do
([String]
p,[String]
st) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Djinn DjinnEnv
getSavedEnv
Either [String] DjinnEnv
est <- forall (m :: * -> *).
MonadLB m =>
DjinnEnv -> m (Either [String] DjinnEnv)
getDjinnEnv ([String]
p, forall a. (a -> Bool) -> [a] -> [a]
strip Char -> Bool
isSpace String
s forall a. a -> [a] -> [a]
: [String]
st)
case Either [String] DjinnEnv
est of
Left [String]
e -> forall (m :: * -> *). Monad m => String -> Cmd m ()
say (forall a. [a] -> a
head [String]
e)
Right DjinnEnv
st' -> forall (m :: * -> *). MonadLBState m => LBState m -> m ()
writeMS (forall a. a -> Maybe a
Just DjinnEnv
st')
djinnEnvCmd :: Cmd Djinn ()
djinnEnvCmd :: Cmd Djinn ()
djinnEnvCmd = do
([String]
prelude,[String]
st) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Djinn DjinnEnv
getSavedEnv
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). Monad m => String -> Cmd m ()
say forall a b. (a -> b) -> a -> b
$ [String]
prelude forall a. [a] -> [a] -> [a]
++ [String]
st
djinnNamesCmd :: Cmd Djinn ()
djinnNamesCmd :: Cmd Djinn ()
djinnNamesCmd = do
([String]
prelude,[String]
st) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Djinn DjinnEnv
getSavedEnv
let names :: String
names = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse String
" " forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
extractNames forall a b. (a -> b) -> a -> b
$ [String]
prelude forall a. [a] -> [a] -> [a]
++ [String]
st
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
names
where extractNames :: String -> [String]
extractNames = forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Bool
isUpper forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (\String
x -> case String
x of Char
_:String
_ -> forall a. [a] -> Maybe a
listToMaybe (ReadS String
lex String
x); String
_ -> forall a. Maybe a
Nothing)
djinnClrCmd :: Cmd Djinn ()
djinnClrCmd :: Cmd Djinn ()
djinnClrCmd = forall (m :: * -> *). MonadLBState m => LBState m -> m ()
writeMS forall a. Maybe a
Nothing
djinnDelCmd :: [Char] -> Cmd Djinn ()
djinnDelCmd :: String -> Cmd Djinn ()
djinnDelCmd String
s = do
([String]
_,[String]
env) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Djinn DjinnEnv
getSavedEnv
Either [String] String
eenv <- forall (m :: * -> *).
MonadLB m =>
[String] -> String -> m (Either [String] String)
djinn [String]
env forall a b. (a -> b) -> a -> b
$ String
":delete " forall a. [a] -> [a] -> [a]
++ forall a. (a -> Bool) -> [a] -> [a]
strip Char -> Bool
isSpace String
s forall a. [a] -> [a] -> [a]
++ String
"\n:environment"
case Either [String] String
eenv of
Left [String]
e -> forall (m :: * -> *). Monad m => String -> Cmd m ()
say (forall a. [a] -> a
head [String]
e)
Right String
env' -> forall (m :: * -> *).
MonadLBState m =>
(LBState m -> LBState m) -> m ()
modifyMS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ \([String]
prel,[String]
_) ->
([String]
prel,forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
prel) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall a b. (a -> b) -> a -> b
$ String
env')
djinnVerCmd :: Cmd Djinn ()
djinnVerCmd :: Cmd Djinn ()
djinnVerCmd = forall (m :: * -> *). Monad m => String -> Cmd m ()
say forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadLB m => m String
getDjinnVersion
getDjinnEnv :: (MonadLB m) => DjinnEnv -> m (Either [String] DjinnEnv)
getDjinnEnv :: forall (m :: * -> *).
MonadLB m =>
DjinnEnv -> m (Either [String] DjinnEnv)
getDjinnEnv ([String]
prel,[String]
env') = do
Either [String] String
env <- forall (m :: * -> *).
MonadLB m =>
[String] -> String -> m (Either [String] String)
djinn [String]
env' String
":environment"
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a b. a -> Either a b
Left (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> DjinnEnv
readEnv) Either [String] String
env)
where
readEnv :: String -> DjinnEnv
readEnv String
o = let new :: [String]
new = forall a. (a -> Bool) -> [a] -> [a]
filter (\String
p -> String
p forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
prel) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall a b. (a -> b) -> a -> b
$ String
o
in ([String]
prel, [String]
new)
getDjinnVersion :: MonadLB m => m String
getDjinnVersion :: forall (m :: * -> *). MonadLB m => m String
getDjinnVersion = do
String
binary <- forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
djinnBinary
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
readVersion (String -> [String] -> String -> IO String
readProcess String
binary [] String
":q"))
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` \SomeException{} ->
forall (m :: * -> *) a. Monad m => a -> m a
return String
"The djinn command does not appear to be installed."
where
readVersion :: String -> String
readVersion = forall {source1}.
RegexContext Regex source1 String =>
source1 -> String
extractVersion forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
extractVersion :: source1 -> String
extractVersion source1
str = case source1
str forall source source1 target (m :: * -> *).
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target, MonadFail m) =>
source1 -> source -> m target
=~~ String
"version [0-9]+(-[0-9]+)*" of
Maybe String
Nothing -> String
"Unknown"
Just String
m -> String
m
djinn :: MonadLB m => [Decl] -> String -> m (Either [String] String)
djinn :: forall (m :: * -> *).
MonadLB m =>
[String] -> String -> m (Either [String] String)
djinn [String]
env String
src = do
String
binary <- forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
djinnBinary
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> [String] -> String -> IO (Either [String] String)
tryDjinn String
binary [String]
env String
src)
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` \e :: SomeException
e@SomeException{} -> do
let cmdDesc :: String
cmdDesc = case String
binary of
String
"djinn" -> String
""
String
_ -> String
"(" forall a. [a] -> [a] -> [a]
++ String
binary forall a. [a] -> [a] -> [a]
++ String
") "
msg :: String
msg = String
"Djinn command " forall a. [a] -> [a] -> [a]
++ String
cmdDesc forall a. [a] -> [a] -> [a]
++ String
"failed: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
e
forall (m :: * -> *). MonadLogging m => String -> m ()
errorM String
msg
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left [String
msg])
tryDjinn :: String -> [Decl] -> String -> IO (Either [String] String)
tryDjinn :: String -> [String] -> String -> IO (Either [String] String)
tryDjinn String
binary [String]
env String
src = do
String
out <- String -> [String] -> String -> IO String
readProcess String
binary [] ([String] -> String
unlines ([String]
env forall a. [a] -> [a] -> [a]
++ [String
src, String
":q"]))
let safeInit :: [a] -> [a]
safeInit [] = []
safeInit [a]
xs = forall a. [a] -> [a]
init [a]
xs
o :: String
o = forall a. (a -> Bool) -> [a] -> [a]
dropFromEnd (forall a. Eq a => a -> a -> Bool
== Char
'\n') forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
clean_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
safeInit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall a b. (a -> b) -> a -> b
$ String
out
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case () of {()
_
| String
o forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
=~ String
"Cannot parse command" Bool -> Bool -> Bool
||
String
o forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
=~ String
"cannot be realized" Bool -> Bool -> Bool
||
String
o forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
=~ String
"^Error:" -> forall a b. a -> Either a b
Left (String -> [String]
lines String
o)
| Bool
otherwise -> forall a b. b -> Either a b
Right String
o
}
clean_ :: String -> String
clean_ :: String -> String
clean_ String
s | Just MatchResult String
mr <- String
s forall source source1 target (m :: * -> *).
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target, MonadFail m) =>
source1 -> source -> m target
=~~ String
prompt = forall a. MatchResult a -> a
mrBefore MatchResult String
mr forall a. [a] -> [a] -> [a]
++ forall a. MatchResult a -> a
mrAfter MatchResult String
mr
| Bool
otherwise = String
s
where
prompt :: String
prompt = String
"(Djinn> *)+"