Commit b2385129 authored by Katharina Brandl's avatar Katharina Brandl
Browse files

update code to be consistent with paper

parent 0a3dd5b6
Pipeline #135463 passed with stages
in 80 minutes and 52 seconds
......@@ -21,7 +21,6 @@ import Control.Arrow.Store
import Control.Arrow.Except
import Control.Arrow.Environment
import Control.Arrow.Closure
import Control.Arrow.Stack
import Control.Arrow.Transformer.State
import Control.Arrow.Utils
import Control.Category
......@@ -42,7 +41,7 @@ newtype StoreT store c x y = StoreT (StateT store c x y)
ArrowCont, ArrowConst r, ArrowReader r,
ArrowEnv var' val', ArrowClosure expr cls,
ArrowFail e, ArrowExcept e, ArrowState store,
ArrowLowerBounded a, ArrowRun, ArrowJoin, ArrowStack s)
ArrowLowerBounded a, ArrowRun, ArrowJoin)
runStoreT :: StoreT store c x y -> c (store, x) (store, y)
runStoreT = coerce
......
......@@ -17,7 +17,6 @@ import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Reader
import Control.Arrow.Stack
import Control.Arrow.State
import Control.Arrow.Store as Store
import Control.Arrow.Trans
......@@ -33,7 +32,7 @@ import Data.Coerce
newtype ExceptT e c x y = ExceptT (KleisliT (Error e) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowLift,ArrowTrans,ArrowRun,
ArrowConst r,ArrowState s,ArrowReader r,ArrowFail err,
ArrowEnv var val, ArrowClosure expr cls,ArrowStore var val, ArrowStack st)
ArrowEnv var val, ArrowClosure expr cls,ArrowStore var val)
runExceptT :: ExceptT e c x y -> c x (Error e y)
runExceptT = coerce
......
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Stack where
import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Reader
import Control.Arrow.Stack
import Control.Arrow.State
import Control.Arrow.Trans
import Control.Arrow.Transformer.State
import Control.Arrow.Utils
import Control.Arrow.Writer
import Data.Profunctor
import Data.Coerce
-- | Arrow transformer that adds a stack to a computation.
newtype StackT v c x y = StackT (StateT [v] c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowRun,
ArrowConst r, ArrowReader r, ArrowFail e, ArrowExcept e, ArrowWriter w)
-- | Execute a computation and only return the result value and store.
runStackT :: StackT v c x y -> c ([v], x) ([v], y)
runStackT = coerce
{-# INLINE runStackT #-}
-- | Execute a computation and only return the result value.
evalStackT :: (Profunctor c) => StackT v c x y -> c ([v], x) y
evalStackT f = rmap pi2 (runStackT f)
-- | Execute a computation and only return the result store.
execStackT :: (Profunctor c) => StackT v c x y -> c ([v], x) [v]
execStackT f = rmap pi1 (runStackT f)
instance (ArrowChoice c, Profunctor c) => ArrowStack v (StackT v c) where
push = StackT $ modify $ arr $ \(v,st) -> ((), v:st)
pop = StackT $ modify $ arr $ \((),v:st) -> (v, st)
peek = StackT $ get >>^ head
ifEmpty (StackT f) (StackT g) = StackT $ proc x -> do
st <- get -< ()
case st of
[] -> g -< x
_ -> f -< x
localFreshStack (StackT f) = StackT $ proc x -> do
st <- get -< ()
put -< []
y <- f -< x
stNew <- get -< ()
put -< stNew ++ st
returnA -< y
--pop2 = StackT $ modify $ arr $ \((),v2:v1:st) -> ((v1,v2), st)
--popn = StackT $ modify $ arr $ \(n,st) -> splitAt (fromIntegral n) st
--pushn = StackT $ modify $ arr $ \(st',st) -> ((),st'++st)
instance ArrowFix (Underlying (StackT v c) x y) => ArrowFix (StackT v c x y) where
type Fix (StackT v c x y) = Fix (Underlying (StackT v c) x y)--StackT v (Fix c ([v],x) ([v],y))
......@@ -31,13 +31,12 @@ import Control.Arrow.Fix
import Control.Arrow.Frame
import Control.Arrow.Trans
import Control.Arrow.Environment
import Control.Arrow.Stack
import Control.Arrow.Store
import Control.Arrow.Except
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.LetRec
import Control.Arrow.Fix.Context
import Control.Arrow.Fix.Context
import Control.Arrow.Writer
import Data.Profunctor.Unsafe
......@@ -47,7 +46,7 @@ newtype ValueT val c x y = ValueT { runValueT :: c x y }
deriving (Profunctor,Category,Arrow,ArrowChoice, ArrowConst r,
ArrowFrame frame, ArrowEnv var val', ArrowLetRec var val', ArrowStore addr val',
ArrowExcept exc,ArrowFail e, ArrowWriter w,
ArrowReader r, ArrowState s, ArrowCont, ArrowCallSite ctx, ArrowStack st)
ArrowReader r, ArrowState s, ArrowCont, ArrowCallSite ctx)
instance (ArrowApply c, Profunctor c) => ArrowApply (ValueT val c) where
app = lift (app .# first coerce)
......
......@@ -23,9 +23,9 @@ import qualified Control.Arrow.Trans as Trans
import Control.Arrow.Except
import Control.Arrow.Fail as Fail
import Control.Arrow.Transformer.JumpTypes
import Control.Arrow.Transformer.Stack
import Control.Arrow.Transformer.StaticGlobalState
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.WasmFrame
......@@ -329,7 +329,7 @@ invokeExported staticS mem tab modInst funcName args =
Trans.run
(Generic.invokeExported ::
ValueT Value
(ReaderT Generic.JumpTypes
(JumpTypesT
(StackT Value
(ExceptT (Generic.Exc Value)
(StaticGlobalStateT Value
......@@ -338,7 +338,7 @@ invokeExported staticS mem tab modInst funcName args =
(TableT
(FrameT FrameData Value
(FailureT Err
(->)))))))))) (Text, [Value]) [Value]) (JoinVector Vec.empty,((0,modInst),(tab,(mem,(staticS,([],(Generic.JumpTypes [],(funcName,args))))))))
(->)))))))))) (Text, [Value]) [Value]) (JoinVector Vec.empty,((0,modInst),(tab,(mem,(staticS,([],([],(funcName,args))))))))
instantiateConcrete :: ValidModule -> IO (Either String (ModuleInstance, StaticGlobalState Value, Memories, Tables))
......
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.DebuggableStack where
import Control.Arrow
import Control.Arrow.Stack (ArrowStack)
import Control.Arrow.Trans
import Control.Arrow.Transformer.Kleisli
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Writer
import Data.Profunctor.Unsafe
class ArrowStack v c => ArrowDebuggableStack v c | c -> v where
getStack :: c () [v]
---------------- instances -------------------------
instance (Profunctor c, Arrow c, Monad f, ArrowDebuggableStack v c) => ArrowDebuggableStack v (KleisliT f c) where
getStack = lift' getStack
instance (Profunctor c, Arrow c, ArrowDebuggableStack v c) => ArrowDebuggableStack v (ReaderT r c) where
getStack = lift' getStack
instance (Profunctor c, Arrow c, ArrowDebuggableStack v c) => ArrowDebuggableStack v (StateT st c) where
getStack = lift' getStack
deriving instance (ArrowDebuggableStack v c) => ArrowDebuggableStack v (ValueT val c)
instance (Monoid w, Profunctor c, Arrow c, ArrowDebuggableStack v c) => ArrowDebuggableStack v (WriterT w c) where
getStack = lift' getStack
......@@ -3,7 +3,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
module Control.Arrow.MemAddress where
module Control.Arrow.EffectiveAddress where
import Control.Arrow
import Control.Arrow.Trans
......@@ -20,18 +20,18 @@ import Control.Arrow.Transformer.Writer
import qualified Data.Order as O
import Data.Profunctor
class ArrowMemAddress base off addr c where
memaddr :: c (base, off) addr
class ArrowEffectiveAddress base off addr c where
effectiveAddress :: c (base, off) addr
deriving instance (ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (ValueT val2 c)
deriving instance (Arrow c, Profunctor c, ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (CE.ExceptT e c)
deriving instance (O.Complete e, Arrow c, Profunctor c, ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (AE.ExceptT e c)
instance (Monad f, Arrow c, Profunctor c, ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (KleisliT f c) where
memaddr = lift' memaddr
--deriving instance (Arrow c, Profunctor c, ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (StackT v c)
instance (Arrow c, Profunctor c, ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (StateT s c) where
memaddr = lift' memaddr
instance (Arrow c, Profunctor c, ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (ReaderT r c) where
memaddr = lift' memaddr
instance (Monoid w, Arrow c, Profunctor c, ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (WriterT w c) where
memaddr = lift' memaddr
deriving instance (ArrowEffectiveAddress base off addr c) => ArrowEffectiveAddress base off addr (ValueT val2 c)
deriving instance (Arrow c, Profunctor c, ArrowEffectiveAddress base off addr c) => ArrowEffectiveAddress base off addr (CE.ExceptT e c)
deriving instance (O.Complete e, Arrow c, Profunctor c, ArrowEffectiveAddress base off addr c) => ArrowEffectiveAddress base off addr (AE.ExceptT e c)
instance (Monad f, Arrow c, Profunctor c, ArrowEffectiveAddress base off addr c) => ArrowEffectiveAddress base off addr (KleisliT f c) where
effectiveAddress = lift' effectiveAddress
--deriving instance (Arrow c, Profunctor c, ArrowEffectiveAddress base off addr c) => ArrowEffectiveAddress base off addr (StackT v c)
instance (Arrow c, Profunctor c, ArrowEffectiveAddress base off addr c) => ArrowEffectiveAddress base off addr (StateT s c) where
effectiveAddress = lift' effectiveAddress
instance (Arrow c, Profunctor c, ArrowEffectiveAddress base off addr c) => ArrowEffectiveAddress base off addr (ReaderT r c) where
effectiveAddress = lift' effectiveAddress
instance (Monoid w, Arrow c, Profunctor c, ArrowEffectiveAddress base off addr c) => ArrowEffectiveAddress base off addr (WriterT w c) where
effectiveAddress = lift' effectiveAddress
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Functions where
import Data
import Control.Arrow
import Control.Arrow.Trans
import Control.Arrow.Transformer.Abstract.Except as AE
import Control.Arrow.Transformer.Concrete.Except as CE
import Control.Arrow.Transformer.Kleisli
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Writer
import qualified Data.Order as O
import Data.Profunctor
import Language.Wasm.Structure (FuncType)
import Language.Wasm.Interpreter (ModuleInstance(..))
class ArrowFunctions c where
-- | Reads a function. Cannot fail due to validation.
--readFunction :: c ((FuncType, ModuleInstance, Function), x) y -> c ((FuncType, HostFunction v c), x) y -> c (Int, x) y
--readFunction :: c ((FuncType, ModuleInstance, Function), x) y -> c (Int, x) y
readFunction :: c FunctionAddr (FuncType,ModuleInstance,Function)
deriving instance (ArrowFunctions c) => ArrowFunctions (ValueT val2 c)
deriving instance (Arrow c, Profunctor c, ArrowFunctions c) => ArrowFunctions (CE.ExceptT e c)
deriving instance (O.Complete e, Arrow c, Profunctor c, ArrowFunctions c) => ArrowFunctions (AE.ExceptT e c)
instance (Arrow c, Profunctor c, Monad f, ArrowFunctions c) => ArrowFunctions (KleisliT f c) where
readFunction = lift' readFunction
instance (Arrow c, Profunctor c, ArrowFunctions c) => ArrowFunctions (StateT s c) where
readFunction = lift' readFunction
instance (Arrow c, Profunctor c, ArrowFunctions c) => ArrowFunctions (ReaderT r c) where
readFunction = lift' readFunction
instance (Arrow c, Profunctor c, Monoid r, ArrowFunctions c) => ArrowFunctions (WriterT r c) where
readFunction = lift' readFunction
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.GlobalState where
import Control.Arrow
import Control.Arrow.Trans
import Control.Arrow.Transformer.Concrete.Except as CE
import Control.Arrow.Transformer.Abstract.Except as AE
import Control.Arrow.Transformer.Kleisli
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.Stack
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Writer
import qualified Data.Order as O
import Data.Profunctor
import Language.Wasm.Structure hiding (exports, Function)
import Language.Wasm.Interpreter (ModuleInstance(..))
import Data
class ArrowGlobalState v m c | c -> v, c -> m where
-- | Reads a global variable. Cannot fail due to validation.
readGlobal :: c Int v
-- | Writes a global variable. Cannot fail due to validation.
writeGlobal :: c (Int, v) ()
-- | Reads a function. Cannot fail due to validation.
--readFunction :: c ((FuncType, ModuleInstance, Function), x) y -> c ((FuncType, HostFunction v c), x) y -> c (Int, x) y
readFunction :: c ((FuncType, ModuleInstance, Function), x) y -> c (Int, x) y
-- | readTable f g h (ta,ix,x)
-- | Lookup `ix` in table `ta` to retrieve the function address `fa`.
-- | Invokes `f (fa, x)` if all goes well.
-- | Invokes `g (ta,ix,x)` if `ix` is out of bounds.
-- | Invokes `h (ta,ix,x)` if `ix` cell is uninitialized.
readTable :: c (Int,x) y -> c (Int,v,x) y -> c (Int,v,x) y -> c (Int,v,x) y
fetchMemory :: c Int m
storeMemory :: c (Int, m) ()
-- | Executes a function relative to a memory instance. The memory instance exists due to validation.
-- withMemoryInstance :: c x y -> c (Int,x) y
deriving instance (ArrowGlobalState v m c) => ArrowGlobalState v m (ValueT v2 c)
instance (Profunctor c, Arrow c, ArrowGlobalState v m c) => ArrowGlobalState v m (StateT s c) where
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
-- readFunction :: (StateT s c) (f, x) y -> (StateT s c) (Int, x) y
-- a :: (StateT s c) (f, x) y
-- unlift a :: Underlying (StateT s c) (f, x) y
-- = c (s, (f, x)) (s, y)
-- readFunction :: c (f, x) y -> c (Int, x) y
-- need foo :: c (s, (f, x)) (s, y) -> c (s, (Int, x)) (s, y)
-- lift :: c (s, (Int, x)) (s, y) ->
-- StateT s c (Int, x) y
--
-- arr :: c (s, (f,x)) (s, y)
-- flip a :: (StateT s c) ((f,x),s) (y,s)
-- modify (flip a) :: (StateT s c) (f,x) y
-- readFunction (modify (flip a)) :: c (Int, x) y
-- second (readFunction (modify (flip a))) :: c (s, (Int,x)) (s, y)
readFunction a = lift $ transform (unlift a)
-- -- proc (f,x) -> arr -< (s, (f,x)) :: c (f,x) (s, y)
-- -- ((proc (f,x) -> arr -< (s, (f,x))) >>^ snd) :: c (f,x) y
-- -- readFunction ((proc (f,x) -> arr -< (s, (f,x))) >>^ snd) :: c (Int, x) y
-- -- c (s, (Int, x)) y
where transform f = proc (s, (i,x)) -> readFunction (proc (fun,(s2,x)) -> f -< (s2, (fun,x))) -< (i,(s,x))
-- -- arr :: c (s, (f,x)) (s, y)
-- -- proc (f,(s2,x)) -> arr -< (s2, (f,x)) :: c (f,(s,x)) (s, y)
-- -- ((proc (f,(s2,x)) -> arr -< (s2, (f,x))) >>^ snd) :: c (f,(s,x)) y
-- -- func "" :: c (Int, (s,x)) y (for z = (s x))
--(sNew,y) <- readFunction ((proc (f,(s2,x)) -> arr -< (s2, (f,x)))) -< (i,(s,x))
--returnA -< (sNew,y)
-- proc (s, (i,x)) -> do
-- y <- func ((proc (f,(s2,x)) -> arr -< (s2, (f,x))) >>^ snd) -< (s,(i,x))
-- returnA -< (s,y)
fetchMemory = lift' fetchMemory
storeMemory = lift' storeMemory
--foo2 :: (c (f,x) y -> c (Int,x) y) -> c (s, (f,x)) (s,y) -> c (s, (Int,x)) (s,y)
--foo2 func arr = proc (s, (i,x)) -> do
-- y <- func ((proc (f,x) -> arr -< (s,(f,x))) >>^ snd) -< (i,x)
-- returnA -< (s,y)
--
--foo :: (Arrow c) => (c (f, (s,x)) y -> c (Int, (s,x)) y) -> c (s, (f,x)) (s, y) -> c (s, (Int, x)) (s, y)
--foo func arr = proc (s, (i,x)) -> do
-- -- arr :: c (s, (f,x)) (s, y)
-- -- proc (f,(s2,x)) -> arr -< (s2, (f,x)) :: c (f,(s,x)) (s, y)
-- -- ((proc (f,(s2,x)) -> arr -< (s2, (f,x))) >>^ snd) :: c (f,(s,x)) y
-- -- func "" :: c (Int, (s,x)) y (for z = (s x))
-- y <- func ((proc (f,(s2,x)) -> arr -< (s2, (f,x))) >>^ snd) -< (i,(s,x))
-- returnA -< (s,y)
readTable = error "TODO: Implement StateT.readTable"
deriving instance (Arrow c, Profunctor c, ArrowGlobalState v m c) => ArrowGlobalState v m (CE.ExceptT e c)
deriving instance (O.Complete e, Arrow c, Profunctor c, ArrowGlobalState v m c) => ArrowGlobalState v m (AE.ExceptT e c)
deriving instance (Arrow c, Profunctor c, ArrowGlobalState v m c) => ArrowGlobalState v m (StackT s c)
instance (Monad f, Arrow c, Profunctor c, ArrowGlobalState v m c) => ArrowGlobalState v m (KleisliT f c) where
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
readFunction a = lift (readFunction (unlift a))
fetchMemory = lift' fetchMemory
storeMemory = lift' storeMemory
readTable = error "TODO: Implement KleisliT.readTable"
instance (Arrow c, Profunctor c, ArrowGlobalState v m c) => ArrowGlobalState v m (ReaderT r c) where
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
-- unlift arr :: c (r, (f,x)) y
-- lift :: c (r, (Int,x)) y -> c (Int,x) y
-- transform :: c (r, (f,x)) y -> c (r, (Int,x)) y
-- readFunction :: c (f,x) y -> c (Int,x) y
readFunction a = lift $ transform (unlift a)
where transform f = proc (r, (i,x)) ->
readFunction (proc (fun,(r,x)) -> f -< (r, (fun,x))) -< (i,(r,x))
fetchMemory = lift' fetchMemory
storeMemory = lift' storeMemory
readTable = error "TODO: Implement ReaderT.readTable"
instance (Arrow c, Profunctor c, Monoid w, ArrowGlobalState v m c) => ArrowGlobalState v m (WriterT w c) where
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
readFunction a = lift (readFunction (unlift a))
fetchMemory = lift' fetchMemory
storeMemory = lift' storeMemory
readTable = error "TODO: Implement WriterT.readTable"
......@@ -6,7 +6,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.StaticGlobalState where
module Control.Arrow.Globals where
import Data
......@@ -23,39 +23,25 @@ import Control.Arrow.Transformer.Writer
import qualified Data.Order as O
import Data.Profunctor
import Language.Wasm.Structure (FuncType)
import Language.Wasm.Interpreter (ModuleInstance(..))
class ArrowStaticGlobalState v c | c -> v where
class ArrowGlobals v c | c -> v where
-- | Reads a global variable. Cannot fail due to validation.
readGlobal :: c Int v
readGlobal :: c GlobalAddr v
-- | Writes a global variable. Cannot fail due to validation.
writeGlobal :: c (Int, v) ()
writeGlobal :: c (GlobalAddr, v) ()
-- | Reads a function. Cannot fail due to validation.
--readFunction :: c ((FuncType, ModuleInstance, Function), x) y -> c ((FuncType, HostFunction v c), x) y -> c (Int, x) y
readFunction :: c ((FuncType, ModuleInstance, Function), x) y -> c (Int, x) y
deriving instance (ArrowStaticGlobalState v c) => ArrowStaticGlobalState v (ValueT val2 c)
deriving instance (Arrow c, Profunctor c, ArrowStaticGlobalState v c) => ArrowStaticGlobalState v (CE.ExceptT e c)
deriving instance (O.Complete e, Arrow c, Profunctor c, ArrowStaticGlobalState v c) => ArrowStaticGlobalState v (AE.ExceptT e c)
instance (Arrow c, Profunctor c, Monad f, ArrowStaticGlobalState v c) => ArrowStaticGlobalState v (KleisliT f c) where
deriving instance (ArrowGlobals v c) => ArrowGlobals v (ValueT val2 c)
deriving instance (Arrow c, Profunctor c, ArrowGlobals v c) => ArrowGlobals v (CE.ExceptT e c)
deriving instance (O.Complete e, Arrow c, Profunctor c, ArrowGlobals v c) => ArrowGlobals v (AE.ExceptT e c)
instance (Arrow c, Profunctor c, Monad f, ArrowGlobals v c) => ArrowGlobals v (KleisliT f c) where
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
readFunction a = lift (readFunction (unlift a))
instance (Arrow c, Profunctor c, ArrowStaticGlobalState v c) => ArrowStaticGlobalState v (StateT s c) where
instance (Arrow c, Profunctor c, ArrowGlobals v c) => ArrowGlobals v (StateT s c) where
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
readFunction a = lift $ transform (unlift a)
where transform f = proc (s, (i,x)) -> readFunction (proc (y,(s2,x)) -> f -< (s2, (y,x))) -< (i,(s,x))
instance (Arrow c, Profunctor c, ArrowStaticGlobalState v c) => ArrowStaticGlobalState v (ReaderT r c) where
instance (Arrow c, Profunctor c, ArrowGlobals v c) => ArrowGlobals v (ReaderT r c) where
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
readFunction a = lift $ transform (unlift a)
where transform f = proc (r, (i,x)) ->
readFunction (proc (y,(r,x)) -> f -< (r, (y,x))) -< (i,(r,x))
instance (Arrow c, Profunctor c, Monoid r, ArrowStaticGlobalState v c) => ArrowStaticGlobalState v (WriterT r c) where
instance (Arrow c, Profunctor c, Monoid r, ArrowGlobals v c) => ArrowGlobals v (WriterT r c) where
readGlobal = lift' readGlobal
writeGlobal = lift' writeGlobal
readFunction a = lift (readFunction (unlift a))
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.JumpTypes where
import Data
import Control.Arrow
import Control.Arrow.Trans
import Control.Arrow.Transformer.Abstract.Except as AE
import Control.Arrow.Transformer.Concrete.Except as CE
import Control.Arrow.Transformer.Kleisli
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Writer
import qualified Data.Order as O
import Data.Profunctor
import Language.Wasm.Structure (ResultType)
class ArrowJumpTypes c where
jumpType :: c JumpIndex ResultType
withJumpType :: c x y -> c (ResultType, x) y
localNoJumpTypes :: c x y -> c x y
deriving instance (ArrowJumpTypes c) => ArrowJumpTypes (ValueT val2 c)
deriving instance (Arrow c, Profunctor c, ArrowJumpTypes c) => ArrowJumpTypes (CE.ExceptT e c)
deriving instance (O.Complete e, Arrow c, Profunctor c, ArrowJumpTypes c) => ArrowJumpTypes (AE.ExceptT e c)
instance (Arrow c, Profunctor c, Monad f, ArrowJumpTypes c) => ArrowJumpTypes (KleisliT f c) where
jumpType = lift' jumpType
withJumpType a = lift (withJumpType (unlift a))
localNoJumpTypes a = lift (localNoJumpTypes (unlift a))
instance (Arrow c, Profunctor c, ArrowJumpTypes c) => ArrowJumpTypes (StateT s c) where
jumpType = lift' jumpType
withJumpType a = lift $ proc (s, (rt,x)) ->
withJumpType (unlift a) -< (rt,(s,x))
localNoJumpTypes a = lift (localNoJumpTypes (unlift a))
instance (Arrow c, Profunctor c, ArrowJumpTypes c) => ArrowJumpTypes (ReaderT r c) where
jumpType = lift' jumpType
withJumpType a = lift $ proc (r, (rt,x)) ->
withJumpType (unlift a) -< (rt,(r,x))
localNoJumpTypes a = lift (localNoJumpTypes (unlift a))
instance (Arrow c, Profunctor c, Monoid r, ArrowJumpTypes c) => ArrowJumpTypes (WriterT r c) where
jumpType = lift' jumpType
withJumpType a = lift (withJumpType (unlift a))
localNoJumpTypes a = lift (localNoJumpTypes (unlift a))
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Logger where
import Prelude hiding (log)
import Control.Arrow
import Control.Arrow.Trans
import qualified Control.Arrow.Transformer.Abstract.Store as AbsStore
import Control.Arrow.Transformer.Abstract.Error
import Control.Arrow.Transformer.Concrete.Except as CE
import Control.Arrow.Transformer.Abstract.Except as AE
import Control.Arrow.Transformer.Concrete.Failure as CF
import Control.Arrow.Transformer.Abstract.Failure as AF
import Control.Arrow.Transformer.Concrete.WasmFrame as CFrame
import Control.Arrow.Transformer.Abstract.WasmFrame as AFrame
import Control.Arrow.Transformer.Kleisli
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.Stack
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Value
import qualified Data.Order as O
import Data.Profunctor
class ArrowLogger v c | c -> v where
log :: c v ()