Commit 96442b2c authored by Sven Keidel's avatar Sven Keidel

new naming scheme

parent f86cf0cf
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
module Control.Arrow.Class.Alloc where
module Control.Arrow.Abstract.Alloc where
import Control.Arrow
import Data.Store (Store)
import Data.Environment(Env)
import Data.Abstract.Store (Store)
import Data.Abstract.Environment(Env)
class Arrow c => ArrowAlloc var addr val c where
alloc :: c (var,Env var addr,Store addr val) addr
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Class.Environment where
import Control.Arrow
import Control.Arrow.Utils
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)
bindings :: (ArrowChoice c, ArrowEnv x y env c) => c ([(x,y)],env) env
bindings = foldA ((\(env,(x,y)) -> (x,y,env)) ^>> extendEnv)
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Class.Fail where
import Control.Arrow
import Control.Monad.Except
class Arrow c => ArrowFail e c | c -> e where
failA :: c e x
instance MonadError e m => ArrowFail e (Kleisli m) where
failA = Kleisli throwError
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
module Control.Arrow.Class.Fix(ArrowFix(..),ArrowFix'(..)) where
import Control.Arrow
class Arrow c => ArrowFix x y c where
fixA :: (c x y -> c x y) -> c x y
class Arrow c => ArrowFix' c y | c -> y where
fixA' :: ((z -> c x y) -> (z -> c x y)) -> (z -> c x y)
{-# LANGUAGE MultiParamTypeClasses #-}
module Control.Arrow.Class.Property where
import Control.Arrow
class Arrow c => HasProp p c where
modifyProp :: (c (x,p) p) -> c x ()
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Class.Reader where
import Control.Arrow
import Control.Monad.Reader
class Arrow c => ArrowReader r c | c -> r where
askA :: c () r
localA :: c x y -> c (r,x) y
instance MonadReader r m => ArrowReader r (Kleisli m) where
askA = Kleisli (const ask)
localA (Kleisli f) = Kleisli (\(r,x) -> local (const r) (f x))
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Class.State where
import Prelude hiding (id,(.))
import Control.Category
import Control.Arrow
import Control.Monad.State
class Arrow c => ArrowState s c | c -> s where
getA :: c () s
putA :: c s ()
modifyA :: ArrowState s c => c (x,s) s -> c x ()
modifyA f = proc x -> do
s <- getA -< ()
putA <<< f -< (x,s)
instance MonadState s m => ArrowState s (Kleisli m) where
getA = Kleisli (const get)
putA = Kleisli put
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Class.Store where
import Prelude hiding (lookup,id)
import Control.Arrow
class Arrow c => ArrowStore var val c | c -> var, c -> val where
lookup :: c var val
store :: c (var,val) ()
module Control.Arrow.Contour(
module Control.Arrow.Transformer.Contour
) where
import Control.Arrow.Transformer.Contour
module Control.Arrow.Either
(module Control.Arrow.Transformer.Either
) where
import Control.Arrow.Transformer.Either
module Control.Arrow.Environment(
module Control.Arrow.Class.Environment,
module Control.Arrow.Transformer.Environment,
module Control.Arrow.Transformer.BoundedEnvironment,
) where
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Environment where
import Control.Arrow.Class.Environment
import Control.Arrow.Transformer.Environment
import Control.Arrow.Transformer.BoundedEnvironment
import Control.Arrow
import Control.Arrow.Utils
class Arrow c => ArrowEnv x y env c | c -> x, c -> y, c -> env where
lookup :: c x 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)
bindings :: (ArrowChoice c, ArrowEnv x y env c) => c ([(x,y)],env) env
bindings = foldA ((\(env,(x,y)) -> (x,y,env)) ^>> extendEnv)
module Control.Arrow.Fail
(module Control.Arrow.Class.Fail,
module Control.Arrow.Transformer.Error,
module Control.Arrow.Transformer.Either
) where
import Control.Arrow.Class.Fail
import Control.Arrow.Transformer.Error
import Control.Arrow.Transformer.Either
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Fail where
import Control.Arrow
import Control.Monad.Except
class Arrow c => ArrowFail e c | c -> e where
failA :: c e x
instance MonadError e m => ArrowFail e (Kleisli m) where
failA = Kleisli throwError
failA' :: ArrowFail () c => c a b
failA' = arr (const ()) >>> failA
module Control.Arrow.Fix
( module Control.Arrow.Class.Fix,
module Control.Arrow.Transformer.FixCache,
module Control.Arrow.Transformer.Fix
)
where
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
module Control.Arrow.Fix(ArrowFix(..),ArrowFix'(..)) where
import Control.Arrow.Class.Fix
import Control.Arrow.Transformer.FixCache
import Control.Arrow.Transformer.Fix
import Control.Arrow
class Arrow c => ArrowFix x y c where
fixA :: (c x y -> c x y) -> c x y
class Arrow c => ArrowFix' c y | c -> y where
fixA' :: ((z -> c x y) -> (z -> c x y)) -> (z -> c x y)
module Control.Arrow.Powerset
(module Control.Arrow.Transformer.Powerset
) where
import Control.Arrow.Transformer.Powerset
module Control.Arrow.Property
(module Control.Arrow.Class.Property,
module Control.Arrow.Transformer.Property
) where
{-# LANGUAGE MultiParamTypeClasses #-}
module Control.Arrow.Property where
import Control.Arrow.Class.Property
import Control.Arrow.Transformer.Property
import Control.Arrow
class Arrow c => HasProp p c where
modifyProp :: (c (x,p) p) -> c x ()
module Control.Arrow.Reader
(module Control.Arrow.Class.Reader,
module Control.Arrow.Transformer.Reader
) where
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Reader where
import Control.Arrow.Class.Reader
import Control.Arrow.Transformer.Reader
import Control.Arrow
import Control.Monad.Reader
class Arrow c => ArrowReader r c | c -> r where
askA :: c () r
localA :: c x y -> c (r,x) y
instance MonadReader r m => ArrowReader r (Kleisli m) where
askA = Kleisli (const ask)
localA (Kleisli f) = Kleisli (\(r,x) -> local (const r) (f x))
module Control.Arrow.State
(module Control.Arrow.Class.State,
module Control.Arrow.Transformer.State
) where
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.State where
import Control.Arrow.Class.State
import Control.Arrow.Transformer.State
import Prelude hiding (id,(.))
import Control.Category
import Control.Arrow
import Control.Monad.State
class Arrow c => ArrowState s c | c -> s where
getA :: c () s
putA :: c s ()
modifyA :: ArrowState s c => c (x,s) s -> c x ()
modifyA f = proc x -> do
s <- getA -< ()
putA <<< f -< (x,s)
instance MonadState s m => ArrowState s (Kleisli m) where
getA = Kleisli (const get)
putA = Kleisli put
module Control.Arrow.Store
(module Control.Arrow.Class.Store) where
import Control.Arrow.Class.Store
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Store where
import Prelude hiding (lookup,id)
import Control.Arrow
class Arrow c => ArrowStore var val c | c -> var, c -> val where
lookup :: c var val
store :: c (var,val) ()
......@@ -7,83 +7,82 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ConstraintKinds #-}
module Control.Arrow.Transformer.BoundedEnvironment(BoundedEnv,runBoundedEnv,liftBoundedEnv,ArrowAlloc(..)) where
module Control.Arrow.Transformer.Abstract.BoundedEnvironment(Environment,runEnvironment,liftEnvironment,ArrowAlloc(..)) where
import Prelude hiding ((.),id)
import Control.Category
import Control.Arrow
import Control.Arrow.Class.Alloc
import Control.Arrow.Class.Environment
import Control.Arrow.Class.Reader
import Control.Arrow.Class.State
import Control.Arrow.Class.Fail
import Control.Arrow.Class.Fix
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.Transformer.Reader
import Data.Hashable
import Data.Order
import Data.Environment (Env)
import qualified Data.Environment as E
import Data.Store (Store)
import qualified Data.Store as S
import Data.Identifiable
import Data.Abstract.Error
import Data.Abstract.Environment (Env)
import qualified Data.Abstract.Environment as E
import Data.Abstract.Store (Store)
import qualified Data.Abstract.Store as S
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 BoundedEnv var addr val c x y =
BoundedEnv ( ReaderArrow (Env var addr,Store addr val) c x y )
deriving (Category,Arrow,ArrowChoice)
newtype Environment var addr val c x y = Environment ( ReaderArrow (Env var addr,Store addr val) c x y )
runBoundedEnv :: (Eq var, Hashable var, Eq addr, Hashable addr, Complete val, ArrowChoice c, ArrowAlloc var addr val c)
=> BoundedEnv var addr val c x y -> c ([(var,val)],x) y
runBoundedEnv f =
let BoundedEnv (ReaderArrow f') = proc (bs,x) -> do
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
env <- getEnv -< ()
env' <- bindings -< (bs,env)
localEnv f -< (env',x)
in (const (E.empty,S.empty) &&& id) ^>> f'
liftBoundedEnv :: Arrow c => c x y -> BoundedEnv var addr val c x y
liftBoundedEnv f = BoundedEnv (liftReader f)
liftEnvironment :: Arrow c => c x y -> Environment var addr val c x y
liftEnvironment f = Environment (liftReader f)
instance (Eq var, Hashable var, Eq addr, Hashable addr, Complete val, ArrowAlloc var addr val c) =>
ArrowEnv var val (Env var addr,Store addr val) (BoundedEnv var addr val c) where
lookup = proc x -> do
(env,store) <- getEnv -< ()
returnA -< do
addr <- E.lookup x env
S.lookup addr store
getEnv = BoundedEnv askA
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
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 <- liftBoundedEnv alloc -< (x,env,store)
addr <- liftEnvironment alloc -< (x,env,store)
returnA -< (E.insert x addr env,S.insertWith () addr y store)
localEnv (BoundedEnv (ReaderArrow f)) = BoundedEnv (ReaderArrow ((\(_,(e,a)) -> (e,a)) ^>> f))
instance ArrowReader r c => ArrowReader r (BoundedEnv var addr val c) where
askA = liftBoundedEnv askA
localA (BoundedEnv (ReaderArrow f)) = BoundedEnv $ ReaderArrow $ (\(env,(r,x)) -> (r,(env,x))) ^>> localA f
instance ArrowState s c => ArrowState s (BoundedEnv var addr val c) where
getA = liftBoundedEnv getA
putA = liftBoundedEnv putA
localEnv (Environment (ReaderArrow f)) = Environment (ReaderArrow ((\(_,(e,a)) -> (e,a)) ^>> f))
instance ArrowFail e c => ArrowFail e (BoundedEnv var addr val c) where
failA = liftBoundedEnv failA
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
instance ArrowApply c => ArrowApply (BoundedEnv var addr val c) where
app = BoundedEnv $ (\(BoundedEnv f,x) -> (f,x)) ^>> app
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 (BoundedEnv var addr val c) where
fixA f = BoundedEnv $ ReaderArrow $ proc ((e,s),x) -> fixA (unlift . f . lift) -< (e,s,x)
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 -> BoundedEnv var addr val c x y
lift g = BoundedEnv (ReaderArrow ((\((e,s),x) -> (e,s,x)) ^>> g))
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 => BoundedEnv var addr val c x y -> c (Env var addr,Store addr val,x) y
unlift (BoundedEnv (ReaderArrow g)) = (\(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 PreOrd (c ((Env var addr,Store addr val),x) y) => PreOrd (BoundedEnv var addr val c x y)
deriving instance Complete (c ((Env var addr,Store addr val),x) y) => Complete (BoundedEnv var addr val c x y)
deriving instance CoComplete (c ((Env var addr,Store addr val),x) y) => CoComplete (BoundedEnv var addr val c x y)
deriving instance LowerBounded (c ((Env var addr,Store addr val),x) y) => LowerBounded (BoundedEnv var addr val c x y)
deriving instance UpperBounded (c ((Env var addr,Store addr val),x) y) => UpperBounded (BoundedEnv var addr val c x y)
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)
deriving instance ArrowState s c => ArrowState s (Environment var addr val c)
deriving instance ArrowFail e c => ArrowFail e (Environment var addr val c)
deriving instance PreOrd (c ((Env var addr,Store addr val),x) y) => PreOrd (Environment var addr val c x y)
deriving instance Complete (c ((Env var addr,Store addr val),x) y) => Complete (Environment var addr val c x y)
deriving instance CoComplete (c ((Env var addr,Store addr val),x) y) => CoComplete (Environment var addr val c x y)
deriving instance LowerBounded (c ((Env var addr,Store addr val),x) y) => LowerBounded (Environment var addr val c x y)
deriving instance UpperBounded (c ((Env var addr,Store addr val),x) y) => UpperBounded (Environment var addr val c x y)
......@@ -5,17 +5,17 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.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,liftContour) where
import Prelude hiding (id,(.),lookup)
import Control.Arrow
import Control.Arrow.Class.Alloc
import Control.Arrow.Class.Reader
import Control.Arrow.Class.State
import Control.Arrow.Class.Fail
import Control.Arrow.Class.Environment
import Control.Arrow.Class.Fix
import Control.Arrow.Abstract.Alloc
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Fail
import Control.Arrow.Environment
import Control.Arrow.Fix
import Control.Arrow.Transformer.Reader
import Control.Category
......
......@@ -5,26 +5,29 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Transformer.Environment where
module Control.Arrow.Transformer.Abstract.Environment where
import Prelude hiding ((.))
import Data.Hashable
import Data.Order
import Data.Environment (Env)
import qualified Data.Environment as E
import Data.Identifiable
import Data.Abstract.Error
import Data.Abstract.Environment (Env)
import qualified Data.Abstract.Environment as E
import Control.Category
import Control.Arrow
import Control.Arrow.Transformer.Reader
import Control.Arrow.Class.Reader
import Control.Arrow.Class.State
import Control.Arrow.Class.Fail
import Control.Arrow.Class.Environment
import Control.Arrow.Class.Fix
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Fail
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)
deriving (Category,Arrow,ArrowChoice)
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
......@@ -32,6 +35,16 @@ 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)
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
case E.lookup x env of
Success y -> returnA -< y
Fail _ -> failA -< printf "variable %s not found" (show x)
Bot -> bottom -< ()
getEnv = Environment askA
extendEnv = arr $ \(x,y,env) -> E.insert x y env
localEnv (Environment f) = Environment (localA f)
instance ArrowApply c => ArrowApply (Environment var val c) where
app = Environment $ (\(Environment f,x) -> (f,x)) ^>> app
......@@ -39,27 +52,12 @@ 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))
instance ArrowState s c => ArrowState s (Environment var val c) where
getA = liftEnv getA
putA = liftEnv putA
instance ArrowFail e c => ArrowFail e (Environment var val c) where
failA = liftEnv failA
instance (Eq var, Hashable var, ArrowChoice c) => ArrowEnv var val (Env var val) (Environment var val c) where
lookup = proc x -> do
env <- getEnv -< ()
returnA -< E.lookup x env
getEnv = Environment askA
extendEnv = arr $ \(x,y,env) -> E.insert x y env
localEnv (Environment f) = Environment (localA f)
instance (ArrowFix (Env var val,x) y c) => ArrowFix x y (Environment var val c) where
fixA f = Environment (ReaderArrow (fixA (unlift . f . lift)))
where
lift = Environment . ReaderArrow
unlift (Environment (ReaderArrow f')) = f'
deriving instance Arrow c => Category (Environment var val c)
deriving instance Arrow c => Arrow (Environment var val c)
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)
deriving instance ArrowFix (Env var val,x) y c => ArrowFix x y (Environment var val c)
deriving instance PreOrd (c (Env var val,x) y) => PreOrd (Environment var val c x y)
deriving instance Complete (c (Env var val,x) y) => Complete (Environment var val c x y)
deriving instance CoComplete (c (Env var val,x) y) => CoComplete (Environment var val c x y)
......