Merge branch 'context-sensitivity'

lib/bench/ArrowTransformerBench.hs

@@ -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)

lib/package.yaml

@@ -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
 

lib/src/Control/Arrow/Fix.hs

-{-# 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 #-}
+

lib/src/Control/Arrow/Fix/Cache.hs

+{-# 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) ()

lib/src/Control/Arrow/Fix/Chaotic.hs

+{-# 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))

lib/src/Control/Arrow/Fix/Context.hs

+{-# 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 #-}

lib/src/Control/Arrow/Fix/Reuse.hs

+{-# 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 (<>) #-}

lib/src/Control/Arrow/Fix/Stack.hs

+{-# 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)

lib/src/Control/Arrow/Fix/Widening.hs

+{-# 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'

lib/src/Control/Arrow/Monad.hs

@@ -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 #-}

lib/src/Control/Arrow/Order.hs

@@ -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@,
 --

lib/src/Control/Arrow/Reader.hs

-{-# 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))

lib/src/Control/Arrow/Store.hs

-{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ConstraintKinds #-}

lib/src/Control/Arrow/Trans.hs

+{-# 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 #-}

lib/src/Control/Arrow/Transformer/Abstract/BoundedEnvironment.hs

@@ -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)

lib/src/Control/Arrow/Transformer/Abstract/Completion.hs

@@ -43,8 +43,8 @@ runCompletionT = coerce