Commit 70a921aa authored by Katharina Brandl's avatar Katharina Brandl
Browse files

abstract exceptions

parent 9f0a3980
Pipeline #108104 failed with stages
in 42 minutes and 26 seconds
......@@ -5,7 +5,7 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Error(ErrorT,runErrorT) where
module Control.Arrow.Transformer.Abstract.Error(ErrorT(..),runErrorT) where
import Prelude hiding (id,lookup,(.),read,fail)
......
......@@ -6,7 +6,7 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE GADTs #-}
module Control.Arrow.Transformer.Abstract.Except(ExceptT,runExceptT) where
module Control.Arrow.Transformer.Abstract.Except(ExceptT(..),runExceptT) where
import Prelude hiding (id,lookup,(.),read,fail)
......
......@@ -4,7 +4,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
module Control.Arrow.Transformer.Abstract.Failure(FailureT,runFailureT) where
module Control.Arrow.Transformer.Abstract.Failure(FailureT(..),runFailureT) where
import Prelude hiding (id,(.),lookup,read)
......
......@@ -21,6 +21,7 @@ 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
......@@ -41,7 +42,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)
ArrowLowerBounded a, ArrowRun, ArrowJoin, ArrowStack s)
runStoreT :: StoreT store c x y -> c (store, x) (store, y)
runStoreT = coerce
......
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Abstract where
import Concrete (TableInst, GlobInst, FuncInst)
import GenericInterpreter hiding (Top)
import Control.Arrow
import Control.Arrow.Transformer.Value
import Data.Abstract.FreeCompletion hiding (Top)
import qualified Data.Abstract.FreeCompletion as FC
import Data.Hashable
import Data.Order
import Data.Vector (Vector)
import qualified Data.Vector as Vec
import GHC.Generics
import Language.Wasm.Structure hiding (exports, Const)
data IsZero = Zero | NotZero | Top deriving (Eq, Show, Generic)
instance Hashable IsZero
instance PreOrd IsZero where
_ Top = True
_ _ = False
instance Complete IsZero where
x y | x == y = x
| otherwise = Top
instance UpperBounded IsZero where
top = Top
data BaseValue ai32 ai64 af32 af64 = VI32 ai32 | VI64 ai64 | VF32 af32 | VF64 af64 deriving (Show, Eq, Generic)
instance (Hashable ai32, Hashable ai64, Hashable af32, Hashable af64) => Hashable (BaseValue ai32 ai64 af32 af64)
instance (PreOrd ai32, PreOrd ai64, PreOrd af32, PreOrd af64) => PreOrd (BaseValue ai32 ai64 af32 af64) where
(VI32 v1) (VI32 v2) = v1 v2
(VI64 v1) (VI64 v2) = v1 v2
(VF32 v1) (VF32 v2) = v1 v2
(VF64 v1) (VF64 v2) = v1 v2
_ _ = False
instance (Complete ai32, Complete ai64, Complete af32, Complete af64) => Complete (FreeCompletion (BaseValue ai32 ai64 af32 af64)) where
(Lower (VI32 v1)) (Lower (VI32 v2)) = Lower $ VI32 $ v1 v2
(Lower (VI64 v1)) (Lower (VI64 v2)) = Lower $ VI64 $ v1 v2
(Lower (VF32 v1)) (Lower (VF32 v2)) = Lower $ VF32 $ v1 v2
(Lower (VF64 v1)) (Lower (VF64 v2)) = Lower $ VF64 $ v1 v2
_ _ = FC.Top
data GlobalState v = GlobalState {
funcInstances :: Vector FuncInst,
tableInstances :: Vector TableInst,
globalInstances:: Vector (FreeCompletion (GlobInst v))
}
instance (PreOrd v) => PreOrd (GlobalState v) where
s1 s2 = let gs1 = globalInstances s1 in
let gs2 = globalInstances s2 in
Vec.all id $ Vec.zipWith () gs1 gs2
instance (Complete v) => Complete (FreeCompletion (GlobalState v)) where
-- assert f1 = f2 and t1 = t2, TODO: do we need to check this?
(Lower (GlobalState f1 t1 g1)) (Lower (GlobalState f2 t2 g2))
| f1 == f2 && t1 == t2 = Lower $ GlobalState f1 t1 (Vec.zipWith () g1 g2)
| otherwise = FC.Top
_ _ = FC.Top
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
module Concrete where
import Data.Abstract.FreeCompletion
import Data.Order
import Data.Vector (Vector, (!), (//))
import qualified Data.Vector as Vec
import Data.Word
......@@ -43,6 +46,14 @@ newtype TableInst = TableInst Wasm.TableInstance deriving (Show,Eq)
data MemInst = MemInst (Maybe Word32) (Vector Word8) deriving (Show,Eq)
data GlobInst v = GlobInst Mut v deriving (Show, Eq)
instance (PreOrd v) => PreOrd (GlobInst v) where
(GlobInst m1 v1) (GlobInst m2 v2) = m1 == m2 && v1 v2
instance (Complete v) => Complete (FreeCompletion (GlobInst v)) where
(Lower (GlobInst m1 v1)) (Lower (GlobInst m2 v2))
| m1 == m2 = Lower $ GlobInst m1 (v1 v2)
| otherwise = Top
_ _ = Top
deriving instance Show Wasm.TableInstance
deriving instance Eq Wasm.TableInstance
......
......@@ -47,58 +47,12 @@ import Language.Wasm.Validate (ValidModule)
import Numeric.Natural (Natural)
-- memory instance: vec(byte) + optional max size
-- bytes are modeled as Word8
-- addresses are modeled as Word32
--newtype WasmMemoryT c x y = WasmMemoryT (StateT (Vector Word8) c x y)
-- deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift,
-- ArrowFail e, ArrowExcept e, ArrowConst r, ArrowStore var' val', ArrowRun, ArrowFrame fd val,
-- ArrowStack st, ArrowState (Vector Word8), ArrowReader r, ArrowGlobalState v2)
--
--instance ArrowTrans (WasmMemoryT) where
-- -- lift' :: c x y -> GlobalStateT v c x y
-- lift' arr = WasmMemoryT (lift' arr)
--
--
--instance (ArrowChoice c, Profunctor c) => ArrowMemory Word32 (Vector Word8) (WasmMemoryT c) where
-- memread sCont eCont = proc (addr, size, x) -> do
-- vec <- get -< ()
-- let addrI = fromIntegral addr
-- case (addrI+size <= length vec) of
-- True -> do
-- let content = Vec.slice addrI size vec
-- sCont -< (content,x)
-- False -> eCont -< x
-- memstore sCont eCont = proc (addr, content, x) -> do
-- vec <- get -< ()
-- let addrI = fromIntegral addr
-- let size = length content
-- case (addrI+size <= length vec) of
-- True -> do
-- let ind = Vec.enumFromN addrI size
-- put -< (Vec.update_ vec ind content)
-- sCont -< x
-- False -> eCont -< x
--
--instance (Arrow c, Profunctor c) => ArrowMemAddress Value Natural Word32 (WasmMemoryT c) where
-- memaddr = proc (Value (Wasm.VI32 base), off) -> returnA -< (base+ (fromIntegral off))
--
--instance ArrowSerialize Value (Vector Word8) ValueType LoadType StoreType (WasmMemoryT c) where
--
--instance ArrowMemSizable Value (WasmMemoryT c) where
--
--instance ArrowFix (Underlying (WasmMemoryT c) x y) => ArrowFix (WasmMemoryT c x y) where
-- type Fix (WasmMemoryT c x y) = Fix (Underlying (WasmMemoryT c) x y)
--
--
toVal32 :: Word32 -> Value
toVal32 = Value . Wasm.VI32
toVal64 :: Word64 -> Value
toVal64 = Value . Wasm.VI64
instance (ArrowChoice c) => IsVal Value (ValueT Value c) where
i32const = proc w32 -> returnA -< Value $ Wasm.VI32 w32
i64const = proc w64 -> returnA -< Value $ Wasm.VI64 w64
......@@ -134,6 +88,11 @@ instance (ArrowChoice c) => IsVal Value (ValueT Value c) where
(Value (Wasm.VF64 _), F64) -> f -< x
_ -> g -< x
instance (Arrow c) => IsException (Exc Value) Value (ValueT Value c) where
type JoinExc y (ValueT Value c) = ()
exception = arr id
handleException = id
addVal :: Wasm.Value -> Wasm.Value -> Wasm.Value
addVal (Wasm.VI32 v1) (Wasm.VI32 v2) = Wasm.VI32 $ v1 + v2
......@@ -150,7 +109,7 @@ evalNumericInst inst stack =
--type TransStack = FrameT FrameData Value (StackT Value (->))
--
evalVariableInst :: (Instruction Natural) -> [Value] -> FrameData -> Vector Value
evalVariableInst :: (Instruction Natural) -> [Value] -> FrameData -> Vector Value
-> GlobalState Value -> ([Value], (Vector Value, (GlobalState Value, ())))
evalVariableInst inst stack fd locals store =
Trans.run
......
......@@ -10,7 +10,8 @@ module Control.Arrow.GlobalState where
import Control.Arrow
import Control.Arrow.Trans
import Control.Arrow.Transformer.Concrete.Except
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
......@@ -18,6 +19,7 @@ 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)
......@@ -102,7 +104,8 @@ instance (Profunctor c, Arrow c, ArrowGlobalState v m c) => ArrowGlobalState v m
-- y <- func ((proc (f,(s2,x)) -> arr -< (s2, (f,x))) >>^ snd) -< (i,(s,x))
-- returnA -< (s,y)
deriving instance (Arrow c, Profunctor c, ArrowGlobalState v m c) => ArrowGlobalState v m (ExceptT e c)
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
......
......@@ -11,28 +11,36 @@ import Prelude hiding (log)
import Control.Arrow
import Control.Arrow.Trans
import Control.Arrow.Transformer.Concrete.Except
import Control.Arrow.Transformer.Concrete.WasmFrame
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 Control.Arrow.Transformer.Concrete.Failure
import Data.Profunctor
import qualified Data.Order as O
import Data.Profunctor
class ArrowLogger v c | c -> v where
log :: c v ()
deriving instance (ArrowLogger v c) => ArrowLogger v (ValueT val c)
deriving instance (Arrow c, Profunctor c, ArrowLogger v c) => ArrowLogger v (FailureT e c)
deriving instance (Arrow c, Profunctor c, ArrowLogger v c) => ArrowLogger v (CF.FailureT e c)
deriving instance (Arrow c, Profunctor c, ArrowLogger v c) => ArrowLogger v (AF.FailureT e c)
instance (Monad f, Arrow c, Profunctor c, ArrowLogger v c) => ArrowLogger v (KleisliT f c) where
log = lift' log
deriving instance (Arrow c, Profunctor c, ArrowLogger v c) => ArrowLogger v (FrameT fd val c)
deriving instance (Arrow c, Profunctor c, ArrowLogger v c) => ArrowLogger v (CFrame.FrameT fd val c)
deriving instance (Arrow c, Profunctor c, ArrowLogger v c) => ArrowLogger v (AFrame.FrameT fd val c)
instance (Arrow c, Profunctor c, ArrowLogger v c) => ArrowLogger v (ReaderT r c) where
log = lift' log
......@@ -40,5 +48,8 @@ instance (Arrow c, Profunctor c, ArrowLogger v c) => ArrowLogger v (ReaderT r c)
instance (Arrow c, Profunctor c, ArrowLogger v c) => ArrowLogger v (StateT s c) where
log = lift' log
deriving instance (Arrow c, Profunctor c, ArrowLogger v c) => ArrowLogger v (ExceptT e c)
deriving instance (Arrow c, Profunctor c, ArrowLogger v c) => ArrowLogger v (CE.ExceptT e c)
deriving instance (O.Complete e, Arrow c, Profunctor c, ArrowLogger v c) => ArrowLogger v (AE.ExceptT e c)
deriving instance (Arrow c, Profunctor c, ArrowLogger v c) => ArrowLogger v (ErrorT e c)
deriving instance (Arrow c, Profunctor c, ArrowLogger v c) => ArrowLogger v (StackT s c)
deriving instance (Arrow c, Profunctor c, ArrowLogger v c) => ArrowLogger v (AbsStore.StoreT store c)
......@@ -8,7 +8,8 @@ module Control.Arrow.MemAddress where
import Control.Arrow
import Control.Arrow.Trans
import Control.Arrow.Transformer.Concrete.Except
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
......@@ -16,13 +17,15 @@ import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Value
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
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 (ExceptT e 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)
......
......@@ -8,7 +8,8 @@ module Control.Arrow.MemSizable where
import Control.Arrow
import Control.Arrow.Trans
import Control.Arrow.Transformer.Concrete.Except
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
......@@ -16,6 +17,7 @@ import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Writer
import qualified Data.Order as O
import Data.Profunctor
class ArrowMemSizable sz c where
......@@ -23,7 +25,8 @@ class ArrowMemSizable sz c where
memgrow :: c (sz,x) y -> c x y -> c (sz,x) y
deriving instance (ArrowMemSizable sz c) => ArrowMemSizable sz (ValueT val2 c)
deriving instance (Arrow c, Profunctor c, ArrowMemSizable sz c) => ArrowMemSizable sz (ExceptT e c)
deriving instance (Arrow c, Profunctor c, ArrowMemSizable sz c) => ArrowMemSizable sz (CE.ExceptT e c)
deriving instance (O.Complete e, Arrow c, Profunctor c, ArrowMemSizable sz c) => ArrowMemSizable sz (AE.ExceptT e c)
instance (Monad f, Arrow c, Profunctor c, ArrowMemSizable sz c) => ArrowMemSizable sz (KleisliT f c) where
memsize = lift' memsize
-- TODO
......
......@@ -3,6 +3,7 @@
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Memory where
......@@ -10,7 +11,8 @@ module Control.Arrow.Memory where
import Control.Arrow
import Control.Arrow.Trans
import Control.Arrow.Transformer.Concrete.Except
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.Stack
......@@ -20,9 +22,13 @@ import Control.Arrow.Transformer.Writer
import Data.Profunctor
import GHC.Exts (Constraint)
class ArrowMemory m addr bytes c | c -> addr, c -> bytes, c -> m where
memread :: c (bytes, x) y -> c x y -> c (m, (addr, Int, x)) (m,y)
memstore :: c x y -> c x y -> c (m, (addr, bytes, x)) (m,y)
type family Join y c :: Constraint
memread :: Join y c => c (bytes, x) y -> c x y -> c (m, (addr, Int, x)) (m,y)
memstore :: Join y c => c x y -> c x y -> c (m, (addr, bytes, x)) (m,y)
-- getMemory :: c () m
-- putMemory :: c m ()
......@@ -35,8 +41,10 @@ class ArrowMemory m addr bytes c | c -> addr, c -> bytes, c -> m where
-- returnA -< (m,y)
deriving instance (ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (ValueT val2 c)
deriving instance (Arrow c, Profunctor c, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (ExceptT e c)
deriving instance (Arrow c, Profunctor c, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (CE.ExceptT e c)
deriving instance (Arrow c, Profunctor c, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (AE.ExceptT e c)
instance (Arrow c, Profunctor c, Functor f, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (KleisliT f c) where
type Join y (KleisliT f c) = Join (f y) c
-- a1 :: KleisliT e c (bytes,x) y, a2 :: KleisliT e c x y
-- c1 :: c (bytes,x) (e y), c2 :: c x (e y)
-- memread :: c (bytes, x) y -> c x y -> c (m, (addr, Int, x)) (m,y)
......@@ -53,6 +61,7 @@ instance (Arrow c, Profunctor c, Functor f, ArrowMemory m addr bytes c) => Arrow
deriving instance (Arrow c, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (StackT e c)
instance (Arrow c, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (StateT s c) where
type Join y (StateT s c) = Join (s,y) c
-- a1 :: StateT s c (bytes,x) y, a2 :: StateT s c x y
-- c1 :: c (s, (bytes,x)) (s,y), c2 :: c (s,x) (s,y)
-- memread :: c (bytes,x) y -> c x y -> c (m, (addr, Int, x)) (m,y)
......@@ -67,12 +76,13 @@ instance (Arrow c, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (Stat
(unlift a2)
-< (m, (addr,i,(s,x)))
returnA -< (newS, (newM, y))
memstore a1 a2 = lift $ proc (s, (m, (addr,bytes,x))) -> do
(newM, (newS,y)) <- memstore (unlift a1) (unlift a2) -< (m, (addr,bytes,(s,x)))
returnA -< (newS, (newM, y))
instance (Arrow c, ArrowMemory m addr bytes c) => ArrowMemory m addr bytes (ReaderT r c) where
type Join y (ReaderT r c) = Join y c
memread a1 a2 = lift $ proc (r, (m, (addr,i,x))) ->
memread (proc (bytes, (r,x)) -> unlift a1 -< (r, (bytes,x)))
(unlift a2)
......
......@@ -10,7 +10,9 @@ module Control.Arrow.Serialize where
import Control.Arrow
import Control.Arrow.Trans
import Control.Arrow.Transformer.Concrete.Except
import qualified Control.Arrow.Transformer.Abstract.Store as AbsStore
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
......@@ -18,40 +20,41 @@ import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Writer
import qualified Data.Order as O
class ArrowSerialize val dat valTy datDecTy datEncTy c | c -> datDecTy, c -> datEncTy where
decode :: c (val, x) y -> c x y -> c (dat, datDecTy, valTy, x) y
encode :: c (dat, x) y -> c x y -> c (val, valTy, datEncTy, x) y
--decode :: c (val, x) y -> c x y -> c (dat, datDecTy, valTy, x) y
decode :: c (val, x) y -> c (dat, datDecTy, valTy, x) y
--encode :: c (dat, x) y -> c x y -> c (val, valTy, datEncTy, x) y
encode :: c (dat, x) y -> c (val, valTy, datEncTy, x) y
deriving instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (ValueT val2 c)
deriving instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (ExceptT e c)
deriving instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (CE.ExceptT e c)
deriving instance (O.Complete e, ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (AE.ExceptT e c)
instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (KleisliT f c) where
decode a1 a2 = lift $
(decode (unlift a1) (unlift a2))
decode a = lift $ decode (unlift a)
encode a1 a2 = lift $
(encode (unlift a1) (unlift a2))
encode a= lift $ encode (unlift a)
deriving instance (Arrow c, ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (StackT v c)
instance (Arrow c, ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (StateT s c) where
decode a1 a2 = lift $ proc (s, (dat, datdecTy, valTy, x)) ->
decode (proc (val, (s,x)) -> (unlift a1) -< (s, (val,x)))
(unlift a2)
decode a = lift $ proc (s, (dat, datdecTy, valTy, x)) ->
decode (proc (val, (s,x)) -> (unlift a) -< (s, (val,x)))
-< (dat, datdecTy, valTy, (s,x))
encode a1 a2 = lift $ proc (s, (val, valTy, datEncTy, x)) ->
encode (proc (dat, (s,x)) -> (unlift a1) -< (s, (dat,x)))
(unlift a2)
encode a = lift $ proc (s, (val, valTy, datEncTy, x)) ->
encode (proc (dat, (s,x)) -> (unlift a) -< (s, (dat,x)))
-< (val, valTy, datEncTy, (s,x))
instance (Arrow c, ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (ReaderT r c) where
-- c1 :: c (r, (val, x)) y
-- c2 :: c (r, x) y
decode a1 a2 = lift $ proc (r, (dat, datdecTy, valTy, x)) -> do
decode (proc (val, (r,x)) -> (unlift a1) -< (r, (val,x)))
(unlift a2)
decode a = lift $ proc (r, (dat, datdecTy, valTy, x)) -> do
decode (proc (val, (r,x)) -> (unlift a) -< (r, (val,x)))
-< (dat, datdecTy, valTy, (r,x))
encode a1 a2 = lift $ proc (r, (val, valTy, datEncTy, x)) ->
encode (proc (dat, (r,x)) -> (unlift a1) -< (r, (dat,x)))
(unlift a2)
encode a = lift $ proc (r, (val, valTy, datEncTy, x)) ->
encode (proc (dat, (r,x)) -> (unlift a) -< (r, (dat,x)))
-< (val, valTy, datEncTy, (r,x))
instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (WriterT w c) where
-- TODO
deriving instance (Arrow c, ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (AbsStore.StoreT store c)
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Abstract.DebuggableStack where
import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.DebuggableStack
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Logger
import Control.Arrow.MemAddress
import Control.Arrow.Memory
import Control.Arrow.MemSizable
import Control.Arrow.Reader
import Control.Arrow.Order
import Control.Arrow.Stack
import Control.Arrow.State
import Control.Arrow.Trans
import Control.Arrow.Serialize
import Control.Arrow.Transformer.Abstract.Stack
import Control.Arrow.GlobalState
import Control.Arrow.Writer
import Control.Arrow.WasmFrame
import Data.Profunctor
import GHC.Exts
-- | Arrow transformer that adds a stack to a computation.
newtype DebuggableStackT v c x y = DebuggableStackT (StackT v c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowRun,
ArrowConst r, ArrowReader r, ArrowFail e, ArrowExcept e, ArrowStack v,
ArrowGlobalState v1 m, ArrowFrame fd v1, ArrowMemory m addr bytes,
ArrowMemAddress v1 n addr, ArrowSerialize v1 bytes valTy loadTy storeTy,
ArrowMemSizable v1, ArrowWriter w, ArrowLogger l)
---- | 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)
deriving instance (ArrowComplete (AbsList v, y) c) => ArrowComplete y (DebuggableStackT v c)
instance (ArrowChoice c, Profunctor c) => ArrowDebuggableStack v (DebuggableStackT v c) where
getStack = DebuggableStackT $ StackT $ get >>^ toList
--instance (ArrowChoice c, Profunctor c) => ArrowStack v (DebuggableStackT v c) where
-- pop = DebuggableStackT pop
-- push = DebuggableStackT push
-- peek = DebuggableStackT peek
-- --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 (DebuggableStackT v c) x y) => ArrowFix (DebuggableStackT v c x y) where
type Fix (DebuggableStackT v c x y) = Fix (Underlying