add arrow that records the contour of a program (k-bounded call stack)

parent ed72cdf9
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RecordWildCards #-}
module Control.Arrow.Class.Contour(ArrowContour(..),Contour,empty,push,toList,size,maxSize) where
import Data.Sequence (Seq,(|>))
import qualified Data.Sequence as S
import qualified Data.Foldable as F
data Contour l = Contour {
contour :: (Seq l),
size :: Int,
maxSize :: Int
}
empty :: Int -> Contour l
empty m = Contour S.empty 0 m
push :: l -> Contour l -> Contour l
push l (Contour {..}) = resize (Contour (contour |> l) (size + 1) maxSize)
resize :: Contour l -> Contour l
resize cont@(Contour {..})
| size > maxSize = Contour (S.drop (size - maxSize) contour) maxSize maxSize
| otherwise = cont
toList :: Contour l -> [l]
toList = F.toList . contour
class ArrowContour l c | c -> l where
askContour :: c () (Contour l)
module Control.Arrow.Contour(
module Control.Arrow.Class.Contour,
module Control.Arrow.Transformer.Contour
) where
import Control.Arrow.Class.Contour
import Control.Arrow.Transformer.Contour
module Control.Arrow.Fix
( module Control.Arrow.Class.Fix,
module Control.Arrow.Transformer.FixpointCache,
module Control.Arrow.Transformer.FixCache,
module Control.Arrow.Transformer.Fix
)
where
import Control.Arrow.Class.Fix
import Control.Arrow.Transformer.FixpointCache
import Control.Arrow.Transformer.FixCache
import Control.Arrow.Transformer.Fix
......@@ -26,24 +26,24 @@ import Data.Order
import Data.Store (Store)
import qualified Data.Store as S
type Alloc a addr b c = BoundedEnv a addr b c a addr
newtype BoundedEnv a addr b c x y = BoundedEnv ( ReaderArrow (Alloc a addr b c, HashMap a addr) (StateArrow (Store addr b) c) x y )
type Alloc var addr val c = BoundedEnv var addr val c var addr
newtype BoundedEnv var addr val c x y = BoundedEnv ( ReaderArrow (Alloc var addr val c, HashMap var addr) (StateArrow (Store addr val) c) x y )
deriving (Category,Arrow,ArrowChoice)
runBoundedEnv :: (Eq a, Hashable a, Eq addr, Hashable addr, Complete b, ArrowChoice c, ArrowApply c)
=> BoundedEnv a addr b c x y -> c (Alloc a addr b c,HashMap a b,x) y
runBoundedEnv :: (Eq var, Hashable var, Eq addr, Hashable addr, Complete val, ArrowChoice c, ArrowApply c)
=> BoundedEnv var addr val c x y -> c (Alloc var addr val c,HashMap var val,x) y
runBoundedEnv f =
let BoundedEnv (ReaderArrow (StateArrow f')) = proc (bs,x) -> do
env <- getEnv -< ()
env' <- bindings -< (bs,env)
localEnv f -< (env',x)
in (\(alloc,env,x) -> (S.empty,((alloc,H.empty),(H.toList env,x)))) ^>> f' >>^ snd
in (\(al,env,x) -> (S.empty,((al,H.empty),(H.toList env,x)))) ^>> f' >>^ snd
liftBoundedEnv :: Arrow c => c x y -> BoundedEnv a addr b c x y
liftBoundedEnv :: Arrow c => c x y -> BoundedEnv var addr vaal c x y
liftBoundedEnv f = BoundedEnv (liftReader (liftState f))
instance (Eq a, Hashable a, Eq addr, Hashable addr, Complete b, ArrowApply c) =>
ArrowEnv a b (HashMap a addr) (BoundedEnv a addr b c) where
instance (Eq var, Hashable var, Eq addr, Hashable addr, Complete val, ArrowApply c) =>
ArrowEnv var val (HashMap var addr) (BoundedEnv var addr val c) where
lookup = proc x -> do
env <- getEnv -< ()
store <- getStore -< ()
......@@ -52,52 +52,54 @@ instance (Eq a, Hashable a, Eq addr, Hashable addr, Complete b, ArrowApply c) =>
S.lookup addr store
getEnv = BoundedEnv (pi2 <<< askA)
extendEnv = proc (x,y,env) -> do
alloc <- BoundedEnv (pi1 <<< askA) -< ()
addr <- localEnv alloc -<< (env,x)
addr <- localEnv alloc -< (env,x)
store <- getStore -< ()
putStore -< S.insertWith () addr y store
returnA -< H.insert x addr env
localEnv (BoundedEnv (ReaderArrow f)) = BoundedEnv (ReaderArrow ((\((alloc,_),(env,a)) -> ((alloc,env),a)) ^>> f))
localEnv (BoundedEnv (ReaderArrow f)) = BoundedEnv (ReaderArrow ((\((al,_),(env,a)) -> ((al,env),a)) ^>> f))
instance ArrowReader r c => ArrowReader r (BoundedEnv a addr b c) where
instance ArrowReader r c => ArrowReader r (BoundedEnv var addr val 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
instance ArrowState s c => ArrowState s (BoundedEnv var addr val c) where
getA = liftBoundedEnv getA
putA = liftBoundedEnv putA
instance ArrowFail e c => ArrowFail e (BoundedEnv a addr b c) where
instance ArrowFail e c => ArrowFail e (BoundedEnv var addr val c) where
failA = liftBoundedEnv failA
instance ArrowApply c => ArrowApply (BoundedEnv a addr b c) where
instance ArrowApply c => ArrowApply (BoundedEnv var addr val c) where
app = BoundedEnv $ (\(BoundedEnv f,x) -> (f,x)) ^>> app
getStore :: Arrow c => BoundedEnv a addr b c () (Store addr b)
getStore :: Arrow c => BoundedEnv var addr val c () (Store addr val)
getStore = BoundedEnv getA
{-# INLINE getStore #-}
putStore :: Arrow c => BoundedEnv a addr b c (Store addr b) ()
putStore :: Arrow c => BoundedEnv var addr val c (Store addr val) ()
putStore = BoundedEnv putA
{-# INLINE putStore #-}
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)
where
lift :: Arrow c => c (Alloc a addr b c, HashMap a addr,Store addr b,x) (Store addr b,y) -> BoundedEnv a addr b c x y
lift g = BoundedEnv (ReaderArrow (StateArrow ((\(s,((a,e),x)) -> (a,e,s,x)) ^>> g)))
alloc :: ArrowApply c => BoundedEnv var addr val c var addr
alloc = proc v -> do
(a,_) <- BoundedEnv askA -< ()
a -<< v
{-# INLINE alloc #-}
lift' :: Arrow c => c (HashMap a addr,Store addr b,x) (Store addr b,y) -> BoundedEnv a addr b c x y
lift' g = BoundedEnv (ReaderArrow (StateArrow ((\(s,((_,e),x)) -> (e,s,x)) ^>> g)))
instance (ArrowApply c, ArrowFix (HashMap var addr,Store addr val,x) (Store addr val,y) c) => ArrowFix x y (BoundedEnv var addr val c) where
fixA f = BoundedEnv $ ReaderArrow $ StateArrow $ proc (s,((a,e),x)) -> do
fixA (unlift a . f . lift) -<< (e,s,x)
where
lift :: Arrow c => c (HashMap var addr,Store addr val,x) (Store addr val,y) -> BoundedEnv var addr val c x y
lift g = BoundedEnv (ReaderArrow (StateArrow ((\(s,((_,e),x)) -> (e,s,x)) ^>> g)))
unlift :: Arrow c => Alloc a addr b c -> BoundedEnv a addr b c x y -> c (HashMap a addr,Store addr b,x) (Store addr b,y)
unlift :: Arrow c => Alloc var addr val c -> BoundedEnv var addr val c x y -> c (HashMap var addr,Store addr val,x) (Store addr val,y)
unlift a (BoundedEnv (ReaderArrow (StateArrow g))) = (\(s,e,x) -> (e,((a,s),x))) ^>> g
deriving instance PreOrd (c (Store addr b,((Alloc a addr b c,HashMap a addr),x)) (Store addr b,y)) => PreOrd (BoundedEnv a addr b c x y)
deriving instance Complete (c (Store addr b,((Alloc a addr b c,HashMap a addr),x)) (Store addr b,y)) => Complete (BoundedEnv a addr b c x y)
deriving instance CoComplete (c (Store addr b,((Alloc a addr b c,HashMap a addr),x)) (Store addr b,y)) => CoComplete (BoundedEnv a addr b c x y)
deriving instance LowerBounded (c (Store addr b,((Alloc a addr b c,HashMap a addr),x)) (Store addr b,y)) => LowerBounded (BoundedEnv a addr b c x y)
deriving instance UpperBounded (c (Store addr b,((Alloc a addr b c,HashMap a addr),x)) (Store addr b,y)) => UpperBounded (BoundedEnv a addr b c x y)
deriving instance PreOrd (c (Store addr val,((Alloc var addr val c,HashMap var addr),x)) (Store addr val,y)) => PreOrd (BoundedEnv var addr val c x y)
deriving instance Complete (c (Store addr val,((Alloc var addr val c,HashMap var addr),x)) (Store addr val,y)) => Complete (BoundedEnv var addr val c x y)
deriving instance CoComplete (c (Store addr val,((Alloc var addr val c,HashMap var addr),x)) (Store addr val,y)) => CoComplete (BoundedEnv var addr val c x y)
deriving instance LowerBounded (c (Store addr val,((Alloc var addr val c,HashMap var addr),x)) (Store addr val,y)) => LowerBounded (BoundedEnv var addr val c x y)
deriving instance UpperBounded (c (Store addr val,((Alloc var addr val c,HashMap var addr),x)) (Store addr val,y)) => UpperBounded (BoundedEnv var addr val c x y)
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Transformer.Contour where
import Prelude hiding (id,(.),lookup)
import Control.Arrow
import Control.Arrow.Class.Contour
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.Transformer.Reader
import Control.Category
newtype ContourArrow l c a b = ContourArrow (ReaderArrow (Contour l) c a b)
liftContour :: Arrow c => c a b -> ContourArrow l c a b
liftContour f = ContourArrow (liftReader f)
runContourArrow :: Arrow c => ContourArrow l c a b -> c (Int,a) b
runContourArrow (ContourArrow (ReaderArrow f)) = first empty ^>> f
instance Arrow c => Category (ContourArrow l c) where
id = liftContour id
ContourArrow f . ContourArrow g = ContourArrow (f . g)
instance Arrow c => Arrow (ContourArrow l c) where
arr f = liftContour (arr f)
first (ContourArrow f) = ContourArrow (first f)
second (ContourArrow f) = ContourArrow (second f)
instance ArrowChoice c => ArrowChoice (ContourArrow l c) where
left (ContourArrow f) = ContourArrow (left f)
right (ContourArrow f) = ContourArrow (right f)
instance ArrowApply c => ArrowApply (ContourArrow l c) where
app = ContourArrow $ (\(ContourArrow f,x) -> (f,x)) ^>> app
instance ArrowReader r c => ArrowReader r (ContourArrow l c) where
askA = liftContour askA
localA (ContourArrow (ReaderArrow f)) = ContourArrow $ ReaderArrow $ (\(cont,(r,x)) -> (r,(cont,x))) ^>> localA f
instance ArrowState s c => ArrowState s (ContourArrow l c) where
getA = liftContour getA
putA = liftContour putA
instance ArrowFail e c => ArrowFail e (ContourArrow l c) where
failA = liftContour failA
instance ArrowEnv x y env c => ArrowEnv x y env (ContourArrow l c) where
lookup = liftContour lookup
getEnv = liftContour getEnv
extendEnv = liftContour extendEnv
localEnv (ContourArrow (ReaderArrow f)) = ContourArrow $ ReaderArrow $ (\(cont,(r,x)) -> (r,(cont,x))) ^>> localEnv f
instance (ArrowFix x y c, ArrowApply c) => ArrowFix x y (ContourArrow x c) where
-- Pushes the last argument on the contour.
fixA f = ContourArrow $ ReaderArrow $ proc (cont,x) -> fixA (unlift . f . lift (push x cont)) -<< x
where
lift :: Arrow c => Contour x -> c x y -> ContourArrow x c x y
lift c f' = proc x -> localContour (liftContour f') -< (c,x)
localContour :: Arrow c => ContourArrow l c x y -> ContourArrow l c (Contour l, x) y
localContour (ContourArrow (ReaderArrow f')) = ContourArrow $ ReaderArrow $ snd ^>> f'
unlift :: Arrow c => ContourArrow x c x y -> c x y
unlift f' = (const 0 &&& id) ^>> runContourArrow f'
......@@ -9,7 +9,7 @@
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE CPP #-}
-- {-# OPTIONS_GHC -DTRACE #-}
module Control.Arrow.Transformer.FixpointCache(CacheArrow,runCacheArrow,runCacheArrow',liftCache) where
module Control.Arrow.Transformer.FixCache(CacheArrow,runCacheArrow,runCacheArrow',liftCache) where
import Prelude hiding (id,(.),lookup)
import Data.Function (fix)
......
......@@ -30,7 +30,9 @@ library
Data.FreeCoCompletion,
Data.Widening,
Data.Store,
Data.Utils
Data.Utils,
Control.Arrow.Contour,
Control.Arrow.Debug,
Control.Arrow.Deduplicate,
Control.Arrow.Either,
......@@ -38,28 +40,36 @@ library
Control.Arrow.Fail,
Control.Arrow.Fix,
Control.Arrow.Join,
Control.Arrow.Try,
Control.Arrow.State,
Control.Arrow.Reader,
Control.Arrow.Powerset,
Control.Arrow.State,
Control.Arrow.Try,
Control.Arrow.Utils,
-- TODO: delete
Control.Monad.Deduplicate,
Control.Monad.Join,
Control.Monad.Try,
Control.Arrow.Utils
other-modules: Control.Arrow.Class.Reader,
Control.Arrow.Class.State,
Control.Monad.Try
other-modules:
Control.Arrow.Class.Contour,
Control.Arrow.Class.Environment,
Control.Arrow.Class.Fail,
Control.Arrow.Class.Fix,
Control.Arrow.Class.Environment,
Control.Arrow.Class.Reader,
Control.Arrow.Class.State,
Control.Arrow.Transformer.BoundedEnvironment,
Control.Arrow.Transformer.Contour,
Control.Arrow.Transformer.Either,
Control.Arrow.Transformer.Environment,
Control.Arrow.Transformer.Reader,
Control.Arrow.Transformer.State,
Control.Arrow.Transformer.FixpointCache,
Control.Arrow.Transformer.FixCache,
Control.Arrow.Transformer.Fix,
Control.Arrow.Transformer.Fail,
Control.Arrow.Transformer.Powerset
Control.Arrow.Transformer.Powerset,
Control.Arrow.Transformer.Reader,
Control.Arrow.Transformer.State
build-depends: base,
containers,
hashable,
......
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