Commit 40ef4a86 authored by Sven Keidel's avatar Sven Keidel

Implement reaching definition analysis

parent 1eebe563
......@@ -8,6 +8,6 @@ import Prelude hiding (lookup,id)
import Control.Arrow
class Arrow c => ArrowStore var val c | c -> var, c -> val where
read :: c var val
write :: c (var,val) ()
class Arrow c => ArrowStore var val lab c | c -> var, c -> val where
read :: c (var,lab) val
write :: c (var,val,lab) ()
......@@ -104,11 +104,10 @@ memoize (FixArrow f) = FixArrow $ \((inCache, outCache),x) -> do
Success y -> trace (printf "\t%s <- memoize -< %s" (show y) (show x)) (outCache,y)
Fail _ ->
let yOld = fromError bottom (S.lookup x inCache)
outCache' = trace (printf "\tout(%s) := %s" (show x) (show yOld)) (S.insert x yOld outCache)
outCache' = S.insert x yOld outCache
(outCache'',y) = trace (printf "\tf -< %s" (show x)) (f ((inCache, outCache'),x))
outCache''' = S.insertWith (flip ()) x y outCache''
in trace (printf "\t%s <- f -< %s\n" (show y) (show x) ++
printf "\tout(%s) := %s ▽ %s = %s\n" (show x) (show yOld) (show y) (show (S.lookup x outCache''')) ++
printf "\t%s <- memoize -< %s" (show y) (show x))
(outCache''',y)
......
......@@ -5,6 +5,7 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveGeneric #-}
module Control.Arrow.Transformer.Abstract.LiveVariables where
import Prelude hiding (id,(.),read)
......@@ -21,46 +22,58 @@ import Control.Arrow.Writer
import Control.Arrow.Transformer.Writer
import Data.HashSet (HashSet)
import Data.Hashable
import qualified Data.HashSet as H
import Data.Identifiable
import Data.Order
import Data.Abstract.Widening
import GHC.Exts
import GHC.Generics
import Text.Printf
newtype LiveVars v = LiveVars (HashSet v) deriving (Eq,Hashable)
data LiveVars v = LiveVars (HashSet v) | Top deriving (Eq,Generic)
instance Show v => Show (LiveVars v) where
show (LiveVars vs) = show (H.toList vs)
show Top = "⊤"
instance Identifiable v => PreOrd (LiveVars v) where
_ Top = True
LiveVars xs LiveVars ys = all (\x -> H.member x ys) xs
_ _ = False
instance Identifiable v => Complete (LiveVars v) where
Top _ = Top
_ Top = Top
LiveVars xs LiveVars ys = LiveVars (H.union xs ys)
instance Identifiable v => Widening (LiveVars v)
instance Identifiable v => UpperBounded (LiveVars v) where
top = Top
instance Identifiable v => IsList (LiveVars v) where
type Item (LiveVars v) = v
fromList = LiveVars . H.fromList
toList (LiveVars vs) = H.toList vs
toList Top = error "toList ⊤"
instance Identifiable v => Monoid (LiveVars v) where
mempty = LiveVars mempty
mappend Top _ = Top
mappend _ Top = Top
mappend (LiveVars xs) (LiveVars ys) = LiveVars (xs `mappend` ys)
newtype LiveVarsTrans v = LiveVarsTrans (LiveVars v -> LiveVars v,LiveVars v)
newtype LiveVarsTrans v = LiveVarsTrans (LiveVars v -> LiveVars v,LiveVars v -> LiveVars v)
entry :: LiveVarsTrans v -> LiveVars v
entry (LiveVarsTrans (f,x)) = f x
entry :: Identifiable v => LiveVarsTrans v -> LiveVars v
entry (LiveVarsTrans (en,_)) = en mempty
exit :: LiveVarsTrans v -> LiveVars v
exit (LiveVarsTrans (_,x)) = x
exit :: Identifiable v => LiveVarsTrans v -> LiveVars v
exit (LiveVarsTrans (_,ex)) = ex mempty
instance Show v => Show (LiveVarsTrans v) where
instance (Identifiable v, Show v) => Show (LiveVarsTrans v) where
show vs = printf "{entry = %s, exit = %s}" (show (entry vs)) (show (exit vs))
instance Identifiable v => Eq (LiveVarsTrans v) where
......@@ -74,15 +87,22 @@ instance Identifiable v => Complete (LiveVarsTrans v) where
instance Identifiable v => Widening (LiveVarsTrans v)
instance Identifiable v => Monoid (LiveVarsTrans v) where
mempty = LiveVarsTrans (id,mempty)
mappend (LiveVarsTrans (f,x)) (LiveVarsTrans (g,y)) = LiveVarsTrans (f . g,mappend x y)
instance Identifiable v => UpperBounded (LiveVarsTrans v) where
top = LiveVarsTrans (top,top)
instance Monoid (LiveVarsTrans v) where
mempty = LiveVarsTrans (id,id)
mappend (LiveVarsTrans (en1,_)) (LiveVarsTrans (en2,ex2)) = LiveVarsTrans (en2 >>> en1, ex2)
live :: Identifiable v => v -> LiveVarsTrans v
live x = LiveVarsTrans (\(LiveVars vars) -> LiveVars (H.insert x vars),mempty)
live x = let en (LiveVars vars) = LiveVars (H.insert x vars)
en Top = Top
in LiveVarsTrans (en,id)
dead :: Identifiable v => v -> LiveVarsTrans v
dead x = LiveVarsTrans (\(LiveVars vars) -> LiveVars (H.delete x vars),mempty)
dead x = let en (LiveVars vars) = LiveVars (H.delete x vars)
en Top = Top
in LiveVarsTrans (en,id)
newtype LiveVariables v c x y = LiveVariables (Writer (LiveVarsTrans v) c x y)
......@@ -97,26 +117,25 @@ instance (Identifiable var, ArrowStore var val c) => ArrowStore var val (LiveVar
tellA -< dead x
write -< (x,v)
type instance Fix x y (LiveVariables v c) = LiveVariables v (Fix x (LiveVarsTrans v,y) c)
instance (Identifiable v, ArrowFix x (LiveVarsTrans v,y) c) => ArrowFix x y (LiveVariables v c) where
fixA f = LiveVariables (Writer (fixA (runLiveVariables . f . commit . LiveVariables . Writer)))
newBasicBlock :: Arrow c => c x (LiveVarsTrans v,y) -> c x (LiveVarsTrans v,y)
newBasicBlock f = f >>^ first (\(LiveVarsTrans (en,_)) -> LiveVarsTrans (en,en))
commit :: Arrow c => LiveVariables v c x y -> LiveVariables v c x y
commit (LiveVariables (Writer f)) = LiveVariables $ Writer $
f >>^ first (\(LiveVarsTrans (g,x)) -> (LiveVarsTrans (id,g x)))
type instance Fix x y (LiveVariables v c) = LiveVariables v (Fix x (LiveVarsTrans v,y) c)
instance (ArrowFix x (LiveVarsTrans v,y) c) => ArrowFix x y (LiveVariables v c) where
fixA f = LiveVariables (Writer (fixA (runLiveVariables . f . LiveVariables . Writer. newBasicBlock)))
instance Identifiable v => ArrowLift (LiveVariables v) where
instance ArrowLift (LiveVariables v) where
lift f = LiveVariables (lift f)
instance (Identifiable v, ArrowApply c) => ArrowApply (LiveVariables v c) where
instance (ArrowApply c) => ArrowApply (LiveVariables v c) where
app = LiveVariables ((\(LiveVariables f,x) -> (f,x)) ^>> app)
deriving instance (Identifiable v, Arrow c) => Category (LiveVariables v c)
deriving instance (Identifiable v, Arrow c) => Arrow (LiveVariables v c)
deriving instance (Identifiable v, ArrowChoice c) => ArrowChoice (LiveVariables v c)
deriving instance (Identifiable v, ArrowReader r c) => ArrowReader r (LiveVariables v c)
deriving instance (Identifiable v, ArrowFail e c) => ArrowFail e (LiveVariables v c)
deriving instance (Identifiable v, ArrowState s c) => ArrowState s (LiveVariables v c)
deriving instance (Arrow c) => Category (LiveVariables v c)
deriving instance (Arrow c) => Arrow (LiveVariables v c)
deriving instance (ArrowChoice c) => ArrowChoice (LiveVariables v c)
deriving instance (ArrowReader r c) => ArrowReader r (LiveVariables v c)
deriving instance (ArrowFail e c) => ArrowFail e (LiveVariables v c)
deriving instance (ArrowState s c) => ArrowState s (LiveVariables v c)
deriving instance PreOrd (c x (LiveVarsTrans v,y)) => PreOrd (LiveVariables v c x y)
deriving instance LowerBounded (c x (LiveVarsTrans v,y)) => LowerBounded (LiveVariables v c x y)
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Transformer.Abstract.ReachingDefinitions where
import Prelude hiding ((.),read)
import Control.Category
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Lift
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Fail
import Control.Arrow.Store
import Control.Arrow.Transformer.State
import Data.Identifiable
import Data.Order
import Data.Abstract.Widening
import Data.Hashable
import Data.HashSet (HashSet)
import qualified Data.HashSet as H
import GHC.Generics
import GHC.Exts
data ReachingDefs v l = ReachingDefs (HashSet (v,Maybe l)) | Top deriving (Eq,Generic)
empty :: ReachingDefs v l
empty = ReachingDefs H.empty
instance (Show v, Show l) => Show (ReachingDefs v l) where
show (ReachingDefs vs) = show (H.toList vs)
show Top = "⊤"
instance (Identifiable v, Identifiable l) => PreOrd (ReachingDefs v l) where
_ Top = True
ReachingDefs xs ReachingDefs ys = all (\x -> H.member x ys) xs
_ _ = False
instance (Identifiable v, Identifiable l) => Complete (ReachingDefs v l) where
Top _ = Top
_ Top = Top
ReachingDefs xs ReachingDefs ys = ReachingDefs (H.union xs ys)
instance (Identifiable v, Identifiable l) => Widening (ReachingDefs v l)
instance (Identifiable v, Identifiable l) => UpperBounded (ReachingDefs v l) where
top = Top
instance (Hashable v, Hashable l) => Hashable (ReachingDefs v l)
instance (Identifiable v, Identifiable l) => IsList (ReachingDefs v l) where
type Item (ReachingDefs v l) = (v,Maybe l)
fromList = ReachingDefs . H.fromList
toList (ReachingDefs vs) = H.toList vs
toList Top = error "toList ⊤"
newtype ReachingDefinitions v l c x y = ReachingDefinitions (State (ReachingDefs v l) c x y)
runReachingDefinitions :: ReachingDefinitions v l c x y -> c (ReachingDefs v l,x) (ReachingDefs v l,y)
runReachingDefinitions (ReachingDefinitions f) = runState f
instance (Identifiable var, Identifiable lab, ArrowStore var val lab c)
=> ArrowStore var val lab (ReachingDefinitions var lab c) where
read = lift read
write = ReachingDefinitions $ State $ proc (ReachingDefs defs,(x,v,l)) -> do
write -< (x,v,l)
returnA -< (ReachingDefs (H.insert (x,Just l) (H.filter (\(y,_) -> x /= y) defs)),())
type instance Fix x y (ReachingDefinitions v l c) = ReachingDefinitions v l (Fix (ReachingDefs v l,x) (ReachingDefs v l,y) c)
instance (ArrowFix (ReachingDefs v l,x) (ReachingDefs v l,y) c) => ArrowFix x y (ReachingDefinitions v l c) where
fixA f = ReachingDefinitions $ State $ fixA $ \g ->
runReachingDefinitions $ f $ ReachingDefinitions $ State $
(\(defs,x) -> ((defs,x),defs)) ^>> first g >>^ (\((_,y),defs) -> (defs,y))
instance ArrowLift (ReachingDefinitions v l) where
lift f = ReachingDefinitions (lift f)
instance (ArrowApply c) => ArrowApply (ReachingDefinitions v l c) where
app = ReachingDefinitions ((\(ReachingDefinitions f,x) -> (f,x)) ^>> app)
instance (ArrowState s c) => ArrowState s (ReachingDefinitions v l c) where
getA = lift getA
putA = lift putA
deriving instance (Arrow c) => Category (ReachingDefinitions v l c)
deriving instance (Arrow c) => Arrow (ReachingDefinitions v l c)
deriving instance (ArrowChoice c) => ArrowChoice (ReachingDefinitions v l c)
deriving instance (ArrowReader r c) => ArrowReader r (ReachingDefinitions v l c)
deriving instance (ArrowFail e c) => ArrowFail e (ReachingDefinitions v l c)
......@@ -39,12 +39,12 @@ execStore :: Arrow c => StoreArrow var val c x y -> c (Store var val, x) (Store
execStore f = runStore f >>> pi1
instance (Show var, Identifiable var, ArrowFail String c, ArrowChoice c, Complete (c ((Store var val,val),var) (Store var val,val))) =>
ArrowStore var val (StoreArrow var val c) where
ArrowStore var val lab (StoreArrow var val c) where
read =
StoreArrow $ State $ proc (s,var) -> case S.lookup var s of
Success v -> joined returnA (proc var -> failA -< printf "could not find variable" (show var)) -< ((s,v),var)
Fail _ -> failA -< printf "could not find variable" (show var)
write = StoreArrow (State (arr (\(s,(x,v)) -> (S.insert x v s,()))))
StoreArrow $ State $ proc (s,(var,_)) -> case S.lookup var s of
Success v -> joined returnA (proc var -> failA -< printf "Variable %s not bound" (show var)) -< ((s,v),var)
Fail _ -> failA -< printf "Variable %s not bound" (show var)
write = StoreArrow (State (arr (\(s,(x,v,_)) -> (S.insert x v s,()))))
instance ArrowState s c => ArrowState s (StoreArrow var val c) where
getA = lift getA
......
......@@ -83,7 +83,7 @@ instance (ArrowLoop c, ArrowEnv x y env c) => ArrowEnv x y env (State r c) where
extendEnv = lift extendEnv
localEnv (State f) = State ((\(r,(env,a)) -> (env,(r,a))) ^>> localEnv f)
instance (ArrowLoop c, ArrowStore var val c) => ArrowStore var val (State r c) where
instance (ArrowLoop c, ArrowStore var val lab c) => ArrowStore var val lab (State r c) where
read = lift read
write = lift write
......
......@@ -43,12 +43,12 @@ instance ArrowLift (StoreArrow var val) where
lift f = StoreArrow (lift f)
instance (Show var, Identifiable var, ArrowFail String c, ArrowChoice c) =>
ArrowStore var val (StoreArrow var val c) where
ArrowStore var val lab (StoreArrow var val c) where
read =
StoreArrow $ State $ proc (s,var) -> case S.lookup var s of
StoreArrow $ State $ proc (s,(var,_)) -> case S.lookup var s of
Success v -> returnA -< (s,v)
Fail _ -> failA -< printf "could not find variable" (show var)
write = StoreArrow (State (arr (\(s,(x,v)) -> (S.insert x v s,()))))
Fail _ -> failA -< printf "Variable %s not bound" (show var)
write = StoreArrow (State (arr (\(s,(x,v,_)) -> (S.insert x v s,()))))
instance ArrowState s c => ArrowState s (StoreArrow var val c) where
getA = lift getA
......
......@@ -51,7 +51,7 @@ deriving instance ArrowReader r c => ArrowReader r (Const r' c)
deriving instance ArrowWriter w c => ArrowWriter w (Const r c)
deriving instance ArrowFail e c => ArrowFail e (Const r c)
deriving instance ArrowEnv x y env c => ArrowEnv x y env (Const r c)
deriving instance ArrowStore var val c => ArrowStore var val (Const r c)
deriving instance ArrowStore var val lab c => ArrowStore var val lab (Const r c)
deriving instance PreOrd (c x y) => PreOrd (Const r c x y)
deriving instance Complete (c x y) => Complete (Const r c x y)
......
......@@ -78,7 +78,7 @@ instance ArrowEnv x y env c => ArrowEnv x y env (State s c) where
extendEnv = lift extendEnv
localEnv (State f) = State ((\(r,(env,a)) -> (env,(r,a))) ^>> localEnv f)
instance ArrowStore var val c => ArrowStore var val (State s c) where
instance ArrowStore var val lab c => ArrowStore var val lab (State s c) where
read = lift read
write = lift write
......
......@@ -66,7 +66,7 @@ instance (Applicative f, ArrowEnv x y env c) => ArrowEnv x y env (Static f c) wh
extendEnv = lift extendEnv
localEnv (Static f) = Static $ localEnv <$> f
instance (Applicative f, ArrowStore var val c) => ArrowStore var val (Static f c) where
instance (Applicative f, ArrowStore var val lab c) => ArrowStore var val lab (Static f c) where
read = lift read
write = lift write
......
......@@ -31,9 +31,9 @@ instance Monoid w => ArrowLift (Writer w) where
instance (Monoid w, Arrow c) => Category (Writer w c) where
id = Writer (arr mempty &&& id)
Writer f . Writer g = Writer $ proc x -> do
(w1,y) <- g -< x
(w2,z) <- f -< y
Writer g . Writer f = Writer $ proc x -> do
(w1,y) <- f -< x
(w2,z) <- g -< y
returnA -< (w1 <> w2,z)
instance (Monoid w, Arrow c) => Arrow (Writer w c) where
......@@ -72,7 +72,7 @@ instance (Monoid w, ArrowEnv x y env c) => ArrowEnv x y env (Writer w c) where
extendEnv = lift extendEnv
localEnv (Writer f) = Writer (localEnv f)
instance (Monoid w, ArrowStore var val c) => ArrowStore var val (Writer w c) where
instance (Monoid w, ArrowStore var val lab c) => ArrowStore var val lab (Writer w c) where
read = lift read
write = lift write
......
......@@ -56,7 +56,7 @@ instance Ord n => Equality (Interval n) where
instance Ord n => Ordering (Interval n) where
Interval i1 i2 < Interval j1 j2
| i2 P.< j1 = True
| j2 P.< i1 = False
| j2 P.<= i1 = False
| otherwise = Top
instance Hashable n => Hashable (Interval n)
......
......@@ -92,7 +92,8 @@ library
Control.Arrow.Transformer.Abstract.Fix,
Control.Arrow.Transformer.Abstract.Powerset,
Control.Arrow.Transformer.Abstract.Store,
Control.Arrow.Transformer.Abstract.LiveVariables,
-- Control.Arrow.Transformer.Abstract.LiveVariables,
Control.Arrow.Transformer.Abstract.ReachingDefinitions,
-- TODO: delete
Control.Monad.Deduplicate,
......
......@@ -31,9 +31,9 @@ import Data.Ord
import qualified Data.List as L
import Data.Abstract.FreeCompletion
import Data.Abstract.Error hiding (fromError)
import Data.Abstract.Error
import qualified Data.Abstract.Store as S
import Data.Abstract.Terminating hiding (fromTerminating)
import Data.Abstract.Terminating
import Data.Abstract.Widening
import Test.Hspec
......@@ -45,7 +45,7 @@ main = hspec spec
newtype Interp x y = Interp {runInterp :: Fix [(Int,Statement)] () (LiveVariables Text (StoreArrow Text (FreeCompletion Expr) (Except String (~>)))) x y}
data Statement = Text := Expr | IfZero Expr [(Int,Statement)] [(Int,Statement)] | WhileZero Expr [(Int,Statement)] deriving (Show,Eq,Generic)
data Expr = Lit Int | Var Text deriving (Show,Eq,Generic)
data Expr = Lit Int | Var Text | Add Expr Expr deriving (Show,Eq,Generic)
run :: (ArrowFix [(Int,Statement)] () c, ArrowChoice c, ArrowStore Text v c, IsVal v c) => c [(Int,Statement)] ()
run = fixA $ \run' -> proc stmts -> case stmts of
......@@ -64,16 +64,22 @@ run = fixA $ \run' -> proc stmts -> case stmts of
class IsVal v c | c -> v where
lit :: c Int v
add :: c (v,v) v
ifZero :: c [(Int,Statement)] () -> c [(Int,Statement)] () -> c (v,[(Int,Statement)],[(Int,Statement)]) ()
instance IsVal (FreeCompletion Expr) Interp where
lit = arr (Lower . Lit)
ifZero f g = proc (_,x,y) -> joined f g -< (x,y)
add = arr (\(e1,e2) -> Add <$> e1 <*> e2)
ifZero (Interp f) (Interp g) = Interp $ proc (_,x,y) -> joined f g -< (x,y)
eval :: (IsVal v c, ArrowChoice c, ArrowStore Text v c) => c Expr v
eval = proc e -> case e of
Lit n -> lit -< n
Var x -> read -< x
Add e1 e2 -> do
v1 <- eval -< e1
v2 <- eval -< e2
add -< (v1,v2)
spec :: Spec
spec = do
......@@ -97,6 +103,23 @@ spec = do
, (3,([],[]))
]
it "x:=1; z:=2; if(2) {y:=x} {y:=x}; x:=y+z" $ do
runAnalysis [ (0,"x" := Lit 1)
, (1,"z" := Lit 2)
, (2,IfZero (Lit 2)
[(3,"y" := Var "x")]
[(4,"y" := Var "x")])
, (5,"x" := Add (Var "y") (Var "z"))
]
`shouldBe`
[ (0,([],["x"]))
, (1,(["x"],["x","z"]))
, (2,(["x","z"],["x","z"]))
, (3,(["x","z"],["y","z"]))
, (4,(["x","z"],["y","z"]))
, (5,(["y","z"],[]))
]
it "x:=1; while(2){y:=x}; z:=y" $ do
runAnalysis [ (0,"x" := Lit 1)
, (1,WhileZero (Lit 2)
......@@ -116,17 +139,9 @@ runAnalysis ss =
S.map (\((_,l),q) -> case l of
[] -> Nothing;
((i,_):_) ->
let trans = (fst (snd (fromError (fromTerminating q))))
let trans = (fst (snd (fromError (error "error") (fromTerminating (error "non terminating") q))))
in Just (i,(L.entry trans, L.exit trans))) $
fst $ runFix' (runExcept (runStore (runLiveVariables (runInterp (run :: Interp [(Int,Statement)] ()))))) (S.empty,ss)
where
fromTerminating :: Terminating a -> a
fromTerminating (Terminating a) = a
fromTerminating NonTerminating = error "non terminating"
fromError :: Error String a -> a
fromError (Success x) = x
fromError (Fail e) = error e
instance Hashable Statement
instance Hashable Expr
......
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE LiberalTypeSynonyms #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module PropertySemantics.FailedReads where
import Prelude (String, Maybe(..), ($), (.), uncurry, fmap,fst)
import Shared
import Data.Text (Text)
import Data.HashSet (HashSet)
import Control.Arrow
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.State
import Control.Arrow.Store
import Control.Arrow.Try
import Control.Arrow.Utils
import Control.Arrow.Transformer.Property
import System.Random
type Interp c = Property (HashSet Text) c
instance (ArrowChoice c, HasStore v c) => HasStore v (Interp c) where
lookup = property $ tryA (second lookup) returnA _
store = _
-- lookup :: (ArrowChoice c, ArrowFail String c, HasStore c Store, HasProp c CProp) => c (Text,Label) Val
-- lookup = proc (x,_) -> do
-- store <- getStore -< ()
-- case Map.lookup x store of
-- Just v -> returnA -< v
-- Nothing -> do
-- modifyProp (arr $ uncurry Set.insert) -< x
-- failA -< "variable not found"
-- ----------
-- -- Arrows
-- ----------
-- type State = (Store,CProp,StdGen)
-- initState :: State
-- initState = (initStore, initCProp, mkStdGen 0)
-- type In a = (State,a)
-- type Out a = Error String (State,a)
-- type M = StateArrow State (ErrorArrow String (Fix (In [Statement]) (Out ())))
-- runM :: [Statement] -> Error String (State,())
-- runM ss = runFix (runErrorArrow (runStateArrow L.run)) (initState, ss)
-- run :: [Statement] -> Error String (Store,CProp)
-- run = fmap ((\(st,pr,_) -> (st,pr)) . fst) . runM
-- runLifted :: [Statement] -> Error String (LiftedStore,CProp)
-- runLifted = fmap (first liftStore) . run
-- instance L.HasStore M Store where
-- getStore = getA >>> arr (\(st, _, _) -> st)
-- putStore = modifyA $ arr $ \(st,(_,pr,rnd)) -> (st,pr,rnd)
-- instance L.HasProp M CProp where
-- getProp = getA >>> arr (\(_, pr, _) -> pr)
-- putProp = modifyA $ arr $ \(pr,(st,_,rnd)) -> (st,pr,rnd)
-- instance L.HasRandomGen M where
-- nextRandom = proc () -> do
-- (st, pr, gen) <- getA -< ()
-- let (r, gen') = random gen
-- putA -< (st, pr, gen')
-- returnA -< r
-- instance L.Eval M Val where
-- lookup = lookup
-- boolLit = Concrete.boolLit
-- and = Concrete.and
-- or = Concrete.or
-- not = Concrete.not
-- numLit = Concrete.numLit
-- randomNum = Concrete.randomNum
-- add = Concrete.add
-- sub = Concrete.sub
-- mul = Concrete.mul
-- div = Concrete.div
-- eq = Concrete.eq
-- fixEval = Concrete.fixEval
-- instance L.Run M Val where
-- store = Concrete.store
-- if_ = Concrete.if_
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Props.FailedReads.Concrete where
import Prelude (String, Maybe(..), ($), (.), uncurry, fmap,fst)