Commit 3d17cf95 authored by Sven Keidel's avatar Sven Keidel

add context-sensitivity transormer

parent 4fe6f30f
Pipeline #15145 failed with stages
in 8 minutes and 54 seconds
......@@ -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 FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
module Control.Arrow.Cache where
import Control.Arrow
import Data.Profunctor
import Data.Abstract.Widening (Stable)
data Cached b = Compute | Cached (Stable,b)
deriving (Show,Eq)
class (Arrow c, Profunctor c) => ArrowCache a b c | c -> a, c -> b where
memoize :: c (a,Cached b) y -> c a y
write :: c (a,b,Stable) ()
update :: c (a,b) (Stable,b)
setStable :: c (Stable,a) ()
{-# 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,ArrowFix(..),IterationStrategy,filter,trace) where
import Prelude hiding (filter,pred)
import Control.Arrow
import Control.Arrow.Trans
import qualified Debug.Trace as Debug
import Control.Arrow
import Control.Arrow.Trans
import Data.Profunctor
import Data.Profunctor
import Data.Lens(Prism',getMaybe,set)
import Text.Printf
-- | Type family that computes the type of the fixpoint.
type family Fix x y (c :: * -> * -> *) :: * -> * -> *
type family Fix (c :: * -> * -> *) 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
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
trace :: (Show a, Show b, Arrow c) => IterationStrategy c a b -> IterationStrategy c a b
trace strat f = proc x -> do
strat (proc x -> do
y <- f -< x
returnA -< Debug.trace (printf "RETURN\neval(%s)\n\t= %s\n\n" (show x) (show y)) y)
-< Debug.trace (printf "CALL\n%s\n\n" (show x)) x
......@@ -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 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)
{-# LANGUAGE Arrows #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module Control.Arrow.Transformer.Abstract.Fix(FixT,runFixT) where
import Prelude hiding (id,(.),const,head,iterate,lookup)
import Control.Category
import Control.Arrow hiding (loop)
import Control.Arrow.Fix
import Control.Arrow.Trans
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
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 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
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
fix f = iterationStrategy (f (fix f))
instance (Profunctor c,ArrowApply c) => ArrowApply (FixT a b c) where
app = FixT (app .# first coerce)
{-# INLINE app #-}
instance ArrowLift (FixT a b) where
lift' = FixT . lift'
{-# INLINE lift' #-}
instance ArrowEffectCommutative c => ArrowEffectCommutative (FixT a b c)
----- Helper functions -----
iterationStrategy :: FixT a b c a b -> FixT a b c a b
iterationStrategy (FixT (ConstT (StaticT f))) = FixT $ ConstT $ StaticT $ \strat -> strat (f strat)
{-# INLINE iterationStrategy #-}
......@@ -5,126 +5,125 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Abstract.Fix.Chaotic where
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Control.Arrow.Transformer.Abstract.Fix.Chaotic(ChaoticT,runChaoticT,chaotic) where
import Prelude hiding (pred,lookup,map,head,iterate,(.))
import Prelude hiding (pred,lookup,map,head,iterate,(.),elem)
import Control.Category
import Control.Arrow
import Control.Arrow hiding (loop)
import Control.Arrow.Fix
import Control.Arrow.Reader
import Control.Arrow.Cache as Cache
import Control.Arrow.Trans
import Control.Arrow.Order(ArrowComplete(..),ArrowJoin(..),ArrowEffectCommutative)
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Arrow.Utils
import Control.Arrow.Transformer.Writer
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Static
import Data.Profunctor
import Data.Order
import Data.HashSet(HashSet)
import qualified Data.HashSet as H
import Data.Identifiable
import Data.Empty
import Data.Coerce
import Data.Abstract.Cache (IsCache)
import qualified Data.Abstract.Cache as Cache
import Data.Abstract.StackWidening(Stack(..))
import Data.Abstract.Widening(Stable(..))
import Text.Printf
newtype ChaoticT cache a b c x y =
ChaoticT (
WriterT (Component a)
(StateT (cache a b)
(ReaderT (Stack a) c)) x y)
newtype ChaoticT a b c x y = ChaoticT (ConstT (IterationStrategy c a (Component a,b)) (WriterT (Component a) c) x y)
deriving (Profunctor,Category,Arrow,ArrowChoice)
runChaoticT :: (IsCache cache a b, Profunctor c) => ChaoticT cache a b c x y -> c x (cache a b,y)
runChaoticT (ChaoticT f) = dimap (\a -> (empty,(empty,a))) (second snd) (runReaderT (runStateT (runWriterT f)))
runChaoticT :: Profunctor c => IterationStrategy c a (Component a,b) -> ChaoticT a b c x y -> c x y
runChaoticT strat (ChaoticT f) = rmap snd (runWriterT (runConstT strat f))
{-# INLINE runChaoticT #-}
runChaoticT' :: (IsCache cache a b, Profunctor c) => ChaoticT cache a b c x y -> c x y
runChaoticT' f = rmap snd (runChaoticT f)
{-# INLINE runChaoticT' #-}
chaotic :: (Identifiable a, IsCache cache a b, Profunctor c, ArrowChoice c, ArrowApply c) => Cache.Widening cache a b -> IterationStrategy (ChaoticT cache a b c) a b
chaotic widen (ChaoticT (WriterT (StateT f))) = ChaoticT $ WriterT $ StateT $ push $ proc (stack,cache,a) -> do
case Cache.lookup a cache of
-- If the cache contains a stable entry, just return it.
Just (Stable,b) ->
returnA -< (cache,(mempty,b))
-- If the entry has appeared on the stack, stop recursion and
-- return the cached entry. Remember with the fixpoint component
-- set that we need to iterate on this entry.
Just (Instable,b) | H.member a stack ->
returnA -< (cache,(Component {head = H.singleton a, body = H.empty},b))
-- If we did not encounter the entry, register the entry and keep
-- recursing.
_ ->
iterate -<< (Cache.initialize a cache,a)
where
iterate = proc (cache,a) -> do
(cache',(component,b)) <- f -< (cache,a)
case () of
-- The call did not depend on any unstable calls. This means
-- we are done and don't need to iterate.