module Language.Drasil.CodeExpr.Class where

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

import Control.Lens ( (^.) )

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 forall s a. s -> Getting a s a -> a
^. forall c. HasUID c => Lens' c 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 forall s a. s -> Getting a s a -> a
^. forall c. HasUID c => Lens' c UID
uid) [CodeExpr]
ps (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map ((forall s a. s -> Getting a s a -> a
^. forall c. HasUID c => Lens' c UID
uid) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(a, CodeExpr)]
ns) 
    (forall a b. (a -> b) -> [a] -> [b]
map 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 forall s a. s -> Getting a s a -> a
^. forall c. HasSpace c => Getter c Space
typ)
    where checkObj :: Space -> CodeExpr
checkObj (Actor String
_) = UID -> UID -> [CodeExpr] -> [(UID, CodeExpr)] -> CodeExpr
Message (c
o forall s a. s -> Getting a s a -> a
^. forall c. HasUID c => Lens' c UID
uid) (f
m forall s a. s -> Getting a s a -> a
^. forall c. HasUID c => Lens' c UID
uid) [CodeExpr]
ps []
          checkObj Space
_ = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Invalid actor message: Actor should have " 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 forall s a. s -> Getting a s a -> a
^. forall c. HasSpace c => Getter c Space
typ)
    where checkObj :: Space -> CodeExpr
checkObj (Actor String
_) = UID -> UID -> [CodeExpr] -> [(UID, CodeExpr)] -> CodeExpr
Message (c
o forall s a. s -> Getting a s a -> a
^. forall c. HasUID c => Lens' c UID
uid) (f
m forall s a. s -> Getting a s a -> a
^. forall c. HasUID c => Lens' c UID
uid) [CodeExpr]
ps 
            (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map ((forall s a. s -> Getting a s a -> a
^. forall c. HasUID c => Lens' c UID
uid) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(a, CodeExpr)]
as) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, CodeExpr)]
as))
          checkObj Space
_ = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Invalid actor message: Actor should have " forall a. [a] -> [a] -> [a]
++ 
            String
"Actor space"

  field :: CodeVarChunk -> CodeVarChunk -> CodeExpr
field CodeVarChunk
o CodeVarChunk
f = Space -> CodeExpr
checkObj (CodeVarChunk
o forall s a. s -> Getting a s a -> a
^. forall c. HasSpace c => Getter c Space
typ)
    where checkObj :: Space -> CodeExpr
checkObj (Actor String
_) = UID -> UID -> CodeExpr
Field (CodeVarChunk
o forall s a. s -> Getting a s a -> a
^. forall c. HasUID c => Lens' c UID
uid) (CodeVarChunk
f forall s a. s -> Getting a s a -> a
^. forall c. HasUID c => Lens' c UID
uid)
          checkObj Space
_ = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Invalid actor field: Actor should have " 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 [] [] = 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 forall s a. s -> Getting a s a -> a
^. forall c. HasUID c => Lens' c UID
uid) [CodeExpr]
ps (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map ((forall s a. s -> Getting a s a -> a
^. forall c. HasUID c => Lens' c UID
uid) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(a, CodeExpr)]
ns) 
    (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, CodeExpr)]
ns))