{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}

module JVM.Data.Abstract.Builder.Code where

import Data.TypeMergingList (TypeMergingList)
import Data.TypeMergingList qualified as TML
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.State.Static.Local
import Effectful.TH (makeEffect)
import JVM.Data.Abstract.Builder.Label
import JVM.Data.Abstract.ClassFile.Method (CodeAttribute)
import JVM.Data.Abstract.Instruction

data CodeBuilder m a where
    AddCodeAttribute :: CodeAttribute -> CodeBuilder m ()
    NewLabel :: CodeBuilder m Label
    Emit' :: [Instruction] -> CodeBuilder m ()
    GetCode :: CodeBuilder m [Instruction]

makeEffect ''CodeBuilder

data CodeState = CodeState
    { CodeState -> [Label]
labelSource :: [Label]
    , CodeState -> TypeMergingList CodeAttribute
attributes :: TypeMergingList CodeAttribute
    , CodeState -> [Instruction]
code :: [Instruction]
    }

initialCodeState :: CodeState
initialCodeState :: CodeState
initialCodeState = CodeState{labelSource :: [Label]
labelSource = Int -> Label
MkLabel (Int -> Label) -> [Int] -> [Label]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0 ..], attributes :: TypeMergingList CodeAttribute
attributes = TypeMergingList CodeAttribute
forall a. Monoid a => a
mempty, code :: [Instruction]
code = []}

-- snoc list

emit :: (CodeBuilder :> r) => Instruction -> Eff r ()
emit :: forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit = [Instruction] -> Eff r ()
forall {k} (es :: [Effect]).
(HasCallStack, CodeBuilder :> es) =>
[Instruction] -> Eff es ()
emit' ([Instruction] -> Eff r ())
-> (Instruction -> [Instruction]) -> Instruction -> Eff r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Instruction -> [Instruction]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

codeBuilderToState :: ((State CodeState) :> r) => Eff (CodeBuilder ': r) a -> Eff r a
codeBuilderToState :: forall (r :: [Effect]) a.
(State CodeState :> r) =>
Eff (CodeBuilder : r) a -> Eff r a
codeBuilderToState = EffectHandler CodeBuilder r -> Eff (CodeBuilder : r) a -> Eff r a
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic) =>
EffectHandler e es -> Eff (e : es) a -> Eff es a
interpret (EffectHandler CodeBuilder r -> Eff (CodeBuilder : r) a -> Eff r a)
-> EffectHandler CodeBuilder r
-> Eff (CodeBuilder : r) a
-> Eff r a
forall a b. (a -> b) -> a -> b
$ \LocalEnv localEs r
_ -> \case
    AddCodeAttribute CodeAttribute
ca -> (CodeState -> CodeState) -> Eff r ()
forall s (es :: [Effect]).
(HasCallStack, State s :> es) =>
(s -> s) -> Eff es ()
modify (\CodeState
s -> CodeState
s{attributes = s.attributes `TML.snoc` ca})
    CodeBuilder (Eff localEs) a
NewLabel -> do
        s@CodeState{labelSource = ls} <- Eff r CodeState
forall s (es :: [Effect]).
(HasCallStack, State s :> es) =>
Eff es s
get
        case ls of
            [] -> [Char] -> Eff r a
forall a. HasCallStack => [Char] -> a
error [Char]
"No more labels"
            Label
l : [Label]
ls' -> do
                CodeState -> Eff r ()
forall s (es :: [Effect]).
(HasCallStack, State s :> es) =>
s -> Eff es ()
put (CodeState
s{labelSource = ls'})
                a -> Eff r a
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
Label
l
    Emit' [Instruction]
is -> (CodeState -> CodeState) -> Eff r ()
forall s (es :: [Effect]).
(HasCallStack, State s :> es) =>
(s -> s) -> Eff es ()
modify (\CodeState
s -> CodeState
s{code = reverse is <> s.code})
    -- code is a snoc list (kind of)
    CodeBuilder (Eff localEs) a
GetCode -> (CodeState -> a) -> Eff r a
forall s (es :: [Effect]) a.
(HasCallStack, State s :> es) =>
(s -> a) -> Eff es a
gets (.code)

runCodeBuilder :: forall r a. Eff (CodeBuilder ': r) a -> Eff r (a, [CodeAttribute], [Instruction])
runCodeBuilder :: forall (r :: [Effect]) a.
Eff (CodeBuilder : r) a
-> Eff r (a, [CodeAttribute], [Instruction])
runCodeBuilder =
    ((a, CodeState) -> (a, [CodeAttribute], [Instruction]))
-> Eff r (a, CodeState)
-> Eff r (a, [CodeAttribute], [Instruction])
forall a b. (a -> b) -> Eff r a -> Eff r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, CodeState) -> (a, [CodeAttribute], [Instruction])
forall {r} {a} {a} {a}.
(HasField "code" r [a],
 HasField "attributes" r (TypeMergingList a)) =>
(a, r) -> (a, [a], [a])
rr
        (Eff r (a, CodeState) -> Eff r (a, [CodeAttribute], [Instruction]))
-> (Eff (CodeBuilder : r) a -> Eff r (a, CodeState))
-> Eff (CodeBuilder : r) a
-> Eff r (a, [CodeAttribute], [Instruction])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeState -> Eff (State CodeState : r) a -> Eff r (a, CodeState)
forall s (es :: [Effect]) a.
HasCallStack =>
s -> Eff (State s : es) a -> Eff es (a, s)
runState CodeState
initialCodeState
        (Eff (State CodeState : r) a -> Eff r (a, CodeState))
-> (Eff (CodeBuilder : r) a -> Eff (State CodeState : r) a)
-> Eff (CodeBuilder : r) a
-> Eff r (a, CodeState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff (CodeBuilder : State CodeState : r) a
-> Eff (State CodeState : r) a
forall (r :: [Effect]) a.
(State CodeState :> r) =>
Eff (CodeBuilder : r) a -> Eff r a
codeBuilderToState
        (Eff (CodeBuilder : State CodeState : r) a
 -> Eff (State CodeState : r) a)
-> (Eff (CodeBuilder : r) a
    -> Eff (CodeBuilder : State CodeState : r) a)
-> Eff (CodeBuilder : r) a
-> Eff (State CodeState : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff (CodeBuilder : r) a
-> Eff (CodeBuilder : State CodeState : r) a
forall (subEs :: [Effect]) (es :: [Effect]) a.
Subset subEs es =>
Eff subEs a -> Eff es a
inject
  where
    rr :: (a, r) -> (a, [a], [a])
rr (a
a, r
s) =
        ( a
a
        , TypeMergingList a -> [a]
forall a. TypeMergingList a -> [a]
TML.toList r
s.attributes
        , [a] -> [a]
forall a. [a] -> [a]
reverse r
s.code
        )