Commit a56353a4 authored by Sven Keidel's avatar Sven Keidel

add type class for environments

parent d6d846cf
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Class.Environment where
import Control.Arrow
class Arrow c => ArrowEnv x y env c | c -> x, c -> y, c -> env where
lookup :: c x (Maybe y)
getEnv :: c () env
extendEnv :: c (x,y,env) env
localEnv :: c a b -> c (env,a) b
extendEnv' :: ArrowEnv x y env c => c a b -> c (x,y,a) b
extendEnv' f = proc (x,y,a) -> do
env <- getEnv -< ()
env' <- extendEnv -< (x,y,env)
localEnv f -< (env',a)
module Control.Arrow.Environment(
module Control.Arrow.Class.Environment,
module Control.Arrow.Transformer.Reader,
module Control.Arrow.Transformer.BoundedEnvironment,
) where
import Control.Arrow.Class.Environment
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.BoundedEnvironment
{-# LANGUAGE Arrows #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.BoundedEnvironment(ArrowAlloc(..),BoundedEnv,runBoundedEnv,liftBoundedEnv) where
import Control.Category
import Control.Arrow
import Control.Arrow.Class.Environment
import Control.Arrow.Class.Reader
import Control.Arrow.Class.State
import Control.Arrow.Class.Fail
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as H
import Data.Hashable
import Data.Order
class Arrow c => ArrowAlloc x addr c | c -> x, c -> addr where
alloc :: c x addr
newtype BoundedEnv a addr b c x y = BoundedEnv ( ReaderArrow (HashMap a addr) (StateArrow (HashMap addr b) c) x y )
deriving (Category,Arrow,ArrowChoice)
runBoundedEnv :: Arrow c => BoundedEnv a addr b c x y -> c (HashMap a addr,HashMap addr b,x) (HashMap addr b,y)
runBoundedEnv (BoundedEnv (ReaderArrow (StateArrow f))) = (\(env,store,x) -> (store,(env,x))) ^>> f
liftBoundedEnv :: Arrow c => c x y -> BoundedEnv a addr b c x y
liftBoundedEnv f = BoundedEnv (liftReader (liftState f))
instance (Eq a, Hashable a, Eq addr, Hashable addr, Complete b, Arrow c, ArrowAlloc a addr (BoundedEnv a addr b c)) =>
ArrowEnv a b (HashMap a addr) (BoundedEnv a addr b c) where
lookup = proc x -> do
env <- getEnv -< ()
store <- getStore -< ()
returnA -< do
addr <- H.lookup x env
H.lookup addr store
getEnv = BoundedEnv askA
extendEnv = proc (x,y,env) -> do
addr <- localEnv alloc -< (env,x)
store <- getStore -< ()
putStore -< H.insertWith () addr y store
returnA -< H.insert x addr env
localEnv (BoundedEnv f) = BoundedEnv (localA f)
instance ArrowReader r c => ArrowReader r (BoundedEnv a addr b c) where
askA = liftBoundedEnv askA
localA (BoundedEnv (ReaderArrow (StateArrow f))) = BoundedEnv $ ReaderArrow $ StateArrow $
(\(e,(s,(r,x))) -> (r,(e,(s,x)))) ^>> localA f
instance ArrowState s c => ArrowState s (BoundedEnv a addr b c) where
getA = liftBoundedEnv getA
putA = liftBoundedEnv putA
instance ArrowFail e c => ArrowFail e (BoundedEnv a addr b c) where
failA = liftBoundedEnv failA
getStore :: Arrow c => BoundedEnv a addr b c () (HashMap addr b)
getStore = BoundedEnv getA
{-# INLINE getStore #-}
putStore :: Arrow c => BoundedEnv a addr b c (HashMap addr b) ()
putStore = BoundedEnv putA
{-# INLINE putStore #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.FixpointCache(CacheArrow,runCacheArrow) where
import Prelude hiding (id,(.))
import Control.Arrow hiding (loop)
import Control.Arrow.Class.Fail (ArrowFail(..))
import Control.Arrow.Class.Reader
import Control.Arrow.Class.State
import Control.Arrow.Class.FixpointCache
import Control.Arrow.Utils
import Control.Category
import Data.Hashable (Hashable)
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as H
import Data.Maybe
import Data.Order
newtype CacheArrow i o c x y = CacheArrow (c ((i,o),x) (o,y))
runCacheArrow :: Arrow c => CacheArrow (HashMap a b) (HashMap a b) c x y -> c x y
runCacheArrow (CacheArrow f) = (\x -> ((H.empty,H.empty),x)) ^>> f >>^ snd
liftCache :: Arrow c => c x y -> CacheArrow i o c x y
liftCache f = CacheArrow $ (\((_,o),x) -> (o,x)) ^>> second f
instance Arrow c => Category (CacheArrow i o c) where
id = liftCache id
CacheArrow f . CacheArrow g = CacheArrow $ proc ((i,o),x) -> do
(o',y) <- g -< ((i,o),x)
f -< ((i,o'),y)
instance Arrow c => Arrow (CacheArrow i o c) where
arr f = liftCache (arr f)
first (CacheArrow f) = CacheArrow $ (\((i,o),(x,y)) -> (((i,o),x),y)) ^>> first f >>^ (\((o,x'),y) -> (o,(x',y)))
second (CacheArrow f) = CacheArrow $ (\((i,o),(x,y)) -> (x,((i,o),y))) ^>> second f >>^ (\(x,(o,y')) -> (o,(x,y')))
instance ArrowChoice c => ArrowChoice (CacheArrow i o c) where
left (CacheArrow f) = CacheArrow $ (\((i,o),e) -> injectRight (o,injectLeft ((i,o),e))) ^>> left f >>^ eject
right (CacheArrow f) = CacheArrow $ (\((i,o),e) -> injectRight ((i,o),injectLeft (o,e))) ^>> right f >>^ eject
instance ArrowState s c => ArrowState s (CacheArrow i o c) where
getA = liftCache getA
putA = liftCache putA
instance ArrowReader r c => ArrowReader r (CacheArrow i o c) where
askA = liftCache askA
localA (CacheArrow f) = CacheArrow $ (\((i,o),(r,x)) -> (r, ((i,o),x))) ^>> localA f
instance ArrowFail e c => ArrowFail e (CacheArrow i o c) where
failA = liftCache failA
instance (Eq x, Hashable x, LowerBounded y, Complete y, Arrow c) => ArrowCache x y (CacheArrow (HashMap x y) (HashMap x y) c) where
askCache = CacheArrow $ arr $ \((_,o),x) -> (o,H.lookup x o)
initializeCache = CacheArrow $ arr $ \((i,o),x) -> (H.insert x (fromMaybe bottom (H.lookup x i)) o,())
updateCache = CacheArrow $ arr $ \((_,o),(x,y)) -> (H.insertWith () x y o,())
retireCache (CacheArrow f) = CacheArrow $ (\((_,o),x) -> ((o,H.empty),x)) ^>> f
reachedFixpoint = CacheArrow $ arr $ \((i,o),()) ->
let reached = H.keys i == H.keys o && all (\(k,v_o) -> v_o (i H.! k)) (H.toList o)
in (o,reached)
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Reader where
{-# LANGUAGE Arrows #-}
module Control.Arrow.Transformer.Reader(ReaderArrow(..),liftReader) where
import Prelude hiding (id,(.))
......@@ -10,9 +11,13 @@ import Control.Arrow
import Control.Arrow.Class.Fail
import Control.Arrow.Class.Reader
import Control.Arrow.Class.State
import Control.Arrow.Class.Environment
import Control.Arrow.Utils
import Data.Order
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as H
import Data.Hashable (Hashable)
newtype ReaderArrow r c x y = ReaderArrow { runReaderArrow :: c (r,x) y }
......@@ -37,7 +42,16 @@ instance ArrowApply c => ArrowApply (ReaderArrow r c) where
instance Arrow c => ArrowReader r (ReaderArrow r c) where
askA = ReaderArrow pi1
localA (ReaderArrow f) = ReaderArrow (pi2 >>> f)
localA (ReaderArrow f) = ReaderArrow $ (\(_,(r,x)) -> (r,x)) ^>> f
instance (Eq x, Hashable x, Arrow c) => ArrowEnv x y (HashMap x y) (ReaderArrow (HashMap x y) c) where
lookup = proc x -> do
env <- getEnv -< ()
returnA -< H.lookup x env
getEnv = askA
extendEnv = arr $ \(x,y,env) ->
H.insert x y env
localEnv = localA
instance ArrowState s c => ArrowState s (ReaderArrow r c) where
getA = liftReader getA
......
......@@ -31,6 +31,7 @@ library
Data.Utils
Control.Arrow.Debug,
Control.Arrow.Deduplicate,
Control.Arrow.Environment,
Control.Arrow.Fail,
Control.Arrow.Fix,
Control.Arrow.Join,
......@@ -44,6 +45,8 @@ library
other-modules: Control.Arrow.Class.Reader,
Control.Arrow.Class.State,
Control.Arrow.Class.Fail,
Control.Arrow.Class.Environment,
Control.Arrow.Transformer.BoundedEnvironment,
Control.Arrow.Transformer.Reader,
Control.Arrow.Transformer.State,
Control.Arrow.Transformer.Fail
......
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