Commit db745b94 authored by Sven Keidel's avatar Sven Keidel

compute types of fixpoints automatically with type families

parent 3ba9f240
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
module Control.Arrow.Fix(ArrowFix(..),ArrowFix'(..)) where
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Fix(ArrowFix(..),Fix,ArrowFix'(..)) where
import Control.Arrow
type family Fix x y (c :: * -> * -> *) :: * -> * -> *
class Arrow c => ArrowFix x y c where
fixA :: (c x y -> c x y) -> c x y
instance ArrowFix x y (->) where
fixA f = f (fixA f)
class Arrow c => ArrowFix' c y | c -> y where
fixA' :: ((z -> c x y) -> (z -> c x y)) -> (z -> c x y)
......@@ -6,7 +6,7 @@
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Abstract.BoundedEnvironment(Environment,runEnvironment,ArrowAlloc(..)) where
import Control.Arrow
......@@ -67,6 +67,7 @@ instance ArrowReader r c => ArrowReader r (Environment var addr val c) where
instance ArrowApply c => ArrowApply (Environment var addr val c) where
app = Environment $ (\(Environment f,x) -> (f,x)) ^>> app
type instance Fix x y (Environment var addr val c) = Environment var addr val (Fix ((Env var addr,Store addr val),x) y c)
deriving instance ArrowFix ((Env var addr,Store addr val),x) y c => ArrowFix x y (Environment var addr val c)
deriving instance Arrow c => Category (Environment var addr val c)
deriving instance Arrow c => Arrow (Environment var addr val c)
......
......@@ -5,6 +5,7 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Abstract.Contour(Contour,empty,push,toList,size,maxSize,ContourArrow,runContourArrow) where
import Prelude hiding (id,(.),lookup)
......@@ -62,6 +63,7 @@ newtype ContourArrow c a b = ContourArrow (Reader Contour c a b)
runContourArrow :: Arrow c => Int -> ContourArrow c a b -> c a b
runContourArrow n (ContourArrow (Reader f)) = (\a -> (empty n,a)) ^>> f
type instance Fix x y (ContourArrow c) = ContourArrow (Fix x y c)
instance (ArrowFix x y c, ArrowApply c, HasLabel x) => ArrowFix x y (ContourArrow c) where
-- Pushes the label of the last argument on the contour.
fixA f = ContourArrow $ Reader $ proc (c,x) -> fixA (unlift c . f . lift) -<< x
......@@ -88,6 +90,7 @@ deriving instance ArrowChoice c => ArrowChoice (ContourArrow c)
deriving instance ArrowState s c => ArrowState s (ContourArrow c)
deriving instance ArrowFail e c => ArrowFail e (ContourArrow c)
deriving instance ArrowEnv x y env c => ArrowEnv x y env (ContourArrow c)
deriving instance PreOrd (c (Contour,x) y) => PreOrd (ContourArrow c x y)
deriving instance LowerBounded (c (Contour,x) y) => LowerBounded (ContourArrow c x y)
deriving instance Complete (c (Contour,x) y) => Complete (ContourArrow c x y)
......
......@@ -5,6 +5,7 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Abstract.Environment where
import Prelude hiding ((.))
......@@ -49,13 +50,14 @@ instance ArrowReader r c => ArrowReader r (Environment var val c) where
askA = lift askA
localA (Environment (Reader f)) = Environment (Reader ((\(env,(r,x)) -> (r,(env,x))) ^>> localA f))
type instance Fix x y (Environment var val c) = Environment var val (Fix (Env var val,x) y c)
deriving instance ArrowFix (Env var val,x) y c => ArrowFix x y (Environment var val c)
deriving instance Arrow c => Category (Environment var val c)
deriving instance Arrow c => Arrow (Environment var val c)
deriving instance ArrowLift (Environment var val)
deriving instance ArrowChoice c => ArrowChoice (Environment var val c)
deriving instance ArrowState s c => ArrowState s (Environment var val c)
deriving instance ArrowFail e c => ArrowFail e (Environment var val c)
deriving instance ArrowFix (Env var val,x) y c => ArrowFix x y (Environment var val c)
deriving instance PreOrd (c (Env var val,x) y) => PreOrd (Environment var val c x y)
deriving instance Complete (c (Env var val,x) y) => Complete (Environment var val c x y)
deriving instance CoComplete (c (Env var val,x) y) => CoComplete (Environment var val c x y)
......
......@@ -4,6 +4,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Abstract.Except(Except(..)) where
import Prelude hiding (id,(.),lookup)
......@@ -47,6 +48,13 @@ instance ArrowChoice c => ArrowChoice (Except r c) where
instance (ArrowChoice c, ArrowApply c) => ArrowApply (Except e c) where
app = Except $ first runExcept ^>> app
instance (ArrowChoice c, ArrowLoop c) => ArrowLoop (Except e c) where
loop (Except f) = Except $ loop $ proc (b,d) -> do
e <- f -< (b,d)
case e of
Fail e' -> returnA -< (Fail e',d)
Success (c,d') -> returnA -< (Success c,d')
instance (ArrowChoice c, ArrowState s c) => ArrowState s (Except e c) where
getA = lift getA
putA = lift putA
......@@ -64,6 +72,7 @@ instance (ArrowChoice c, ArrowEnv x y env c) => ArrowEnv x y env (Except e c) wh
extendEnv = lift extendEnv
localEnv (Except f) = Except (localEnv f)
type instance Fix x y (Except e c) = Except e (Fix x (Error e y) c)
instance (ArrowChoice c, ArrowFix x (Error e y) c) => ArrowFix x y (Except e c) where
fixA f = Except (fixA (runExcept . f . Except))
......
{-# LANGUAGE Arrows #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}
module Control.Arrow.Transformer.Abstract.Fix(Fix,runFix,runFix',liftFix) where
{-# OPTIONS_GHC -DTRACE #-}
module Control.Arrow.Transformer.Abstract.Fix(type (~>),runFix,runFix',liftFix) where
import Prelude hiding (id,(.),lookup)
import Data.Function (fix)
......@@ -34,46 +39,56 @@ import Text.Printf
-- The main idea of this fixpoint caching algorithm is due to David Darais et. al., Abstract Definitional Interpreters (Functional Pearl), ICFP' 17
-- We made some changes to the algorithm to simplify it.
newtype Fix a b x y = Fix (((Store a (Terminating b), Store a (Terminating b)),x) -> (Store a (Terminating b), Terminating y))
runFix :: Fix a b x y -> (x -> Terminating y)
data (~>) x y
type instance Fix a b (~>) = FixArrow a b
newtype FixArrow a b x y = FixArrow (((Store a (Terminating b), Store a (Terminating b)),x) -> (Store a (Terminating b), Terminating y))
runFix :: Fix a b (~>) x y -> (x -> Terminating y)
runFix f = runFix' f >>^ snd
runFix' :: Fix a b x y -> (x -> (Store a (Terminating b), Terminating y))
runFix' (Fix f) = (\x -> ((S.empty,S.empty),x)) ^>> f
runFix' :: Fix a b (~>) x y -> (x -> (Store a (Terminating b), Terminating y))
runFix' (FixArrow f) = (\x -> ((S.empty,S.empty),x)) ^>> f
liftFix :: (x -> y) -> Fix a b x y
liftFix f = Fix ((\((_,o),x) -> (o,x)) ^>> second (f ^>> Terminating))
liftFix :: (x -> y) -> FixArrow a b x y
liftFix f = FixArrow ((\((_,o),x) -> (o,x)) ^>> second (f ^>> Terminating))
instance Category (Fix i o) where
instance Category (FixArrow i o) where
id = liftFix id
Fix f . Fix g = Fix $ proc ((i,o),x) -> do
FixArrow f . FixArrow g = FixArrow $ proc ((i,o),x) -> do
(o',y) <- g -< ((i,o),x)
case y of
NonTerminating -> returnA -< (o,NonTerminating)
Terminating y' -> f -< ((i,o'),y')
instance Arrow (Fix i o) where
instance Arrow (FixArrow i o) where
arr f = liftFix (arr f)
first (Fix f) = Fix $ to assoc ^>> first f >>^ (\((o,x'),y) -> (o,strength1 (x',y)))
first (FixArrow f) = FixArrow $ to assoc ^>> first f >>^ (\((o,x'),y) -> (o,strength1 (x',y)))
instance ArrowChoice (Fix i o) where
left (Fix f) = Fix $ \((i,o),e) -> case e of
instance ArrowChoice (FixArrow i o) where
left (FixArrow f) = FixArrow $ \((i,o),e) -> case e of
Left x -> second (fmap Left) (f ((i,o),x))
Right y -> (o,return (Right y))
right (Fix f) = Fix $ \((i,o),e) -> case e of
right (FixArrow f) = FixArrow $ \((i,o),e) -> case e of
Left x -> (o,return (Left x))
Right y -> second (fmap Right) (f ((i,o),y))
Fix f ||| Fix g = Fix $ \((i,o),e) -> case e of
FixArrow f ||| FixArrow g = FixArrow $ \((i,o),e) -> case e of
Left x -> f ((i,o),x)
Right y -> g ((i,o),y)
instance ArrowApply (Fix i o) where
app = Fix $ (\(io,(Fix f,x)) -> (f,(io,x))) ^>> app
instance ArrowLoop (FixArrow i o) where
loop (FixArrow f) = FixArrow $ loop $ \(((i,o),b),d) ->
case f ((i,o),(b,d)) of
(o',Terminating (c,d')) -> ((o',Terminating c),d')
(o',NonTerminating) -> ((o',NonTerminating),d)
instance ArrowApply (FixArrow i o) where
app = FixArrow $ (\(io,(FixArrow f,x)) -> (f,(io,x))) ^>> app
#ifdef TRACE
instance (Show x, Show y, Identifiable x, LowerBounded y, Widening y)
=> ArrowFix x y (Fix x y) where
instance (Show x, Show y, Identifiable x, Widening y)
=> ArrowFix x y (FixArrow x y) where
fixA f = trace (printf "fixA f") $ proc x -> do
old <- getOutCache -< ()
setOutCache -< bottom
......@@ -83,25 +98,22 @@ instance (Show x, Show y, Identifiable x, LowerBounded y, Widening y)
then returnA -< y
else fixA f -< x
memoize :: (Show x, Show y, Identifiable x, LowerBounded y, Widening y) => Fix x y x y -> Fix x y x y
memoize f = proc x -> do
m <- lookupOutCache -< trace (printf "\tmemoize -< %s" (show x)) x
case m of
Success y -> do
returnA -< trace (printf "\t%s <- memoize -< %s" (show y) (show x)) y
Fail _ -> do
yOld <- lookupInCache -< x
writeOutCache -< trace (printf "\tout(%s) := %s" (show x) (show (fromError bottom yOld))) (x, fromError bottom yOld)
y <- f -< trace (printf "\tf -< %s" (show x)) x
yCached <- lookupOutCache -< x
updateOutCache -< (x, y)
yNew <- lookupOutCache -< x
returnA -< trace (printf "\t%s <- f -< %s\n" (show y) (show x) ++
printf "\tout(%s) := %s ▽ %s = %s\n" (show x) (show yCached) (show y) (show yNew) ++
printf "\t%s <- memoize -< %s" (show y) (show x)) y
memoize :: (Show x, Show y, Identifiable x, Widening y) => FixArrow x y x y -> FixArrow x y x y
memoize (FixArrow f) = FixArrow $ \((inCache, outCache),x) -> do
case trace (printf "\tmemoize -< %s" (show x)) (S.lookup x outCache) of
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'',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)
#else
instance (Identifiable x, Widening y)
=> ArrowFix x y (Fix x y) where
instance (Identifiable x, Widening y) => ArrowFix x y (FixArrow x y) where
fixA f = proc x -> do
old <- getOutCache -< ()
setOutCache -< bottom
......@@ -111,49 +123,28 @@ instance (Identifiable x, Widening y)
then returnA -< y
else fixA f -< x
memoize :: (Identifiable x, Widening y) => Fix x y x y -> Fix x y x y
memoize f = proc x -> do
m <- lookupOutCache -< x
case m of
Success y -> do
returnA -< y
Fail _ -> do
yOld <- lookupInCache -< x
writeOutCache -< (x, yOld)
y <- catch f -< x
updateOutCache -< (x, y)
throw -< y
where
catch :: Fix x y a b -> Fix x y a (Terminating b)
catch (Fix g) = Fix (g >>^ second Terminating)
throw :: Fix x y (Terminating a) a
throw = Fix (arr (\((_,o),x) -> (o,x)))
memoize :: (Identifiable x, Widening y) => FixArrow x y x y -> FixArrow x y x y
memoize (FixArrow f) = FixArrow $ \((inCache, outCache),x) -> do
case S.lookup x outCache of
Success y -> (outCache,y)
Fail _ ->
let yOld = fromError bottom (S.lookup x inCache)
outCache' = S.insert x yOld outCache
(outCache'',y) = f ((inCache, outCache'),x)
in (S.insertWith (flip ()) x y outCache'',y)
#endif
lookupOutCache :: Identifiable x => Fix x y x (Error () y)
lookupOutCache = Fix $ \((_,o),x) -> (o,strength2 $ S.lookup x o)
lookupInCache :: (Identifiable x, PreOrd y) => Fix x y x (Terminating y)
lookupInCache = Fix $ \((i,o),x) -> (o, return $ fromError bottom $ S.lookup x i)
writeOutCache :: Identifiable x => Fix x y (x,Terminating y) ()
writeOutCache = Fix $ \((_,o),(x,y)) -> (S.insert x y o,return ())
getOutCache :: Fix x y () (Store x (Terminating y))
getOutCache = Fix $ (\((_,o),()) -> (o,return o))
setOutCache :: Fix x y (Store x (Terminating y)) ()
setOutCache = Fix $ (\((_,_),o) -> (o,return ()))
getOutCache :: FixArrow x y () (Store x (Terminating y))
getOutCache = FixArrow $ (\((_,o),()) -> (o,return o))
localInCache :: Fix x y x y -> Fix x y (Store x (Terminating y),x) y
localInCache (Fix f) = Fix (\((_,o),(i,x)) -> f ((i,o),x))
setOutCache :: FixArrow x y (Store x (Terminating y)) ()
setOutCache = FixArrow $ (\((_,_),o) -> (o,return ()))
updateOutCache :: (Identifiable x, Widening y) => Fix x y (x,Terminating y) ()
updateOutCache = Fix $ \((_,o),(x,y)) -> (S.insertWith (flip ()) x y o,return ())
localInCache :: FixArrow x y x y -> FixArrow x y (Store x (Terminating y),x) y
localInCache (FixArrow f) = FixArrow (\((_,o),(i,x)) -> f ((i,o),x))
deriving instance (Identifiable a, PreOrd b, PreOrd y) => PreOrd (Fix a b x y)
deriving instance (Identifiable a, Complete b, Complete y) => Complete (Fix a b x y)
deriving instance (Identifiable a, CoComplete b, CoComplete y) => CoComplete (Fix a b x y)
deriving instance (Identifiable a, PreOrd b, PreOrd y) => LowerBounded (Fix a b x y)
deriving instance (Identifiable a, PreOrd b, PreOrd y) => PreOrd (FixArrow a b x y)
deriving instance (Identifiable a, Complete b, Complete y) => Complete (FixArrow a b x y)
deriving instance (Identifiable a, CoComplete b, CoComplete y) => CoComplete (FixArrow a b x y)
deriving instance (Identifiable a, PreOrd b, PreOrd y) => LowerBounded (FixArrow a b x y)
-- deriving instance (Identifiable a, UpperBounded b, UpperBounded y) => UpperBounded (Fix a b x y)
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Abstract.LiveVariables where
import Prelude hiding (id,(.),read)
import Control.Category
import Control.Arrow
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Lift
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Store
import Control.Arrow.Transformer.BackwardState
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
newtype LiveVars v = LiveVars (HashSet v) deriving (Eq,Hashable)
instance Show v => Show (LiveVars v) where
show (LiveVars vs) = show (H.toList vs)
instance Identifiable v => PreOrd (LiveVars v) where
LiveVars xs LiveVars ys = all (\x -> H.member x ys) xs
instance Identifiable v => Complete (LiveVars v) where
LiveVars xs LiveVars ys = LiveVars (H.union xs ys)
instance Identifiable v => Widening (LiveVars v)
instance Identifiable v => IsList (LiveVars v) where
type Item (LiveVars v) = v
fromList = LiveVars . H.fromList
toList (LiveVars vs) = H.toList vs
empty :: LiveVars v
empty = LiveVars H.empty
live :: Identifiable v => v -> LiveVars v -> LiveVars v
live x (LiveVars vars) = LiveVars (H.insert x vars)
dead :: Identifiable v => v -> LiveVars v -> LiveVars v
dead x (LiveVars vars) = LiveVars (H.delete x vars)
newtype LiveVariables v c x y = LiveVariables (State (LiveVars v) c x y)
runLiveVariables :: LiveVariables v c x y -> c (LiveVars v,x) (LiveVars v,y)
runLiveVariables (LiveVariables (State f)) = f
instance (Identifiable var, ArrowLoop c, ArrowStore var val c) => ArrowStore var val (LiveVariables var c) where
read = LiveVariables $ State $ proc (vars,x) -> do
v <- read -< x
returnA -< (live x vars,v)
write = LiveVariables $ State $ proc (vars,(x,v)) -> do
() <- write -< (x,v)
returnA -< (dead x vars,())
instance ArrowLift (LiveVariables r) where
lift f = LiveVariables (lift f)
instance (ArrowLoop c, ArrowApply c) => ArrowApply (LiveVariables v c) where
app = LiveVariables (State (arr (\(p,(LiveVariables (State f),b)) -> (f,(p,b))) >>> app))
instance (ArrowLoop c, ArrowState s c) => ArrowState s (LiveVariables v c) where
getA = lift getA
putA = lift putA
type instance Fix x y (LiveVariables v c) = LiveVariables v (Fix (LiveVars v,x) (LiveVars v,y) c)
instance (ArrowLoop c, ArrowFix (LiveVars v,x) (LiveVars v,y) c) => ArrowFix x y (LiveVariables v c) where
fixA f = LiveVariables (State (fixA (runLiveVariables . f . LiveVariables . State)))
deriving instance ArrowLoop c => Category (LiveVariables v c)
deriving instance ArrowLoop c => Arrow (LiveVariables v c)
deriving instance (ArrowLoop c, ArrowChoice c) => ArrowChoice (LiveVariables v c)
deriving instance (ArrowLoop c, ArrowReader r c) => ArrowReader r (LiveVariables v c)
deriving instance (ArrowLoop c, ArrowFail e c) => ArrowFail e (LiveVariables v c)
......@@ -5,6 +5,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Abstract.Store where
import Control.Arrow
......@@ -55,6 +56,9 @@ deriving instance ArrowChoice c => ArrowChoice (StoreArrow var val c)
deriving instance ArrowLift (StoreArrow var val)
deriving instance ArrowReader r c => ArrowReader r (StoreArrow var val c)
deriving instance ArrowFail e c => ArrowFail e (StoreArrow var val c)
deriving instance ArrowLoop c => ArrowLoop (StoreArrow var val c)
instance ArrowApply c => ArrowApply (StoreArrow var val c) where app = StoreArrow $ (\(StoreArrow f,x) -> (f,x)) ^>> app
type instance Fix x y (StoreArrow var val c) = StoreArrow var val (Fix (Store var val,x) (Store var val,y) c)
deriving instance ArrowFix (Store var val, x) (Store var val, y) c => ArrowFix x y (StoreArrow var val c)
deriving instance PreOrd (c (Store var val,x) (Store var val,y)) => PreOrd (StoreArrow var val c x y)
deriving instance Complete (c (Store var val,x) (Store var val,y)) => Complete (StoreArrow var val c x y)
......
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.BackwardState where
import Prelude hiding (id,(.),lookup,read)
import Control.Arrow
import Control.Arrow.Deduplicate
import Control.Arrow.Environment
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Lift
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Store
import Control.Arrow.Try
import Control.Arrow.Utils
import Control.Category
import Data.Hashable
import Data.Order
import Data.Monoidal
newtype State s c x y = State { runState :: c (s,x) (s,y) }
evalBackwardState :: Arrow c => State s c x y -> c (s,x) y
evalBackwardState f = runState f >>> pi2
execBackwardState :: Arrow c => State s c x y -> c (s,x) s
execBackwardState f = runState f >>> pi1
instance ArrowLoop c => Category (State s c) where
id = State id
State f . State g = State $ proc (s1,x) -> do
rec (s3,y) <- g -< (s2,x)
(s2,z) <- f -< (s1,y)
returnA -< (s3,z)
instance ArrowLift (State r) where
lift f = State (second f)
instance ArrowLoop c => Arrow (State s c) where
arr f = lift (arr f)
first (State f) = State $ (\(s,(b,c)) -> ((s,b),c)) ^>> first f >>^ (\((s,d),c) -> (s,(d,c)))
second (State f) = State $ (\(s,(a,b)) -> (a,(s,b))) ^>> second f >>^ (\(a,(s,c)) -> (s,(a,c)))
State f &&& State g = State $ proc (s1,x) -> do
rec (s3,y) <- f -< (s2,x)
(s2,z) <- g -< (s1,x)
returnA -< (s3,(y,z))
State f *** State g = State $ proc (s1,(x,y)) -> do
rec (s3,x') <- f -< (s2,x)
(s2,y') <- g -< (s1,y)
returnA -< (s3,(x',y'))
instance (ArrowLoop c, ArrowChoice c) => ArrowChoice (State s c) where
left (State f) = State (to distribute ^>> left f >>^ from distribute)
right (State f) = State (to distribute ^>> right f >>^ from distribute)
State f +++ State g = State $ to distribute ^>> f +++ g >>^ from distribute
State f ||| State g = State $ to distribute ^>> f ||| g
instance (ArrowLoop c, ArrowApply c) => ArrowApply (State s c) where
app = State $ (\(s,(State f,b)) -> (f,(s,b))) ^>> app
instance (ArrowLoop c) => ArrowState s (State s c) where
getA = State $ arr (\(s,_) -> (s,s))
putA = State $ arr (\(_,s) -> (s,()))
instance (ArrowLoop c, ArrowFail e c) => ArrowFail e (State s c) where
failA = lift failA
instance (ArrowLoop c, ArrowReader r c) => ArrowReader r (State s c) where
askA = lift askA
localA (State f) = State $ (\(s,(r,x)) -> (r,(s,x))) ^>> localA f
instance (ArrowLoop c, ArrowEnv x y env c) => ArrowEnv x y env (State r c) where
lookup = lift lookup
getEnv = lift getEnv
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
read = lift read
write = lift write
type instance Fix x y (State s c) = State s (Fix (s,x) (s,y) c)
instance (ArrowLoop c, ArrowFix (s,x) (s,y) c) => ArrowFix x y (State s c) where
fixA f = State (fixA (runState . f . State))
instance (ArrowLoop c, ArrowTry (s,x) (s,y) (s,z) c) => ArrowTry x y z (State s c) where
tryA (State f) (State g) (State h) = State $ tryA f g h
instance (ArrowLoop c, ArrowZero c) => ArrowZero (State s c) where
zeroArrow = lift zeroArrow
instance (ArrowLoop c, ArrowPlus c) => ArrowPlus (State s c) where
State f <+> State g = State (f <+> g)
instance (Eq s, Hashable s, ArrowLoop c, ArrowDeduplicate c) => ArrowDeduplicate (State s c) where
dedupA (State f) = State (dedupA f)
deriving instance PreOrd (c (s,x) (s,y)) => PreOrd (State s c x y)
deriving instance LowerBounded (c (s,x) (s,y)) => LowerBounded (State s c x y)
deriving instance Complete (c (s,x) (s,y)) => Complete (State s c x y)
deriving instance CoComplete (c (s,x) (s,y)) => CoComplete (State s c x y)
deriving instance UpperBounded (c (s,x) (s,y)) => UpperBounded (State s c x y)