Commit 7e2d38cc authored by Sven Keidel's avatar Sven Keidel

add arrow config to fixpoint algorithm

parent fd730a0b
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
module Control.Arrow.Class.Config where
import Control.Arrow
class Arrow c => ArrowConfig cIn cOut c | c -> cIn, c -> cOut where
getInConfig :: c () cIn
getOutConfig :: c () cOut
setOutConfig :: c cOut ()
instance ArrowConfig () () (->) where
getInConfig = id
getOutConfig = id
setOutConfig = id
module Control.Arrow.Fix
( module Control.Arrow.Class.Fix,
module Control.Arrow.Class.Config,
module Control.Arrow.Transformer.FixpointCache
)
where
import Control.Arrow.Class.Fix
import Control.Arrow.Class.Config
import Control.Arrow.Transformer.FixpointCache
......@@ -13,6 +13,7 @@ import Control.Arrow.Class.Environment
import Control.Arrow.Class.Reader
import Control.Arrow.Class.State
import Control.Arrow.Class.Fail
import Control.Arrow.Class.Config
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Arrow.Utils
......@@ -80,6 +81,11 @@ putStore :: Arrow c => BoundedEnv a addr b c (Store addr b) ()
putStore = BoundedEnv putA
{-# INLINE putStore #-}
instance (Eq a, Hashable a, Eq addr, Hashable addr, Complete b, ArrowConfig cIn cOut c, ArrowApply c) => ArrowConfig (HashMap a addr,(Store addr b, cIn)) (Store addr b, cOut) (BoundedEnv a addr b c) where
getInConfig = getEnv &&& getStore &&& liftBoundedEnv getInConfig
getOutConfig = getStore &&& liftBoundedEnv getOutConfig
setOutConfig = voidA $ putStore *** liftBoundedEnv setOutConfig
deriving instance PreOrd (c (Store addr b,((Alloc a addr b c,HashMap a addr),x)) (Store addr b,y)) => PreOrd (BoundedEnv a addr b c x y)
deriving instance Complete (c (Store addr b,((Alloc a addr b c,HashMap a addr),x)) (Store addr b,y)) => Complete (BoundedEnv a addr b c x y)
deriving instance CoComplete (c (Store addr b,((Alloc a addr b c,HashMap a addr),x)) (Store addr b,y)) => CoComplete (BoundedEnv a addr b c x y)
......
......@@ -19,6 +19,7 @@ import Control.Arrow.Class.Reader
import Control.Arrow.Class.State
import Control.Arrow.Class.Fail
import Control.Arrow.Class.Environment
import Control.Arrow.Class.Config
newtype Environment a b c x y = Environment (ReaderArrow (HashMap a b) c x y)
deriving (Category,Arrow,ArrowChoice)
......@@ -51,6 +52,12 @@ instance (Eq a, Hashable a, Arrow c) => ArrowEnv a b (HashMap a b) (Environment
extendEnv = arr $ \(x,y,env) -> H.insert x y env
localEnv (Environment f) = Environment (localA f)
instance (Eq a, Hashable a, ArrowConfig cIn cOut c) => ArrowConfig (HashMap a b,cIn) cOut (Environment a b c) where
getInConfig = getEnv &&& liftEnv getInConfig
getOutConfig = liftEnv getOutConfig
setOutConfig = liftEnv setOutConfig
deriving instance PreOrd (c (HashMap a b,x) y) => PreOrd (Environment a b c x y)
deriving instance Complete (c (HashMap a b,x) y) => Complete (Environment a b c x y)
deriving instance CoComplete (c (HashMap a b,x) y) => CoComplete (Environment a b c x y)
......
......@@ -13,6 +13,7 @@ import Control.Arrow.Class.Fail
import Control.Arrow.Class.Reader
import Control.Arrow.Class.State
import Control.Arrow.Class.Environment
import Control.Arrow.Class.Config
import Control.Monad (join)
import Data.Error
......@@ -83,6 +84,11 @@ instance (ArrowChoice c, ArrowEnv x y env c) => ArrowEnv x y env (ErrorArrow e c
extendEnv = liftError extendEnv
localEnv (ErrorArrow f) = ErrorArrow (localEnv f)
instance (ArrowChoice c, ArrowConfig cIn cOut c) => ArrowConfig cIn cOut (ErrorArrow e c) where
getInConfig = liftError getInConfig
getOutConfig = liftError getOutConfig
setOutConfig = liftError setOutConfig
deriving instance PreOrd (c x (Error e y)) => PreOrd (ErrorArrow e c x y)
deriving instance LowerBounded (c x (Error e y)) => LowerBounded (ErrorArrow e c x y)
deriving instance Complete (c x (Error e y)) => Complete (ErrorArrow e c x y)
......
......@@ -5,6 +5,8 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MonoLocalBinds #-}
module Control.Arrow.Transformer.FixpointCache(CacheArrow,runCacheArrow,liftCache) where
import Prelude hiding (id,(.),lookup)
......@@ -16,6 +18,7 @@ import Control.Arrow.Class.Reader
import Control.Arrow.Class.State
import Control.Arrow.Class.Fix
import Control.Arrow.Class.Environment
import Control.Arrow.Class.Config
import Control.Arrow.Utils
import Control.Category
......@@ -25,9 +28,6 @@ import Data.Order
import Data.Store (Store)
import qualified Data.Store as S
import Debug.Trace
import Text.Printf
newtype CacheArrow a b c x y = CacheArrow (c ((Store a b,Store a b),x) (Store a b,y))
runCacheArrow :: Arrow c => CacheArrow a b c x y -> c x y
......@@ -71,25 +71,32 @@ instance ArrowEnv a b env c => ArrowEnv a b env (CacheArrow x y c) where
extendEnv = liftCache extendEnv
localEnv (CacheArrow f) = CacheArrow $ (\(s,(env,a)) -> (env,(s,a))) ^>> localEnv f
instance (Show a, Show b, Eq a, Hashable a, LowerBounded b, Complete b, ArrowChoice c) => ArrowFix a b (CacheArrow a b c) where
instance ArrowConfig cIn cOut c => ArrowConfig cIn cOut (CacheArrow cIn cOut c) where
instance (Eq x, Eq cIn, Hashable x, Hashable cIn, LowerBounded y, Complete y, LowerBounded cOut, Complete cOut, ArrowConfig cIn cOut c, ArrowChoice c) => ArrowFix x y (CacheArrow (x,cIn) (y,cOut) c) where
fixA f = proc x -> do
(y,fp) <- retireCache (fix (f . memoize) &&& reachedFixpoint) -< x
if fp
then returnA -< y
else fixA f -< x
memoize :: (Show a, Show b, Eq a, Hashable a, LowerBounded b, Complete b, ArrowChoice c) => CacheArrow a b c a b -> CacheArrow a b c a b
memoize :: (Eq (x,cIn), Hashable (x,cIn), LowerBounded (y,cOut), Complete (y,cOut), ArrowConfig cIn cOut c, ArrowChoice c) => CacheArrow (x,cIn) (y,cOut) c x y -> CacheArrow (x,cIn) (y,cOut) c x y
memoize f = proc x -> do
m <- askCache -< x
cIn <- liftCache getInConfig -< ()
m <- askCache -< (x,cIn)
case m of
Just y -> returnA -< y
Just (y,cOut) -> do
liftCache setOutConfig -< cOut
returnA -< y
Nothing -> do
initializeCache -< x
initializeCache -< (x,cIn)
y <- f -< x
updateCache -< (x,y)
cOut <- liftCache getOutConfig -< ()
updateCache -< ((x,cIn),(y,cOut))
returnA -< y
askCache :: (Eq a, Hashable a, Arrow c) => CacheArrow a b c a (Maybe b)
askCache :: (Eq x, Hashable x, Arrow c) => CacheArrow x y c x (Maybe y)
askCache = CacheArrow $ arr $ \((_,o),x) -> (o,S.lookup x o)
retireCache :: (Eq a, Hashable a, LowerBounded b, Arrow c) => CacheArrow a b c x y -> CacheArrow a b c x y
......@@ -101,7 +108,7 @@ initializeCache = CacheArrow $ arr $ \((i,o),x) -> (S.insert x (fromMaybe bottom
updateCache :: (Eq a, Hashable a, Complete b, Arrow c) => CacheArrow a b c (a,b) ()
updateCache = CacheArrow $ arr $ \((_,o),(x,y)) -> (S.insertWith () x y o,())
reachedFixpoint :: (Show a, Show b, Eq a, Hashable a, LowerBounded b, Arrow c) => CacheArrow a b c x Bool
reachedFixpoint :: (Eq a, Hashable a, LowerBounded b, Arrow c) => CacheArrow a b c x Bool
reachedFixpoint = CacheArrow $ arr $ \((i,o),_) -> (o,o i)
deriving instance PreOrd (c ((Store a b,Store a b),x) (Store a b,y)) => PreOrd (CacheArrow a b c x y)
......
......@@ -14,6 +14,7 @@ import Control.Arrow.Class.Fail
import Control.Arrow.Class.Reader
import Control.Arrow.Class.State
import Control.Arrow.Class.Environment
import Control.Arrow.Class.Config
import Control.Arrow.Utils
import Data.Order
......@@ -56,6 +57,11 @@ instance ArrowEnv x y env c => ArrowEnv x y env (ReaderArrow r c) where
extendEnv = liftReader extendEnv
localEnv (ReaderArrow f) = ReaderArrow ((\(r,(env,a)) -> (env,(r,a))) ^>> localEnv f)
instance ArrowConfig cIn cOut c => ArrowConfig (r,cIn) cOut (ReaderArrow r c) where
getInConfig = askA &&& liftReader getInConfig
getOutConfig = liftReader getOutConfig
setOutConfig = liftReader setOutConfig
deriving instance PreOrd (c (r,x) y) => PreOrd (ReaderArrow r c x y)
deriving instance LowerBounded (c (r,x) y) => LowerBounded (ReaderArrow r c x y)
deriving instance Complete (c (r,x) y) => Complete (ReaderArrow r c x y)
......
......@@ -13,6 +13,7 @@ import Control.Arrow.Class.Fail
import Control.Arrow.Class.State
import Control.Arrow.Class.Reader
import Control.Arrow.Class.Environment
import Control.Arrow.Class.Config
import Control.Arrow.Utils
import Data.Order
......@@ -56,6 +57,11 @@ instance ArrowEnv x y env c => ArrowEnv x y env (StateArrow r c) where
extendEnv = liftState extendEnv
localEnv (StateArrow f) = StateArrow ((\(r,(env,a)) -> (env,(r,a))) ^>> localEnv f)
instance ArrowConfig cIn cOut c => ArrowConfig (s,cIn) (s,cOut) (StateArrow s c) where
getInConfig = getA &&& liftState getInConfig
getOutConfig = getA &&& liftState getOutConfig
setOutConfig = voidA (putA *** liftState setOutConfig)
deriving instance PreOrd (c (s,x) (s,y)) => PreOrd (StateArrow s c x y)
deriving instance LowerBounded (c (s,x) (s,y)) => LowerBounded (StateArrow s c x y)
deriving instance Complete (c (s,x) (s,y)) => Complete (StateArrow s c x y)
......
......@@ -91,6 +91,9 @@ instance Complete () where
instance (PreOrd a,PreOrd b) => PreOrd (a,b) where
(a1,b1) (a2,b2) = a1 a2 && b1 b2
instance (LowerBounded a,LowerBounded b) => LowerBounded (a,b) where
bottom = (bottom,bottom)
instance (Complete a, Complete b) => Complete (a,b) where
(a1,b1) (a2,b2) = (a1 a2, b1 b2)
......
......@@ -49,6 +49,7 @@ library
Control.Arrow.Class.Fail,
Control.Arrow.Class.Fix,
Control.Arrow.Class.Environment,
Control.Arrow.Class.Config,
Control.Arrow.Transformer.BoundedEnvironment,
Control.Arrow.Transformer.Environment,
Control.Arrow.Transformer.Reader,
......
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