Verified Commit 41ab4f5f authored by Sven Keidel's avatar Sven Keidel

Merge branch 'context-sensitivity'

parents 4fe6f30f 2a2f6246
...@@ -17,8 +17,10 @@ import Data.Profunctor ...@@ -17,8 +17,10 @@ import Data.Profunctor
import Data.Abstract.Error import Data.Abstract.Error
import Data.Abstract.Except import Data.Abstract.Except
import Data.Abstract.Cache import Data.Abstract.Cache
import qualified Data.Abstract.Widening as W
import Control.DeepSeq import Control.DeepSeq
import Control.Category
import Control.Arrow import Control.Arrow
import Control.Arrow.Transformer.Const import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Reader import Control.Arrow.Transformer.Reader
...@@ -164,7 +166,7 @@ main = do ...@@ -164,7 +166,7 @@ main = do
{-# INLINE runExceptT' #-} {-# INLINE runExceptT' #-}
runChaoticT'' :: Profunctor c => ChaoticT Cache () () c x y -> c x y runChaoticT'' :: Profunctor c => ChaoticT Cache () () c x y -> c x y
runChaoticT'' = runChaoticT' runChaoticT'' = runChaoticT' id W.finite
{-# INLINE runChaoticT'' #-} {-# INLINE runChaoticT'' #-}
expr = addN 20 (Num 1) expr = addN 20 (Num 1)
......
...@@ -9,6 +9,7 @@ category: Language ...@@ -9,6 +9,7 @@ category: Language
dependencies: dependencies:
- base - base
- containers - containers
- comonad
- hashable - hashable
- mtl - mtl
- random - random
...@@ -19,7 +20,14 @@ dependencies: ...@@ -19,7 +20,14 @@ dependencies:
- profunctors - profunctors
library: library:
ghc-options: -Wall ghc-options:
-Wall
-Wcompat
-Widentities
-Wincomplete-record-updates
-Wincomplete-uni-patterns
-Wpartial-fields
-Wredundant-constraints
source-dirs: source-dirs:
- src - src
......
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
{-# LANGUAGE DefaultSignatures #-} {-# 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
import Control.Arrow.Trans import Control.Arrow.Trans
import Data.Profunctor import Data.Profunctor
import Data.Lens(Iso',from,Prism',getMaybe,get,set)
-- | Type family that computes the type of the fixpoint. -- | 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. -- | 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. -- | 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 (->) = (->) default fix :: (c ~ c' x y, ArrowTrans c', Underlying c' x y ~ c'' x' y', ArrowFix (c'' x' y')) => (c -> c) -> c
instance ArrowFix x y (->) where fix f = lift (fix (unlift . f . lift))
fix f = f (fix f) {-# 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 type instance Fix (->) x y = (->)
liftFix f = lift $ fix (unlift . f . lift) instance ArrowFix (x -> y) where
{-# INLINE liftFix #-} fix f = f (fix f)
type IterationStrategy c a b = c a b -> c a b 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 #-}
{-# 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) ()
{-# 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))
{-# 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 #-}
{-# 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 (<>) #-}
{-# 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)
{-# 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'
...@@ -3,6 +3,7 @@ module Control.Arrow.Monad where ...@@ -3,6 +3,7 @@ module Control.Arrow.Monad where
import Control.Arrow import Control.Arrow
import Control.Monad (join) import Control.Monad (join)
import Control.Comonad
import Data.Profunctor import Data.Profunctor
class (Functor f, Arrow c, Profunctor c) => ArrowFunctor f c where 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 ...@@ -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 :: c x (f y) -> c (f x) (f y)
mapJoinA f = rmap join (mapA f) 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 ...@@ -19,6 +19,7 @@ class (Arrow c, Profunctor c) => ArrowComplete y c where
instance Complete y => ArrowComplete y (->) where instance Complete y => ArrowComplete y (->) where
(<>) f g = \x -> f x g x (<>) f g = \x -> f x g x
{-# INLINE (<⊔>) #-}
-- | An arrow computation @c@ is effect commutative iff for all @f, g :: c x y@, -- | An arrow computation @c@ is effect commutative iff for all @f, g :: c x y@,
-- --
......
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Reader where module Control.Arrow.Reader where
import Control.Arrow import Control.Arrow
import Control.Monad.Reader (MonadReader) import Data.Profunctor
import qualified Control.Monad.Reader as M
import Data.Profunctor
-- | Arrow-based interface for read-only values. -- | Arrow-based interface for read-only values.
class (Arrow c, Profunctor c) => ArrowReader r c | c -> r where 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 ...@@ -15,7 +11,3 @@ class (Arrow c, Profunctor c) => ArrowReader r c | c -> r where
ask :: c () r ask :: c () r
-- | Runs a computation with a new value. -- | Runs a computation with a new value.
local :: c x y -> c (r,x) y 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 MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
......
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Trans where module Control.Arrow.Trans where
import Control.Arrow import Control.Arrow
import Data.Profunctor import Data.Profunctor
import Data.Coerce
class (Arrow c, Profunctor c) => ArrowRun c where class (Arrow c, Profunctor c) => ArrowRun c where
type Rep c x y type Run c x y
run :: c x y -> Rep 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 instance ArrowRun (->) where
type Rep (->) x y = x -> y type Run (->) x y = x -> y
run = id run = id
{-# INLINE run #-}
class ArrowLift t where class ArrowLift t where
lift' :: (Arrow c, Profunctor c) => c x y -> t c x y lift' :: (Arrow c, Profunctor c) => c x y -> t c x y
-- | Lifts an inner computation into an arrow transformer and vice versa. -- | Lifts an inner computation into an arrow transformer and vice versa.
class ArrowTrans t where class ArrowTrans c where
type Dom t x y :: * type Underlying c x y :: *
type Cod t 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 unlift1 :: ArrowTrans c => (c x y -> c x' y') -> (Underlying c x y -> Underlying c x' y')
unlift :: (Arrow c, Profunctor c) => t c x y -> c (Dom t x y) (Cod t 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) ...@@ -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 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 ) 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) deriving instance ArrowExcept e c => ArrowExcept e (EnvT var addr val c)
runEnvT :: (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Profunctor c) runEnvT :: Alloc c var addr val -> EnvT var addr val c x y -> c (Env var addr val,x) y
=> 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) runEnvT alloc (EnvT f) = runReaderT (runConstT alloc f)
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Profunctor c) => 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 ...@@ -73,16 +72,10 @@ instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Prof
(_,store) <- Reader.ask -< () (_,store) <- Reader.ask -< ()
Reader.local f -< ((env,store),x) Reader.local f -< ((env,store),x)
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, ArrowRun c) => ArrowRun (EnvT var addr val c) where instance (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 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) 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 instance ArrowLift (EnvT var addr val) where
lift' f = EnvT (lift' (lift' f)) lift' f = EnvT (lift' (lift' f))
...@@ -94,6 +87,5 @@ instance ArrowReader r c => ArrowReader r (EnvT var addr val c) where ...@@ -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 instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var addr val c) where
app = EnvT (app .# first coerce) 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 (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)
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)
...@@ -43,8 +43,8 @@ runCompletionT = coerce ...@@ -43,8 +43,8 @@ runCompletionT = coerce