module Drasil.Code.CodeExpr.Class where

import Control.Lens ((^.))

import Drasil.Database (HasUID(..))

import Drasil.Code.Classes (IsArgumentName, Callable)
import Drasil.Code.CodeExpr.Lang (CodeExpr(FCall, New, Message, Field))
import Drasil.Code.CodeVar (CodeIdea, CodeVarChunk)
import Language.Drasil.Symbol (HasSymbol)
import Language.Drasil.Space (Space(Actor), HasSpace(..))
import Language.Drasil.Expr.Class (ExprC(..))

class CodeExprC r where
  -- | Constructs a CodeExpr for actor creation (constructor call)
  new :: (Callable f, HasUID f, CodeIdea f) => f -> [r] -> r

  -- | Constructs a CodeExpr for actor creation (constructor call) that uses named arguments
  newWithNamedArgs :: (Callable f, HasUID f, CodeIdea f, HasUID a,
    IsArgumentName a) => f -> [r] -> [(a, r)] -> r

  -- | Constructs a CodeExpr for actor messaging (method call)
  msg :: (Callable f, HasUID f, CodeIdea f, HasUID c, HasSpace c, CodeIdea c)
    => c -> f -> [r] -> r

  -- | Constructs a CodeExpr for actor messaging (method call) that uses named arguments
  msgWithNamedArgs :: (Callable f, HasUID f, CodeIdea f, HasUID c, HasSpace c,
    CodeIdea c, HasUID a, IsArgumentName a) => c -> f -> [r] -> [(a, r)] ->
    r

  -- | Constructs a CodeExpr representing the field of an actor
  field :: CodeVarChunk -> CodeVarChunk -> r

  -- | Similar to 'apply', but takes a relation to apply to 'FCall'.
  applyWithNamedArgs :: (HasUID f, HasSymbol f, HasUID a, IsArgumentName a) => f
    -> [r] -> [(a, r)] -> r

instance CodeExprC CodeExpr where
  new :: forall f.
(Callable f, HasUID f, CodeIdea f) =>
f -> [CodeExpr] -> CodeExpr
new f
c [CodeExpr]
ps = UID -> [CodeExpr] -> [(UID, CodeExpr)] -> CodeExpr
New (f
c f -> Getting UID f UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID f UID
forall c. HasUID c => Getter c UID
Getter f UID
uid) [CodeExpr]
ps []

  newWithNamedArgs :: forall f a.
(Callable f, HasUID f, CodeIdea f, HasUID a, IsArgumentName a) =>
f -> [CodeExpr] -> [(a, CodeExpr)] -> CodeExpr
newWithNamedArgs f
c [CodeExpr]
ps [(a, CodeExpr)]
ns = UID -> [CodeExpr] -> [(UID, CodeExpr)] -> CodeExpr
New (f
c f -> Getting UID f UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID f UID
forall c. HasUID c => Getter c UID
Getter f UID
uid) [CodeExpr]
ps ([UID] -> [CodeExpr] -> [(UID, CodeExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((a, CodeExpr) -> UID) -> [(a, CodeExpr)] -> [UID]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> Getting UID a UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID a UID
forall c. HasUID c => Getter c UID
Getter a UID
uid) (a -> UID) -> ((a, CodeExpr) -> a) -> (a, CodeExpr) -> UID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, CodeExpr) -> a
forall a b. (a, b) -> a
fst) [(a, CodeExpr)]
ns)
    (((a, CodeExpr) -> CodeExpr) -> [(a, CodeExpr)] -> [CodeExpr]
forall a b. (a -> b) -> [a] -> [b]
map (a, CodeExpr) -> CodeExpr
forall a b. (a, b) -> b
snd [(a, CodeExpr)]
ns))

  msg :: forall f c.
(Callable f, HasUID f, CodeIdea f, HasUID c, HasSpace c,
 CodeIdea c) =>
c -> f -> [CodeExpr] -> CodeExpr
msg c
o f
m [CodeExpr]
ps = Space -> CodeExpr
checkObj (c
o c -> Getting Space c Space -> Space
forall s a. s -> Getting a s a -> a
^. Getting Space c Space
forall c. HasSpace c => Getter c Space
Getter c Space
typ)
    where checkObj :: Space -> CodeExpr
checkObj (Actor String
_) = UID -> UID -> [CodeExpr] -> [(UID, CodeExpr)] -> CodeExpr
Message (c
o c -> Getting UID c UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID c UID
forall c. HasUID c => Getter c UID
Getter c UID
uid) (f
m f -> Getting UID f UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID f UID
forall c. HasUID c => Getter c UID
Getter f UID
uid) [CodeExpr]
ps []
          checkObj Space
_ = String -> CodeExpr
forall a. HasCallStack => String -> a
error (String -> CodeExpr) -> String -> CodeExpr
forall a b. (a -> b) -> a -> b
$ String
"Invalid actor message: Actor should have " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
"Actor space"

  msgWithNamedArgs :: forall f c a.
(Callable f, HasUID f, CodeIdea f, HasUID c, HasSpace c,
 CodeIdea c, HasUID a, IsArgumentName a) =>
c -> f -> [CodeExpr] -> [(a, CodeExpr)] -> CodeExpr
msgWithNamedArgs c
o f
m [CodeExpr]
ps [(a, CodeExpr)]
as = Space -> CodeExpr
checkObj (c
o c -> Getting Space c Space -> Space
forall s a. s -> Getting a s a -> a
^. Getting Space c Space
forall c. HasSpace c => Getter c Space
Getter c Space
typ)
    where checkObj :: Space -> CodeExpr
checkObj (Actor String
_) = UID -> UID -> [CodeExpr] -> [(UID, CodeExpr)] -> CodeExpr
Message (c
o c -> Getting UID c UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID c UID
forall c. HasUID c => Getter c UID
Getter c UID
uid) (f
m f -> Getting UID f UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID f UID
forall c. HasUID c => Getter c UID
Getter f UID
uid) [CodeExpr]
ps
            ([UID] -> [CodeExpr] -> [(UID, CodeExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((a, CodeExpr) -> UID) -> [(a, CodeExpr)] -> [UID]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> Getting UID a UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID a UID
forall c. HasUID c => Getter c UID
Getter a UID
uid) (a -> UID) -> ((a, CodeExpr) -> a) -> (a, CodeExpr) -> UID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, CodeExpr) -> a
forall a b. (a, b) -> a
fst) [(a, CodeExpr)]
as) (((a, CodeExpr) -> CodeExpr) -> [(a, CodeExpr)] -> [CodeExpr]
forall a b. (a -> b) -> [a] -> [b]
map (a, CodeExpr) -> CodeExpr
forall a b. (a, b) -> b
snd [(a, CodeExpr)]
as))
          checkObj Space
_ = String -> CodeExpr
forall a. HasCallStack => String -> a
error (String -> CodeExpr) -> String -> CodeExpr
forall a b. (a -> b) -> a -> b
$ String
"Invalid actor message: Actor should have " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
"Actor space"

  field :: CodeVarChunk -> CodeVarChunk -> CodeExpr
field CodeVarChunk
o CodeVarChunk
f = Space -> CodeExpr
checkObj (CodeVarChunk
o CodeVarChunk -> Getting Space CodeVarChunk Space -> Space
forall s a. s -> Getting a s a -> a
^. Getting Space CodeVarChunk Space
forall c. HasSpace c => Getter c Space
Getter CodeVarChunk Space
typ)
    where checkObj :: Space -> CodeExpr
checkObj (Actor String
_) = UID -> UID -> CodeExpr
Field (CodeVarChunk
o CodeVarChunk -> Getting UID CodeVarChunk UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID CodeVarChunk UID
forall c. HasUID c => Getter c UID
Getter CodeVarChunk UID
uid) (CodeVarChunk
f CodeVarChunk -> Getting UID CodeVarChunk UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID CodeVarChunk UID
forall c. HasUID c => Getter c UID
Getter CodeVarChunk UID
uid)
          checkObj Space
_ = String -> CodeExpr
forall a. HasCallStack => String -> a
error (String -> CodeExpr) -> String -> CodeExpr
forall a b. (a -> b) -> a -> b
$ String
"Invalid actor field: Actor should have " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
"Actor space"

  -- | Similar to 'apply', but takes a relation to apply to 'FCall'.
  applyWithNamedArgs :: forall f a.
(HasUID f, HasSymbol f, HasUID a, IsArgumentName a) =>
f -> [CodeExpr] -> [(a, CodeExpr)] -> CodeExpr
applyWithNamedArgs f
f [] [] = f -> CodeExpr
forall c. (HasUID c, HasSymbol c) => c -> CodeExpr
forall r c. (ExprC r, HasUID c, HasSymbol c) => c -> r
sy f
f
  applyWithNamedArgs f
f [CodeExpr]
ps [(a, CodeExpr)]
ns = UID -> [CodeExpr] -> [(UID, CodeExpr)] -> CodeExpr
FCall (f
f f -> Getting UID f UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID f UID
forall c. HasUID c => Getter c UID
Getter f UID
uid) [CodeExpr]
ps ([UID] -> [CodeExpr] -> [(UID, CodeExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((a, CodeExpr) -> UID) -> [(a, CodeExpr)] -> [UID]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> Getting UID a UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID a UID
forall c. HasUID c => Getter c UID
Getter a UID
uid) (a -> UID) -> ((a, CodeExpr) -> a) -> (a, CodeExpr) -> UID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, CodeExpr) -> a
forall a b. (a, b) -> a
fst) [(a, CodeExpr)]
ns)
    (((a, CodeExpr) -> CodeExpr) -> [(a, CodeExpr)] -> [CodeExpr]
forall a b. (a -> b) -> [a] -> [b]
map (a, CodeExpr) -> CodeExpr
forall a b. (a, b) -> b
snd [(a, CodeExpr)]
ns))