Commit 56eae7b3 authored by Katharina Ritter's avatar Katharina Ritter
Browse files

using ArrowState and StateT

parent 8abdff3c
Pipeline #139292 failed with stages
in 37 minutes and 12 seconds
......@@ -45,8 +45,9 @@ import Text.Printf
import Data.String
import Data.Functor.Identity
import Control.Monad.State
--import Control.Arrow.Transformer.State
--import Control.Monad.Trans.State
import Control.Arrow.State
import Control.Arrow.Transformer.State
......@@ -57,27 +58,29 @@ type Addr = Int
type Env = HashMap Text Addr
type Store = HashMap Addr Val
type Exception = (Text,Val)
newtype AllocT c x y = AllocT ((StateT Int (State Int)) c) --TODO: working on this atm
--type AllocT c x y = StateT Int (State Int) Int
--newtype AllocT c x y = AllocT (StateT Int)
--type AllocT c x y = c x y -> (StateT Int (State Int))
-- | The concrete interpreter of the while language instantiates
-- 'Generic.run' with the concrete components for failure ('FailureT'), store ('StoreT'),
-- environments ('EnvT'), random numbers ('RandomT'), and values ('ConcreteT').
run :: [LStatement] -> Error String (Error Exception (HashMap Addr Val))
run :: [LStatement] -> Error String (Error Exception (HashMap Addr Val)) --TODO: working on this atm
run ss =
let ?fixpointAlgorithm = Function.fix in
fmap fst <$>
Trans.run
(Generic.run ::
ValueT Val
(RandomT
(EnvT Env
(StoreT Store
(ExceptT Exception
(FailureT String
(->)))))) [Statement] ())
(StateT Addr
(EnvT Env
(StoreT Store
(ExceptT Exception
(FailureT String
(->))))))) [Statement] ())
(M.empty,(M.empty,(R.mkStdGen 0, generate <$> ss)))
run1 :: [(Text,Addr)] -> [LStatement] -> Error String (Error Exception (HashMap Addr Val))
{-run1 :: [(Text,Addr)] -> [LStatement] -> Error String (Error Exception (HashMap Addr Val))
run1 env0 ss =
let ?fixpointAlgorithm = Function.fix in
fmap fst <$>
......@@ -90,23 +93,23 @@ run1 env0 ss =
(ExceptT Exception
(FailureT String
(->)))))) [Statement] ())
(M.empty,(M.fromList env0 ,(R.mkStdGen 0, generate <$> ss)))
(M.empty,(M.fromList env0 ,(R.mkStdGen 0, generate <$> ss)))-}
--TODO: working on this atm
instance (ArrowChoice c, Profunctor c, ArrowFail String c, Fail.Join Addr c) => ArrowAlloc Addr Val (AllocT Addr Val c) where
--instance (ArrowChoice c, Profunctor c, ArrowFail String c, Fail.Join Addr c) => ArrowAlloc Addr Val (ValueT Val c) where
--instance (ArrowChoice c, Profunctor c, ArrowFail String c, Fail.Join Addr c) => ArrowAlloc Addr Val (ValueT (AllocT c) c) where
instance (ArrowChoice c, Profunctor c, ArrowFail String c, ArrowState Addr c, Fail.Join Addr c) => ArrowAlloc Addr Val (ValueT Val c) where
--this is the code that should work with StateT included
{- allocVar = proc _ -> do
allocVar = proc _ -> do
addr <- get -< ()
put -< addr + 1
returnA -< addr
allocValue = proc _ -> do
addr <- get -< ()
put -< addr + 1
returnA -< addr-}
allocVar = arr $ \(_,_,l) -> labelVal l
allocValue = arr $ \(_,l) -> labelVal l
returnA -< addr
{- allocVar = arr $ \(_,_,l) -> labelVal l
allocValue = arr $ \(_,l) -> labelVal l-}
addr2Val = proc addr -> returnA -< (Pointer addr)
val2Addr = proc v1 -> case v1 of
Pointer addr1 -> returnA -< addr1
......
......@@ -26,6 +26,8 @@ import Data.String
import Syntax
import GHC.Exts
import Control.Arrow.State
type Prog = [Statement]
......@@ -35,11 +37,11 @@ type Prog = [Statement]
-- values @v@, addresses @addr@, environment @env@ and arrow type
-- @c@. It uses the @IsVal@ interface to combine values and uses the
-- @ArrowEnv@ and @ArrowStore@ interface to access the environment.
eval :: (Show addr, Show v, ArrowChoice c, ArrowRand v c,
eval :: (Show addr, Show v, ArrowChoice c,
ArrowEnv Text addr c, ArrowStore addr v c,
ArrowAlloc addr v c,
ArrowExcept exc c, ArrowFail e c,
IsVal v c, IsException exc v c, IsString e,
IsVal v c, IsString e,
Env.Join v c, Env.Join addr c, Store.Join v c, Fail.Join v c, Fail.Join addr c
)
=> c Expr v
......@@ -94,11 +96,11 @@ run :: (Show addr, Show v,
?fixpointAlgorithm :: FixpointAlgorithm (Fix (c [Statement] ())),
ArrowChoice c, ArrowFix (c [Statement] ()),
ArrowEnv Text addr c, ArrowStore addr v c,
ArrowFail err c,
ArrowFail err c, ArrowState Int c,
ArrowAlloc addr v c,
ArrowExcept exc c, ArrowRand v c,
IsString err, IsVal v c, IsException exc v c, IsAddr addr v c,
Env.Join v c, Env.Join addr c, Store.Join v c, Except.Join () c,
IsString err, IsVal v c, IsAddr addr v c,
Env.Join v c, Env.Join addr c, Store.Join v c,
Fail.Join v c, JoinVal () c, JoinExc () c, Fail.Join addr c
)
=> c [Statement] ()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment