Commit a08271b7 authored by Sven Keidel's avatar Sven Keidel

rename arrow transformer types

parent 96442b2c
module Control.Arrow.Lift where
import Control.Arrow
class ArrowLift c where
lift :: Arrow d => d x y -> c d x y
......@@ -7,18 +7,19 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ConstraintKinds #-}
module Control.Arrow.Transformer.Abstract.BoundedEnvironment(Environment,runEnvironment,liftEnvironment,ArrowAlloc(..)) where
module Control.Arrow.Transformer.Abstract.BoundedEnvironment(Environment,runEnvironment,ArrowAlloc(..)) where
import Prelude hiding ((.),id)
import Control.Category
import Control.Arrow
import Control.Arrow.Abstract.Alloc
import Control.Arrow.Environment
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Lift
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Transformer.Reader
import Control.Category
import Prelude hiding ((.),id)
import Data.Order
import Data.Identifiable
......@@ -33,49 +34,41 @@ import Text.Printf
-- The galois connection for environment store pairs ensures that if
-- an variable is bound to an address in the environment, then the
-- address has an binding in the store.
newtype Environment var addr val c x y = Environment ( ReaderArrow (Env var addr,Store addr val) c x y )
newtype Environment var addr val c x y = Environment ( Reader (Env var addr,Store addr val) c x y )
runEnvironment :: (Show var, Identifiable var, Identifiable addr, Complete val, ArrowChoice c, ArrowFail String c, ArrowAlloc var addr val c,LowerBounded (c () val))
=> Environment var addr val c x y -> c ([(var,val)],x) y
runEnvironment f =
let Environment (ReaderArrow f') = proc (bs,x) -> do
let Environment (Reader f') = proc (bs,x) -> do
env <- getEnv -< ()
env' <- bindings -< (bs,env)
localEnv f -< (env',x)
in (const (E.empty,S.empty) &&& id) ^>> f'
liftEnvironment :: Arrow c => c x y -> Environment var addr val c x y
liftEnvironment f = Environment (liftReader f)
instance ArrowLift (Environment var addr val) where
lift f = Environment (lift f)
instance (Show var, Identifiable var, Identifiable addr, Complete val, ArrowChoice c, ArrowFail String c, ArrowAlloc var addr val c, LowerBounded (c () val)) =>
ArrowEnv var val (Env var addr,Store addr val) (Environment var addr val c) where
lookup = Environment $ ReaderArrow $ proc ((env,store),x) -> do
lookup = Environment $ Reader $ proc ((env,store),x) -> do
case do {addr <- E.lookup x env; S.lookup addr store} of
Success v -> returnA -< v
Fail _ -> failA -< printf "variable %s not found" (show x)
Bot -> bottom -< ()
getEnv = Environment askA
extendEnv = proc (x,y,(env,store)) -> do
addr <- liftEnvironment alloc -< (x,env,store)
addr <- lift alloc -< (x,env,store)
returnA -< (E.insert x addr env,S.insertWith () addr y store)
localEnv (Environment (ReaderArrow f)) = Environment (ReaderArrow ((\(_,(e,a)) -> (e,a)) ^>> f))
localEnv (Environment (Reader f)) = Environment (Reader ((\(_,(e,a)) -> (e,a)) ^>> f))
instance ArrowReader r c => ArrowReader r (Environment var addr val c) where
askA = liftEnvironment askA
localA (Environment (ReaderArrow f)) = Environment $ ReaderArrow $ (\(env,(r,x)) -> (r,(env,x))) ^>> localA f
askA = lift askA
localA (Environment (Reader f)) = Environment $ Reader $ (\(env,(r,x)) -> (r,(env,x))) ^>> localA f
instance ArrowApply c => ArrowApply (Environment var addr val c) where
app = Environment $ (\(Environment f,x) -> (f,x)) ^>> app
instance ArrowFix (Env var addr,Store addr val,x) y c => ArrowFix x y (Environment var addr val c) where
fixA f = Environment $ ReaderArrow $ proc ((e,s),x) -> fixA (unlift . f . lift) -< (e,s,x)
where
lift :: Arrow c => c (Env var addr,Store addr val,x) y -> Environment var addr val c x y
lift g = Environment (ReaderArrow ((\((e,s),x) -> (e,s,x)) ^>> g))
unlift :: Arrow c => Environment var addr val c x y -> c (Env var addr,Store addr val,x) y
unlift (Environment (ReaderArrow g)) = (\(e,s,x) -> ((e,s),x)) ^>> g
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)
deriving instance ArrowChoice c => ArrowChoice (Environment var addr val c)
......
......@@ -5,17 +5,18 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Contour(Contour,empty,push,toList,size,maxSize,ContourArrow,runContourArrow,liftContour) where
module Control.Arrow.Transformer.Abstract.Contour(Contour,empty,push,toList,size,maxSize,ContourArrow,runContourArrow) where
import Prelude hiding (id,(.),lookup)
import Control.Arrow
import Control.Arrow.Abstract.Alloc
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Fail
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.Transformer.Reader
import Control.Category
......@@ -56,47 +57,37 @@ resize cont@(Contour {..})
toList :: Contour -> [Label]
toList = F.toList . contour
newtype ContourArrow c a b = ContourArrow (ReaderArrow Contour c a b)
liftContour :: Arrow c => c a b -> ContourArrow c a b
liftContour f = ContourArrow (liftReader f)
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 (ReaderArrow f)) = (\a -> (empty n,a)) ^>> f
deriving instance Arrow c => Category (ContourArrow c)
deriving instance Arrow c => Arrow (ContourArrow c)
deriving instance ArrowChoice c => ArrowChoice (ContourArrow c)
deriving instance ArrowState s c => ArrowState s (ContourArrow c)
instance ArrowApply c => ArrowApply (ContourArrow c) where
app = ContourArrow $ (\(ContourArrow f,x) -> (f,x)) ^>> app
instance ArrowReader r c => ArrowReader r (ContourArrow c) where
askA = liftContour askA
localA (ContourArrow (ReaderArrow f)) = ContourArrow (ReaderArrow ((\(c,(r,x)) -> (r,(c,x))) ^>> localA f))
deriving instance ArrowFail e c => ArrowFail e (ContourArrow c)
instance ArrowEnv x y env c => ArrowEnv x y env (ContourArrow c) where
lookup = liftContour lookup
getEnv = liftContour getEnv
extendEnv = liftContour extendEnv
localEnv (ContourArrow (ReaderArrow f)) = ContourArrow (ReaderArrow ((\(c,(r,x)) -> (r,(c,x))) ^>> localEnv f))
runContourArrow n (ContourArrow (Reader f)) = (\a -> (empty n,a)) ^>> f
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 $ ReaderArrow $ proc (c,x) -> fixA (unlift c . f . lift) -<< x
fixA f = ContourArrow $ Reader $ proc (c,x) -> fixA (unlift c . f . lift) -<< x
where
lift :: Arrow c => c x y -> ContourArrow c x y
lift = liftContour
unlift :: (HasLabel x, ArrowApply c) => Contour -> ContourArrow c x y -> c x y
unlift c (ContourArrow (ReaderArrow f')) = proc x -> do
unlift c (ContourArrow (Reader f')) = proc x -> do
y <- f' -< (push (label x) c, x)
returnA -< y
instance Arrow c => ArrowAlloc var (var,Contour) val (ContourArrow c) where
alloc = ContourArrow $ ReaderArrow $ proc (l,(x,_,_)) -> returnA -< (x,l)
alloc = ContourArrow $ Reader $ proc (l,(x,_,_)) -> returnA -< (x,l)
instance ArrowApply c => ArrowApply (ContourArrow c) where
app = ContourArrow $ (\(ContourArrow f,x) -> (f,x)) ^>> app
instance ArrowReader r c => ArrowReader r (ContourArrow c) where
askA = lift askA
localA (ContourArrow (Reader f)) = ContourArrow (Reader ((\(c,(r,x)) -> (r,(c,x))) ^>> localA f))
deriving instance Arrow c => Category (ContourArrow c)
deriving instance Arrow c => Arrow (ContourArrow c)
deriving instance ArrowLift ContourArrow
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)
......
......@@ -22,21 +22,19 @@ import Control.Arrow.Transformer.Reader
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Fail
import Control.Arrow.Lift
import Control.Arrow.Environment
import Control.Arrow.Fix
import Text.Printf
newtype Environment var val c x y = Environment (ReaderArrow (Env var val) c x y)
newtype Environment var val c x y = Environment (Reader (Env var val) c x y)
runEnvironment :: (Arrow c, Eq var, Hashable var) => Environment var val c x y -> c ([(var,val)],x) y
runEnvironment (Environment (ReaderArrow f)) = first E.fromList ^>> f
liftEnv :: Arrow c => c x y -> Environment var val c x y
liftEnv f = Environment (liftReader f)
runEnvironment (Environment (Reader f)) = first E.fromList ^>> f
instance (Show var, Identifiable var, ArrowChoice c, ArrowFail String c, LowerBounded (c () val)) => ArrowEnv var val (Env var val) (Environment var val c) where
lookup = Environment $ ReaderArrow $ proc (env,x) -> do
lookup = Environment $ Reader $ proc (env,x) -> do
case E.lookup x env of
Success y -> returnA -< y
Fail _ -> failA -< printf "variable %s not found" (show x)
......@@ -49,11 +47,12 @@ instance ArrowApply c => ArrowApply (Environment var val c) where
app = Environment $ (\(Environment f,x) -> (f,x)) ^>> app
instance ArrowReader r c => ArrowReader r (Environment var val c) where
askA = liftEnv askA
localA (Environment (ReaderArrow f)) = Environment (ReaderArrow ((\(env,(r,x)) -> (r,(env,x))) ^>> localA f))
askA = lift askA
localA (Environment (Reader f)) = Environment (Reader ((\(env,(r,x)) -> (r,(env,x))) ^>> localA f))
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)
......
......@@ -4,7 +4,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Transformer.Abstract.Error(ErrorArrow(..),liftError) where
module Control.Arrow.Transformer.Abstract.Except(Except(..)) where
import Prelude hiding (id,(.),lookup)
......@@ -12,6 +12,7 @@ import Control.Category
import Control.Arrow
import Control.Arrow.Environment
import Control.Arrow.Fail
import Control.Arrow.Lift
import Control.Arrow.Fix
import Control.Arrow.Reader
import Control.Arrow.State
......@@ -19,25 +20,24 @@ import Control.Arrow.State
import Data.Abstract.Error
import Data.Order
newtype ErrorArrow e c x y = ErrorArrow { runErrorArrow :: c x (Error e y) }
newtype Except e c x y = Except { runExcept :: c x (Error e y) }
liftError :: Arrow c => c x y -> ErrorArrow e c x y
liftError f = ErrorArrow (f >>> arr Success)
{-# INLINE liftError #-}
instance ArrowLift (Except e) where
lift f = Except (f >>> arr Success)
instance ArrowChoice c => Category (ErrorArrow r c) where
id = liftError id
ErrorArrow f . ErrorArrow g = ErrorArrow $ proc x -> do
instance ArrowChoice c => Category (Except r c) where
id = lift id
Except f . Except g = Except $ proc x -> do
ey <- g -< x
case ey of
Bot -> returnA -< Bot
Fail e -> returnA -< Fail e
Success y -> f -< y
instance ArrowChoice c => Arrow (ErrorArrow r c) where
arr f = liftError (arr f)
first (ErrorArrow f) = ErrorArrow $ first f >>^ injectRight
second (ErrorArrow f) = ErrorArrow $ second f >>^ injectLeft
instance ArrowChoice c => Arrow (Except r c) where
arr f = lift (arr f)
first (Except f) = Except $ first f >>^ injectRight
second (Except f) = Except $ second f >>^ injectLeft
injectRight :: (Error e a,x) -> Error e (a,x)
injectRight (er,x) = case er of
......@@ -53,9 +53,9 @@ injectLeft (x,er) = case er of
Success a -> Success (x,a)
{-# INLINE injectLeft #-}
instance ArrowChoice c => ArrowChoice (ErrorArrow r c) where
left (ErrorArrow f) = ErrorArrow $ left f >>^ commuteLeft
right (ErrorArrow f) = ErrorArrow $ right f >>^ commuteRight
instance ArrowChoice c => ArrowChoice (Except r c) where
left (Except f) = Except $ left f >>^ commuteLeft
right (Except f) = Except $ right f >>^ commuteRight
commuteLeft :: Either (Error e x) y -> Error e (Either x y)
commuteLeft e0 = case e0 of
......@@ -73,31 +73,31 @@ commuteRight e0 = case e0 of
Right (Success x) -> Success (Right x)
{-# INLINE commuteRight #-}
instance (ArrowChoice c, ArrowApply c) => ArrowApply (ErrorArrow e c) where
app = ErrorArrow $ first runErrorArrow ^>> app
instance (ArrowChoice c, ArrowApply c) => ArrowApply (Except e c) where
app = Except $ first runExcept ^>> app
instance (ArrowChoice c, ArrowState s c) => ArrowState s (ErrorArrow e c) where
getA = liftError getA
putA = liftError putA
instance (ArrowChoice c, ArrowState s c) => ArrowState s (Except e c) where
getA = lift getA
putA = lift putA
instance ArrowChoice c => ArrowFail e (ErrorArrow e c) where
failA = ErrorArrow (arr Fail)
instance ArrowChoice c => ArrowFail e (Except e c) where
failA = Except (arr Fail)
instance (ArrowChoice c, ArrowReader r c) => ArrowReader r (ErrorArrow e c) where
askA = liftError askA
localA (ErrorArrow f) = ErrorArrow (localA f)
instance (ArrowChoice c, ArrowReader r c) => ArrowReader r (Except e c) where
askA = lift askA
localA (Except f) = Except (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)
instance (ArrowChoice c, ArrowEnv x y env c) => ArrowEnv x y env (Except e c) where
lookup = lift lookup
getEnv = lift getEnv
extendEnv = lift extendEnv
localEnv (Except f) = Except (localEnv f)
instance (ArrowChoice c, ArrowFix x (Error e y) c) => ArrowFix x y (ErrorArrow e c) where
fixA f = ErrorArrow (fixA (runErrorArrow . f . ErrorArrow))
instance (ArrowChoice c, ArrowFix x (Error e y) c) => ArrowFix x y (Except e c) where
fixA f = Except (fixA (runExcept . f . Except))
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)
deriving instance CoComplete (c x (Error e y)) => CoComplete (ErrorArrow e c x y)
deriving instance UpperBounded (c x (Error e y)) => UpperBounded (ErrorArrow e c x y)
deriving instance PreOrd (c x (Error e y)) => PreOrd (Except e c x y)
deriving instance LowerBounded (c x (Error e y)) => LowerBounded (Except e c x y)
deriving instance Complete (c x (Error e y)) => Complete (Except e c x y)
deriving instance CoComplete (c x (Error e y)) => CoComplete (Except e c x y)
deriving instance UpperBounded (c x (Error e y)) => UpperBounded (Except e c x y)
......@@ -8,7 +8,7 @@
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE CPP #-}
module Control.Arrow.Transformer.Abstract.Fix(CacheArrow,runCacheArrow,runCacheArrow',liftCache) where
module Control.Arrow.Transformer.Abstract.Fix(Fix,runFix,runFix',liftFix) where
import Prelude hiding (id,(.),lookup)
import Data.Function (fix)
......@@ -18,7 +18,6 @@ import Control.Arrow.Fix
import Control.Arrow.Utils
import Control.Category
import Data.Hashable (Hashable)
import Data.Order
import Data.Identifiable
......@@ -34,34 +33,34 @@ 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 CacheArrow a b x y = CacheArrow (((Store a b,Store a b),x) -> (Store a b,y))
newtype Fix a b x y = Fix (((Store a b,Store a b),x) -> (Store a b,y))
runCacheArrow :: CacheArrow a b x y -> (x -> y)
runCacheArrow f = runCacheArrow' f >>^ snd
runFix :: Fix a b x y -> (x -> y)
runFix f = runFix' f >>^ snd
runCacheArrow' :: CacheArrow a b x y -> (x -> (Store a b,y))
runCacheArrow' (CacheArrow f) = (\x -> ((S.empty,S.empty),x)) ^>> f
runFix' :: Fix a b x y -> (x -> (Store a b,y))
runFix' (Fix f) = (\x -> ((S.empty,S.empty),x)) ^>> f
liftCache :: (x -> y) -> CacheArrow a b x y
liftCache f = CacheArrow ((\((_,o),x) -> (o,x)) ^>> second f)
liftFix :: (x -> y) -> Fix a b x y
liftFix f = Fix ((\((_,o),x) -> (o,x)) ^>> second f)
instance Category (CacheArrow i o) where
id = liftCache id
CacheArrow f . CacheArrow g = CacheArrow $ proc ((i,o),x) -> do
instance Category (Fix i o) where
id = liftFix id
Fix f . Fix g = Fix $ proc ((i,o),x) -> do
(o',y) <- g -< ((i,o),x)
f -< ((i,o'),y)
instance Arrow (CacheArrow i o) 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 Arrow (Fix i o) where
arr f = liftFix (arr f)
first (Fix f) = Fix $ (\((i,o),(x,y)) -> (((i,o),x),y)) ^>> first f >>^ (\((o,x'),y) -> (o,(x',y)))
second (Fix f) = Fix $ (\((i,o),(x,y)) -> (x,((i,o),y))) ^>> second f >>^ (\(x,(o,y')) -> (o,(x,y')))
instance ArrowChoice (CacheArrow i o) 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 ArrowChoice (Fix i o) where
left (Fix f) = Fix $ (\((i,o),e) -> injectRight (o,injectLeft ((i,o),e))) ^>> left f >>^ eject
right (Fix f) = Fix $ (\((i,o),e) -> injectRight ((i,o),injectLeft (o,e))) ^>> right f >>^ eject
instance ArrowApply (CacheArrow i o) where
app = CacheArrow $ (\(io,(CacheArrow f,x)) -> (f,(io,x))) ^>> app
instance ArrowApply (Fix i o) where
app = Fix $ (\(io,(Fix f,x)) -> (f,(io,x))) ^>> app
#ifdef TRACE
instance (Show x, Show y, Eq x, Hashable x, LowerBounded y, Widening y)
......@@ -93,8 +92,8 @@ memoize f = proc x -> do
printf "\t%s <- memoize -< %s" (show y) (show x)) y
#else
instance (Eq x, Hashable x, LowerBounded y, Widening y)
=> ArrowFix x y (CacheArrow x y) where
instance (Identifiable x, LowerBounded y, Widening y)
=> ArrowFix x y (Fix x y) where
fixA f = proc x -> do
old <- getOutCache -< ()
setOutCache -< bottom
......@@ -104,7 +103,7 @@ instance (Eq x, Hashable x, LowerBounded y, Widening y)
then returnA -< y
else fixA f -< x
memoize :: (Eq x, Hashable x, LowerBounded y, Widening y) => CacheArrow x y x y -> CacheArrow x y x y
memoize :: (Identifiable x, LowerBounded y, Widening y) => Fix x y x y -> Fix x y x y
memoize f = proc x -> do
m <- lookupOutCache -< x
case m of
......@@ -119,29 +118,29 @@ memoize f = proc x -> do
Bot -> bottom -< ()
#endif
lookupOutCache :: (Identifiable x) => CacheArrow x y x (Error () y)
lookupOutCache = CacheArrow $ \((_,o),x) -> (o,S.lookup x o)
lookupOutCache :: Identifiable x => Fix x y x (Error () y)
lookupOutCache = Fix $ \((_,o),x) -> (o,S.lookup x o)
lookupInCache :: (Identifiable x) => CacheArrow x y x (Error () y)
lookupInCache = CacheArrow $ \((i,o),x) -> (o,S.lookup x i)
lookupInCache :: Identifiable x => Fix x y x (Error () y)
lookupInCache = Fix $ \((i,o),x) -> (o,S.lookup x i)
writeOutCache :: (Eq x, Hashable x) => CacheArrow x y (x,y) ()
writeOutCache = CacheArrow $ \((_,o),(x,y)) -> (S.insert x y o,())
writeOutCache :: Identifiable x => Fix x y (x,y) ()
writeOutCache = Fix $ \((_,o),(x,y)) -> (S.insert x y o,())
getOutCache :: CacheArrow x y () (Store x y)
getOutCache = CacheArrow $ (\((_,o),()) -> (o,o))
getOutCache :: Fix x y () (Store x y)
getOutCache = Fix $ (\((_,o),()) -> (o,o))
setOutCache :: CacheArrow x y (Store x y) ()
setOutCache = CacheArrow $ (\((_,_),o) -> (o,()))
setOutCache :: Fix x y (Store x y) ()
setOutCache = Fix $ (\((_,_),o) -> (o,()))
localInCache :: CacheArrow x y x y -> CacheArrow x y (Store x y,x) y
localInCache (CacheArrow f) = CacheArrow (\((_,o),(i,x)) -> f ((i,o),x))
localInCache :: Fix x y x y -> Fix x y (Store x y,x) y
localInCache (Fix f) = Fix (\((_,o),(i,x)) -> f ((i,o),x))
updateOutCache :: (Eq x, Hashable x, Widening y) => CacheArrow x y (x,y) ()
updateOutCache = CacheArrow $ \((_,o),(x,y)) -> (S.insertWith (flip ()) x y o,())
updateOutCache :: (Identifiable x, Widening y) => Fix x y (x,y) ()
updateOutCache = Fix $ \((_,o),(x,y)) -> (S.insertWith (flip ()) x y o,())
deriving instance PreOrd (((Store a b,Store a b),x) -> (Store a b,y)) => PreOrd (CacheArrow a b x y)
deriving instance Complete (((Store a b,Store a b),x) -> (Store a b,y)) => Complete (CacheArrow a b x y)
deriving instance CoComplete (((Store a b,Store a b),x) -> (Store a b,y)) => CoComplete (CacheArrow a b x y)
deriving instance LowerBounded (((Store a b,Store a b),x) -> (Store a b,y)) => LowerBounded (CacheArrow a b x y)
deriving instance UpperBounded (((Store a b,Store a b),x) -> (Store a b,y)) => UpperBounded (CacheArrow a b x y)
deriving instance PreOrd (((Store a b,Store a b),x) -> (Store a b,y)) => PreOrd (Fix a b x y)
deriving instance Complete (((Store a b,Store a b),x) -> (Store a b,y)) => Complete (Fix a b x y)
deriving instance CoComplete (((Store a b,Store a b),x) -> (Store a b,y)) => CoComplete (Fix a b x y)
deriving instance LowerBounded (((Store a b,Store a b),x) -> (Store a b,y)) => LowerBounded (Fix a b x y)
deriving instance UpperBounded (((Store a b,Store a b),x) -> (Store a b,y)) => UpperBounded (Fix a b x y)
......@@ -4,16 +4,17 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Transformer.Abstract.Powerset(PowersetArrow(..),liftPowerset) where
module Control.Arrow.Transformer.Abstract.Powerset(Powerset(..)) where
import Prelude hiding (id,lookup)
import Control.Arrow
import Control.Arrow.Deduplicate
import Control.Arrow.Environment
import Control.Arrow.Fail
import Control.Arrow.Lift
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Deduplicate
import Control.Category
import Control.Monad (join)
......@@ -22,13 +23,10 @@ import qualified Data.Abstract.Powerset as A
import Data.Order
import Data.Sequence
newtype PowersetArrow c x y = PowersetArrow { runPowersetArrow :: c x (Pow y)}
newtype Powerset c x y = Powerset { runPowerset :: c x (Pow y)}
liftPowerset :: Arrow c => c x y -> PowersetArrow c x y
liftPowerset f = PowersetArrow $ proc x -> do
g <- f -< x
returnA -< A.singleton g
{-# INLINE liftPowerset #-}
instance ArrowLift Powerset where
lift f = Powerset $ f >>^ A.singleton
mapPow :: ArrowChoice c => c x y -> c (Pow x) (Pow y)
mapPow f = proc (A.Pow s) -> case viewl s of
......@@ -38,18 +36,18 @@ mapPow f = proc (A.Pow s) -> case viewl s of
A.Pow ps <- mapPow f -< A.Pow xs
returnA -< A.Pow (p <| ps)
instance ArrowChoice c => Category (PowersetArrow c) where
id = liftPowerset id
PowersetArrow f . PowersetArrow g = PowersetArrow $ g >>> mapPow f >>^ join
instance ArrowChoice c => Category (Powerset c) where
id = lift id
Powerset f . Powerset g = Powerset $ g >>> mapPow f >>^ join
instance ArrowChoice c => Arrow (PowersetArrow c) where
arr f = liftPowerset (arr f)
first (PowersetArrow f) = PowersetArrow $ first f >>^ \(pow,n) -> A.cartesian (pow, A.singleton n)
second (PowersetArrow f) = PowersetArrow $ second f >>^ \(n,pow) -> A.cartesian (A.singleton n, pow)
instance ArrowChoice c => Arrow (Powerset c) where
arr f = lift (arr f)
first (Powerset f) = Powerset $ first f >>^ \(pow,n) -> A.cartesian (pow, A.singleton n)
second (Powerset f) = Powerset $ second f >>^ \(n,pow) -> A.cartesian (A.singleton n, pow)
instance ArrowChoice c => ArrowChoice (PowersetArrow c) where
left (PowersetArrow f) = PowersetArrow $ left f >>^ commuteLeft
right (PowersetArrow f) = PowersetArrow $ right f >>^ commuteRight
instance ArrowChoice c => ArrowChoice (Powerset c) where
left (Powerset f) = Powerset $ left f >>^ commuteLeft
right (Powerset f) = Powerset $ right f >>^ commuteRight
commuteLeft :: Either (Pow c) d -> Pow (Either c d)
commuteLeft e0 = case e0 of
......@@ -63,37 +61,37 @@ commuteRight e0 = case e0 of
Right (A.Pow e) -> A.fromFoldable $ fmap Right e
{-# INLINE commuteRight #-}
instance (ArrowChoice c, ArrowApply c) => ArrowApply (PowersetArrow c) where
app = PowersetArrow $ first runPowersetArrow ^>> app