Commit 566913c5 authored by Sven Keidel's avatar Sven Keidel

delete ArrowConfig

parent 592c7179
{-# 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
......@@ -14,7 +14,6 @@ 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.Class.Fix
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
......@@ -83,11 +82,6 @@ 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
instance (ArrowApply c, ArrowFix (HashMap a addr,Store addr b,x) (Store addr b,y) c) => ArrowFix x y (BoundedEnv a addr b c) where
fixA f = lift $ proc (a,e,s,x) -> do
fixA (unlift a . f . lift') -<< (e,s,x)
......
......@@ -21,7 +21,6 @@ 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
import Control.Arrow.Class.Fix
newtype Environment a b c x y = Environment (ReaderArrow (HashMap a b) c x y)
......@@ -55,11 +54,6 @@ 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
instance (ArrowFix (HashMap a b,x) y c) => ArrowFix x y (Environment a b c) where
fixA f = Environment (ReaderArrow (fixA (runEnvironment . f . Environment . ReaderArrow)))
......
......@@ -13,7 +13,6 @@ 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.Class.Fix
import Control.Monad (join)
......@@ -85,11 +84,6 @@ 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
instance (ArrowChoice c, ArrowFix x (Error e y) c) => ArrowFix x y (ErrorArrow e c) where
fixA f = ErrorArrow (fixA (runErrorArrow . f . ErrorArrow))
......
......@@ -18,7 +18,6 @@ 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
......@@ -74,12 +73,7 @@ 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 ArrowConfig cIn cOut c => ArrowConfig cIn cOut (CacheArrow cIn cOut c) where
getInConfig = liftCache getInConfig
getOutConfig = liftCache getOutConfig
setOutConfig = liftCache setOutConfig
instance (Show x, Show y, Eq x, Hashable x, LowerBounded y, Complete y, ArrowChoice c) => ArrowFix x y (CacheArrow x y c) where
instance (Eq x, Hashable x, LowerBounded y, Complete y, ArrowChoice c) => ArrowFix x y (CacheArrow x y c) where
fixA f = proc x -> do
(y,fp) <- retireCache (fix (f . memoize) &&& reachedFixpoint) -< x
if fp
......@@ -97,28 +91,6 @@ memoize f = proc x -> do
updateCache -< (x,y)
returnA -< y
-- instance (Eq (x,cIn), Hashable (x,cIn), LowerBounded (y,cOut), Complete (y,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 :: (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
-- cIn <- liftCache getInConfig -< ()
-- m <- askCache -< (x,cIn)
-- case m of
-- Just (y,cOut) -> do
-- liftCache setOutConfig -< cOut
-- returnA -< y
-- Nothing -> do
-- initializeCache -< (x,cIn)
-- y <- f -< x
-- cOut <- liftCache getOutConfig -< ()
-- updateCache -< ((x,cIn),(y,cOut))
-- returnA -< y
askCache :: (Eq x, Hashable x, Arrow c) => CacheArrow x y c x (Maybe y)
askCache = CacheArrow $ arr $ \((_,o),x) -> (o,S.lookup x o)
......@@ -131,7 +103,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,7 +14,6 @@ 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.Class.Fix
import Control.Arrow.Utils
......@@ -58,11 +57,6 @@ 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
instance ArrowFix (r,x) y c => ArrowFix x y (ReaderArrow r c) where
fixA f = ReaderArrow (fixA (runReaderArrow . f . ReaderArrow))
......
......@@ -13,7 +13,6 @@ 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.Class.Fix
import Control.Arrow.Utils
......@@ -58,11 +57,6 @@ 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)
instance ArrowFix (s,x) (s,y) c => ArrowFix x y (StateArrow s c) where
fixA f = StateArrow (fixA (runStateArrow . f . StateArrow))
......
......@@ -49,7 +49,6 @@ 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