expand fixpoint caching algorithm

parent f7ab4379
......@@ -5,13 +5,14 @@
{-# LANGUAGE StandaloneDeriving #-}
module Control.Arrow.Transformer.Fail(ErrorArrow(..),liftError) where
import Prelude hiding (id)
import Prelude hiding (id,lookup)
import Control.Category
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.Monad (join)
import Data.Error
......@@ -76,6 +77,12 @@ instance (ArrowChoice c, ArrowReader r c) => ArrowReader r (ErrorArrow e c) wher
askA = liftError askA
localA (ErrorArrow f) = ErrorArrow (localA f)
instance (ArrowChoice c, ArrowEnv x y env c) => ArrowEnv x y env (ErrorArrow e c) where
lookup = liftError lookup
getEnv = liftError getEnv
extendEnv = liftError extendEnv
localEnv (ErrorArrow f) = ErrorArrow (localEnv f)
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)
......
......@@ -3,11 +3,14 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.FixpointCache(CacheArrow,runCacheArrow) where
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFunctor #-}
module Control.Arrow.Transformer.FixpointCache(CacheArrow,runCacheArrow,liftCache,Cache,empty,insert,lookup,insertWith,(!),keys,toList) where
import Prelude hiding (id,(.))
import Prelude hiding (id,lookup)
import Control.Arrow hiding (loop)
import Control.Arrow
import Control.Arrow.Class.Fail (ArrowFail(..))
import Control.Arrow.Class.Reader
import Control.Arrow.Class.State
......@@ -18,16 +21,12 @@ import Control.Category
import Data.Hashable (Hashable)
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as H
import Data.HashSet (HashSet)
import qualified Data.HashSet as S
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
newtype CacheArrow a b c x y = CacheArrow (c ((Cache a b,Cache a b),x) (Cache a b,y))
instance Arrow c => Category (CacheArrow i o c) where
id = liftCache id
......@@ -55,11 +54,59 @@ instance ArrowReader r c => ArrowReader r (CacheArrow i o c) where
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)
instance (Eq x, Hashable x, LowerBounded y, Complete y, Arrow c) => ArrowCache x y (CacheArrow x y c) where
askCache = CacheArrow $ arr $ \((_,o),x) -> (o,lookup x o)
-- transfer cached value from old fixpoint iteration into the new cache
initializeCache = CacheArrow $ arr $ \((Cache i,Cache o),x) -> (Cache $ H.insert x (fromMaybe bottom (H.lookup x i)) o,())
updateCache = CacheArrow $ arr $ \((_,o),(x,y)) -> (insertWith () x y o,())
retireCache (CacheArrow f) = CacheArrow $ (\((_,o),x) -> ((o,bottom),x)) ^>> f
-- we reached or overshot the fixpoint if we landed in the reductive set, i.e. if f x ⊑ x
reachedFixpoint = CacheArrow $ arr $ \((i,o),()) -> (o,o i)
newtype Cache a b = Cache (HashMap a b) deriving (Functor,Foldable,Traversable)
instance (Eq a, Hashable a, PreOrd b) => PreOrd (Cache a b) where
Cache m1 Cache m2 = subsetKeys m1 m2 && all (\(k,v1) -> v1 (m2 H.! k)) (H.toList m1)
Cache m1 Cache m2 = H.keys m1 == H.keys m2 && all (\(k,v_o) -> v_o (m2 H.! k)) (H.toList m1)
instance (Eq a, Hashable a, Complete b) => Complete (Cache a b) where
Cache m1 Cache m2 = Cache (H.unionWith () m1 m2)
instance (Eq a, Hashable a, CoComplete b) => CoComplete (Cache a b) where
Cache m1 Cache m2 = Cache (H.intersectionWith () m1 m2)
instance (Eq a, Hashable a, PreOrd b) => LowerBounded (Cache a b) where
bottom = empty
subsetKeys :: (Eq a, Hashable a) => HashMap a b -> HashMap a b -> Bool
subsetKeys m1 m2 = subset (S.fromMap (H.map (const ()) m1)) (S.fromMap (H.map (const ()) m2))
subset :: (Eq a, Hashable a) => HashSet a -> HashSet a -> Bool
subset s1 s2 = S.size (S.intersection s1 s2) == S.size s1
empty :: Cache a b
empty = Cache H.empty
runCacheArrow :: Arrow c => CacheArrow a b c x y -> Cache a b -> c x y
runCacheArrow (CacheArrow f) i = (\x -> ((i,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
lookup :: (Eq a, Hashable a) => a -> Cache a b -> Maybe b
lookup a (Cache m) = H.lookup a m
insert :: (Eq a, Hashable a) => a -> b -> Cache a b -> Cache a b
insert a b (Cache m) = Cache (H.insert a b m)
insertWith :: (Eq a, Hashable a) => (b -> b -> b) -> a -> b -> Cache a b -> Cache a b
insertWith f a b (Cache m) = Cache (H.insertWith f a b m)
(!) :: (Eq a, Hashable a) => Cache a b -> a -> b
Cache m ! a = m H.! a
keys :: Cache a b -> [a]
keys (Cache m) = H.keys m
toList :: Cache a b -> [(a,b)]
toList (Cache m) = H.toList m
......@@ -6,7 +6,7 @@
{-# LANGUAGE StandaloneDeriving #-}
module Control.Arrow.Transformer.Reader(ReaderArrow(..),liftReader) where
import Prelude hiding (id,(.))
import Prelude hiding (id,(.),lookup)
import Control.Category
import Control.Arrow
......@@ -50,6 +50,12 @@ instance ArrowState s c => ArrowState s (ReaderArrow r c) where
instance ArrowFail e c => ArrowFail e (ReaderArrow r c) where
failA = liftReader failA
instance ArrowEnv x y env c => ArrowEnv x y env (ReaderArrow r c) where
lookup = liftReader lookup
getEnv = liftReader getEnv
extendEnv = liftReader extendEnv
localEnv (ReaderArrow f) = ReaderArrow ((\(r,(env,a)) -> (env,(r,a))) ^>> localEnv f)
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)
......
......@@ -5,13 +5,14 @@
{-# LANGUAGE StandaloneDeriving #-}
module Control.Arrow.Transformer.State(StateArrow(..),liftState) where
import Prelude hiding (id,(.))
import Prelude hiding (id,(.),lookup)
import Control.Category
import Control.Arrow
import Control.Arrow.Class.Fail
import Control.Arrow.Class.State
import Control.Arrow.Class.Reader
import Control.Arrow.Class.Environment
import Control.Arrow.Utils
import Data.Order
......@@ -49,6 +50,12 @@ instance ArrowReader r c => ArrowReader r (StateArrow s c) where
askA = liftState askA
localA (StateArrow f) = StateArrow $ (\(s,(r,x)) -> (r,(s,x))) ^>> localA f
instance ArrowEnv x y env c => ArrowEnv x y env (StateArrow r c) where
lookup = liftState lookup
getEnv = liftState getEnv
extendEnv = liftState extendEnv
localEnv (StateArrow f) = StateArrow ((\(r,(env,a)) -> (env,(r,a))) ^>> localEnv f)
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)
......
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