-- | Command utilities
module Calamity.Commands.CommandUtils
    ( TypedCommandC
    , CommandForParsers
    , buildCommand
    , buildCommand'
    , buildParser
    , buildCallback
    , runCommand
    , invokeCommand ) where

import           Calamity.Commands.Check
import           Calamity.Commands.Command
import           Calamity.Commands.Context
import           Calamity.Commands.Error
import           Calamity.Commands.Group
import           Calamity.Commands.Parser
import           Calamity.Internal.RunIntoIO
import           Calamity.Internal.Utils

import           Control.Lens                hiding ( (<.>), Context )
import           Control.Monad

import           Data.Foldable
import           Data.Kind
import           Data.Maybe
import           Data.Text                   as S
import           Data.Text.Lazy              as L
import           Data.Typeable

import qualified Polysemy                    as P
import qualified Polysemy.Error              as P
import qualified Polysemy.Fail               as P

buildCommand' :: P.Member (P.Final IO) r
              => S.Text
              -> Maybe Group
              -> [Check]
              -> (Context -> L.Text)
              -> (Context -> P.Sem r (Either CommandError a))
              -> ((Context, a) -> P.Sem (P.Fail ': r) ())
              -> P.Sem r Command
buildCommand' :: Text
-> Maybe Group
-> [Check]
-> (Context -> Text)
-> (Context -> Sem r (Either CommandError a))
-> ((Context, a) -> Sem (Fail : r) ())
-> Sem r Command
buildCommand' name :: Text
name parent :: Maybe Group
parent checks :: [Check]
checks help :: Context -> Text
help parser :: Context -> Sem r (Either CommandError a)
parser cb :: (Context, a) -> Sem (Fail : r) ()
cb = do
  (Context, a) -> IO (Maybe Text)
cb' <- ((Context, a) -> Sem (Fail : r) ())
-> Sem r ((Context, a) -> IO (Maybe Text))
forall (r :: [(* -> *) -> * -> *]) a.
Member (Final IO) r =>
((Context, a) -> Sem (Fail : r) ())
-> Sem r ((Context, a) -> IO (Maybe Text))
buildCallback (Context, a) -> Sem (Fail : r) ()
cb
  Context -> IO (Either CommandError a)
parser' <- Text
-> (Context -> Sem r (Either CommandError a))
-> Sem r (Context -> IO (Either CommandError a))
forall (r :: [(* -> *) -> * -> *]) a.
Member (Final IO) r =>
Text
-> (Context -> Sem r (Either CommandError a))
-> Sem r (Context -> IO (Either CommandError a))
buildParser Text
name Context -> Sem r (Either CommandError a)
parser
  Command -> Sem r Command
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Command -> Sem r Command) -> Command -> Sem r Command
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Group
-> [Check]
-> (Context -> Text)
-> (Context -> IO (Either CommandError a))
-> ((Context, a) -> IO (Maybe Text))
-> Command
forall a.
Text
-> Maybe Group
-> [Check]
-> (Context -> Text)
-> (Context -> IO (Either CommandError a))
-> ((Context, a) -> IO (Maybe Text))
-> Command
Command Text
name Maybe Group
parent [Check]
checks Context -> Text
help Context -> IO (Either CommandError a)
parser' (Context, a) -> IO (Maybe Text)
cb'

buildCommand :: forall ps a r.
             (P.Member (P.Final IO) r, TypedCommandC ps a r)
             => S.Text
             -> Maybe Group
             -> [Check]
             -> (Context -> L.Text)
             -> (Context -> CommandForParsers ps r)
             -> P.Sem r Command
buildCommand :: Text
-> Maybe Group
-> [Check]
-> (Context -> Text)
-> (Context -> CommandForParsers ps r)
-> Sem r Command
buildCommand name :: Text
name parent :: Maybe Group
parent checks :: [Check]
checks help :: Context -> Text
help command :: Context -> CommandForParsers ps r
command = let (parser :: Context -> Sem r (Either CommandError a)
parser, cb :: (Context, a) -> Sem (Fail : r) ()
cb) = (Context -> CommandForParsers ps r)
-> (Context -> Sem r (Either CommandError a),
    (Context, a) -> Sem (Fail : r) ())
forall (ps :: [*]) a (r :: [(* -> *) -> * -> *]).
TypedCommandC ps a r =>
(Context -> CommandForParsers ps r)
-> (Context -> Sem r (Either CommandError a),
    (Context, a) -> Sem (Fail : r) ())
buildTypedCommand @ps Context -> CommandForParsers ps r
command
                                               in Text
-> Maybe Group
-> [Check]
-> (Context -> Text)
-> (Context -> Sem r (Either CommandError a))
-> ((Context, a) -> Sem (Fail : r) ())
-> Sem r Command
forall (r :: [(* -> *) -> * -> *]) a.
Member (Final IO) r =>
Text
-> Maybe Group
-> [Check]
-> (Context -> Text)
-> (Context -> Sem r (Either CommandError a))
-> ((Context, a) -> Sem (Fail : r) ())
-> Sem r Command
buildCommand' Text
name Maybe Group
parent [Check]
checks Context -> Text
help Context -> Sem r (Either CommandError a)
parser (Context, a) -> Sem (Fail : r) ()
cb

buildParser :: P.Member (P.Final IO) r
            => S.Text
            -> (Context -> P.Sem r (Either CommandError a))
            -> P.Sem r (Context -> IO (Either CommandError a))
buildParser :: Text
-> (Context -> Sem r (Either CommandError a))
-> Sem r (Context -> IO (Either CommandError a))
buildParser cmdName :: Text
cmdName cb :: Context -> Sem r (Either CommandError a)
cb = do
  Context -> IO (Maybe (Either CommandError a))
cb' <- (Context -> Sem r (Either CommandError a))
-> Sem r (Context -> IO (Maybe (Either CommandError a)))
forall (r :: [(* -> *) -> * -> *]) p a.
Member (Final IO) r =>
(p -> Sem r a) -> Sem r (p -> IO (Maybe a))
bindSemToIO Context -> Sem r (Either CommandError a)
cb
  let cb'' :: Context -> IO (Either CommandError a)
cb'' ctx :: Context
ctx = Either CommandError a
-> Maybe (Either CommandError a) -> Either CommandError a
forall a. a -> Maybe a -> a
fromMaybe (CommandError -> Either CommandError a
forall a b. a -> Either a b
Left (CommandError -> Either CommandError a)
-> CommandError -> Either CommandError a
forall a b. (a -> b) -> a -> b
$ Text -> Text -> CommandError
ParseError ("Parser for command: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cmdName) "failed internally") (Maybe (Either CommandError a) -> Either CommandError a)
-> IO (Maybe (Either CommandError a)) -> IO (Either CommandError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO (Maybe (Either CommandError a))
cb' Context
ctx
  (Context -> IO (Either CommandError a))
-> Sem r (Context -> IO (Either CommandError a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Context -> IO (Either CommandError a)
cb''

buildCallback
  :: P.Member (P.Final IO) r => ((Context, a) -> P.Sem (P.Fail ': r) ()) -> P.Sem r ((Context, a) -> IO (Maybe L.Text))
buildCallback :: ((Context, a) -> Sem (Fail : r) ())
-> Sem r ((Context, a) -> IO (Maybe Text))
buildCallback cb :: (Context, a) -> Sem (Fail : r) ()
cb = do
  (Context, a) -> IO (Maybe (Maybe Text))
cb' <- ((Context, a) -> Sem r (Maybe Text))
-> Sem r ((Context, a) -> IO (Maybe (Maybe Text)))
forall (r :: [(* -> *) -> * -> *]) p a.
Member (Final IO) r =>
(p -> Sem r a) -> Sem r (p -> IO (Maybe a))
bindSemToIO (\x :: (Context, a)
x -> Sem (Fail : r) () -> Sem r (Either String ())
forall (r :: [(* -> *) -> * -> *]) a.
Sem (Fail : r) a -> Sem r (Either String a)
P.runFail ((Context, a) -> Sem (Fail : r) ()
cb (Context, a)
x) Sem r (Either String ())
-> (Either String () -> Maybe Text) -> Sem r (Maybe Text)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                        Left e :: String
e -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
L.pack String
e
                        _      -> Maybe Text
forall a. Maybe a
Nothing)
  let cb'' :: (Context, a) -> IO (Maybe Text)
cb'' = Maybe Text -> Maybe (Maybe Text) -> Maybe Text
forall a. a -> Maybe a -> a
fromMaybe (Text -> Maybe Text
forall a. a -> Maybe a
Just "failed internally") (Maybe (Maybe Text) -> Maybe Text)
-> ((Context, a) -> IO (Maybe (Maybe Text)))
-> (Context, a)
-> IO (Maybe Text)
forall (f :: * -> *) a b c.
Functor f =>
(a -> b) -> (c -> f a) -> c -> f b
<.> (Context, a) -> IO (Maybe (Maybe Text))
cb'
  ((Context, a) -> IO (Maybe Text))
-> Sem r ((Context, a) -> IO (Maybe Text))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context, a) -> IO (Maybe Text)
cb''

runCommand :: P.Member (P.Embed IO) r => Context -> Command -> P.Sem r (Either CommandError ())
runCommand :: Context -> Command -> Sem r (Either CommandError ())
runCommand ctx :: Context
ctx Command { Text
$sel:name:Command :: Command -> Text
name :: Text
name, Context -> IO (Either CommandError a)
$sel:parser:Command :: ()
parser :: Context -> IO (Either CommandError a)
parser, (Context, a) -> IO (Maybe Text)
$sel:callback:Command :: ()
callback :: (Context, a) -> IO (Maybe Text)
callback } = IO (Either CommandError a) -> Sem r (Either CommandError a)
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (Context -> IO (Either CommandError a)
parser Context
ctx) Sem r (Either CommandError a)
-> (Either CommandError a -> Sem r (Either CommandError ()))
-> Sem r (Either CommandError ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left e :: CommandError
e   -> Either CommandError () -> Sem r (Either CommandError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CommandError () -> Sem r (Either CommandError ()))
-> Either CommandError () -> Sem r (Either CommandError ())
forall a b. (a -> b) -> a -> b
$ CommandError -> Either CommandError ()
forall a b. a -> Either a b
Left CommandError
e
  Right p' :: a
p' -> IO (Maybe Text) -> Sem r (Maybe Text)
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed ((Context, a) -> IO (Maybe Text)
callback (Context
ctx, a
p')) Sem r (Maybe Text)
-> (Maybe Text -> Either CommandError ())
-> Sem r (Either CommandError ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Maybe CommandError -> Either CommandError ()
forall e. Maybe e -> Either e ()
justToEither (Maybe CommandError -> Either CommandError ())
-> (Maybe Text -> Maybe CommandError)
-> Maybe Text
-> Either CommandError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> CommandError
InvokeError Text
name (Text -> CommandError) -> Maybe Text -> Maybe CommandError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

invokeCommand :: P.Member (P.Embed IO) r => Context -> Command -> P.Sem r (Either CommandError ())
invokeCommand :: Context -> Command -> Sem r (Either CommandError ())
invokeCommand ctx :: Context
ctx cmd :: Command
cmd@Command { [Check]
$sel:checks:Command :: Command -> [Check]
checks :: [Check]
checks } = Sem (Error CommandError : r) () -> Sem r (Either CommandError ())
forall e (r :: [(* -> *) -> * -> *]) a.
Sem (Error e : r) a -> Sem r (Either e a)
P.runError (Sem (Error CommandError : r) () -> Sem r (Either CommandError ()))
-> Sem (Error CommandError : r) ()
-> Sem r (Either CommandError ())
forall a b. (a -> b) -> a -> b
$ do
  [Check]
-> (Check -> Sem (Error CommandError : r) ())
-> Sem (Error CommandError : r) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Check]
checks (Either CommandError () -> Sem (Error CommandError : r) ()
forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
Either e a -> Sem r a
P.fromEither (Either CommandError () -> Sem (Error CommandError : r) ())
-> (Check -> Sem (Error CommandError : r) (Either CommandError ()))
-> Check
-> Sem (Error CommandError : r) ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Context
-> Check -> Sem (Error CommandError : r) (Either CommandError ())
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
Context -> Check -> Sem r (Either CommandError ())
runCheck Context
ctx)
  Either CommandError () -> Sem (Error CommandError : r) ()
forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
Either e a -> Sem r a
P.fromEither (Either CommandError () -> Sem (Error CommandError : r) ())
-> Sem (Error CommandError : r) (Either CommandError ())
-> Sem (Error CommandError : r) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Context
-> Command -> Sem (Error CommandError : r) (Either CommandError ())
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
Context -> Command -> Sem r (Either CommandError ())
runCommand Context
ctx Command
cmd

type CommandSemType r = P.Sem (P.Fail ': r) ()

type TypedCommandC ps a r =
  ( ApplyTupRes a (CommandSemType r) ~ CommandForParsers ps r
  , a ~ ParamsFromParsers ps
  , BuildTypedCommandParser ps r
  , ApplyTup a (CommandSemType r))

buildTypedCommand
  :: forall (ps :: [Type]) a r.
  TypedCommandC ps a r
  => (Context -> CommandForParsers ps r)
  -> ( Context
         -> P.Sem r (Either CommandError a)
     , (Context, a)
         -> P.Sem (P.Fail ': r) ())
buildTypedCommand :: (Context -> CommandForParsers ps r)
-> (Context -> Sem r (Either CommandError a),
    (Context, a) -> Sem (Fail : r) ())
buildTypedCommand cmd :: Context -> CommandForParsers ps r
cmd = let parser :: Context -> Sem r (Either CommandError (ParamsFromParsers ps))
parser ctx :: Context
ctx = (Context, Text)
-> Sem r (Either CommandError (ParamsFromParsers ps))
forall (ps :: [*]) (r :: [(* -> *) -> * -> *]).
BuildTypedCommandParser ps r =>
(Context, Text)
-> Sem r (Either CommandError (ParamsFromParsers ps))
buildTypedCommandParser @ps (Context
ctx, Context
ctx Context -> Getting Text Context Text -> Text
forall s a. s -> Getting a s a -> a
^. IsLabel "unparsedParams" (Getting Text Context Text)
Getting Text Context Text
#unparsedParams)
                            consumer :: (Context, a) -> Sem (Fail : r) ()
consumer (ctx :: Context
ctx, r :: a
r) = ApplyTupRes a (Sem (Fail : r) ()) -> a -> Sem (Fail : r) ()
forall a b. ApplyTup a b => ApplyTupRes a b -> a -> b
applyTup (Context -> CommandForParsers ps r
cmd Context
ctx) a
r
                        in (Context -> Sem r (Either CommandError a)
Context -> Sem r (Either CommandError (ParamsFromParsers ps))
parser, (Context, a) -> Sem (Fail : r) ()
consumer)

class ApplyTup a b where
  type ApplyTupRes a b

  applyTup :: ApplyTupRes a b -> a -> b

instance ApplyTup as b => ApplyTup (a, as) b where
  type ApplyTupRes (a, as) b = a -> ApplyTupRes as b

  applyTup :: ApplyTupRes (a, as) b -> (a, as) -> b
applyTup f :: ApplyTupRes (a, as) b
f (a :: a
a, as :: as
as) = ApplyTupRes as b -> as -> b
forall a b. ApplyTup a b => ApplyTupRes a b -> a -> b
applyTup (ApplyTupRes (a, as) b
a -> ApplyTupRes as b
f a
a) as
as

instance ApplyTup () b where
  type ApplyTupRes () b = b

  applyTup :: ApplyTupRes () b -> () -> b
applyTup r :: ApplyTupRes () b
r () = b
ApplyTupRes () b
r

class BuildTypedCommandParser (ps :: [Type]) r where
  buildTypedCommandParser :: (Context, L.Text) -> P.Sem r (Either CommandError (ParamsFromParsers ps))

instance BuildTypedCommandParser '[] r where
  buildTypedCommandParser :: (Context, Text)
-> Sem r (Either CommandError (ParamsFromParsers '[]))
buildTypedCommandParser (_, _) = Either CommandError ()
-> Sem r (Either CommandError (ParamsFromParsers '[]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CommandError ()
 -> Sem r (Either CommandError (ParamsFromParsers '[])))
-> Either CommandError ()
-> Sem r (Either CommandError (ParamsFromParsers '[]))
forall a b. (a -> b) -> a -> b
$ () -> Either CommandError ()
forall a b. b -> Either a b
Right ()

instance (Typeable x, Parser x r, BuildTypedCommandParser xs r) => BuildTypedCommandParser (x ': xs) r where
  buildTypedCommandParser :: (Context, Text)
-> Sem r (Either CommandError (ParamsFromParsers (x : xs)))
buildTypedCommandParser (ctx :: Context
ctx, msg :: Text
msg) = (Context, Text) -> Sem r (Either Text (ParserResult x, Text))
forall a (r :: [(* -> *) -> * -> *]).
Parser a r =>
(Context, Text) -> Sem r (Either Text (ParserResult a, Text))
parse @x (Context
ctx, Text
msg) Sem r (Either Text (ParserResult x, Text))
-> (Either Text (ParserResult x, Text)
    -> Sem
         r (Either CommandError (ParserResult x, ParamsFromParsers xs)))
-> Sem
     r (Either CommandError (ParserResult x, ParamsFromParsers xs))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right (a :: ParserResult x
a, msg' :: Text
msg') -> (ParserResult x
a, ) (ParamsFromParsers xs -> (ParserResult x, ParamsFromParsers xs))
-> Sem r (Either CommandError (ParamsFromParsers xs))
-> Sem
     r (Either CommandError (ParserResult x, ParamsFromParsers xs))
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<<$>> (Context, Text)
-> Sem r (Either CommandError (ParamsFromParsers xs))
forall (ps :: [*]) (r :: [(* -> *) -> * -> *]).
BuildTypedCommandParser ps r =>
(Context, Text)
-> Sem r (Either CommandError (ParamsFromParsers ps))
buildTypedCommandParser @xs (Context
ctx, Text
msg')
    Left e :: Text
e          -> Either CommandError (ParserResult x, ParamsFromParsers xs)
-> Sem
     r (Either CommandError (ParserResult x, ParamsFromParsers xs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CommandError (ParserResult x, ParamsFromParsers xs)
 -> Sem
      r (Either CommandError (ParserResult x, ParamsFromParsers xs)))
-> Either CommandError (ParserResult x, ParamsFromParsers xs)
-> Sem
     r (Either CommandError (ParserResult x, ParamsFromParsers xs))
forall a b. (a -> b) -> a -> b
$ CommandError
-> Either CommandError (ParserResult x, ParamsFromParsers xs)
forall a b. a -> Either a b
Left (Text -> Text -> CommandError
ParseError (String -> Text
S.pack (String -> Text) -> (Proxy x -> String) -> Proxy x -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> (Proxy x -> TypeRep) -> Proxy x -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy x -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy x -> Text) -> Proxy x -> Text
forall a b. (a -> b) -> a -> b
$ Proxy x
forall k (t :: k). Proxy t
Proxy @x) Text
e)

type family ParamsFromParsers (ps :: [Type]) where
  ParamsFromParsers '[] = ()
  ParamsFromParsers (x ': xs) = (ParserResult x, ParamsFromParsers xs)

type family CommandForParsers (ps :: [Type]) r where
  CommandForParsers '[] r = P.Sem (P.Fail ': r) ()
  CommandForParsers (x ': xs) r = ParserResult x -> CommandForParsers xs r