{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleContexts #-}
-- Copyright (c) 2005 Donald Bruce Stewart - http://www.cse.unsw.edu.au/~dons
-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)

-- Written: Mon Dec 12 10:16:56 EST 2005

-- | A binding to Djinn.
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

-- | We can accumulate an interesting environment
type DjinnEnv = ([Decl] {- prelude -}, [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

    -- gratuitous invocation at startup to let the user know if the command is missing
    , 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 ([],[]) -- get the prelude
            
            -- TODO: don't swallow errors here
            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

-- check the args, reject them if they start with a colon (ignoring whitespace)
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

-- Normal commands
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

-- Augment environment. Have it checked by djinn.
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')

-- Display the environment
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

-- Display the environment's names (quarter-baked)
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)

-- Reset the env
djinnClrCmd :: Cmd Djinn ()
djinnClrCmd :: Cmd Djinn ()
djinnClrCmd = forall (m :: * -> *). MonadLBState m => LBState m -> m ()
writeMS forall a. Maybe a
Nothing

-- Remove sym from environment. We let djinn do the hard work of
-- looking up the symbols.
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')

-- Version number
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

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

-- | Extract the default environment
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

-- | Call the binary:

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 up djinn output
--
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> *)+"