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

widening returns stable indicator

parent 25de95c1
{ pkgs ? import <nixpkgs> {} }: { pkgs ? import <nixpkgs> {} }:
let let
hsEnv = pkgs.haskell.packages.ghc844.ghcWithPackages(p: with p; [ hsEnv = pkgs.haskellPackages.ghcWithPackages (p: with p; [
stack stack
]); ]);
...@@ -10,6 +10,6 @@ in pkgs.stdenv.mkDerivation { ...@@ -10,6 +10,6 @@ in pkgs.stdenv.mkDerivation {
version = "0.0.1"; version = "0.0.1";
src = ./.; src = ./.;
buildInputs = [ buildInputs = [
hsEnv pkgs.pandoc hsEnv pkgs.jdk
]; ];
} }
...@@ -4,7 +4,6 @@ module Control.Arrow.Abstract.Join where ...@@ -4,7 +4,6 @@ module Control.Arrow.Abstract.Join where
import Prelude hiding ((.)) import Prelude hiding ((.))
import Control.Arrow import Control.Arrow
import Control.Arrow.Utils
import Data.Order(Complete(..)) import Data.Order(Complete(..))
import Data.Profunctor import Data.Profunctor
...@@ -17,8 +16,8 @@ class (Arrow c, Profunctor c) => ArrowJoin c where ...@@ -17,8 +16,8 @@ class (Arrow c, Profunctor c) => ArrowJoin c where
-- @ -- @
joinWith :: (y -> y -> y) -> c x y -> c x y -> c x y joinWith :: (y -> y -> y) -> c x y -> c x y -> c x y
joinWith' :: ArrowJoin c => (y -> y -> y) -> c x y -> c x' y -> c (x,x') y joinWith' :: (ArrowJoin c) => (y -> y -> y) -> c x y -> c x' y -> c (x,x') y
joinWith' lub f g = joinWith lub (f <<< pi1) (g <<< pi2) joinWith' lub f g = joinWith lub (lmap fst f) (lmap snd g)
(<>) :: (ArrowJoin c, Complete y) => c x y -> c x y -> c x y (<>) :: (ArrowJoin c, Complete y) => c x y -> c x y -> c x y
(<>) = joinWith () (<>) = joinWith ()
...@@ -30,8 +29,8 @@ joinWith' lub f g = joinWith lub (f <<< pi1) (g <<< pi2) ...@@ -30,8 +29,8 @@ joinWith' lub f g = joinWith lub (f <<< pi1) (g <<< pi2)
-- @ -- @
joinList :: (ArrowChoice c, ArrowJoin c, Complete y) => c (e,s) y -> c (e,(x,s)) y -> c (e,([x],s)) y joinList :: (ArrowChoice c, ArrowJoin c, Complete y) => c (e,s) y -> c (e,(x,s)) y -> c (e,([x],s)) y
joinList empty f = proc (e,(l,s)) -> case l of joinList empty f = proc (e,(l,s)) -> case l of
[] -> empty -< (e,s) [] -> empty -< (e,s)
[x] -> f -< (e,(x,s)) [x] -> f -< (e,(x,s))
(x:xs) -> (f -< (e,(x,s))) <> (joinList empty f -< (e,(xs,s))) (x:xs) -> (f -< (e,(x,s))) <> (joinList empty f -< (e,(xs,s)))
instance ArrowJoin (->) where instance ArrowJoin (->) where
......
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE GADTs #-}
module Control.Arrow.Transformer.Abstract.Error(ErrorT(..)) where
import Prelude hiding (id,lookup,(.),read,fail)
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Deduplicate
import Control.Arrow.Environment as Env
import Control.Arrow.Fail
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Store as Store
import Control.Arrow.Except as Exc
import Control.Arrow.Fix
import Control.Arrow.Utils (duplicate)
import Control.Arrow.Abstract.Join
import Control.Category
import Data.Monoidal
import Data.Order
import Data.Profunctor
import Data.Abstract.Error
import Data.Abstract.Widening (toJoin2)
newtype ErrorT e c x y = ErrorT { runErrorT :: c x (Error e y)}
instance (ArrowChoice c, Profunctor c) => ArrowFail e (ErrorT e c) where
fail = lift $ arr Fail
instance (ArrowChoice c, Profunctor c) => Category (ErrorT e c) where
id = lift' id
f . g = lift $ rmap toEither (unlift g) >>> (arr Fail ||| unlift f)
instance (Profunctor c, Arrow c) => Profunctor (ErrorT e c) where
dimap f g h = lift $ dimap f (fmap g) (unlift h)
lmap f h = lift $ lmap f (unlift h)
rmap g h = lift $ rmap (fmap g) (unlift h)
instance ArrowLift (ErrorT e) where
lift' f = ErrorT (rmap Success f)
instance ArrowTrans (ErrorT e) where
type Dom (ErrorT e) x y = x
type Cod (ErrorT e) x y = Error e y
lift = ErrorT
unlift = runErrorT
instance (ArrowChoice c, Profunctor c) => Arrow (ErrorT e c) where
arr f = lift' (arr f)
first f = lift $ rmap strength1 (first (unlift f))
second f = lift $ rmap strength2 (second (unlift f))
f &&& g = lmap duplicate (f *** g)
f *** g = first f >>> second g
instance (ArrowChoice c, Profunctor c) => ArrowChoice (ErrorT e c) where
left f = lift $ rmap strength1 (left (unlift f))
right f = lift $ rmap strength2 (right (unlift f))
f ||| g = lift $ unlift f ||| unlift g
f +++ g = left f >>> right g
instance (ArrowApply c, ArrowChoice c, Profunctor c) => ArrowApply (ErrorT e c) where
app = lift $ lmap (first unlift) app
instance (ArrowState s c, ArrowChoice c, Profunctor c) => ArrowState s (ErrorT e c) where
get = lift' get
put = lift' put
instance (ArrowStore var val c, ArrowChoice c, Profunctor c) => ArrowStore var val (ErrorT e c) where
type Join (ErrorT e c) x y = Store.Join c (Dom (ErrorT e) x y) (Cod (ErrorT e) x y)
read f g = lift $ read (unlift f) (unlift g)
write = lift' write
instance (ArrowReader r c, ArrowChoice c, Profunctor c) => ArrowReader r (ErrorT e c) where
ask = lift' ask
local f = lift (local (unlift f))
instance (ArrowEnv x y env c, ArrowChoice c, Profunctor c) => ArrowEnv x y env (ErrorT e c) where
type Join (ErrorT e c) x y = Env.Join c (Dom (ErrorT e) x y) (Cod (ErrorT e) x y)
lookup f g = lift $ lookup (unlift f) (unlift g)
getEnv = lift' getEnv
extendEnv = lift' extendEnv
localEnv f = lift (localEnv (unlift f))
instance (ArrowChoice c, ArrowExcept e c) => ArrowExcept e (ErrorT e' c) where
type Join (ErrorT e' c) x y = Exc.Join c (Dom (ErrorT e') x y) (Cod (ErrorT e') x y)
throw = lift $ throw
catch f g = lift $ catch (unlift f) (unlift g)
finally f g = lift $ finally (unlift f) (unlift g)
type instance Fix x y (ErrorT e c) = ErrorT e (Fix (Dom (ErrorT e) x y) (Cod (ErrorT e) x y) c)
instance (ArrowFix (Dom (ErrorT e) x y) (Cod (ErrorT e) x y) c, ArrowChoice c, Profunctor c) => ArrowFix x y (ErrorT e c) where
fix = liftFix
instance (ArrowDeduplicate (Dom (ErrorT e) x y) (Cod (ErrorT e) x y) c, ArrowChoice c, Profunctor c) => ArrowDeduplicate x y (ErrorT e c) where
dedup f = lift $ dedup (unlift f)
instance (ArrowConst r c, ArrowChoice c) => ArrowConst r (ErrorT e c) where
askConst = lift' askConst
instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowJoin (ErrorT e c) where
joinWith lub' f g = ErrorT $ joinWith (toJoin2 widening () lub') (unlift f) (unlift g)
deriving instance PreOrd (c x (Error e y)) => PreOrd (ErrorT e c x y)
deriving instance LowerBounded (c x (Error e y)) => LowerBounded (ErrorT e c x y)
deriving instance Complete (c x (Error e y)) => Complete (ErrorT e c x y)
deriving instance CoComplete (c x (Error e y)) => CoComplete (ErrorT e c x y)
deriving instance UpperBounded (c x (Error e y)) => UpperBounded (ErrorT e c x y)
...@@ -25,15 +25,16 @@ import Control.Arrow.Utils (duplicate) ...@@ -25,15 +25,16 @@ import Control.Arrow.Utils (duplicate)
import Control.Arrow.Abstract.Join import Control.Arrow.Abstract.Join
import Control.Category import Control.Category
import Data.Abstract.Error
import Data.Monoidal import Data.Monoidal
import Data.Order import Data.Order
import Data.Profunctor import Data.Profunctor
import Data.Abstract.Except
import Data.Abstract.Widening (toJoin2)
newtype ExceptT e c x y = ExceptT { runExceptT :: c x (Error e y)} newtype ExceptT e c x y = ExceptT { runExceptT :: c x (Except e y)}
instance (ArrowChoice c, Complete e, ArrowJoin c) => ArrowExcept e (ExceptT e c) where instance (ArrowChoice c, Complete e, ArrowJoin c) => ArrowExcept e (ExceptT e c) where
type Join (ExceptT e c) (x,(x,e)) y = Complete (c (y,(x,e)) (Error e y)) type Join (ExceptT e c) (x,(x,e)) y = Complete (c (y,(x,e)) (Except e y))
throw = lift $ arr Fail throw = lift $ arr Fail
catch f g = lift $ proc x -> do catch f g = lift $ proc x -> do
e <- unlift f -< x e <- unlift f -< x
...@@ -56,11 +57,12 @@ instance (ArrowChoice c, ArrowJoin c, Complete e) => Category (ExceptT e c) wher ...@@ -56,11 +57,12 @@ instance (ArrowChoice c, ArrowJoin c, Complete e) => Category (ExceptT e c) wher
SuccessOrFail e y' -> do SuccessOrFail e y' -> do
-- Ideally we would like to write '(returnA -< Fail e) ⊔ (f -< y)', -- Ideally we would like to write '(returnA -< Fail e) ⊔ (f -< y)',
-- however this is not possible, because the result type of -- however this is not possible, because the result type of
-- 'f', 'Error e z', is not 'Complete' because 'z' is not -- 'f', 'Except e z', is not 'Complete' because 'z' is not
-- 'Complete'. However, in '(returnA -< Fail e) ⊔ (f -< y)' we -- 'Complete'. However, in '(returnA -< Fail e) ⊔ (f -< y)' we
-- actually never join to values of type 'z'. -- actually never join to values of type 'z'.
joinWith' (\(Fail e) er -> case er of joinWith' (\(Fail e) er -> case er of
Success z -> SuccessOrFail e z Success z -> SuccessOrFail e z
Fail e' -> Fail (e e') Fail e' -> Fail (e e')
SuccessOrFail e' z -> SuccessOrFail (e e') z) SuccessOrFail e' z -> SuccessOrFail (e e') z)
id (unlift f) -< (Fail e,y') id (unlift f) -< (Fail e,y')
...@@ -75,7 +77,7 @@ instance ArrowLift (ExceptT e) where ...@@ -75,7 +77,7 @@ instance ArrowLift (ExceptT e) where
instance ArrowTrans (ExceptT e) where instance ArrowTrans (ExceptT e) where
type Dom (ExceptT e) x y = x type Dom (ExceptT e) x y = x
type Cod (ExceptT e) x y = Error e y type Cod (ExceptT e) x y = Except e y
lift = ExceptT lift = ExceptT
unlift = runExceptT unlift = runExceptT
...@@ -129,10 +131,10 @@ instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowConst r c) => ArrowConst ...@@ -129,10 +131,10 @@ instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowConst r c) => ArrowConst
askConst = lift' askConst askConst = lift' askConst
instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowJoin (ExceptT e c) where instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowJoin (ExceptT e c) where
joinWith lub' f g = ExceptT $ joinWith (widening () lub') (unlift f) (unlift g) joinWith lub' f g = ExceptT $ joinWith (toJoin2 widening () lub') (unlift f) (unlift g)
deriving instance PreOrd (c x (Error e y)) => PreOrd (ExceptT e c x y) deriving instance PreOrd (c x (Except e y)) => PreOrd (ExceptT e c x y)
deriving instance LowerBounded (c x (Error e y)) => LowerBounded (ExceptT e c x y) deriving instance LowerBounded (c x (Except e y)) => LowerBounded (ExceptT e c x y)
deriving instance Complete (c x (Error e y)) => Complete (ExceptT e c x y) deriving instance Complete (c x (Except e y)) => Complete (ExceptT e c x y)
deriving instance CoComplete (c x (Error e y)) => CoComplete (ExceptT e c x y) deriving instance CoComplete (c x (Except e y)) => CoComplete (ExceptT e c x y)
deriving instance UpperBounded (c x (Error e y)) => UpperBounded (ExceptT e c x y) deriving instance UpperBounded (c x (Except e y)) => UpperBounded (ExceptT e c x y)
...@@ -10,7 +10,6 @@ module Control.Arrow.Transformer.Abstract.Failure(FailureT(..)) where ...@@ -10,7 +10,6 @@ module Control.Arrow.Transformer.Abstract.Failure(FailureT(..)) where
import Prelude hiding (id,(.),lookup,read) import Prelude hiding (id,(.),lookup,read)
import Control.Applicative
import Control.Arrow import Control.Arrow
import Control.Arrow.Const import Control.Arrow.Const
import Control.Arrow.Deduplicate import Control.Arrow.Deduplicate
...@@ -26,11 +25,12 @@ import Control.Arrow.Utils(duplicate) ...@@ -26,11 +25,12 @@ import Control.Arrow.Utils(duplicate)
import Control.Arrow.Abstract.Join import Control.Arrow.Abstract.Join
import Control.Category import Control.Category
import Data.Abstract.Failure
import Data.Order import Data.Order
import Data.Monoidal import Data.Monoidal
import Data.Identifiable import Data.Identifiable
import Data.Profunctor import Data.Profunctor
import Data.Abstract.Failure
import Data.Abstract.Widening (toJoin)
-- | Describes computations that can fail. -- | Describes computations that can fail.
newtype FailureT e c x y = FailureT { runFailureT :: c x (Failure e y) } newtype FailureT e c x y = FailureT { runFailureT :: c x (Failure e y) }
...@@ -110,7 +110,7 @@ instance (ArrowChoice c, ArrowConst r c) => ArrowConst r (FailureT e c) where ...@@ -110,7 +110,7 @@ instance (ArrowChoice c, ArrowConst r c) => ArrowConst r (FailureT e c) where
askConst = lift' askConst askConst = lift' askConst
instance (ArrowJoin c, ArrowChoice c) => ArrowJoin (FailureT e c) where instance (ArrowJoin c, ArrowChoice c) => ArrowJoin (FailureT e c) where
joinWith lub' (FailureT f) (FailureT g) = FailureT $ joinWith (widening lub') f g joinWith lub' (FailureT f) (FailureT g) = FailureT $ joinWith (toJoin widening lub') f g
deriving instance PreOrd (c x (Failure e y)) => PreOrd (FailureT e c x y) deriving instance PreOrd (c x (Failure e y)) => PreOrd (FailureT e c x y)
deriving instance LowerBounded (c x (Failure e y)) => LowerBounded (FailureT e c x y) deriving instance LowerBounded (c x (Failure e y)) => LowerBounded (FailureT e c x y)
......
...@@ -9,22 +9,24 @@ ...@@ -9,22 +9,24 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix(FixT,runFixT) where module Control.Arrow.Transformer.Abstract.Fix(FixT,runFixT) where
import Prelude hiding (id,(.),const,head,iterate)
import Control.Category
import Control.Arrow hiding (loop) import Control.Arrow hiding (loop)
import Control.Arrow.Const
import Control.Arrow.Fix import Control.Arrow.Fix
import Control.Arrow.Reader import Control.Arrow.Reader
import Control.Arrow.State import Control.Arrow.State
import Control.Arrow.Trans
import Control.Arrow.Abstract.Join import Control.Arrow.Abstract.Join
import Control.Arrow.Transformer.Const import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Static
import Control.Arrow.Transformer.Reader import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State import Control.Arrow.Transformer.State
import Control.Category import Control.Arrow.Utils (const,(&&>))
import qualified Control.Monad.State as S
import Data.Identifiable import Data.Identifiable
import Data.Order import Data.Order
import Data.Abstract.Widening (Widening) import Data.Abstract.Widening (Widening,Stable(..))
import Data.Abstract.StackWidening (StackWidening,Loop(..)) import Data.Abstract.StackWidening (StackWidening,Loop(..))
import Data.HashMap.Lazy (HashMap) import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M import qualified Data.HashMap.Lazy as M
...@@ -48,73 +50,46 @@ runFixT sw w f = dimap (\x -> ((M.empty,H.empty),(mempty,x))) snd $ runStateT $ ...@@ -48,73 +50,46 @@ runFixT sw w f = dimap (\x -> ((M.empty,H.empty),(mempty,x))) snd $ runStateT $
#ifndef TRACE #ifndef TRACE
instance (Identifiable a, LowerBounded b, Profunctor c,ArrowChoice c) => ArrowFix a b (FixT s a b c) where instance (Identifiable a, LowerBounded b, Profunctor c,ArrowChoice c) => ArrowFix a b (FixT s a b c) where
fix f = FixT $ proc x -> do fix f = FixT $ stackWiden'
(stackWiden,stack) <- getStackWidening -< () (let iterate = proc (x,x') -> do
let ((loop,x'),stack') = S.runState (stackWiden x) stack -- If we are not in a loop, continue recursing.
case loop of (y,(member,head)) <- unFixT (f (fix f)) &&& inComponent -< x'
-- If we are not in a loop, continue recursing. if member
NoLoop -> do then do
y <- local (unFixT (f (fix f))) -< (stack',x') (stable,yNew) <- updateCache -< (x',y)
comp <- getComponent -< () -- If we did not reach a fixpoint of f(x'), keep iterating.
if not (H.null comp) && x' `H.member` comp if head && not stable
then do then iterate -< (x,x')
yOld <- updateCache -< (x',bottom) else returnA -< yNew
yNew <- updateCache -< (x',y) else returnA -< y
deleteFromComponent -< x' in iterate)
-- If we did not reach a fixpoint of f(x'), keep iterating.
if x' `isHeadOf` comp && yOld yNew
then unFixT (fix f) -< x
else returnA -< yNew
else do
returnA -< y
-- If we are in a loop, return the cached value or bottom otherwise. -- If we are in a loop, return the cached value or bottom otherwise.
-- Furthermore, add x' to the current component. -- Furthermore, add x' to the current component.
Loop -> do (addToComponent &&> initializeCache)
addToComponent -< x'
updateCache -< (x',bottom)
where
y y' = {- y ⊑ y' && -} not (y' y)
#else #else
instance (Show a, Show b, Show (s a), Identifiable a, LowerBounded b, Profunctor c,ArrowChoice c) => ArrowFix a b (FixT s a b c) where instance (Show a, Show b, Show (s a), Identifiable a, LowerBounded b, Profunctor c,ArrowChoice c) => ArrowFix a b (FixT s a b c) where
fix f = FixT $ proc x -> do fix f = FixT $ stackWiden'
(stackWiden,stack) <- getStackWidening -< () (let iterate = proc (x,x') -> do
let ((loop,x'),stack') = S.runState (stackWiden x) stack -- If we are not in a loop, continue recursing.
case loop of (y,(member,head)) <- unFixT (f (fix f)) &&& inComponent -< trace (printf "call [%s -> %s]" (show x) (show x')) x'
NoLoop -> do if member
y <- local (unFixT (f (fix f))) -< trace (printf "call [%s -> %s, %s]" (show x) (show x') (show stack)) $ (stack',x') then do
(stable,yNew) <- updateCache -< (x',y)
comp <- getComponent -< ()
if not (H.null comp) && x' `H.member` comp -- If we did not reach a fixpoint of f(x'), keep iterating.
then do if head && not stable
yOld <- updateCache -< (x',bottom) then iterate -< trace (printf "iterate [%s -> %s] = %s" (show x) (show x') (show yNew)) (x,x')
yNew <- updateCache -< (x',y) else returnA -< if head then trace (printf "fixed [%s -> %s] = %s" (show x) (show x') (show yNew)) yNew else yNew
deleteFromComponent -< x' else returnA -< trace (printf "return [%s -> %s] = %s" (show x) (show x') (show y)) y
in iterate)
if x' `isHeadOf` comp && yOld yNew
then unFixT (fix f) -< trace (printf "iterate [%s -> %s, %s] = [%s -> %s]" (show x) (show x') (show stack) (show yOld) (show yNew)) $ x
else returnA -< if x' `isHeadOf` comp then trace (printf "fixed [%s -> %s] = %s" (show x) (show x') (show yNew)) yNew else yNew
else do
returnA -< y
-- returnA -< trace (printf "return [%s -> %s] = %s" (show x) (show x') (show y)) y
-- If we are in a loop, return the cached value or bottom otherwise. -- If we are in a loop, return the cached value or bottom otherwise.
-- Furthermore, add x' to the current component. -- Furthermore, add x' to the current component.
Loop -> do (addToComponent &&> initializeCache)
addToComponent -< x'
y <- updateCache -< (x',bottom)
-- returnA -< y
returnA -< trace (printf "loop [%s -> %s, %s] = %s" (show x) (show x') (show stack) (show y)) y
where
y y' = {- y ⊑ y' && -} not (y' y)
#endif #endif
instance (ArrowJoin c, ArrowChoice c) => ArrowJoin (FixT s a b c) where instance (ArrowJoin c, ArrowChoice c) => ArrowJoin (FixT s a b c) where
...@@ -131,31 +106,43 @@ instance (ArrowJoin (FixT s a b c), Profunctor c, Complete y, PreOrd (c x y)) => ...@@ -131,31 +106,43 @@ instance (ArrowJoin (FixT s a b c), Profunctor c, Complete y, PreOrd (c x y)) =>
instance PreOrd (c x y) => PreOrd (FixT s a b c x y) where instance PreOrd (c x y) => PreOrd (FixT s a b c x y) where
() = error "f ⊑ g iff forall x. snd (f x) ⊑ snd (g x)" () = error "f ⊑ g iff forall x. snd (f x) ⊑ snd (g x)"
instance (Arrow c, Profunctor c, LowerBounded (c x y)) => LowerBounded (FixT s a b c x y) where
bottom = lift' bottom
instance ArrowLift (FixT s a b) where
lift' = FixT . lift' . lift' . lift'
instance (ArrowApply c, Profunctor c) => ArrowApply (FixT s a b c) where instance (ArrowApply c, Profunctor c) => ArrowApply (FixT s a b c) where
app = FixT (lmap (first unFixT) app) app = FixT (lmap (first unFixT) app)
----- Helper functions ----- ----- Helper functions -----
stackWiden' :: (ArrowReader (s a) c,ArrowChoice c) => ConstT (StackWidening s a,r) c (a,a) b -> ConstT (StackWidening s a,r) c a b -> ConstT (StackWidening s a,r) c a b
stackWiden' (ConstT (StaticT f)) (ConstT (StaticT g)) = constT $ \(sw,w) -> (local (f (sw,w)) ||| g (sw,w))
<<< rmap (\(s,x) -> let ~(s',(l,x')) = sw s x
in case l of
NoLoop -> Left (s',(x,x'))
Loop -> Right x'
) (const ask &&& id)
getStackWidening :: (ArrowConst (StackWidening s a,r) c, ArrowReader (s a) c) => c () (StackWidening s a,s a) initializeCache :: (Identifiable a, LowerBounded b, ArrowState (Cache a b,Component a) c) => c a b
getStackWidening = rmap (first fst) (askConst &&& ask) initializeCache = modifyCache (\x -> insertWithLookup (\_ old -> old) x bottom)
updateCache :: (Identifiable a, LowerBounded b, ArrowState (Cache a b,Component a) c) => ConstT (r,Widening b) c (a,b) b updateCache :: (Identifiable a, LowerBounded b, ArrowState (Cache a b,Component a) c) => ConstT (r,Widening b) c (a,b) (Bool,b)
updateCache = constT $ \(_,widen) -> modify' (\(x,y) -> insertWithLookup (\new old -> if new bottom then old else widen old new) x y) (curry snd) updateCache = constT $ \(_,widen) -> modifyCache $ \(x,y) cache -> case M.lookup x cache of
Just yOld -> let (s,yNew) = widen yOld y in ((s == Stable,yNew),M.insert x yNew cache)
Nothing -> ((False,y),M.insert x y cache)
getComponent :: ArrowState (Cache a b,Component a) c => c () (Component a) inComponent :: (Identifiable a, Arrow c, Profunctor c, ArrowState (Cache a b,Component a) c) => c a (Bool,Bool)
getComponent = rmap snd get inComponent = modifyComp $ \x comp -> ((not (H.null comp) && H.member x comp, H.singleton x == comp), H.delete x comp)
addToComponent :: (Identifiable a,ArrowState (Cache a b,Component a) c) => c a () addToComponent :: (Identifiable a,ArrowState (Cache a b,Component a) c) => c a ()
addToComponent = modify (arr (\(x,(cache,comp)) -> ((),(cache,H.insert x comp)))) addToComponent = modifyComp (\x comp -> ((),H.insert x comp))
isHeadOf :: Identifiable a => a -> Component a -> Bool
isHeadOf x comp = H.singleton x == comp
deleteFromComponent :: (Identifiable a,ArrowState (Cache a b,Component a) c) => c a () modifyCache :: ArrowState (Cache a b,Component a) c => (x -> Cache a b -> (y,Cache a b)) -> c x y
deleteFromComponent = modify (arr (\(x,(cache,comp)) -> ((),(cache,H.delete x comp)))) modifyCache f = modify (arr $ \(x,(cache,comp)) -> let (y,cache') = f x cache in (y,(cache',comp)))
modify' :: ArrowState (Cache a b,Component a) c => (x -> Cache a b -> (y,Cache a b)) -> (x -> Component a -> Component a) -> c x y modifyComp :: ArrowState (Cache a b,Component a) c => (x -> Component a -> (y,Component a)) -> c x y
modify' f g = modify (arr $ \(x,(cache,comp)) -> let (y,cache') = f x cache in (y,(cache',g x comp))) modifyComp f = modify (arr $ \(x,(cache,comp)) -> let (y,comp') = f x comp in (y,(cache,comp')))
insertWithLookup :: Identifiable a => (b -> b -> b) -> a -> b -> HashMap a b -> (b,HashMap a b) insertWithLookup :: Identifiable a => (b -> b -> b) -> a -> b -> HashMap a b -> (b,HashMap a b)
insertWithLookup w a b m = insertWithLookup w a b m =
......
...@@ -19,10 +19,11 @@ import Control.Arrow.Utils(duplicate) ...@@ -19,10 +19,11 @@ import Control.Arrow.Utils(duplicate)
import Control.Arrow.Abstract.Join import Control.Arrow.Abstract.Join
import Control.Category import Control.Category
import Data.Abstract.Terminating
import Data.Order import Data.Order
import Data.Monoidal import Data.Monoidal
import Data.Profunctor import Data.Profunctor
import Data.Abstract.Terminating
import Data.Abstract.Widening (toJoin)
-- | Arrow that propagates non-terminating computations. -- | Arrow that propagates non-terminating computations.
newtype TerminatingT c x y = TerminatingT { runTerminatingT :: c x (Terminating y) } newtype TerminatingT c x y = TerminatingT { runTerminatingT :: c x (Terminating y) }
...@@ -77,7 +78,7 @@ instance (ArrowChoice c, ArrowFix (Dom TerminatingT x y) (Cod TerminatingT x y) ...@@ -77,7 +78,7 @@ instance (ArrowChoice c, ArrowFix (Dom TerminatingT x y) (Cod TerminatingT x y)
fix = liftFix fix = liftFix
instance (ArrowChoice c, ArrowJoin c) => ArrowJoin (TerminatingT c) where instance (ArrowChoice c, ArrowJoin c) => ArrowJoin (TerminatingT c) where
joinWith lub' f g = lift $ joinWith (widening lub') (unlift f) (unlift g) joinWith lub' f g = lift $ joinWith (toJoin widening lub') (unlift f) (unlift g)
deriving instance PreOrd (c x (Terminating y)) => PreOrd (TerminatingT c x y) deriving instance PreOrd (c x (Terminating y)) => PreOrd (TerminatingT c x y)
deriving instance LowerBounded (c x (Terminating y)) => LowerBounded (TerminatingT c x y) deriving instance LowerBounded (c x (Terminating y)) => LowerBounded (TerminatingT c x y)
......
...@@ -24,12 +24,12 @@ import Control.Arrow.Utils ...@@ -24,12 +24,12 @@ import Control.Arrow.Utils
import Control.Category import Control.Category
import Data.Profunctor import Data.Profunctor
import Data.Concrete.Failure import Data.Concrete.Error
import Data.Monoidal import Data.Monoidal
import Data.Identifiable import Data.Identifiable