Commit 5616e1e3 authored by Sven Keidel's avatar Sven Keidel

update stratego

parent e584c808
Pipeline #17324 failed with stages
in 80 minutes and 24 seconds
......@@ -18,6 +18,7 @@ import Control.Arrow.Fix.Cache
import Data.Abstract.Stable
import Data.Order
import Data.Metric
import Data.Profunctor
import Data.Monoid (First(..))
......@@ -27,11 +28,15 @@ import Text.Printf
class (Arrow c, Profunctor c) => ArrowReuse a b c where
-- | Reuse cached results at the cost of precision.
reuse :: (Monoid m) => (a -> a -> Stable -> b -> m) -> c (a,Stable) m
reuse :: (Monoid m) => Stable -> (a -> a -> Stable -> b -> m -> m) -> c a m
reuseFirst :: (ArrowChoice c, ArrowReuse a b c) => Stable -> IterationStrategy c a b
reuseFirst st f = proc a -> do
m <- reuse (\_ a' s' b' -> First (Just (a',b',s'))) -< (a,st)
reuseFirst :: (PreOrd a, ArrowChoice c, ArrowReuse a b c) => Stable -> IterationStrategy c a b
reuseFirst s f = proc a -> do
m <- reuse s (\a a' s' b' m -> case m of
First (Just _) -> m
First Nothing
| a a' -> First (Just (a',b',s'))
| otherwise -> m) -< a
case getFirst m of
Just (_,b,Stable) -> returnA -< b
Just (a',_,Unstable) -> f -< a'
......@@ -46,17 +51,20 @@ reuseExact f = proc a -> do
_ -> f -< a
{-# INLINE reuseExact #-}
reuseByMetric :: (Ord n, ArrowChoice c, ArrowReuse a b c) => Metric a n -> IterationStrategy c a b
reuseByMetric :: (PreOrd a, Ord n, ArrowChoice c, ArrowReuse a b c) => Metric a n -> IterationStrategy c a b
reuseByMetric metric = reuseByMetric_ (\s a a' -> Product s (metric a a')) Unstable
{-# INLINE reuseByMetric #-}
reuseStableByMetric :: (Ord n, ArrowChoice c, ArrowReuse a b c) => Metric a n -> IterationStrategy c a b
reuseStableByMetric :: (PreOrd a, Ord n, ArrowChoice c, ArrowReuse a b c) => Metric a n -> IterationStrategy c a b
reuseStableByMetric metric = reuseByMetric_ (const metric) Stable
{-# INLINE reuseStableByMetric #-}
reuseByMetric_ :: (Ord n, ArrowChoice c, ArrowReuse a b c) => (Stable -> Metric a n) -> Stable -> IterationStrategy c a b
reuseByMetric_ metric st f = proc a -> do
m <- reuse (\a a' s' b' -> Just (Measured { input = a', output = b', stable = s', measured = metric s' a a' })) -< (a,st)
reuseByMetric_ :: (PreOrd a, Ord n, ArrowChoice c, ArrowReuse a b c) => (Stable -> Metric a n) -> Stable -> IterationStrategy c a b
reuseByMetric_ metric s f = proc a -> do
m <- reuse s (\a a' s' b' m ->
if a a'
then m <> Just (Measured { input = a', output = b', stable = s', measured = metric s' a a' })
else m) -< a
case m of
Just Measured { stable = Stable, output = b } -> returnA -< b
Just Measured { stable = Unstable, input = a' } -> f -< a'
......
......@@ -52,16 +52,19 @@ joinList empty f = proc (e,(l,s)) -> case l of
[] -> empty -< (e,s)
[x] -> f -< (e,(x,s))
(x:xs) -> (f -< (e,(x,s))) <> (joinList empty f -< (e,(xs,s)))
{-# INLINABLE joinList #-}
joinList1 :: (ArrowChoice c, ArrowLowerBounded c, ArrowComplete y c) => c (e,(x,s)) y -> c (e,([x],s)) y
joinList1 f = proc (e,(l,s)) -> case l of
[] -> bottom -< ()
[x] -> f -< (e,(x,s))
(x:xs) -> (f -< (e,(x,s))) <> (joinList1 f -< (e,(xs,s)))
{-# INLINABLE joinList1 #-}
joinList1' :: (ArrowChoice c, ArrowLowerBounded c, ArrowComplete y c) => c (x,e) y -> c ([x],e) y
joinList1' f = proc (l,e) -> case l of
[] -> bottom -< ()
[x] -> f -< (x,e)
(x:xs) -> (f -< (x,e)) <> (joinList1' f -< (xs,e))
{-# INLINABLE joinList1' #-}
......@@ -7,6 +7,7 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
module Control.Arrow.Transformer.Abstract.Environment where
import Prelude hiding ((.),read,Maybe(..))
......@@ -26,6 +27,7 @@ import Control.Arrow.Closure as Cls
import Control.Arrow.Fix
import Control.Arrow.Order
import Data.Abstract.IntersectionSet (Set)
import Data.Abstract.Maybe
import qualified Data.Abstract.StrongMap as SM
import qualified Data.Abstract.Environment.Flat as FM
......@@ -40,7 +42,7 @@ import Data.Coerce
import GHC.Exts
newtype EnvT env var val c x y = EnvT (ReaderT (env var val) c x y)
newtype EnvT (env :: k1 -> k2 -> *) var val c x y = EnvT (ReaderT (env 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)
......@@ -66,7 +68,7 @@ instance (Identifiable var, UpperBounded val, ArrowChoice c, Profunctor c) => Ar
{-# INLINE lookup #-}
{-# INLINE extend #-}
instance (Identifiable var, IsClosure val (FM.Env var val), Complete val, ArrowChoice c, Profunctor c) => ArrowEnv var val (EnvT FM.Env var val c) where
instance (Identifiable var, Traversable val, Complete (val (Set var)), ArrowChoice c, Profunctor c) => ArrowEnv var (val (FM.Env var val)) (EnvT FM.Env var val c) where
type Join y (EnvT FM.Env var val c) = ArrowComplete y c
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
env <- Reader.ask -< ()
......@@ -80,7 +82,7 @@ instance (Identifiable var, IsClosure val (FM.Env var val), Complete val, ArrowC
{-# INLINE lookup #-}
{-# INLINE extend #-}
instance (Identifiable var, IsClosure val (FM.Env var val), Complete val, ArrowChoice c, Profunctor c) => ArrowLetRec var val (EnvT FM.Env var val c) where
instance (Identifiable var, Traversable val, Complete (val (Set var)), ArrowChoice c, Profunctor c) => ArrowLetRec var (val (FM.Env var val)) (EnvT FM.Env var val c) where
letRec (EnvT f) = EnvT $ proc (ls,x) -> do
env <- Reader.ask -< ()
Reader.local f -< (FM.insertRec ls env,x)
......
......@@ -40,6 +40,7 @@ instance ArrowRun c => ArrowRun (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))
{-# NOINLINE fix #-}
instance (Profunctor c,ArrowApply c) => ArrowApply (FixT a b c) where
app = FixT (app .# first coerce)
......
......@@ -115,10 +115,10 @@ instance (Arrow c, ArrowContext ctx a c) => ArrowContext ctx a (CacheT Cache a b
{-# INLINE localContext #-}
{-# INLINE joinByContext #-}
instance (PreOrd a, Arrow c, Profunctor c) => ArrowReuse a b (CacheT Cache a b c) where
reuse f = CacheT $ proc (a,s) -> do
instance (Arrow c, Profunctor c) => ArrowReuse a b (CacheT Cache a b c) where
reuse s f = CacheT $ proc a -> 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
returnA -< M.foldlWithKey' (\m a' (s',b') -> if s' s then f a a' s' b' m else m) mempty cache
{-# INLINE reuse #-}
instance Identifiable a => IsList (Cache a b) where
......@@ -154,7 +154,7 @@ instance (Arrow c, ArrowContext ctx a c) => ArrowContext ctx (k,a) (CacheT (Grou
{-# INLINE joinByContext #-}
instance (Identifiable k, IsEmpty (cache a b), ArrowApply c, Profunctor c, ArrowReuse a b (CacheT cache a b c)) => ArrowReuse (k,a) b (CacheT (Group cache) (k,a) b c) where
reuse f = proc ((k,a0),s) -> withCache (reuse (\a a' -> f (k,a) (k,a'))) -<< (k,(a0,s))
reuse s f = proc (k,a0) -> withCache (reuse s (\a a' -> f (k,a) (k,a'))) -<< (k,a0)
{-# 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
......
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
......@@ -33,8 +33,6 @@ import Data.Order hiding (top)
import Data.Abstract.Widening (Widening)
import Data.HashSet(HashSet)
import qualified Data.HashSet as H
import Data.Abstract.Stable
import Data.Foldable
maxSize :: (ArrowChoice c, ArrowStack a c) => Int -> IterationStrategy c a b -> IterationStrategy c a b
maxSize limit strat f = proc a -> do
......@@ -65,14 +63,9 @@ instance IsEmpty (Stack a) where
newtype StackT stack a c x y = StackT (ReaderT (stack a) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowJoin,ArrowComplete z,ArrowCache a b,ArrowState s,ArrowTrans,ArrowContext ctx a)
instance (PreOrd a, LowerBounded b, ArrowChoice c, ArrowReuse a b c, ArrowStack a (StackT stack a c)) => ArrowReuse a b (StackT stack a c) where
reuse f = proc (a,s) -> case s of
Unstable -> do
m0 <- StackT (reuse f) -< (a,Unstable)
stack <- Stack.elems -< ()
returnA -< foldl' (\m a' -> if a a' then m <> f a a' Unstable bottom else m) m0 stack
Stable ->
StackT (reuse f) -< (a,Stable)
instance (ArrowReuse a b c, ArrowStack a (StackT stack a c)) => ArrowReuse a b (StackT stack a c) where
reuse s f = StackT $ reuse s f
{-# INLINABLE reuse #-}
instance (Identifiable a, Arrow c, Profunctor c) => ArrowStack a (StackT Stack a c) where
peek = lift $ proc (stack,()) -> returnA -< top stack
......@@ -87,7 +80,7 @@ instance (Identifiable a, Arrow c, Profunctor c) => ArrowStack a (StackT Stack a
{-# INLINE size #-}
runStackT :: (IsEmpty (stack a), Profunctor c) => StackT stack a c x y -> c x y
runStackT (StackT f) = lmap (\x -> (empty,x)) (runReaderT f)
runStackT (StackT f) = lmap (empty,) (runReaderT f)
{-# INLINE runStackT #-}
instance (IsEmpty (stack a), ArrowRun c) => ArrowRun (StackT stack a c) where
......
......@@ -15,7 +15,7 @@ import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Fix.Chaotic
import Control.Arrow.Fix.Reuse as Reuse
import Control.Arrow.Fix.Cache as Cache
-- import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.Context as Context
import Control.Arrow.State
......@@ -34,6 +34,20 @@ trace showA showB f = proc x -> do
returnA -< Debug.trace (printf "RETURN\n%s\n%s\n\n" (showA x) (showB y)) y
{-# INLINE trace #-}
trace' :: (Eq a, ArrowApply c) => (a -> String) -> (b -> String) -> IterationStrategy c a b -> IterationStrategy c a b
trace' showA showB strat f = proc x -> do
y <- strat (proc x' -> f -< Debug.trace (if x == x'
then printf "CALL\n%s\n\n" (showA x)
else printf "CALL\n%s~>\n%s\n\n" (showA x) (showA x')) x') -<< x
returnA -< Debug.trace (printf "RETURN\n%s\n%s\n\n" (showA x) (showB y)) y
{-# INLINE trace' #-}
traceCache :: ArrowState cache c => (cache -> String) -> IterationStrategy c a b
traceCache showCache f = proc a -> do
cache <- get -< ()
f -< Debug.trace (printf "CACHE %s\n\n" (showCache cache)) a
{-# INLINE traceCache #-}
traceCtx :: (ArrowContext ctx a' c,ArrowState cache c) => (a -> String) -> (b -> String) -> (ctx -> String) -> (cache -> String) -> IterationStrategy c a b
traceCtx showA showB showCtx showCache f = proc x -> do
ctx <- askContext -< ()
......@@ -56,26 +70,26 @@ newtype TraceT c x y = TraceT (c x y)
-- m <- Reuse.reuse f -< (a,s)
-- returnA -< Debug.trace (printf "REUSE\nx: %s\n%s\n\n" (show a) (show m)) m
instance (Show a, ArrowIterate a c) => ArrowIterate a (TraceT c) where
iterate = TraceT $ proc (a,b) ->
iterate -< Debug.trace (printf "ITERATE\n\tx: %s\n\n" (show a)) (a,b)
instance (Show a, Show b, ArrowCache a b c) => ArrowCache a b (TraceT c) where
lookup = TraceT $ proc a -> do
b <- lookup -< a
returnA -< Debug.trace (printf "LOOKUP\n\tx: %s\n\ty: %s\n\n" (show a) (show b)) b
update = TraceT $ proc (a,b) -> do
bOld <- lookup -< a
(s,b') <- update -< (a,b)
returnA -< Debug.trace (printf "UPDATE\n\tx: %s\n\ty: %s -> %s, %s\n\n" (show a) (show bOld) (show b') (show s)) (s,b')
write = TraceT $ proc (a,b,s) -> do
write -< Debug.trace (printf "WRITE\n\tx: %s\n\ty: %s\n\t%s\n\t\n\n" (show a) (show b) (show s)) (a,b,s)
setStable = TraceT $ proc (s,a) ->
setStable -< Debug.trace (printf "STABLE\n\tx: %s\n\t%s\n\n" (show a) (show s)) (s,a)
{-# INLINE lookup #-}
{-# INLINE update #-}
{-# INLINE write #-}
{-# INLINE setStable #-}
-- instance (Show a, ArrowIterate a c) => ArrowIterate a (TraceT c) where
-- iterate = TraceT $ proc (a,b) ->
-- iterate -< Debug.trace (printf "ITERATE\n\tx: %s\n\n" (show a)) (a,b)
-- instance (Show a, Show b, ArrowCache a b c) => ArrowCache a b (TraceT c) where
-- lookup = TraceT $ proc a -> do
-- b <- lookup -< a
-- returnA -< b -- Debug.trace (printf "LOOKUP\n\tx: %s\n\ty: %s\n\n" (show a) (show b)) b
-- update = TraceT $ proc (a,b) -> do
-- bOld <- lookup -< a
-- (s,b') <- update -< (a,b)
-- returnA -< Debug.trace (printf "UPDATE\n\tx: %s\n\ty: %s -> %s, %s\n\n" (show a) (show bOld) (show b') (show s)) (s,b')
-- write = TraceT $ proc (a,b,s) -> do
-- write -< (a,b,s) -- Debug.trace (printf "WRITE\n\tx: %s\n\ty: %s\n\t%s\n\t\n\n" (show a) (show b) (show s)) (a,b,s)
-- setStable = TraceT $ proc (s,a) ->
-- setStable -< Debug.trace (printf "STABLE\n\tx: %s\n\t%s\n\n" (show a) (show s)) (s,a)
-- {-# INLINE lookup #-}
-- {-# INLINE update #-}
-- {-# INLINE write #-}
-- {-# INLINE setStable #-}
runTraceT :: TraceT c x y -> c x y
runTraceT (TraceT f) = f
......
......@@ -68,9 +68,9 @@ instance (ArrowChoice c, Profunctor c) => ArrowClosure expr (Closure expr (HashM
instance (Identifiable var, IsClosure val (HashMap var val), ArrowChoice c, Profunctor c)
=> ArrowLetRec var val (EnvT var val c) where
letRec (EnvT f) = EnvT $ proc (ls,x) -> do
letRec (EnvT f) = EnvT $ proc (bindings,x) -> do
env <- Reader.ask -< ()
let env' = foldr (\(var,val) -> M.insert var (setEnvironment env' val)) env ls
let env' = foldr (\(var,val) -> M.insert var (setEnvironment env' val)) env bindings
Reader.local f -< (env',x)
instance (ArrowApply c,Profunctor c) => ArrowApply (EnvT var val c) where
......
......@@ -34,7 +34,7 @@ import Data.Coerce
-- | Passes along constant data.
newtype ConstT r c x y = ConstT (StaticT ((->) r) c x y)
deriving (Category,Profunctor,Arrow,ArrowChoice,ArrowLowerBounded,ArrowLift,ArrowJoin,
ArrowState s,ArrowReader r',ArrowWriter w,
ArrowState s,ArrowReader r',ArrowWriter w, ArrowLetRec var val,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore var val,
ArrowFail e, ArrowExcept e,ArrowContext ctx a)
......
......@@ -50,7 +50,7 @@ instance (Identifiable var, ArrowEnv var val c, Profunctor c) => ArrowEnv var va
lookup (FreeVarsT f) (FreeVarsT g) = FreeVarsT $ proc (var,x) -> do
tell -< H.singleton var
Env.lookup f g -< (var,x)
extend (FreeVarsT f) = FreeVarsT $ proc (var,val,x) -> do
extend (FreeVarsT f) = FreeVarsT $ proc (var,val,x) ->
censor (\(var,_,_) -> H.delete var) (Env.extend f) -< (var,val,x)
instance (Identifiable var,ArrowApply c, Profunctor c) => ArrowApply (FreeVarsT var c) where
......
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.NoInline where
import Prelude hiding (id,(.),lookup,read,fail)
import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
import Control.Arrow.Except as Exc
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Fix.Reuse as Reuse
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Context as Context
import Control.Arrow.Order
import Control.Arrow.Reader as Reader
import Control.Arrow.State as State
import Control.Arrow.Store as Store
import Control.Arrow.Trans
import Control.Arrow.Writer
import Data.Profunctor
import Data.Profunctor.Unsafe
import Unsafe.Coerce
newtype NoInlineT c x y = NoInlineT { runNoInlineTT :: c x y }
instance ArrowRun c => ArrowRun (NoInlineT c) where type Run (NoInlineT c) x y = Run c x y
instance ArrowTrans (NoInlineT c) where type Underlying (NoInlineT c) x y = c x y
instance Profunctor c => Profunctor (NoInlineT c) where
dimap f g h = lift $ dimap f g (unlift h)
lmap f h = lift $ lmap f (unlift h)
rmap g h = lift $ rmap g (unlift h)
f .# _ = f `seq` unsafeCoerce f
_ #. g = g `seq` unsafeCoerce g
{-# NOINLINE dimap #-}
{-# NOINLINE lmap #-}
{-# NOINLINE rmap #-}
{-# NOINLINE (.#) #-}
{-# NOINLINE (#.) #-}
-- instance ArrowLift NoInlineT where
-- lift' = lift
-- {-# NOINLINE lift' #-}
instance Category c => Category (NoInlineT c) where
id = lift id
f . g = lift (unlift f . unlift g)
{-# NOINLINE id #-}
{-# NOINLINE (.) #-}
instance Arrow c => Arrow (NoInlineT c) where
arr f = lift (arr f)
first f = lift $ first (unlift f)
second f = lift $ second (unlift f)
f &&& g = lift $ unlift f &&& unlift g
f *** g = lift $ unlift f *** unlift g
{-# NOINLINE arr #-}
{-# NOINLINE first #-}
{-# NOINLINE second #-}
{-# NOINLINE (&&&) #-}
{-# NOINLINE (***) #-}
instance (ArrowChoice c) => ArrowChoice (NoInlineT c) where
left f = lift $ left (unlift f)
right f = lift $ right (unlift f)
f +++ g = lift $ unlift f +++ unlift g
f ||| g = lift $ unlift f ||| unlift g
{-# NOINLINE left #-}
{-# NOINLINE right #-}
{-# NOINLINE (+++) #-}
{-# NOINLINE (|||) #-}
instance (ArrowApply c, Profunctor c) => ArrowApply (NoInlineT c) where
app = lift $ lmap (\(f,b) -> (unlift f,b)) app
{-# NOINLINE app #-}
instance ArrowReader r c => ArrowReader r (NoInlineT c) where
ask = lift ask
local f = lift $ local (unlift f)
{-# NOINLINE ask #-}
{-# NOINLINE local #-}
instance ArrowState s c => ArrowState s (NoInlineT c) where
get = lift State.get
put = lift State.put
modify f = lift (State.modify (unlift f))
{-# NOINLINE get #-}
{-# NOINLINE put #-}
{-# NOINLINE modify #-}
instance ArrowWriter w c => ArrowWriter w (NoInlineT c) where
tell = lift tell
{-# NOINLINE tell #-}
instance ArrowFail e c => ArrowFail e (NoInlineT c) where
fail = lift fail
{-# NOINLINE fail #-}
instance ArrowEnv var val c => ArrowEnv var val (NoInlineT c) where
type Join y (NoInlineT c) = Env.Join y c
lookup f g = lift (Env.lookup (unlift f) (unlift g))
extend f = lift (Env.extend (unlift f))
{-# NOINLINE lookup #-}
{-# NOINLINE extend #-}
instance ArrowLetRec var val c => ArrowLetRec var val (NoInlineT c) where
letRec f = lift (letRec (unlift f))
{-# NOINLINE letRec #-}
instance ArrowClosure expr cls c => ArrowClosure expr cls (NoInlineT c) where
type Join y (NoInlineT c) = Cls.Join y c
closure = lift Cls.closure
apply f = lift $ Cls.apply (unlift f)
{-# NOINLINE closure #-}
{-# NOINLINE apply #-}
instance ArrowStore var val c => ArrowStore var val (NoInlineT c) where
type Join y (NoInlineT c) = Store.Join y c
read f g = lift $ Store.read (unlift f) (unlift g)
write = lift Store.write
{-# NOINLINE read #-}
{-# NOINLINE write #-}
type instance Fix (NoInlineT c) x y = NoInlineT (Fix c x y)
instance ArrowFix (Underlying (NoInlineT c) x y) => ArrowFix (NoInlineT c x y)
instance ArrowExcept e c => ArrowExcept e (NoInlineT c) where
type Join z (NoInlineT c) = Exc.Join z c
throw = lift throw
try f g h = lift $ try (unlift f) (unlift g) (unlift h)
{-# NOINLINE throw #-}
{-# NOINLINE try #-}
instance ArrowLowerBounded c => ArrowLowerBounded (NoInlineT c) where
bottom = lift bottom
{-# NOINLINE bottom #-}
instance ArrowJoin c => ArrowJoin (NoInlineT c) where
joinSecond lub f g = lift $ joinSecond lub f (unlift g)
{-# NOINLINE joinSecond #-}
instance ArrowComplete y c => ArrowComplete y (NoInlineT c) where
f <> g = lift $ unlift f <> unlift g
{-# NOINLINE (<⊔>) #-}
instance ArrowConst x c => ArrowConst x (NoInlineT c) where
askConst f = lift (askConst (unlift . f))
{-# NOINLINE askConst #-}
instance ArrowEffectCommutative c => ArrowEffectCommutative (NoInlineT c)
instance ArrowReuse a b c => ArrowReuse a b (NoInlineT c) where
reuse s f = lift $ reuse s f
{-# NOINLINE reuse #-}
instance ArrowContext ctx a c => ArrowContext ctx a (NoInlineT c) where
type Widening (NoInlineT c) a = Widening c a
askContext = Context.askContext
localContext f = lift (localContext (unlift f))
joinByContext widen = lift $ joinByContext widen
{-# NOINLINE askContext #-}
{-# NOINLINE localContext #-}
{-# NOINLINE joinByContext #-}
instance ArrowCache a b c => ArrowCache a b (NoInlineT c) where
lookup = lift Cache.lookup
write = lift Cache.write
update = lift Cache.update
setStable = lift Cache.setStable
{-# NOINLINE lookup #-}
{-# NOINLINE write #-}
{-# NOINLINE update #-}
{-# NOINLINE setStable #-}
......@@ -157,7 +157,7 @@ instance ArrowConst x c => ArrowConst x (ReaderT r c) where
instance ArrowEffectCommutative c => ArrowEffectCommutative (ReaderT r c)
instance ArrowReuse a b c => ArrowReuse a b (ReaderT r c) where
reuse f = lift' $ reuse f
reuse s f = lift' $ reuse s f
{-# INLINE reuse #-}
instance ArrowContext ctx a c => ArrowContext ctx a (ReaderT r c) where
......
......@@ -135,6 +135,11 @@ instance (Applicative f, ArrowClosure expr cls c) => ArrowClosure expr cls (Stat
{-# INLINE apply #-}
{-# SPECIALIZE instance ArrowClosure expr cls c => ArrowClosure expr cls (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowLetRec var val c) => ArrowLetRec var val (StaticT f c) where
letRec (StaticT f) = StaticT $ Env.letRec <$> f
{-# INLINE letRec #-}
{-# SPECIALIZE instance ArrowLetRec var val c => ArrowLetRec var val (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowStore var val c) => ArrowStore var val (StaticT f c) where
type Join y (StaticT f c) = Store.Join y c
read (StaticT f) (StaticT g) = StaticT $ Store.read <$> f <*> g
......
......@@ -184,7 +184,7 @@ instance (Monoid w, ArrowStack a c) => ArrowStack a (WriterT w c) where
{-# INLINE size #-}
instance (Monoid w, ArrowReuse a b c) => ArrowReuse a b (WriterT w c) where
reuse f = lift' (Reuse.reuse f)
reuse s f = lift' (Reuse.reuse s f)
{-# INLINE reuse #-}
instance (Monoid w, ArrowContext ctx a c) => ArrowContext ctx a (WriterT w c) where
......
......@@ -26,15 +26,19 @@ newtype Closure expr env = Closure (HashMap expr env)
instance (Identifiable expr, PreOrd env) => PreOrd (Closure expr env) where
() = withCls $ \m1 m2 -> M.keysSet m1 M.keysSet m2
&& and (M.intersectionWith () m1 m2)
{-# INLINE (⊑) #-}
instance (Identifiable expr, Complete env) => Complete (Closure expr env) where
() = withCls $ M.unionWith ()
{-# INLINE (⊔) #-}
instance Foldable (Closure expr) where
foldMap = foldMapDefault
{-# INLINE foldMap #-}
instance Traversable (Closure expr) where
traverse f (Closure m) = Closure <$> traverse f m
{-# INLINE traverse #-}
instance (Show a,Show b) => Show (Closure a b) where
show (Closure h)
......@@ -48,15 +52,18 @@ instance (Identifiable expr, Complete env) => IsList (Closure expr env) where
closure :: Identifiable expr => expr -> env -> Closure expr env
closure expr env = Closure $ M.singleton expr env
{-# INLINE closure #-}
apply :: (O.ArrowComplete y c, O.ArrowLowerBounded c, ArrowChoice c)
=> c ((expr,env),x) y -> c (Closure expr env,x) y
apply f = lmap (first (\(Closure m) -> M.toList m)) (O.joinList1' f)
{-# INLINE apply #-}
widening :: Identifiable expr => Widening env -> Widening (Closure expr env)
widening w = withCls $ \m1 m2 ->
(fold $ M.intersectionWith (\x y -> fst (w x y)) m1 m2,
M.unionWith (\x y -> snd (w x y)) m1 m2)
{-# INLINE widening #-}
withCls :: Coercible x x' => (HashMap expr env -> x') -> (Closure expr env -> x)
withCls = coerce
......
......@@ -33,13 +33,10 @@ instance PreOrd n => PreOrd (Constr n) where
instance Complete n => Complete (Constr n) where
Constr m1 Constr m2 = Constr (M.unionWith (IM.unionWith (zipWith ())) m1 m2)
widening :: (Identifiable n,Complete n) => Widening n -> Widening (Constr n)
widening :: (Complete n) => Widening n -> Widening (Constr n)
widening w c1@(Constr m1) c2@(Constr m2) =
( if size c1 < size c2 then Unstable else fst (sequenceA (M.intersectionWith (sequenceA <.> IM.intersectionWith (sequenceA <.> zipWith w)) m1 m2))
, c1 c2)
where
(<.>) = (.) . (.)
infixr 9 <.>
let c3 = Constr (M.unionWith (IM.unionWith (zipWith (\x y -> snd (w x y)))) m1 m2)
in (if c3 c1 && c3 c2 then Stable else Unstable, c3)
instance PreOrd n => LowerBounded (Constr n) where
bottom = Constr M.empty
......@@ -59,10 +56,10 @@ isEmpty :: Constr n -> Bool
isEmpty (Constr n) = M.null n
isSingleton :: (n -> Bool) -> Constr n -> Bool
isSingleton isSing (Constr n) = M.size n == 1 && forAll n (\a -> IM.size a == 1 && forAll a (\l -> all isSing l))
isSingleton isSing (Constr n) = M.size n == 1 && forAll n (\a -> IM.size a == 1 && forAll a (all isSing))
size :: (Identifiable n, Complete n) => Constr n -> Int
size c = length (toList c)
-- size :: (Identifiable n, Complete n) => Constr n -> Int
-- size c = length (toList c)
removeEmpty :: Constr n -> Constr n
removeEmpty (Constr m) = Constr (M.mapMaybe (\a -> if IM.null a then Nothing else Just a) m)
......
......@@ -87,6 +87,7 @@ widening (Pow xs) (Pow ys) = let zs = H.union xs ys in (if H.size zs == H.size x
widening Top (Pow _) = (Unstable,Top)
widening (Pow _) Top = (Unstable,Top)
widening Top Top = (Stable,Top)
{-# INLINABLE widening #-}
instance Identifiable x => Complete (FreeCompletion (Pow x)) where
F.Top _ = F.Top
......
......@@ -21,14 +21,12 @@ module Data.Abstract.Environment.Flat
import Prelude hiding (lookup)
import Control.Arrow.Closure
import Data.Abstract.IntersectionSet (Set)
import qualified Data.Abstract.IntersectionSet as H
import qualified Data.Abstract.Maybe as A
import Data.Abstract.Widening
import Data.Abstract.Stable
import Data.Abstract.IntersectionSet (Set)
import qualified Data.Abstract.IntersectionSet as H
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
import Data.Empty
......@@ -40,14 +38,13 @@ import Data.Hashable
import Text.Printf
import GHC.Generics
data Env var val = Env { visible :: Set var, env :: HashMap var val } | Visible (Set var)
data Env var val = Env { visible :: Set var, env :: HashMap var (val (Set var)) }
deriving (Generic)
deriving instance (Eq var, Eq val) => Eq (Env var val)
instance (Hashable var, Hashable val) => Hashable (Env var val)
deriving instance (Eq var, Eq (val (Set var))) => Eq (Env var val)
instance (Hashable var, Hashable (val (Set var))) => Hashable (Env var val)
instance (Identifiable var, Show var,Show val) => Show (Env var val) where
show (Visible vs) = show vs
instance (Identifiable var, Show var,Show (val (Set var))) => Show (Env var val) where
show Env {..}
| M.null env = "[]"