{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE ViewPatterns        #-}

module Dovetail.Core.Control.Monad.ST.Internal where

import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Foldable (fold, for_)
import Data.IORef qualified as IORef
import Data.Typeable (Typeable)
import Data.Vector (Vector)
import Dovetail
import Dovetail.Core.Effect.Ref
import Dovetail.Evaluate (ForeignType(..), builtIn)
    
type ST ctx a = Value ctx -> Eval ctx a

env :: forall ctx. Typeable ctx => Env ctx
env :: Env ctx
env = do
  let _ModuleName :: ModuleName
_ModuleName = Text -> ModuleName
ModuleName Text
"Control.Monad.ST.Internal"

  [Env ctx] -> Env ctx
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ -- new :: forall a r. a -> ST r (STRef r a)
      ModuleName -> Text -> (Value ctx -> ST ctx (Ref ctx)) -> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @(Value ctx -> ST ctx (Ref ctx))
        ModuleName
_ModuleName Text
"new"
        \Value ctx
s Value ctx
_ -> 
          IORef (Value ctx) -> Ref ctx
forall a. a -> ForeignType a
ForeignType (IORef (Value ctx) -> Ref ctx)
-> Eval ctx (IORef (Value ctx)) -> Eval ctx (Ref ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IORef (Value ctx)) -> Eval ctx (IORef (Value ctx))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Value ctx -> IO (IORef (Value ctx))
forall a. a -> IO (IORef a)
IORef.newIORef Value ctx
s)
      -- read :: forall a r. STRef r a -> ST r a
    , ModuleName -> Text -> (Ref ctx -> ST ctx (Value ctx)) -> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @(Ref ctx -> ST ctx (Value ctx))
        ModuleName
_ModuleName Text
"read"
        \(ForeignType IORef (Value ctx)
ref) Value ctx
_ ->
          IO (Value ctx) -> Eval ctx (Value ctx)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Value ctx) -> IO (Value ctx)
forall a. IORef a -> IO a
IORef.readIORef IORef (Value ctx)
ref)
      -- write :: forall a r. a -> STRef r a -> ST r a
    , ModuleName
-> Text -> (Value ctx -> Ref ctx -> ST ctx (Value ctx)) -> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @(Value ctx -> Ref ctx -> ST ctx (Value ctx))
        ModuleName
_ModuleName Text
"write"
        \Value ctx
s (ForeignType IORef (Value ctx)
ref) Value ctx
_ -> do
          IO () -> Eval ctx ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Value ctx) -> Value ctx -> IO ()
forall a. IORef a -> a -> IO ()
IORef.writeIORef IORef (Value ctx)
ref Value ctx
s)
          ST ctx (Value ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Text (Value ctx) -> Value ctx
forall ctx. HashMap Text (Value ctx) -> Value ctx
Object HashMap Text (Value ctx)
forall a. Monoid a => a
mempty)
      -- modifyImpl :: forall r a b.           
      --   (a                    
      --    -> { state :: a      
      --       , value :: b      
      --       }                 
      --   )                     
      --   -> Ref r a -> ST r b
    , ModuleName
-> Text
-> ((Value ctx -> Eval ctx (ModifyResult ctx))
    -> Ref ctx -> ST ctx (Value ctx))
-> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @((Value ctx -> Eval ctx (ModifyResult ctx)) -> Ref ctx -> ST ctx (Value ctx))
        ModuleName
_ModuleName Text
"modifyImpl"
        \Value ctx -> Eval ctx (ModifyResult ctx)
f (ForeignType IORef (Value ctx)
ref) Value ctx
_ -> do
          Value ctx
s <- IO (Value ctx) -> Eval ctx (Value ctx)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Value ctx) -> IO (Value ctx)
forall a. IORef a -> IO a
IORef.readIORef IORef (Value ctx)
ref)
          ModifyResult Value ctx
newState Value ctx
result <- Value ctx -> Eval ctx (ModifyResult ctx)
f Value ctx
s
          IO () -> Eval ctx ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Value ctx) -> Value ctx -> IO ()
forall a. IORef a -> a -> IO ()
IORef.writeIORef IORef (Value ctx)
ref Value ctx
newState)
          ST ctx (Value ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value ctx
result
      -- map_ :: forall r a b. (a -> b) -> ST r a -> ST r b
    , ModuleName
-> Text
-> (ST ctx (Value ctx) -> ST ctx (Value ctx) -> ST ctx (Value ctx))
-> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @((Value ctx -> Eval ctx (Value ctx)) -> ST ctx (Value ctx) -> ST ctx (Value ctx))
        ModuleName
_ModuleName Text
"map_"
        \ST ctx (Value ctx)
f ST ctx (Value ctx)
st Value ctx
rw ->
          ST ctx (Value ctx)
f ST ctx (Value ctx) -> Eval ctx (Value ctx) -> Eval ctx (Value ctx)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ST ctx (Value ctx)
st Value ctx
rw
      -- pure_ :: forall r a. a -> ST r a
    , ModuleName -> Text -> (Value ctx -> ST ctx (Value ctx)) -> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @(Value ctx -> ST ctx (Value ctx))
        ModuleName
_ModuleName Text
"pure_"
        \Value ctx
a Value ctx
_ -> ST ctx (Value ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value ctx
a
      -- bind_ :: forall r a b. ST r a -> (a -> ST r b) -> ST r b
    , ModuleName
-> Text
-> (ST ctx (Value ctx)
    -> (Value ctx -> ST ctx (Value ctx)) -> ST ctx (Value ctx))
-> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @(ST ctx (Value ctx) -> (Value ctx -> ST ctx (Value ctx)) -> ST ctx (Value ctx))
        ModuleName
_ModuleName Text
"bind_"
        \ST ctx (Value ctx)
st Value ctx -> ST ctx (Value ctx)
f Value ctx
rw ->
          ST ctx (Value ctx)
st Value ctx
rw Eval ctx (Value ctx) -> ST ctx (Value ctx) -> Eval ctx (Value ctx)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Value ctx
a -> Value ctx -> ST ctx (Value ctx)
f Value ctx
a Value ctx
rw
      -- run :: forall a. (forall r. ST r a) -> a
    , ModuleName
-> Text -> (ST ctx (Value ctx) -> Eval ctx (Value ctx)) -> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @(ST ctx (Value ctx) -> Eval ctx (Value ctx))
        ModuleName
_ModuleName Text
"run"
        \ST ctx (Value ctx)
st -> 
          ST ctx (Value ctx)
st (HashMap Text (Value ctx) -> Value ctx
forall ctx. HashMap Text (Value ctx) -> Value ctx
Object HashMap Text (Value ctx)
forall a. Monoid a => a
mempty)
      -- while :: forall r a. ST r Boolean -> ST r a -> ST r Unit
    , ModuleName
-> Text
-> (ST ctx Bool -> ST ctx (Value ctx) -> ST ctx (Value ctx))
-> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @(ST ctx Bool -> ST ctx (Value ctx) -> ST ctx (Value ctx))
        ModuleName
_ModuleName Text
"while"
        \ST ctx Bool
cond ST ctx (Value ctx)
body Value ctx
rw -> do
          let loop :: Eval ctx ()
loop = do
                Bool
b <- ST ctx Bool
cond Value ctx
rw
                Bool -> Eval ctx () -> Eval ctx ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (ST ctx (Value ctx)
body Value ctx
rw Eval ctx (Value ctx) -> Eval ctx () -> Eval ctx ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Eval ctx ()
loop)
          Eval ctx ()
loop
          ST ctx (Value ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Text (Value ctx) -> Value ctx
forall ctx. HashMap Text (Value ctx) -> Value ctx
Object HashMap Text (Value ctx)
forall a. Monoid a => a
mempty)
      -- for :: forall r a. Int -> Int -> (Int -> ST r a) -> ST r Unit
    , ModuleName
-> Text
-> (Integer
    -> Integer
    -> (Integer -> ST ctx (Value ctx))
    -> ST ctx (Value ctx))
-> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @(Integer -> Integer -> (Integer -> ST ctx (Value ctx)) -> ST ctx (Value ctx))
        ModuleName
_ModuleName Text
"for"
        \Integer
from Integer
to Integer -> ST ctx (Value ctx)
body Value ctx
rw -> do
          [Integer] -> (Integer -> Eval ctx (Value ctx)) -> Eval ctx ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Integer
from .. Integer
to] \Integer
i -> 
            Integer -> ST ctx (Value ctx)
body Integer
i Value ctx
rw
          ST ctx (Value ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Text (Value ctx) -> Value ctx
forall ctx. HashMap Text (Value ctx) -> Value ctx
Object HashMap Text (Value ctx)
forall a. Monoid a => a
mempty)
      -- foreach :: forall r a. Array a -> (a -> ST r Unit) -> ST r Unit
    , ModuleName
-> Text
-> (Vector (Value ctx)
    -> (Value ctx -> ST ctx (Value ctx)) -> ST ctx (Value ctx))
-> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @(Vector (Value ctx) -> (Value ctx -> ST ctx (Value ctx)) -> ST ctx (Value ctx))
        ModuleName
_ModuleName Text
"foreach"
        \Vector (Value ctx)
xs Value ctx -> ST ctx (Value ctx)
f Value ctx
rw -> do
          Vector (Value ctx) -> ST ctx (Value ctx) -> Eval ctx ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Vector (Value ctx)
xs \Value ctx
x -> 
            Value ctx -> ST ctx (Value ctx)
f Value ctx
x Value ctx
rw
          ST ctx (Value ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Text (Value ctx) -> Value ctx
forall ctx. HashMap Text (Value ctx) -> Value ctx
Object HashMap Text (Value ctx)
forall a. Monoid a => a
mempty)
    ]