{-# 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 = Module (Maybe DjinnEnv)
forall st. Module st
newModule
    { moduleSerialize :: Maybe (Serial (Maybe DjinnEnv))
moduleSerialize = Maybe (Serial (Maybe DjinnEnv))
forall a. Maybe a
Nothing
    , moduleDefState :: LB (Maybe DjinnEnv)
moduleDefState = Maybe DjinnEnv -> LB (Maybe DjinnEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DjinnEnv
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 = ModuleT (Maybe DjinnEnv) LB (Either [String] String)
-> ModuleT (Maybe DjinnEnv) LB ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ([String]
-> String -> ModuleT (Maybe DjinnEnv) LB (Either [String] String)
forall (m :: * -> *).
MonadLB m =>
[String] -> String -> m (Either [String] String)
djinn [] String
"")

    , moduleCmds :: ModuleT (Maybe DjinnEnv) LB [Command (ModuleT (Maybe DjinnEnv) LB)]
moduleCmds = [Command (ModuleT (Maybe DjinnEnv) LB)]
-> ModuleT
     (Maybe DjinnEnv) LB [Command (ModuleT (Maybe DjinnEnv) LB)]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"djinn")
            { help :: Cmd (ModuleT (Maybe DjinnEnv) LB) ()
help = (String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ())
-> [String] -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
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 (ModuleT (Maybe DjinnEnv) LB) ()
process = (String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ())
-> String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *).
Monad m =>
(String -> Cmd m ()) -> String -> Cmd m ()
rejectingCmds String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
djinnCmd
            }
        , (String -> Command Identity
command String
"djinn-add")
            { help :: Cmd (ModuleT (Maybe DjinnEnv) LB) ()
help = do
                String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"djinn-add <expr>."
                String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Define a new function type or type synonym"
            , process :: String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
process = (String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ())
-> String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *).
Monad m =>
(String -> Cmd m ()) -> String -> Cmd m ()
rejectingCmds String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
djinnAddCmd
            }
        , (String -> Command Identity
command String
"djinn-del")
            { help :: Cmd (ModuleT (Maybe DjinnEnv) LB) ()
help = do
                String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"djinn-del <ident>."
                String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Remove a symbol from the environment"
            , process :: String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
process = (String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ())
-> String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *).
Monad m =>
(String -> Cmd m ()) -> String -> Cmd m ()
rejectingCmds String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
djinnDelCmd
            }
        , (String -> Command Identity
command String
"djinn-env")
            { help :: Cmd (ModuleT (Maybe DjinnEnv) LB) ()
help = do
                String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"djinn-env."
                String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Show the current djinn environment"
            , process :: String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
process = Cmd (ModuleT (Maybe DjinnEnv) LB) ()
-> String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall a b. a -> b -> a
const Cmd (ModuleT (Maybe DjinnEnv) LB) ()
djinnEnvCmd
            }
        , (String -> Command Identity
command String
"djinn-names")
            { help :: Cmd (ModuleT (Maybe DjinnEnv) LB) ()
help = do
                String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"djinn-names."
                String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Show the current djinn environment, compactly."
            , process :: String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
process = Cmd (ModuleT (Maybe DjinnEnv) LB) ()
-> String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall a b. a -> b -> a
const Cmd (ModuleT (Maybe DjinnEnv) LB) ()
djinnNamesCmd
            }
        , (String -> Command Identity
command String
"djinn-clr")
            { help :: Cmd (ModuleT (Maybe DjinnEnv) LB) ()
help = do
                String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"djinn-clr."
                String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Reset the djinn environment"
            , process :: String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
process = Cmd (ModuleT (Maybe DjinnEnv) LB) ()
-> String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall a b. a -> b -> a
const Cmd (ModuleT (Maybe DjinnEnv) LB) ()
djinnClrCmd
            }
        , (String -> Command Identity
command String
"djinn-ver")
            { help :: Cmd (ModuleT (Maybe DjinnEnv) LB) ()
help = do
                String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"djinn-ver."
                String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Show current djinn version"
            , process :: String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
process = Cmd (ModuleT (Maybe DjinnEnv) LB) ()
-> String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall a b. a -> b -> a
const Cmd (ModuleT (Maybe DjinnEnv) LB) ()
djinnVerCmd
            }
        ]
    }

getSavedEnv :: Djinn DjinnEnv
getSavedEnv :: Djinn DjinnEnv
getSavedEnv = (LBState (ModuleT (Maybe DjinnEnv) LB)
 -> (LBState (ModuleT (Maybe DjinnEnv) LB)
     -> ModuleT (Maybe DjinnEnv) LB ())
 -> Djinn DjinnEnv)
-> Djinn DjinnEnv
forall (m :: * -> *) a.
MonadLBState m =>
(LBState m -> (LBState m -> m ()) -> m a) -> m a
withMS ((LBState (ModuleT (Maybe DjinnEnv) LB)
  -> (LBState (ModuleT (Maybe DjinnEnv) LB)
      -> ModuleT (Maybe DjinnEnv) LB ())
  -> Djinn DjinnEnv)
 -> Djinn DjinnEnv)
-> (LBState (ModuleT (Maybe DjinnEnv) LB)
    -> (LBState (ModuleT (Maybe DjinnEnv) LB)
        -> ModuleT (Maybe DjinnEnv) LB ())
    -> Djinn DjinnEnv)
-> Djinn DjinnEnv
forall a b. (a -> b) -> a -> b
$ \LBState (ModuleT (Maybe DjinnEnv) LB)
st LBState (ModuleT (Maybe DjinnEnv) LB)
-> ModuleT (Maybe DjinnEnv) LB ()
write -> 
    case LBState (ModuleT (Maybe DjinnEnv) LB)
st of
        Just env -> DjinnEnv -> Djinn DjinnEnv
forall (m :: * -> *) a. Monad m => a -> m a
return DjinnEnv
env
        LBState (ModuleT (Maybe DjinnEnv) LB)
Nothing -> do
            Either [String] DjinnEnv
st' <- DjinnEnv -> ModuleT (Maybe DjinnEnv) LB (Either [String] DjinnEnv)
forall (m :: * -> *).
MonadLB m =>
DjinnEnv -> m (Either [String] DjinnEnv)
getDjinnEnv ([],[]) -- get the prelude
            
            -- TODO: don't swallow errors here
            let newMS :: ([String], [a])
newMS = (([String] -> [String])
-> (DjinnEnv -> [String]) -> Either [String] DjinnEnv -> [String]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([String] -> [String] -> [String]
forall a b. a -> b -> a
const []) DjinnEnv -> [String]
forall a b. (a, b) -> b
snd{-!-} Either [String] DjinnEnv
st', [])
            LBState (ModuleT (Maybe DjinnEnv) LB)
-> ModuleT (Maybe DjinnEnv) LB ()
write (DjinnEnv -> Maybe DjinnEnv
forall a. a -> Maybe a
Just DjinnEnv
forall a. ([String], [a])
newMS)
            DjinnEnv -> Djinn DjinnEnv
forall (m :: * -> *) a. Monad m => a -> m a
return DjinnEnv
forall a. ([String], [a])
newMS

getUserEnv :: Djinn [Decl]
getUserEnv :: Djinn [String]
getUserEnv = (DjinnEnv -> [String]) -> Djinn DjinnEnv -> Djinn [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DjinnEnv -> [String]
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 :: (String -> Cmd m ()) -> String -> Cmd m ()
rejectingCmds String -> Cmd m ()
action String
args
    | Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1 ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
args) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
":"
                = String -> Cmd m ()
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 (ModuleT (Maybe DjinnEnv) LB) ()
djinnCmd String
s = do
        [String]
env     <- Djinn [String] -> Cmd (ModuleT (Maybe DjinnEnv) LB) [String]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Djinn [String]
getUserEnv
        Either [String] String
e       <- [String]
-> String
-> Cmd (ModuleT (Maybe DjinnEnv) LB) (Either [String] String)
forall (m :: * -> *).
MonadLB m =>
[String] -> String -> m (Either [String] String)
djinn [String]
env (String
 -> Cmd (ModuleT (Maybe DjinnEnv) LB) (Either [String] String))
-> String
-> Cmd (ModuleT (Maybe DjinnEnv) LB) (Either [String] String)
forall a b. (a -> b) -> a -> b
$ String
":set +sorted\nf ? " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall source1. RegexLike Regex source1 => source1 -> source1
dropForall String
s
        (String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ())
-> [String] -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say ([String] -> Cmd (ModuleT (Maybe DjinnEnv) LB) ())
-> [String] -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall a b. (a -> b) -> a -> b
$ ([String] -> [String])
-> (String -> [String]) -> Either [String] String -> [String]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [String] -> [String]
forall a. a -> a
id ([String] -> [String]
parse ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) Either [String] String
e
    where
      dropForall :: source1 -> source1
dropForall source1
t = source1
-> (MatchResult source1 -> source1)
-> Maybe (MatchResult source1)
-> source1
forall b a. b -> (a -> b) -> Maybe a -> b
maybe source1
t MatchResult source1 -> source1
forall a. MatchResult a -> a
mrAfter (source1
t source1 -> String -> Maybe (MatchResult source1)
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 [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
                then [String
"No output from Djinn; installed?"]
                else [String] -> [String]
forall a. [a] -> [a]
tail [String]
x

-- Augment environment. Have it checked by djinn.
djinnAddCmd :: [Char] -> Cmd Djinn ()
djinnAddCmd :: String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
djinnAddCmd String
s = do
    ([String]
p,[String]
st)  <- Djinn DjinnEnv -> Cmd (ModuleT (Maybe DjinnEnv) LB) DjinnEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Djinn DjinnEnv
getSavedEnv
    Either [String] DjinnEnv
est     <- DjinnEnv
-> Cmd (ModuleT (Maybe DjinnEnv) LB) (Either [String] DjinnEnv)
forall (m :: * -> *).
MonadLB m =>
DjinnEnv -> m (Either [String] DjinnEnv)
getDjinnEnv ([String]
p, (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
strip Char -> Bool
isSpace String
s String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
st)
    case Either [String] DjinnEnv
est of
        Left [String]
e     -> String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say ([String] -> String
forall a. [a] -> a
head [String]
e)
        Right DjinnEnv
st'  -> LBState (Cmd (ModuleT (Maybe DjinnEnv) LB))
-> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). MonadLBState m => LBState m -> m ()
writeMS (DjinnEnv -> Maybe DjinnEnv
forall a. a -> Maybe a
Just DjinnEnv
st')

-- Display the environment
djinnEnvCmd :: Cmd Djinn ()
djinnEnvCmd :: Cmd (ModuleT (Maybe DjinnEnv) LB) ()
djinnEnvCmd = do
    ([String]
prelude,[String]
st) <- Djinn DjinnEnv -> Cmd (ModuleT (Maybe DjinnEnv) LB) DjinnEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Djinn DjinnEnv
getSavedEnv
    (String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ())
-> [String] -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say ([String] -> Cmd (ModuleT (Maybe DjinnEnv) LB) ())
-> [String] -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall a b. (a -> b) -> a -> b
$ [String]
prelude [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
st

-- Display the environment's names (quarter-baked)
djinnNamesCmd :: Cmd Djinn ()
djinnNamesCmd :: Cmd (ModuleT (Maybe DjinnEnv) LB) ()
djinnNamesCmd = do
    ([String]
prelude,[String]
st) <- Djinn DjinnEnv -> Cmd (ModuleT (Maybe DjinnEnv) LB) DjinnEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Djinn DjinnEnv
getSavedEnv
    let names :: String
names = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
" " ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
extractNames ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
prelude [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
st
    String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
names
  where extractNames :: String -> [String]
extractNames = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Bool
isUpper (Char -> Bool) -> (String -> Char) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Char
forall a. [a] -> a
head) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe (String, String)) -> String -> [String]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (\String
x -> case String
x of Char
_:String
_ -> [(String, String)] -> Maybe (String, String)
forall a. [a] -> Maybe a
listToMaybe (ReadS String
lex String
x); String
_ -> Maybe (String, String)
forall a. Maybe a
Nothing)

-- Reset the env
djinnClrCmd :: Cmd Djinn ()
djinnClrCmd :: Cmd (ModuleT (Maybe DjinnEnv) LB) ()
djinnClrCmd = LBState (Cmd (ModuleT (Maybe DjinnEnv) LB))
-> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). MonadLBState m => LBState m -> m ()
writeMS LBState (Cmd (ModuleT (Maybe DjinnEnv) LB))
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 (ModuleT (Maybe DjinnEnv) LB) ()
djinnDelCmd String
s =  do
    ([String]
_,[String]
env) <- Djinn DjinnEnv -> Cmd (ModuleT (Maybe DjinnEnv) LB) DjinnEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Djinn DjinnEnv
getSavedEnv
    Either [String] String
eenv <- [String]
-> String
-> Cmd (ModuleT (Maybe DjinnEnv) LB) (Either [String] String)
forall (m :: * -> *).
MonadLB m =>
[String] -> String -> m (Either [String] String)
djinn [String]
env (String
 -> Cmd (ModuleT (Maybe DjinnEnv) LB) (Either [String] String))
-> String
-> Cmd (ModuleT (Maybe DjinnEnv) LB) (Either [String] String)
forall a b. (a -> b) -> a -> b
$ String
":delete " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
strip Char -> Bool
isSpace String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n:environment"
    case Either [String] String
eenv of
        Left [String]
e     -> String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say ([String] -> String
forall a. [a] -> a
head [String]
e)
        Right String
env' -> (Maybe DjinnEnv -> Maybe DjinnEnv)
-> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *).
MonadLBState m =>
(LBState m -> LBState m) -> m ()
modifyMS ((Maybe DjinnEnv -> Maybe DjinnEnv)
 -> Cmd (ModuleT (Maybe DjinnEnv) LB) ())
-> ((DjinnEnv -> DjinnEnv) -> Maybe DjinnEnv -> Maybe DjinnEnv)
-> (DjinnEnv -> DjinnEnv)
-> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DjinnEnv -> DjinnEnv) -> Maybe DjinnEnv -> Maybe DjinnEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((DjinnEnv -> DjinnEnv) -> Cmd (ModuleT (Maybe DjinnEnv) LB) ())
-> (DjinnEnv -> DjinnEnv) -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall a b. (a -> b) -> a -> b
$ \([String]
prel,[String]
_) ->
            ([String]
prel,(String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
prel) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String
env')

-- Version number
djinnVerCmd :: Cmd Djinn ()
djinnVerCmd :: Cmd (ModuleT (Maybe DjinnEnv) LB) ()
djinnVerCmd = String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> Cmd (ModuleT (Maybe DjinnEnv) LB) ())
-> Cmd (ModuleT (Maybe DjinnEnv) LB) String
-> Cmd (ModuleT (Maybe DjinnEnv) LB) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Cmd (ModuleT (Maybe DjinnEnv) LB) String
forall (m :: * -> *). MonadLB m => m String
getDjinnVersion

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

-- | Extract the default environment
getDjinnEnv :: (MonadLB m) => DjinnEnv -> m (Either [String] DjinnEnv)
getDjinnEnv :: DjinnEnv -> m (Either [String] DjinnEnv)
getDjinnEnv ([String]
prel,[String]
env') = do
    Either [String] String
env <- [String] -> String -> m (Either [String] String)
forall (m :: * -> *).
MonadLB m =>
[String] -> String -> m (Either [String] String)
djinn [String]
env' String
":environment"
    Either [String] DjinnEnv -> m (Either [String] DjinnEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (([String] -> Either [String] DjinnEnv)
-> (String -> Either [String] DjinnEnv)
-> Either [String] String
-> Either [String] DjinnEnv
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [String] -> Either [String] DjinnEnv
forall a b. a -> Either a b
Left (DjinnEnv -> Either [String] DjinnEnv
forall a b. b -> Either a b
Right (DjinnEnv -> Either [String] DjinnEnv)
-> (String -> DjinnEnv) -> String -> Either [String] DjinnEnv
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 = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\String
p -> String
p String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
prel) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String
o
                     in ([String]
prel, [String]
new)

getDjinnVersion :: MonadLB m => m String
getDjinnVersion :: m String
getDjinnVersion = do
    String
binary <- Config String -> m String
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
djinnBinary
    IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io ((String -> String) -> IO String -> IO String
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"))
        m String -> (SomeException -> m String) -> m String
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` \SomeException{} ->
            String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"The djinn command does not appear to be installed."
    where 
        readVersion :: String -> String
readVersion = String -> String
forall source1.
RegexContext Regex source1 String =>
source1 -> String
extractVersion (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
1 ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
        extractVersion :: source1 -> String
extractVersion source1
str = case source1
str source1 -> String -> Maybe String
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 :: [String] -> String -> m (Either [String] String)
djinn [String]
env String
src = do
    String
binary <- Config String -> m String
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
djinnBinary
    IO (Either [String] String) -> m (Either [String] String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> [String] -> String -> IO (Either [String] String)
tryDjinn String
binary [String]
env String
src)
        m (Either [String] String)
-> (SomeException -> m (Either [String] String))
-> m (Either [String] String)
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
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
binary String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") "
                msg :: String
msg = String
"Djinn command " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmdDesc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
            String -> m ()
forall (m :: * -> *). MonadLogging m => String -> m ()
errorM String
msg
            Either [String] String -> m (Either [String] String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> Either [String] String
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 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
src, String
":q"]))
    let safeInit :: [a] -> [a]
safeInit [] = []
        safeInit [a]
xs = [a] -> [a]
forall a. [a] -> [a]
init [a]
xs
        o :: String
o = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropFromEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
clean_ (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
safeInit ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
2 ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
out
    Either [String] String -> IO (Either [String] String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] String -> IO (Either [String] String))
-> Either [String] String -> IO (Either [String] String)
forall a b. (a -> b) -> a -> b
$ case () of {()
_
        | String
o String -> String -> Bool
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 String -> String -> Bool
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 String -> String -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ String
"^Error:"                -> [String] -> Either [String] String
forall a b. a -> Either a b
Left (String -> [String]
lines String
o)
        | Bool
otherwise                     -> String -> Either [String] String
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 String -> String -> Maybe (MatchResult String)
forall source source1 target (m :: * -> *).
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target, MonadFail m) =>
source1 -> source -> m target
=~~ String
prompt  = MatchResult String -> String
forall a. MatchResult a -> a
mrBefore MatchResult String
mr String -> String -> String
forall a. [a] -> [a] -> [a]
++ MatchResult String -> String
forall a. MatchResult a -> a
mrAfter MatchResult String
mr
         | Bool
otherwise                = String
s
    where
        prompt :: String
prompt = String
"(Djinn> *)+"