...
 
Commits (9)
......@@ -23,8 +23,8 @@ before_install:
install:
# Build dependencies
- stack --no-terminal --install-ghc test --only-dependencies -j1
- stack --no-terminal --install-ghc --fast test --only-dependencies -j1
script:
# Build the package and run the tests
- stack --no-terminal test -j1
- stack --no-terminal --fast test -j1
......@@ -17,8 +17,10 @@ import Data.Profunctor
import Data.Abstract.Error
import Data.Abstract.Except
import Data.Abstract.Cache
import qualified Data.Abstract.Widening as W
import Control.DeepSeq
import Control.Category
import Control.Arrow
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Reader
......@@ -164,7 +166,7 @@ main = do
{-# INLINE runExceptT' #-}
runChaoticT'' :: Profunctor c => ChaoticT Cache () () c x y -> c x y
runChaoticT'' = runChaoticT'
runChaoticT'' = runChaoticT' id W.finite
{-# INLINE runChaoticT'' #-}
expr = addN 20 (Num 1)
......
......@@ -9,6 +9,7 @@ category: Language
dependencies:
- base
- containers
- comonad
- hashable
- mtl
- random
......@@ -19,7 +20,14 @@ dependencies:
- profunctors
library:
ghc-options: -Wall
ghc-options:
-Wall
-Wcompat
-Widentities
-Wincomplete-record-updates
-Wincomplete-uni-patterns
-Wpartial-fields
-Wredundant-constraints
source-dirs:
- src
......
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DefaultSignatures #-}
module Control.Arrow.Fix(Fix,ArrowFix(..),liftFix,IterationStrategy) where
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Fix(Fix,Fix',ArrowFix(..),IterationStrategy,transform,filter) where
import Prelude hiding (filter,pred)
import Control.Arrow
import Control.Arrow.Trans
import Data.Profunctor
import Data.Lens(Iso',from,Prism',getMaybe,get,set)
-- | Type family that computes the type of the fixpoint.
type family Fix x y (c :: * -> * -> *) :: * -> * -> *
type family Fix (c :: * -> * -> *) x y :: * -> * -> *
type Fix' c x y = Fix c x y x y
-- | Interface for describing fixpoint computations.
class (Arrow c, Profunctor c) => ArrowFix x y c where
class ArrowFix c where
-- | Computes the fixpoint of an arrow computation.
fix :: (c x y -> c x y) -> c x y
fix :: (c -> c) -> c
type instance Fix x y (->) = (->)
instance ArrowFix x y (->) where
fix f = f (fix f)
default fix :: (c ~ c' x y, ArrowTrans c', Underlying c' x y ~ c'' x' y', ArrowFix (c'' x' y')) => (c -> c) -> c
fix f = lift (fix (unlift . f . lift))
{-# INLINE fix #-}
liftFix :: (Arrow c, Profunctor c, ArrowFix (Dom t x y) (Cod t x y) c,ArrowTrans t) => (t c x y -> t c x y) -> t c x y
liftFix f = lift $ fix (unlift . f . lift)
{-# INLINE liftFix #-}
type instance Fix (->) x y = (->)
instance ArrowFix (x -> y) where
fix f = f (fix f)
type IterationStrategy c a b = c a b -> c a b
transform :: Profunctor c => Iso' a a' -> IterationStrategy c a' b -> IterationStrategy c a b
transform iso strat f = lmap (get iso) (strat (lmap (get (from iso)) f))
{-# INLINE transform #-}
filter :: (Profunctor c, ArrowChoice c, ArrowApply c) => Prism' a a' -> IterationStrategy c a' b -> IterationStrategy c a b
filter pred strat f = proc a -> case getMaybe pred a of
Just a' -> strat (lmap (\x -> set pred x a) f) -<< a'
Nothing -> f -< a
{-# INLINE filter #-}
{-# LANGUAGE FunctionalDependencies #-}
module Control.Arrow.Fix.Cache where
import Control.Arrow
import Data.Profunctor
import Data.Abstract.Stable
class (Arrow c, Profunctor c) => ArrowCache a b c | c -> a, c -> b where
-- | Looks up if there is an entry in the cache.
lookup :: c a (Maybe (Stable,b))
-- | Write a new entry to the cache.
write :: c (a,b,Stable) ()
-- | Update an existing entry in the cache.
update :: c (a,b) (Stable,b)
-- | Set a given entry to stable or unstable.
setStable :: c (Stable,a) ()
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Control.Arrow.Fix.Chaotic where
import Prelude hiding (head)
import Control.Arrow
import Data.HashSet (HashSet)
import qualified Data.HashSet as H
import Data.Identifiable
import Data.Profunctor
import Data.Order
import Text.Printf
class (Arrow c, Profunctor c) => ArrowIterate a c where
-- | Remembers to iterate on an unstable result until it stabilized.
iterate :: c (a,b) b
class (Arrow c, Profunctor c) => ArrowComponent a c | c -> a where
setComponent :: c (Component a,y) y
withComponent :: c x y -> (c (x,y,Component a) y) -> c x y
data Component a = Component { head :: HashSet a, body :: HashSet a } deriving (Eq)
instance Identifiable a => PreOrd (Component a) where
c1 c2 = head c1 head c2 && body c1 body c2
{-# INLINE (⊑) #-}
instance Identifiable a => Complete (Component a) where
c1 c2 = c1 <> c2
{-# INLINE (⊔) #-}
instance Identifiable a => Semigroup (Component a) where
Component h1 b1 <> Component h2 b2 = Component { head = h1 <> h2, body = b1 <> b2 }
{-# INLINE (<>) #-}
instance Identifiable a => Monoid (Component a) where
mempty = Component { head = H.empty, body = H.empty }
mappend = (<>)
{-# INLINE mempty #-}
{-# INLINE mappend #-}
singleton :: Identifiable a => a -> Component a
singleton a = Component { head = H.singleton a, body = H.empty }
{-# INLINE singleton #-}
instance Show a => Show (Component a) where
show (Component h b) = printf "Component { head = %s, body = %s }" (show (H.toList h)) (show (H.toList b))
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Fix.Context where
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.State
import Data.Profunctor
class (Arrow c, Profunctor c) => ArrowContext ctx c | c -> ctx where
askContext :: c () ctx
localContext :: c x y -> c (ctx,x) y
class ArrowJoinContext cache a b c where
type Widening cache a :: *
joinContexts' :: Widening cache a -> IterationStrategy c (cache a b, a) b
joinContexts :: forall a cache b c. (ArrowState (cache a b) c, ArrowJoinContext cache a b c) => Widening cache a -> IterationStrategy c a b
joinContexts widen f = proc a -> do
cache <- get -< ()
joinContexts' widen (proc (cache,a) -> do
put -< cache
f -< a) -< (cache,a)
{-# INLINE joinContexts #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Fix.Reuse where
import Control.Arrow
import Control.Arrow.Fix
import Data.Abstract.Stable
import Data.Metric
import Data.Profunctor
import Data.Monoid
import Text.Printf
class (Arrow c, Profunctor c) => ArrowReuse a b c where
type Dom c :: *
-- | Reuse cached results at the cost of precision.
reuse :: (Monoid m) => (Dom c -> Dom c -> Stable -> b -> m) -> c (a,Stable) m
reuseFirst :: (ArrowChoice c, ArrowReuse a b c) => IterationStrategy c a b
reuseFirst f = proc a -> do
m <- reuse (\_ _ _ b -> First (Just b)) -< (a,Stable)
case getFirst m of
Just b -> returnA -< b
Nothing -> f -< a
{-# INLINE reuseFirst #-}
reuseExact :: (Eq (Dom c), ArrowChoice c, ArrowReuse a b c) => IterationStrategy c a b
reuseExact = reuseByMetric discrete
{-# INLINE reuseExact #-}
reuseByMetric :: (Ord n, ArrowChoice c, ArrowReuse a b c) => Metric (Dom c) n -> IterationStrategy c a b
reuseByMetric metric f = proc a -> do
m <- reuse (\a a' _ b -> Just (Measured { measured = metric a a', argument = b })) -< (a,Stable)
case m of
Just n -> returnA -< argument n
Nothing -> f -< a
{-# INLINE reuseByMetric #-}
data Measured a n = Measured { argument :: a, measured :: n }
instance (Show a, Show n) => Show (Measured a n) where
show m = printf "%s@%s" (show (argument m)) (show (measured m))
instance Ord n => Semigroup (Measured a n) where
m1 <> m2
| measured m1 <= measured m2 = m1
| otherwise = m2
{-# INLINE (<>) #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
module Control.Arrow.Fix.Stack where
import Control.Arrow
import Data.Profunctor
import Data.HashSet
class (Arrow c, Profunctor c) => ArrowStack a c | c -> a where
peek :: c () (Maybe a)
size :: c () Int
push :: c a b -> c a b
elem :: c a Bool
elems :: c () (HashSet a)
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module Control.Arrow.Fix.Widening where
import Control.Arrow
import Data.Profunctor
import Data.Order
import Data.Abstract.Stable
import Data.Abstract.Widening (finite)
class (Arrow c, Profunctor c) => ArrowWidening a c where
widening :: c (a,a) (Stable,a)
instance Complete a => ArrowWidening a (->) where
widening (a,a') = finite a a'
......@@ -3,6 +3,7 @@ module Control.Arrow.Monad where
import Control.Arrow
import Control.Monad (join)
import Control.Comonad
import Data.Profunctor
class (Functor f, Arrow c, Profunctor c) => ArrowFunctor f c where
......@@ -17,3 +18,20 @@ class (Monad f, ArrowFunctor f c) => ArrowMonad f c where
mapJoinA :: c x (f y) -> c (f x) (f y)
mapJoinA f = rmap join (mapA f)
{-# INLINE unitA #-}
{-# INLINE joinA #-}
{-# INLINE mapJoinA #-}
class (Comonad f, ArrowFunctor f c) => ArrowComonad f c where
extractA :: c (f x) x
extractA = arr extract
duplicateA :: c (f x) (f (f x))
duplicateA = arr duplicate
mapDuplicateA :: c (f x) y -> c (f x) (f y)
mapDuplicateA f = lmap duplicate (mapA f)
{-# INLINE extractA #-}
{-# INLINE duplicateA #-}
{-# INLINE mapDuplicateA #-}
......@@ -19,6 +19,7 @@ class (Arrow c, Profunctor c) => ArrowComplete y c where
instance Complete y => ArrowComplete y (->) where
(<>) f g = \x -> f x g x
{-# INLINE (<⊔>) #-}
-- | An arrow computation @c@ is effect commutative iff for all @f, g :: c x y@,
--
......
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Control.Arrow.Reader where
import Control.Arrow
import Control.Monad.Reader (MonadReader)
import qualified Control.Monad.Reader as M
import Data.Profunctor
import Control.Arrow
import Data.Profunctor
-- | Arrow-based interface for read-only values.
class (Arrow c, Profunctor c) => ArrowReader r c | c -> r where
......@@ -15,7 +11,3 @@ class (Arrow c, Profunctor c) => ArrowReader r c | c -> r where
ask :: c () r
-- | Runs a computation with a new value.
local :: c x y -> c (r,x) y
instance MonadReader r m => ArrowReader r (Kleisli m) where
ask = Kleisli (const M.ask)
local (Kleisli f) = Kleisli (\(r,x) -> M.local (const r) (f x))
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
......
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Trans where
import Control.Arrow
import Data.Profunctor
import Data.Coerce
class (Arrow c, Profunctor c) => ArrowRun c where
type Rep c x y
run :: c x y -> Rep c x y
type Run c x y
run :: c x y -> Run c x y
default run :: (Underlying c x y ~ c' x' y', Run c x y ~ Run c' x' y', ArrowRun c', ArrowTrans c) => c x y -> Run c x y
run = run . unlift
{-# INLINE run #-}
instance ArrowRun (->) where
type Rep (->) x y = x -> y
type Run (->) x y = x -> y
run = id
{-# INLINE run #-}
class ArrowLift t where
lift' :: (Arrow c, Profunctor c) => c x y -> t c x y
-- | Lifts an inner computation into an arrow transformer and vice versa.
class ArrowTrans t where
type Dom t x y :: *
type Cod t x y :: *
class ArrowTrans c where
type Underlying c x y :: *
lift :: Underlying c x y -> c x y
unlift :: c x y -> Underlying c x y
default lift :: forall x y. (Coercible (c x y) (Underlying c x y)) => Underlying c x y -> c x y
lift = coerce
{-# INLINE lift #-}
default unlift :: forall x y. (Coercible (c x y) (Underlying c x y)) => c x y -> Underlying c x y
unlift = coerce
{-# INLINE unlift #-}
lift1 :: ArrowTrans c => (Underlying c x y -> Underlying c x' y') -> (c x y -> c x' y')
lift1 f = lift . f . unlift
{-# INLINE lift1 #-}
lift :: (Arrow c, Profunctor c) => c (Dom t x y) (Cod t x y) -> t c x y
unlift :: (Arrow c, Profunctor c) => t c x y -> c (Dom t x y) (Cod t x y)
unlift1 :: ArrowTrans c => (c x y -> c x' y') -> (Underlying c x y -> Underlying c x' y')
unlift1 f = unlift . f . lift
{-# INLINE unlift1 #-}
......@@ -44,12 +44,11 @@ type Env var addr val = (HM.HashMap var addr,HM.HashMap addr val)
type Alloc c var addr val = c (var,val,Env var addr val) addr
newtype EnvT var addr val c x y = EnvT (ConstT (Alloc c var addr val) (ReaderT (Env var addr val) c) x y )
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowFail e, ArrowComplete z, ArrowLowerBounded)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowFail e, ArrowComplete z, ArrowLowerBounded, ArrowTrans)
deriving instance ArrowExcept e c => ArrowExcept e (EnvT var addr val c)
runEnvT :: (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Profunctor c)
=> Alloc c var addr val -> EnvT var addr val c x y -> c (Env var addr val,x) y
runEnvT :: Alloc c var addr val -> EnvT var addr val c x y -> c (Env var addr val,x) y
runEnvT alloc (EnvT f) = runReaderT (runConstT alloc f)
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Profunctor c) =>
......@@ -73,16 +72,10 @@ instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Prof
(_,store) <- Reader.ask -< ()
Reader.local f -< ((env,store),x)
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, ArrowRun c) => ArrowRun (EnvT var addr val c) where
type Rep (EnvT var addr val c) x y = Alloc c var addr val -> Rep c (Env var addr val,x) y
instance (ArrowChoice c, ArrowRun c) => ArrowRun (EnvT var addr val c) where
type Run (EnvT var addr val c) x y = Alloc c var addr val -> Run c (Env var addr val,x) y
run f alloc = run (runEnvT alloc f)
instance ArrowTrans (EnvT var addr val) where
type Dom (EnvT var addr val) x y = (Env var addr val,x)
type Cod (EnvT var addr val) x y = y
lift = undefined
unlift = undefined
instance ArrowLift (EnvT var addr val) where
lift' f = EnvT (lift' (lift' f))
......@@ -94,6 +87,5 @@ instance ArrowReader r c => ArrowReader r (EnvT var addr val c) where
instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var addr val c) where
app = EnvT (app .# first coerce)
deriving instance ArrowFix (Dom (EnvT var addr val) x y) (Cod (EnvT var addr val) x y) c => ArrowFix x y (EnvT var addr val c)
type instance Fix x y (EnvT var addr val c) = EnvT var addr val (Fix (Dom (EnvT var addr val) x y) (Cod (EnvT var addr val) x y) c)
type instance Fix (EnvT var addr val c) x y = EnvT var addr val (Fix c (Env var addr val,x) y)
deriving instance (Arrow c, Profunctor c, ArrowFix (c (Env var addr val,x) y)) => ArrowFix (EnvT var addr val c x y)
......@@ -43,8 +43,8 @@ runCompletionT = coerce
instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (CompletionT c) where
app = lift (app .# first coerce)
type instance Fix x y (CompletionT c) = CompletionT (Fix (Dom (CompletionT) x y) (Cod (CompletionT) x y) c)
deriving instance (ArrowChoice c, ArrowFix (Dom (CompletionT) x y) (Cod (CompletionT) x y) c) => ArrowFix x y (CompletionT c)
type instance Fix (CompletionT c) x y = CompletionT (Fix c x (FreeCompletion y))
deriving instance (ArrowFix (Underlying (CompletionT c) x y)) => ArrowFix (CompletionT c x y)
instance (ArrowChoice c, ArrowLowerBounded c) => ArrowLowerBounded (CompletionT c) where
bottom = lift $ bottom
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Abstract.Contour(ContourT,runContourT,contour,CallString) where
import Prelude hiding (id,(.),lookup)
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Environment
import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.Reader as Reader
import Control.Arrow.State
import Control.Arrow.Order
import Control.Arrow.Transformer.Reader
import Control.Category
import Data.Label
import Data.CallString
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
-- | Records the k-bounded call string. Meant to be used in
-- conjunction with 'Abstract.BoundedEnvironment'.
newtype ContourT lab c a b = ContourT (ReaderT (CallString lab) c a b)
deriving (Profunctor,Category,Arrow,ArrowLift,ArrowChoice,
ArrowConst r, ArrowState s,
ArrowEnv var val, ArrowClosure var val env,
ArrowFail e, ArrowExcept e, ArrowLowerBounded, ArrowComplete z)
-- | Runs a computation that records a call string. The argument 'k'
-- specifies the maximum length of a call string. All larger call
-- strings are truncated to at most 'k' elements.
runContourT :: (Arrow c, Profunctor c) => Int -> ContourT lab c a b -> c a b
runContourT k (ContourT (ReaderT f)) = lmap (\a -> (empty k,a)) f
{-# INLINE runContourT #-}
contour :: (Arrow c, Profunctor c) => ContourT lab c () (CallString lab)
contour = ContourT Reader.ask
instance ArrowRun c => ArrowRun (ContourT lab c) where
type Rep (ContourT lab c) x y = Int -> Rep c x y
run f i = run (runContourT i f)
{-# INLINE run #-}
type instance Fix x y (ContourT lab c) = ContourT lab (Fix x y c)
instance (ArrowFix x y c, ArrowApply c, HasLabel x lab,Profunctor c) => ArrowFix x y (ContourT lab c) where
-- Pushes the label of the last argument on the call string and truncate the call string in case it reached the maximum length
fix f = ContourT $ ReaderT $ proc (c,x) -> fix (unwrap c . f . wrap) -<< x
where
wrap :: (Arrow c, Profunctor c) => c x y -> ContourT lab c x y
wrap = lift'
unwrap :: (HasLabel x lab, Arrow c, Profunctor c) => CallString lab -> ContourT lab c x y -> c x y
unwrap c (ContourT (ReaderT f')) = proc x -> do
y <- f' -< (push (label x) c,x)
returnA -< y
instance (ArrowApply c, Profunctor c) => ArrowApply (ContourT lab c) where
app = ContourT (app .# first coerce)
instance ArrowReader r c => ArrowReader r (ContourT lab c) where
ask = lift' Reader.ask
local (ContourT (ReaderT f)) = ContourT $ ReaderT $ ((\(c,(r,x)) -> (r,(c,x))) ^>> Reader.local f)
......@@ -37,11 +37,11 @@ newtype EnvT var val c x y = EnvT (ReaderT (Map var val) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowLowerBounded, ArrowComplete z,
ArrowState s, ArrowFail e, ArrowExcept e, ArrowStore var' val', ArrowConst k, ArrowRun)
runEnvT :: (Arrow c, Profunctor c) => EnvT var val c x y -> c (Map var val,x) y
runEnvT :: EnvT var val c x y -> c (Map var val,x) y
runEnvT = coerce
{-# INLINE runEnvT #-}
runEnvT' :: (Arrow c, Profunctor c, Identifiable var) => EnvT var val c x y -> c ([(var,val)],x) y
runEnvT' :: (Profunctor c, Identifiable var) => EnvT var val c x y -> c ([(var,val)],x) y
runEnvT' f = lmap (first M.fromList) (runEnvT f)
{-# INLINE runEnvT' #-}
......@@ -68,5 +68,5 @@ instance ArrowReader r c => ArrowReader r (EnvT var val c) where
ask = lift' Reader.ask
local f = lift $ lmap (\(env,(r,x)) -> (r,(env,x))) (Reader.local (unlift f))
type instance Fix x y (EnvT var val c) = EnvT var val (Fix (Dom (EnvT var val) x y) (Cod (EnvT var val) x y) c)
deriving instance ArrowFix (Map var val,x) y c => ArrowFix x y (EnvT var val c)
type instance Fix (EnvT var val c) x y = EnvT var val (Fix c (Map var val,x) y)
deriving instance ArrowFix (Underlying (EnvT var val c) x y) => ArrowFix (EnvT var val c x y)
......@@ -46,8 +46,8 @@ instance (ArrowChoice c, Profunctor c) => ArrowFail e (ErrorT e c) where
instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (ErrorT e c) where
app = lift (app .# first coerce)
type instance Fix x y (ErrorT e c) = ErrorT e (Fix (Dom (ErrorT e) x y) (Cod (ErrorT e) x y) c)
deriving instance (ArrowChoice c, ArrowFix (Dom (ErrorT e) x y) (Cod (ErrorT e) x y) c) => ArrowFix x y (ErrorT e c)
type instance Fix (ErrorT e c) x y = ErrorT e (Fix c x (Error e y))
deriving instance (ArrowFix (Underlying (ErrorT e c) x y)) => ArrowFix (ErrorT e c x y)
instance (ArrowChoice c, ArrowLowerBounded c) => ArrowLowerBounded (ErrorT e c) where
bottom = lift bottom
......
......@@ -57,8 +57,8 @@ instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowApply c, Profunctor c) =>
app = lift (app .# first coerce)
{-# INLINE app #-}
type instance Fix x y (ExceptT e c) = ExceptT e (Fix (Dom (ExceptT e) x y) (Cod (ExceptT e) x y) c)
deriving instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowFix (Dom (ExceptT e) x y) (Cod (ExceptT e) x y) c) => ArrowFix x y (ExceptT e c)
type instance Fix (ExceptT e c) x y = ExceptT e (Fix c x (Except e y))
instance ArrowFix (Underlying (ExceptT e c) x y) => ArrowFix (ExceptT e c x y)
deriving instance (Complete e, ArrowChoice c, ArrowJoin c, ArrowComplete (Except e y) c) => ArrowComplete y (ExceptT e c)
......
......@@ -47,6 +47,5 @@ instance (ArrowChoice c, Profunctor c) => ArrowFail e (FailureT e c) where
instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (FailureT e c) where
app = lift (app .# first coerce)
type instance Fix x y (FailureT e c) = FailureT e (Fix (Dom (FailureT e) x y) (Cod (FailureT e) x y) c)
deriving instance (ArrowChoice c, ArrowFix (Dom (FailureT e) x y) (Cod (FailureT e) x y) c) =>
ArrowFix x y (FailureT e c)
type instance Fix (FailureT e c) x y = FailureT e (Fix c x y)
instance (ArrowChoice c, ArrowFix (Underlying (FailureT e c) x y)) => ArrowFix (FailureT e c x y)
......@@ -21,8 +21,6 @@ import Control.Arrow.Order
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Static
import Data.Identifiable
import Data.Order
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
......@@ -30,18 +28,17 @@ import Data.Coerce
newtype FixT a b c x y = FixT { unFixT :: ConstT (IterationStrategy c a b) c x y }
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowComplete z, ArrowJoin)
runFixT :: (Identifiable a, PreOrd b)
=> IterationStrategy c a b -> FixT a b c x y -> c x y
runFixT :: IterationStrategy c a b -> FixT a b c x y -> c x y
runFixT iterationStrat (FixT f) = runConstT iterationStrat f
{-# INLINE runFixT #-}
instance ArrowRun c => ArrowRun (FixT a b c) where
type Rep (FixT a b c) x y = IterationStrategy c a b -> Rep c x y
type Run (FixT a b c) x y = IterationStrategy c a b -> Run c x y
run (FixT f) iterationStrat = run (runConstT iterationStrat f)
{-# INLINE run #-}
type instance Fix x y (FixT _ _ c) = FixT x y c
instance (Profunctor c,ArrowChoice c,ArrowApply c) => ArrowFix a b (FixT a b c) where
type instance Fix (FixT _ _ c) x y = FixT x y c
instance (Profunctor c,ArrowChoice c) => ArrowFix (FixT a b c a b) where
fix f = iterationStrategy (f (fix f))
instance (Profunctor c,ArrowApply c) => ArrowApply (FixT a b c) where
......
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Control.Arrow.Transformer.Abstract.Fix.Cache where
import Prelude hiding (pred,lookup,map,head,iterate,(.),truncate,elem)
import Control.Category
import Control.Arrow
import Control.Arrow.Trans
import Control.Arrow.State
import Control.Arrow.Fix.Context as Context hiding (Widening)
import Control.Arrow.Order(ArrowJoin(..),ArrowComplete(..),ArrowEffectCommutative)
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.State
import Data.Profunctor.Unsafe
import Data.Empty
import Data.Order
import Data.Coerce
import Data.Abstract.Widening
newtype CacheT cache a b c x y = CacheT { unCacheT :: ConstT (Widening b) (StateT (cache a b) c) x y}
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowContext ctx,ArrowState (cache a b))
runCacheT :: (IsEmpty (cache a b), Profunctor c) => Widening b -> CacheT cache a b c x y -> c x (cache a b,y)
runCacheT widen (CacheT f) = lmap (\x -> (empty,x)) (runStateT (runConstT widen f))
{-# INLINE runCacheT #-}
liftCacheT :: Arrow c => CacheT cache' a' b c x y -> CacheT cache a b c (cache' a' b,x) (cache' a' b,y)
liftCacheT (CacheT f) = CacheT (lift $ \widen -> (withStateT (runConstT widen f)))
{-# INLINE liftCacheT #-}
liftCacheT' :: Arrow c => CacheT cache' a' b c x y -> ConstT (Widening b) (StateT (cache a b) c) (cache' a' b,x) (cache' a' b,y)
liftCacheT' = coerce liftCacheT
{-# INLINE liftCacheT' #-}
instance (IsEmpty (cache a b), ArrowRun c) => ArrowRun (CacheT cache a b c) where
type Run (CacheT cache a b c) x y = Widening b -> Run c x (cache a b,y)
run f widen = run (runCacheT widen f)
{-# INLINE run #-}
instance (Complete y, ArrowEffectCommutative c) => ArrowComplete y (CacheT cache a b c) where
CacheT f <> CacheT g = CacheT $ rmap (uncurry ()) (f &&& g)
{-# INLINE (<⊔>) #-}
instance (Arrow c, Profunctor c) => ArrowJoin (CacheT cache a b c) where
joinSecond (CacheT f) = CacheT (second f)
{-# INLINE joinSecond #-}
instance (Profunctor c,ArrowApply c) => ArrowApply (CacheT cache a b c) where
app = CacheT (app .# first coerce)
{-# INLINE app #-}
instance ArrowEffectCommutative c => ArrowEffectCommutative (CacheT cache a b c)
{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.Cache.Basic where
import Prelude hiding (pred,lookup,map,head,iterate,(.))
import Control.Arrow
import Control.Arrow.Fix.Reuse
import Control.Arrow.Fix.Cache
import Control.Arrow.State
import Control.Arrow.Const
import Control.Arrow.Transformer.Abstract.Fix.Cache
import Data.Order
import Data.Profunctor
import Data.Identifiable
import Data.Empty
import Data.HashMap.Lazy(HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Abstract.Stable
newtype Cache a b = Cache { getMap :: HashMap a (Stable,b)}
instance (Show a, Show b) => Show (Cache a b) where
show (Cache m) = show (M.toList m)
instance IsEmpty (Cache a b) where
empty = Cache M.empty
{-# INLINE empty #-}
instance (Identifiable a, ArrowChoice c, Profunctor c) => ArrowCache a b (CacheT Cache a b c) where
lookup = CacheT $ proc a -> do
Cache cache <- get -< ()
returnA -< M.lookup a cache
update = CacheT $ askConst $ \widen -> proc (a,b) -> do
Cache cache <- get -< ()
case M.lookup a cache of
Just (_,b') -> do
let b'' = widen b' b
put -< Cache (M.insert a b'' cache)
returnA -< b''
Nothing -> do
put -< Cache (M.insert a (Unstable,b) cache)
returnA -< (Unstable,b)
write = CacheT $ modify' (\((a,b,s),Cache cache) -> ((),Cache (M.insert a (s,b) cache)))
setStable = CacheT $ modify' $ \((s,a),Cache cache) -> ((),Cache (M.adjust (first (const s)) a cache))
{-# INLINE lookup #-}
{-# INLINE write #-}
{-# INLINE update #-}
{-# INLINE setStable #-}
instance (PreOrd a, Arrow c, Profunctor c) => ArrowReuse a b (CacheT Cache a b c) where
type Dom (CacheT Cache a b c) = a
reuse f = CacheT $ proc (a,s) -> do
Cache cache <- get -< ()
returnA -< M.foldlWithKey' (\m a' (s',b') -> if s' s && a a' then m <> f a a' s' b' else m) mempty cache
{-# INLINE reuse #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.Cache.ContextSensitive
( module Control.Arrow.Transformer.Abstract.Fix.Cache
, Cache(..)
) where
import Prelude hiding (pred,lookup,map,head,iterate,(.),truncate,elem)
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.State
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Context as Context
import Control.Arrow.Fix.Reuse as Reuse
import Control.Arrow.Transformer.Abstract.Fix.Cache
import Data.Identifiable
import Data.Profunctor.Unsafe
import Data.Empty
import Data.Order
import Data.Abstract.Widening as W
import Data.Abstract.Stable
import Data.HashMap.Lazy(HashMap)
import qualified Data.HashMap.Lazy as M
newtype Cache ctx a b = Cache (HashMap ctx (a,b,Stable)) deriving (Show)
instance IsEmpty (Cache ctx a b) where
empty = Cache M.empty
{-# INLINE empty #-}
instance (Identifiable ctx, PreOrd a, LowerBounded b, ArrowChoice c, ArrowContext ctx c) => ArrowJoinContext (Cache ctx) a b c where
type Widening (Cache ctx) a = W.Widening a
joinContexts' widen f = proc (Cache cache,a) -> do
ctx <- askContext -< ()
(f ||| returnA) -< case M.lookup ctx cache of
-- If there exists a stable cached entry and the actual input is
-- smaller than the cached input, recurse the cached result.
Just (a',b,s)
| a a' -> case s of
Stable -> Right b
Unstable -> Left (Cache cache,a')
| otherwise ->
-- If there exists the actual input is not smaller than the cached
-- input, widen the input and recompute.
let (_,a'') = widen a' a
in Left (Cache (M.insert ctx (a'',b,Unstable) cache), a'')
Nothing -> Left (Cache (M.insert ctx (a,bottom,Unstable) cache), a)
{-# INLINE joinContexts' #-}
instance (Identifiable ctx, PreOrd a, Eq a, Complete b, ArrowChoice c, Profunctor c, ArrowContext ctx c)
=> ArrowCache a b (CacheT (Cache ctx) a b c) where
lookup = CacheT $ proc a -> do
ctx <- askContext -< ()
Cache cache <- get -< ()
case M.lookup ctx cache of
Just (a',b,s)
| a a' -> returnA -< Just (s,b)
| otherwise -> returnA -< Just (Unstable,b)
Nothing -> returnA -< Nothing
update = CacheT $ askConst $ \widening -> proc (a,b) -> do
ctx <- askContext -< ()
Cache cache <- get -< ()
case M.lookup ctx cache of
Just (a',b',_) -> do
let (s,b'') = widening b' b
put -< Cache (M.insert ctx (a',b'',if a == a' then s else Unstable) cache)
returnA -< (s,b'')
Nothing -> do
put -< Cache (M.insert ctx (a,b,Unstable) cache)
returnA -< (Unstable,b)
write = CacheT $ proc (a,b,s) -> do
ctx <- askContext -< ()
Cache cache <- get -< ()
case M.lookup ctx cache of
Just (a',b',s') -> do
let b'' = b b'
put -< Cache (M.insert ctx (a',b'',if a == a' then s else s') cache)
Nothing ->
put -< Cache (M.insert ctx (a,b,s) cache)
setStable = CacheT $ proc (s,a) -> do
Cache cache <- get -< ()
ctx <- askContext -< ()
put -< Cache (M.adjust (\(a',b',s') -> (a',b',if a == a' then s else s')) ctx cache)
{-# INLINE lookup #-}
{-# INLINE update #-}
{-# INLINE write #-}
{-# INLINE setStable #-}
instance (PreOrd a, Arrow c, Profunctor c) => ArrowReuse a b (CacheT (Cache ctx) a b c) where
type Dom (CacheT (Cache ctx) a b c) = a
reuse f = CacheT $ proc (a,s) -> do
Cache cache <- get -< ()
returnA -< M.foldl' (\m (a',b',s') -> if s' s && a a' then m <> f a a' s' b' else m) mempty cache
{-# INLINE reuse #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.Cache.Group where
import Prelude hiding (pred,lookup,map,head,iterate,(.))
import Control.Arrow
import Control.Arrow.Fix.Reuse
import Control.Arrow.Fix.Context
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.State
import Control.Arrow.Transformer.Abstract.Fix.Cache
import Control.Arrow.Transformer.Reader
import Data.Profunctor
import Data.Identifiable
import Data.Empty
import Data.HashMap.Lazy(HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Maybe (fromMaybe)
import Data.Monoidal
data Group cache a b where
Groups :: HashMap k (cache a b) -> Group cache (k,a) b
instance (Show k, Show (cache a b)) => Show (Group cache (k,a) b) where
show (Groups m) = show (M.toList m)
instance IsEmpty (Group cache (k,a) b) where
empty = Groups empty
{-# INLINE empty #-}
instance (Identifiable k, IsEmpty (cache a b), Arrow c, ArrowJoinContext cache a b (ReaderT (k,Group cache (k,a) b) c)) => ArrowJoinContext (Group cache) (k,a) b c where
type Widening (Group cache) (k,a) = Widening cache a
joinContexts' widen f = proc (g,(k,a)) -> do
let Groups groups = g
runReaderT (joinContexts' widen (ReaderT (proc ((k,g),(cache,a)) -> do
let Groups groups = g
f -< (Groups (M.insert k cache groups),(k,a))
))) -< ((k,g),(fromMaybe empty (M.lookup k groups),a))
{-# INLINE joinContexts' #-}
instance (Identifiable k, Arrow c, Profunctor c, ArrowCache a b (CacheT cache a b c), IsEmpty (cache a b)) => ArrowCache (k,a) b (CacheT (Group cache) (k,a) b c) where
lookup = withCache Cache.lookup
update = lmap assoc2 (withCache Cache.update)
write = lmap (\((k,a),b,s) -> (k,(a,b,s))) (withCache Cache.write)
setStable = lmap shuffle1 (withCache Cache.setStable)
{-# INLINE lookup #-}
{-# INLINE update #-}
{-# INLINE write #-}
{-# INLINE setStable #-}
instance (Identifiable k, IsEmpty (cache a b), Arrow c, Profunctor c, ArrowReuse a b (CacheT cache a b c)) => ArrowReuse (k,a) b (CacheT (Group cache) (k,a) b c) where
type Dom (CacheT (Group cache) (k,a) b c) = Dom (CacheT cache a b c)
reuse f = lmap (\((k,a),s) -> (k,(a,s))) (withCache (reuse f))
{-# INLINE reuse #-}
withCache :: (Identifiable k, IsEmpty (cache a b), Arrow c, Profunctor c) => CacheT cache a b c x y -> CacheT (Group cache) (k,a) b c (k,x) y
withCache f = CacheT $ modify $ proc ((k,x),g) -> do
let Groups groups = g
(cache',y) <- liftCacheT' f -< (fromMaybe empty (M.lookup k groups),x)
returnA -< (y,Groups (M.insert k cache' groups))
{-# INLINE withCache #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.Context where
import Prelude hiding (lookup,truncate)
import Control.Category
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Fix.Context
import Control.Arrow.Fix.Cache
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.Order
import Control.Arrow.Transformer.Reader
import Data.Profunctor.Unsafe
import Data.Coerce
import Data.Empty
import Data.Abstract.CallString
callsiteSensitive :: (ArrowContext (CallString lab) c) => Int -> (a -> lab) -> IterationStrategy c a b
callsiteSensitive k getLabel f = proc a -> do
callString <- askContext -< ()
localContext f -< (truncate k (push (getLabel a) callString),a)
{-# INLINE callsiteSensitive #-}
newtype ContextT ctx c x y = ContextT (ReaderT ctx c x y)
deriving (Category,Arrow,ArrowChoice,Profunctor,ArrowTrans,ArrowLift,ArrowComplete z,ArrowJoin,ArrowCache a b)
instance (Arrow c, Profunctor c) => ArrowContext ctx (ContextT ctx c) where
askContext = ContextT ask
localContext (ContextT f) = ContextT (local f)
{-# INLINE askContext #-}
{-# INLINE localContext #-}
runContextT :: (IsEmpty ctx, Profunctor c) => ContextT ctx c x y -> c x y
runContextT (ContextT f) = lmap (\x -> (empty,x)) (runReaderT f)
{-# INLINE runContextT #-}
instance (IsEmpty ctx, ArrowRun c) => ArrowRun (ContextT ctx c) where
type Run (ContextT ctx c) x y = Run c x y
run f = run (runContextT f)
{-# INLINE run #-}
instance ArrowEffectCommutative c => ArrowEffectCommutative (ContextT ctx c)
instance (Profunctor c,ArrowApply c) => ArrowApply (ContextT ctx c) where
app = ContextT (app .# first coerce)
{-# INLINE app #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.Finite where
import Prelude hiding ((.))
import Data.Coerce
import Data.Empty
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Identifiable
import Data.Order
import Data.Profunctor
import Data.Profunctor.Unsafe
import Control.Category
import Control.Arrow
import Control.Arrow.Order
import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.State
import Control.Arrow.Transformer.State
newtype FiniteT a b c x y = FiniteT (StateT (HashMap a b) c x y)
deriving (Category,Arrow,ArrowChoice,ArrowTrans,Profunctor)
runFiniteT :: Profunctor c => FiniteT a b c x y -> c x (HashMap a b,y)
runFiniteT (FiniteT f) = lmap (\x -> (empty,x)) (runStateT f)
finite :: (Identifiable a, Arrow c,Profunctor c) => IterationStrategy (FiniteT a b c) a b
finite (FiniteT f) = FiniteT $ proc a -> do
b <- f -< a
modify' (\((a,b),m) -> (b,M.insert a b m)) -< (a,b)
instance ArrowRun c => ArrowRun (FiniteT a b c) where
type Rep (FiniteT a b c) x y = Rep c x (HashMap a b,y)
run = run . runFiniteT
instance (Profunctor c, Arrow c, Complete y) => ArrowComplete y (FiniteT a b c) where
FiniteT f <> FiniteT g = FiniteT $ dimap (\x -> (x,x)) (\(y1,y2) -> y1 y2) (f *** g)
instance (Profunctor c, ArrowApply c) => ArrowApply (FiniteT a b c) where
app = FiniteT (app .# first coerce)
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.IterationStrategy(
IterationStrategy, trace, filter,
module Control.Arrow.Transformer.Abstract.Fix.StackWidening,
module Control.Arrow.Transformer.Abstract.Fix.Parallel,
module Control.Arrow.Transformer.Abstract.Fix.Chaotic,
module Control.Arrow.Transformer.Abstract.Fix.Finite
) where
import Prelude hiding (pred,filter)
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Transformer.Abstract.Fix.StackWidening
import Control.Arrow.Transformer.Abstract.Fix.Parallel
import Control.Arrow.Transformer.Abstract.Fix.Chaotic
import Control.Arrow.Transformer.Abstract.Fix.Finite
import Data.Profunctor
import Data.Lens (Prism',getMaybe,set)
import qualified Debug.Trace as Debug
import Text.Printf
trace :: (Show a, Show b, Arrow c) => IterationStrategy c a b -> IterationStrategy c a b
trace strat f = proc x -> do
y <- strat f -< Debug.trace (printf "CALL\n%s\n\n" (show x)) x
returnA -< Debug.trace (printf "RETURN\neval(%s)\n\t= %s\n\n" (show x) (show y)) y
filter :: (Profunctor c, ArrowChoice c, ArrowApply c) => Prism' a a' -> IterationStrategy c a' b -> IterationStrategy c a b
filter pred strat f = proc a -> case getMaybe pred a of
Just a' -> strat (lmap (\x -> set pred x a) f) -<< a'
Nothing -> f -< a
......@@ -8,100 +8,92 @@
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.Parallel where
import Prelude hiding (pred,lookup,map,head,iterate,(.))
-- import Prelude hiding (pred,lookup,map,head,iterate,(.))
import Control.Category
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.State
import Control.Arrow.Reader
import Control.Arrow.Trans
import Control.Arrow.Order(ArrowComplete(..),ArrowJoin(..),ArrowEffectCommutative)
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
-- import Control.Category
-- import Control.Arrow
-- import Control.Arrow.Fix
-- import Control.Arrow.State
-- import Control.Arrow.Reader
-- import Control.Arrow.Trans
-- import Control.Arrow.Cache
-- import Control.Arrow.Order(ArrowComplete(..),ArrowJoin(..),ArrowEffectCommutative)
-- import Control.Arrow.Transformer.Reader
-- import Control.Arrow.Transformer.State
import Data.Profunctor
import Data.Order
import qualified Data.HashSet as H
import Data.Identifiable
import Data.Empty
import Data.Coerce
-- import Data.Profunctor
-- import Data.Order
-- import qualified Data.HashSet as H
-- import Data.Identifiable
-- import Data.Empty
-- import Data.Coerce
-- import Data.HashMap.Lazy(HashMap)
-- import qualified Data.HashMap.Lazy as M
import Data.Abstract.Cache(IsCache)
import qualified Data.Abstract.Cache as Cache
import Data.Abstract.StackWidening(Stack(..))
import Data.Abstract.Widening(Stable(..))
import qualified Data.Abstract.Widening as W
-- import Data.Abstract.StackWidening(Stack(..))
-- import Data.Abstract.Widening(Stable(..))
-- import qualified Data.Abstract.Widening as W
data Iteration cache a b = Iteration { old :: cache a b, new :: cache a b, stable :: Stable }
newtype ParallelT cache a b c x y = ParallelT (ReaderT (Stack a) (StateT (Iteration cache a b) c) x y)
deriving (Profunctor,Category,Arrow,ArrowChoice)
-- data Iteration a b = Iteration { old :: HashMap a b, new :: HashMap a b, stable :: Stable }
-- newtype ParallelT a b c x y = ParallelT (StateT (Iteration a b) c x y)
-- deriving (Profunctor,Category,Arrow,ArrowChoice)
runParallelT :: (IsCache cache a b, Profunctor c) => ParallelT cache a b c x y -> c x (cache a b,y)
runParallelT (ParallelT f) = dimap (\a -> (empty,(empty,a))) (first new) (runStateT (runReaderT f))
-- runParallelT :: (Profunctor c) => ParallelT cache a b c x y -> c x (HashMap a b,y)
-- runParallelT (ParallelT f) = dimap (\a -> (empty,a)) (first new) (runStateT f)
execParallelT :: (IsCache cache a b, Profunctor c) => ParallelT cache a b c x y -> c x (cache a b)
execParallelT f = rmap fst (runParallelT f)
evalParallelT :: (IsCache cache a b, Profunctor c) => ParallelT cache a b c x y -> c x y
evalParallelT f = rmap snd (runParallelT f)
parallel :: (Identifiable a, IsCache cache a b, Profunctor c, ArrowChoice c) => Cache.Widening (Iteration cache) a b -> IterationStrategy (ParallelT cache a b c) a b
parallel widen (ParallelT f) = ParallelT $ push $ proc (xs,a) -> do
cache <- get -< ()
case Cache.lookup a cache of
Just (_,b) | H.member a xs -> returnA -< b
_ -> iterate -< (xs,a)
where
iterate = proc (xs,a) -> do
modify' (\(a,cache) -> ((),Cache.initialize a cache)) -< a
b <- f -< a
(st,b') <- modify' (\((a,b),cache) -> Cache.update widen a b cache) -< (a,b)
cache <- get -< ()
if H.null xs && st == Instable
then do
put -< cache { new = empty, old = new cache, stable = Stable }
iterate -< (xs,a)
else
returnA -< b'
-- parallel :: (Identifiable a, Profunctor c, ArrowChoice c) => W.Widening b -> IterationStrategy (ParallelT a b c) a b
-- parallel widen (ParallelT f) = ParallelT $ push $ memoize $ proc (r,a) -> do
-- case r of
-- Just (_,b) | H.member a xs -> returnA -< b
-- _ -> iterate -< (xs,a)
-- where
-- iterate = proc (xs,a) -> do
-- modify' (\(a,cache) -> ((),Cache.initialize a cache)) -< a
-- b <- f -< a
-- (st,b') <- modify' (\((a,b),cache) -> Cache.update widen a b cache) -< (a,b)
-- cache <- get -< ()
-- if H.null xs && st == Instable
-- then do
-- put -< cache { new = empty, old = new cache, stable = Stable }
-- iterate -< (xs,a)
-- else
-- returnA -< b'
push g = proc a -> do
Stack xs <- ask -< ()
local g -< (Stack (H.insert a xs),(xs,a))
instance IsCache cache a b => IsCache (Iteration cache) a b where
type Widening (Iteration cache) a b = Cache.Widening cache a b
initialize a cache =
case (Cache.lookup a (old cache), Cache.lookup a (new cache)) of
(Just (st,b), Nothing) ->
let new' = Cache.insert a b st (new cache)
in cache { new = new', stable = stable cache st }
(Nothing, Nothing) ->
let new' = Cache.initialize a (new cache)
in cache { new = new', stable = Instable }
(_,_) -> cache
insert a b st cache = cache { new = Cache.insert a b st (new cache)
, stable = stable cache st }
setStable a cache = cache { new = Cache.setStable a (new cache)}
update widen a b cache =
let ((st,b'),new') = Cache.update widen a b (new cache)
st' = stable cache st
in ((st',b'),cache { new = new', stable = st' })
lookup a cache = do
(st,b) <- Cache.lookup a (new cache)
return (stable cache st, b)
-- push g = proc a -> do