{-# LANGUAGE RecursiveDo #-}

-- | A DSL for generating commands and groups
module Calamity.Commands.Dsl
    ( command'
    , command
    , help
    , requires
    , requires'
    , requiresPure
    , group
    , DSLState
    , raiseDSL ) where

import           Calamity.Commands.Check
import           Calamity.Commands.Command     hiding ( help )
import           Calamity.Commands.CommandUtils
import           Calamity.Commands.Context     hiding ( command )
import           Calamity.Commands.Error
import           Calamity.Commands.Group       hiding ( help )
import           Calamity.Commands.LocalWriter

import qualified Data.HashMap.Lazy             as LH
import qualified Data.Text                     as S
import qualified Data.Text.Lazy                as L

import qualified Polysemy                      as P
import qualified Polysemy.Fail                 as P
import qualified Polysemy.Fixpoint             as P
import qualified Polysemy.Reader               as P

type DSLState r = (LocalWriter (LH.HashMap S.Text Command) ':
                       LocalWriter (LH.HashMap S.Text Group) ':
                       P.Reader (Maybe Group) ':
                       P.Reader (Context -> L.Text) ':
                       P.Reader [Check] ':
                       P.Fixpoint ': r)

raiseDSL :: P.Sem r a -> P.Sem (DSLState r) a
raiseDSL :: Sem r a -> Sem (DSLState r) a
raiseDSL = Sem
  (LocalWriter (HashMap Text Group)
     : Reader (Maybe Group) : Reader (Context -> Text) : Reader [Check]
     : Fixpoint : r)
  a
-> Sem (DSLState r) a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
P.raise (Sem
   (LocalWriter (HashMap Text Group)
      : Reader (Maybe Group) : Reader (Context -> Text) : Reader [Check]
      : Fixpoint : r)
   a
 -> Sem (DSLState r) a)
-> (Sem r a
    -> Sem
         (LocalWriter (HashMap Text Group)
            : Reader (Maybe Group) : Reader (Context -> Text) : Reader [Check]
            : Fixpoint : r)
         a)
-> Sem r a
-> Sem (DSLState r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem
  (Reader (Maybe Group)
     : Reader (Context -> Text) : Reader [Check] : Fixpoint : r)
  a
-> Sem
     (LocalWriter (HashMap Text Group)
        : Reader (Maybe Group) : Reader (Context -> Text) : Reader [Check]
        : Fixpoint : r)
     a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
P.raise (Sem
   (Reader (Maybe Group)
      : Reader (Context -> Text) : Reader [Check] : Fixpoint : r)
   a
 -> Sem
      (LocalWriter (HashMap Text Group)
         : Reader (Maybe Group) : Reader (Context -> Text) : Reader [Check]
         : Fixpoint : r)
      a)
-> (Sem r a
    -> Sem
         (Reader (Maybe Group)
            : Reader (Context -> Text) : Reader [Check] : Fixpoint : r)
         a)
-> Sem r a
-> Sem
     (LocalWriter (HashMap Text Group)
        : Reader (Maybe Group) : Reader (Context -> Text) : Reader [Check]
        : Fixpoint : r)
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Reader (Context -> Text) : Reader [Check] : Fixpoint : r) a
-> Sem
     (Reader (Maybe Group)
        : Reader (Context -> Text) : Reader [Check] : Fixpoint : r)
     a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
P.raise (Sem (Reader (Context -> Text) : Reader [Check] : Fixpoint : r) a
 -> Sem
      (Reader (Maybe Group)
         : Reader (Context -> Text) : Reader [Check] : Fixpoint : r)
      a)
-> (Sem r a
    -> Sem
         (Reader (Context -> Text) : Reader [Check] : Fixpoint : r) a)
-> Sem r a
-> Sem
     (Reader (Maybe Group)
        : Reader (Context -> Text) : Reader [Check] : Fixpoint : r)
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Reader [Check] : Fixpoint : r) a
-> Sem (Reader (Context -> Text) : Reader [Check] : Fixpoint : r) a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
P.raise (Sem (Reader [Check] : Fixpoint : r) a
 -> Sem
      (Reader (Context -> Text) : Reader [Check] : Fixpoint : r) a)
-> (Sem r a -> Sem (Reader [Check] : Fixpoint : r) a)
-> Sem r a
-> Sem (Reader (Context -> Text) : Reader [Check] : Fixpoint : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Fixpoint : r) a -> Sem (Reader [Check] : Fixpoint : r) a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
P.raise (Sem (Fixpoint : r) a -> Sem (Reader [Check] : Fixpoint : r) a)
-> (Sem r a -> Sem (Fixpoint : r) a)
-> Sem r a
-> Sem (Reader [Check] : Fixpoint : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem r a -> Sem (Fixpoint : r) a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
P.raise

-- | Build a command with an already prepared invokation action
command'
  :: P.Member (P.Final IO) r
  => S.Text
  -> (Context -> P.Sem r (Either CommandError a))
  -> ((Context, a) -> P.Sem (P.Fail ': r) ())
  -> P.Sem (DSLState r) Command
command' :: Text
-> (Context -> Sem r (Either CommandError a))
-> ((Context, a) -> Sem (Fail : r) ())
-> Sem (DSLState r) Command
command' name :: Text
name parser :: Context -> Sem r (Either CommandError a)
parser cb :: (Context, a) -> Sem (Fail : r) ()
cb = do
  Maybe Group
parent <- forall (r :: EffectRow).
MemberWithError (Reader (Maybe Group)) r =>
Sem r (Maybe Group)
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @(Maybe Group)
  [Check]
checks <- forall (r :: EffectRow).
MemberWithError (Reader [Check]) r =>
Sem r [Check]
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @[Check]
  Context -> Text
help' <- forall (r :: EffectRow).
MemberWithError (Reader (Context -> Text)) r =>
Sem r (Context -> Text)
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @(Context -> L.Text)
  Command
cmd <- Sem r Command -> Sem (DSLState r) Command
forall (r :: EffectRow) a. Sem r a -> Sem (DSLState r) a
raiseDSL (Sem r Command -> Sem (DSLState r) Command)
-> Sem r Command -> Sem (DSLState r) Command
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Group
-> [Check]
-> (Context -> Text)
-> (Context -> Sem r (Either CommandError a))
-> ((Context, a) -> Sem (Fail : r) ())
-> Sem r Command
forall (r :: EffectRow) 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
  HashMap Text Command -> Sem (DSLState r) ()
forall o (r :: EffectRow).
MemberWithError (LocalWriter o) r =>
o -> Sem r ()
ltell (HashMap Text Command -> Sem (DSLState r) ())
-> HashMap Text Command -> Sem (DSLState r) ()
forall a b. (a -> b) -> a -> b
$ Text -> Command -> HashMap Text Command
forall k v. Hashable k => k -> v -> HashMap k v
LH.singleton Text
name Command
cmd
  Command -> Sem (DSLState r) Command
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command
cmd

command :: forall ps a r.
        ( P.Member (P.Final IO) r,
          TypedCommandC ps a r)
        => S.Text
        -> (Context -> CommandForParsers ps r)
        -> P.Sem (DSLState r) Command
command :: Text
-> (Context -> CommandForParsers ps r) -> Sem (DSLState r) Command
command name :: Text
name cmd :: Context -> CommandForParsers ps r
cmd = do
  Maybe Group
parent <- forall (r :: EffectRow).
MemberWithError (Reader (Maybe Group)) r =>
Sem r (Maybe Group)
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @(Maybe Group)
  [Check]
checks <- forall (r :: EffectRow).
MemberWithError (Reader [Check]) r =>
Sem r [Check]
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @[Check]
  Context -> Text
help' <- forall (r :: EffectRow).
MemberWithError (Reader (Context -> Text)) r =>
Sem r (Context -> Text)
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @(Context -> L.Text)
  Command
cmd' <- Sem r Command -> Sem (DSLState r) Command
forall (r :: EffectRow) a. Sem r a -> Sem (DSLState r) a
raiseDSL (Sem r Command -> Sem (DSLState r) Command)
-> Sem r Command -> Sem (DSLState r) Command
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Group
-> [Check]
-> (Context -> Text)
-> (Context -> CommandForParsers ps r)
-> Sem r Command
forall (ps :: [*]) a (r :: EffectRow).
(Member (Final IO) r, TypedCommandC ps a r) =>
Text
-> Maybe Group
-> [Check]
-> (Context -> Text)
-> (Context -> CommandForParsers ps r)
-> Sem r Command
buildCommand @ps Text
name Maybe Group
parent [Check]
checks Context -> Text
help' Context -> CommandForParsers ps r
cmd
  HashMap Text Command -> Sem (DSLState r) ()
forall o (r :: EffectRow).
MemberWithError (LocalWriter o) r =>
o -> Sem r ()
ltell (HashMap Text Command -> Sem (DSLState r) ())
-> HashMap Text Command -> Sem (DSLState r) ()
forall a b. (a -> b) -> a -> b
$ Text -> Command -> HashMap Text Command
forall k v. Hashable k => k -> v -> HashMap k v
LH.singleton Text
name Command
cmd'
  Command -> Sem (DSLState r) Command
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command
cmd'

help :: P.Member (P.Reader (Context -> L.Text)) r
     => (Context -> L.Text)
     -> P.Sem r a
     -> P.Sem r a
help :: (Context -> Text) -> Sem r a -> Sem r a
help = ((Context -> Text) -> Context -> Text) -> Sem r a -> Sem r a
forall i (r :: EffectRow) a.
MemberWithError (Reader i) r =>
(i -> i) -> Sem r a -> Sem r a
P.local (((Context -> Text) -> Context -> Text) -> Sem r a -> Sem r a)
-> ((Context -> Text) -> (Context -> Text) -> Context -> Text)
-> (Context -> Text)
-> Sem r a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context -> Text) -> (Context -> Text) -> Context -> Text
forall a b. a -> b -> a
const

requires :: [Check]
         -> P.Sem (DSLState r) a
         -> P.Sem (DSLState r) a
requires :: [Check] -> Sem (DSLState r) a -> Sem (DSLState r) a
requires = ([Check] -> [Check]) -> Sem (DSLState r) a -> Sem (DSLState r) a
forall i (r :: EffectRow) a.
MemberWithError (Reader i) r =>
(i -> i) -> Sem r a -> Sem r a
P.local (([Check] -> [Check]) -> Sem (DSLState r) a -> Sem (DSLState r) a)
-> ([Check] -> [Check] -> [Check])
-> [Check]
-> Sem (DSLState r) a
-> Sem (DSLState r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Check] -> [Check] -> [Check]
forall a. Semigroup a => a -> a -> a
(<>)

requires' :: P.Member (P.Final IO) r
          => S.Text
          -> (Context -> P.Sem r (Maybe L.Text))
          -> P.Sem (DSLState r) a
          -> P.Sem (DSLState r) a
requires' :: Text
-> (Context -> Sem r (Maybe Text))
-> Sem (DSLState r) a
-> Sem (DSLState r) a
requires' name :: Text
name cb :: Context -> Sem r (Maybe Text)
cb m :: Sem (DSLState r) a
m = do
  Check
check <- Sem r Check -> Sem (DSLState r) Check
forall (r :: EffectRow) a. Sem r a -> Sem (DSLState r) a
raiseDSL (Sem r Check -> Sem (DSLState r) Check)
-> Sem r Check -> Sem (DSLState r) Check
forall a b. (a -> b) -> a -> b
$ Text -> (Context -> Sem r (Maybe Text)) -> Sem r Check
forall (r :: EffectRow).
Member (Final IO) r =>
Text -> (Context -> Sem r (Maybe Text)) -> Sem r Check
buildCheck Text
name Context -> Sem r (Maybe Text)
cb
  [Check] -> Sem (DSLState r) a -> Sem (DSLState r) a
forall (r :: EffectRow) a.
[Check] -> Sem (DSLState r) a -> Sem (DSLState r) a
requires [Check
check] Sem (DSLState r) a
m

requiresPure :: [(S.Text, Context -> Maybe L.Text)]
             -> P.Sem (DSLState r) a
             -> P.Sem (DSLState r) a
requiresPure :: [(Text, Context -> Maybe Text)]
-> Sem (DSLState r) a -> Sem (DSLState r) a
requiresPure checks :: [(Text, Context -> Maybe Text)]
checks = [Check] -> Sem (DSLState r) a -> Sem (DSLState r) a
forall (r :: EffectRow) a.
[Check] -> Sem (DSLState r) a -> Sem (DSLState r) a
requires ([Check] -> Sem (DSLState r) a -> Sem (DSLState r) a)
-> [Check] -> Sem (DSLState r) a -> Sem (DSLState r) a
forall a b. (a -> b) -> a -> b
$ ((Text, Context -> Maybe Text) -> Check)
-> [(Text, Context -> Maybe Text)] -> [Check]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> (Context -> Maybe Text) -> Check)
-> (Text, Context -> Maybe Text) -> Check
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> (Context -> Maybe Text) -> Check
buildCheckPure) [(Text, Context -> Maybe Text)]
checks

group :: P.Member (P.Final IO) r
         => S.Text
         -> P.Sem (DSLState r) a
         -> P.Sem (DSLState r) a
group :: Text -> Sem (DSLState r) a -> Sem (DSLState r) a
group name :: Text
name m :: Sem (DSLState r) a
m = mdo
  Maybe Group
parent <- forall (r :: EffectRow).
MemberWithError (Reader (Maybe Group)) r =>
Sem r (Maybe Group)
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @(Maybe Group)
  [Check]
checks <- forall (r :: EffectRow).
MemberWithError (Reader [Check]) r =>
Sem r [Check]
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @[Check]
  Context -> Text
help'  <- forall (r :: EffectRow).
MemberWithError (Reader (Context -> Text)) r =>
Sem r (Context -> Text)
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @(Context -> L.Text)
  let group' :: Group
group' = Text
-> Maybe Group
-> HashMap Text Command
-> HashMap Text Group
-> (Context -> Text)
-> [Check]
-> Group
Group Text
name Maybe Group
parent HashMap Text Command
commands HashMap Text Group
children Context -> Text
help' [Check]
checks
  (children :: HashMap Text Group
children, (commands :: HashMap Text Command
commands, res :: a
res)) <- forall (r :: EffectRow) a.
MemberWithError (LocalWriter (HashMap Text Group)) r =>
Sem r a -> Sem r (HashMap Text Group, a)
forall o (r :: EffectRow) a.
MemberWithError (LocalWriter o) r =>
Sem r a -> Sem r (o, a)
llisten @(LH.HashMap S.Text Group) (Sem (DSLState r) (HashMap Text Command, a)
 -> Sem
      (DSLState r) (HashMap Text Group, (HashMap Text Command, a)))
-> Sem (DSLState r) (HashMap Text Command, a)
-> Sem (DSLState r) (HashMap Text Group, (HashMap Text Command, a))
forall a b. (a -> b) -> a -> b
$ forall (r :: EffectRow) a.
MemberWithError (LocalWriter (HashMap Text Command)) r =>
Sem r a -> Sem r (HashMap Text Command, a)
forall o (r :: EffectRow) a.
MemberWithError (LocalWriter o) r =>
Sem r a -> Sem r (o, a)
llisten @(LH.HashMap S.Text Command) (Sem (DSLState r) a -> Sem (DSLState r) (HashMap Text Command, a))
-> Sem (DSLState r) a -> Sem (DSLState r) (HashMap Text Command, a)
forall a b. (a -> b) -> a -> b
$ (Maybe Group -> Maybe Group)
-> Sem (DSLState r) a -> Sem (DSLState r) a
forall i (r :: EffectRow) a.
MemberWithError (Reader i) r =>
(i -> i) -> Sem r a -> Sem r a
P.local (Maybe Group -> Maybe Group -> Maybe Group
forall a b. a -> b -> a
const (Maybe Group -> Maybe Group -> Maybe Group)
-> Maybe Group -> Maybe Group -> Maybe Group
forall a b. (a -> b) -> a -> b
$ Group -> Maybe Group
forall a. a -> Maybe a
Just Group
group') Sem (DSLState r) a
m
  HashMap Text Group -> Sem (DSLState r) ()
forall o (r :: EffectRow).
MemberWithError (LocalWriter o) r =>
o -> Sem r ()
ltell (HashMap Text Group -> Sem (DSLState r) ())
-> HashMap Text Group -> Sem (DSLState r) ()
forall a b. (a -> b) -> a -> b
$ Text -> Group -> HashMap Text Group
forall k v. Hashable k => k -> v -> HashMap k v
LH.singleton Text
name Group
group'
  a -> Sem (DSLState r) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res