Commit 5616e1e3 by 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 ... ...