From db4e0fb451ac7e8a93a6b808d96b2bb0c1b5c563 Mon Sep 17 00:00:00 2001 From: Sven Keidel Date: Fri, 1 Feb 2019 14:45:37 +0100 Subject: [PATCH] inline all typeclass methods and implement Profunctor arrows --- lib/package.yaml | 3 +- lib/src/Control/Arrow/Abstract/Join.hs | 6 +- lib/src/Control/Arrow/Abstract/Terminating.hs | 9 + lib/src/Control/Arrow/Alloc.hs | 3 +- lib/src/Control/Arrow/Conditional.hs | 3 +- lib/src/Control/Arrow/Const.hs | 3 +- lib/src/Control/Arrow/Deduplicate.hs | 3 +- lib/src/Control/Arrow/Environment.hs | 8 +- lib/src/Control/Arrow/Except.hs | 9 +- lib/src/Control/Arrow/Fail.hs | 4 +- lib/src/Control/Arrow/Fix.hs | 3 +- lib/src/Control/Arrow/Random.hs | 3 +- lib/src/Control/Arrow/Reader.hs | 3 +- lib/src/Control/Arrow/State.hs | 5 +- lib/src/Control/Arrow/Store.hs | 4 +- lib/src/Control/Arrow/Trans.hs | 7 +- .../Abstract/BoundedEnvironment.hs | 34 ++-- .../Arrow/Transformer/Abstract/Completion.hs | 70 +++++-- .../Arrow/Transformer/Abstract/Contour.hs | 37 ++-- .../Arrow/Transformer/Abstract/Environment.hs | 35 ++-- .../Arrow/Transformer/Abstract/Except.hs | 118 +++++++---- .../Arrow/Transformer/Abstract/Failure.hs | 79 ++++++-- .../Arrow/Transformer/Abstract/Fixpoint.hs | 183 +++++++++--------- .../Arrow/Transformer/Abstract/Powerset.hs | 55 ++++-- .../Abstract/ReachingDefinitions.hs | 49 +++-- .../Arrow/Transformer/Abstract/Stack.hs | 18 +- .../Arrow/Transformer/Abstract/Store.hs | 25 +-- .../Arrow/Transformer/Abstract/Terminating.hs | 107 ++++++++++ .../Arrow/Transformer/Concrete/Environment.hs | 20 +- .../Arrow/Transformer/Concrete/Except.hs | 16 +- .../Arrow/Transformer/Concrete/Failure.hs | 16 +- .../Arrow/Transformer/Concrete/Fixpoint.hs | 5 +- .../Arrow/Transformer/Concrete/Random.hs | 22 +-- .../Arrow/Transformer/Concrete/Store.hs | 16 +- .../Arrow/Transformer/Concrete/Trace.hs | 10 +- lib/src/Control/Arrow/Transformer/Const.hs | 42 ++-- lib/src/Control/Arrow/Transformer/Cont.hs | 39 +++- lib/src/Control/Arrow/Transformer/Reader.hs | 101 +++++++--- lib/src/Control/Arrow/Transformer/State.hs | 105 +++++++--- lib/src/Control/Arrow/Transformer/Static.hs | 63 ++++-- lib/src/Control/Arrow/Transformer/Writer.hs | 78 ++++++-- lib/src/Control/Arrow/Utils.hs | 6 + lib/src/Control/Arrow/Writer.hs | 3 +- lib/src/Data/Abstract/Error.hs | 29 +-- lib/src/Data/Abstract/Failure.hs | 112 +++++++---- lib/src/Data/Abstract/Terminating.hs | 11 +- lib/src/Data/Monoidal.hs | 27 +-- stratego/package.yaml | 13 ++ stratego/src/ConcreteSemantics.hs | 3 +- stratego/src/GrammarSemantics.hs | 2 + stratego/src/SortSemantics.hs | 27 ++- stratego/src/WildcardSemantics.hs | 2 + 52 files changed, 1127 insertions(+), 527 deletions(-) create mode 100644 lib/src/Control/Arrow/Abstract/Terminating.hs create mode 100644 lib/src/Control/Arrow/Transformer/Abstract/Terminating.hs diff --git a/lib/package.yaml b/lib/package.yaml index acab3399..266a3861 100644 --- a/lib/package.yaml +++ b/lib/package.yaml @@ -15,6 +15,7 @@ dependencies: - text - unordered-containers - deepseq + - profunctors flags: trace: @@ -23,7 +24,7 @@ flags: manual: True library: - ghc-options: -Wall + ghc-options: -Wall -O2 source-dirs: - src when: diff --git a/lib/src/Control/Arrow/Abstract/Join.hs b/lib/src/Control/Arrow/Abstract/Join.hs index bb553951..649780e6 100644 --- a/lib/src/Control/Arrow/Abstract/Join.hs +++ b/lib/src/Control/Arrow/Abstract/Join.hs @@ -6,8 +6,9 @@ import Prelude hiding ((.)) import Control.Arrow import Control.Arrow.Utils import Data.Order(Complete(..)) +import Data.Profunctor -class Arrow c => ArrowJoin c where +class (Arrow c, Profunctor c) => ArrowJoin c where -- | Join two arrow computation with the provided upper bound operator. -- -- Laws: @@ -18,10 +19,11 @@ class Arrow c => ArrowJoin c where 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) - +{-# INLINE joinWith' #-} (<⊔>) :: (ArrowJoin c, Complete y) => c x y -> c x y -> c x y (<⊔>) = joinWith (⊔) +{-# INLINE (<⊔>) #-} -- | Joins a list of arguments. Use it with idiom brackets: -- @ diff --git a/lib/src/Control/Arrow/Abstract/Terminating.hs b/lib/src/Control/Arrow/Abstract/Terminating.hs new file mode 100644 index 00000000..f3254f30 --- /dev/null +++ b/lib/src/Control/Arrow/Abstract/Terminating.hs @@ -0,0 +1,9 @@ +module Control.Arrow.Abstract.Terminating where + +import Control.Arrow +import Data.Abstract.Terminating +import Data.Profunctor + +class (Arrow c, Profunctor c) => ArrowTerminating c where + throwTerminating :: c (Terminating x) x + catchTerminating :: c x y -> c x (Terminating y) diff --git a/lib/src/Control/Arrow/Alloc.hs b/lib/src/Control/Arrow/Alloc.hs index 895440e3..cfaf5e52 100644 --- a/lib/src/Control/Arrow/Alloc.hs +++ b/lib/src/Control/Arrow/Alloc.hs @@ -3,8 +3,9 @@ module Control.Arrow.Alloc where import Control.Arrow +import Data.Profunctor -- | Arrow-based interface for allocating addresses. -class Arrow c => ArrowAlloc x y c where +class (Arrow c, Profunctor c) => ArrowAlloc x y c where -- | Allocates a new address. alloc :: c x y diff --git a/lib/src/Control/Arrow/Conditional.hs b/lib/src/Control/Arrow/Conditional.hs index 878c39b2..2877bcf0 100644 --- a/lib/src/Control/Arrow/Conditional.hs +++ b/lib/src/Control/Arrow/Conditional.hs @@ -6,9 +6,10 @@ module Control.Arrow.Conditional where import Control.Arrow import GHC.Exts(Constraint) +import Data.Profunctor -- | Arrow based interface to implement conditionals. -class Arrow c => ArrowCond v c | c -> v where +class (Arrow c, Profunctor c) => ArrowCond v c | c -> v where -- | Type class constraint used by the abstract instances to join arrow computations. type family Join (c :: * -> * -> *) x y :: Constraint diff --git a/lib/src/Control/Arrow/Const.hs b/lib/src/Control/Arrow/Const.hs index de91410f..a22758fc 100644 --- a/lib/src/Control/Arrow/Const.hs +++ b/lib/src/Control/Arrow/Const.hs @@ -3,9 +3,10 @@ module Control.Arrow.Const where import Control.Arrow +import Data.Profunctor -- | Arrow-based interface that gives access to a constant value. -class Arrow c => ArrowConst r c | c -> r where +class (Arrow c, Profunctor c) => ArrowConst r c | c -> r where -- | Retrieve the constant value. askConst :: c () r diff --git a/lib/src/Control/Arrow/Deduplicate.hs b/lib/src/Control/Arrow/Deduplicate.hs index 85a6bb08..968b7916 100644 --- a/lib/src/Control/Arrow/Deduplicate.hs +++ b/lib/src/Control/Arrow/Deduplicate.hs @@ -3,11 +3,12 @@ module Control.Arrow.Deduplicate where import Control.Arrow +import Data.Profunctor -- | Arrow-based interface to deduplicate the result /set/ of a computation. -- This is required by the 'Control.Arrow.Transformer.Abstract.Powerset.PowT' -- arrow transformer. -class Arrow c => ArrowDeduplicate x y c where +class (Arrow c, Profunctor c) => ArrowDeduplicate x y c where dedup :: c x y -> c x y instance ArrowDeduplicate x y (->) where diff --git a/lib/src/Control/Arrow/Environment.hs b/lib/src/Control/Arrow/Environment.hs index 04588432..c4ffe928 100644 --- a/lib/src/Control/Arrow/Environment.hs +++ b/lib/src/Control/Arrow/Environment.hs @@ -15,6 +15,7 @@ import Control.Arrow.Fail import Control.Arrow.Utils import Data.String +import Data.Profunctor import Text.Printf @@ -22,7 +23,7 @@ import GHC.Exts (Constraint) -- | Arrow-based interface for interacting with environments. -class Arrow c => ArrowEnv var val env c | c -> var, c -> val, c -> env where +class (Arrow c, Profunctor c) => ArrowEnv var val env c | c -> var, c -> val, c -> env where -- | Type class constraint used by the abstract instances to join arrow computations. type family Join (c :: * -> * -> *) x y :: Constraint @@ -44,6 +45,7 @@ class Arrow c => ArrowEnv var val env c | c -> var, c -> val, c -> env where -- | Simpler version of environment lookup. lookup' :: (Join c ((val,var),var) val, Show var, IsString e, ArrowFail e c, ArrowEnv var val env c) => c var val lookup' = lookup'' id +{-# INLINE lookup' #-} lookup'' :: (Join c ((val,var),var) y, Show var, IsString e, ArrowFail e c, ArrowEnv var val env c) => c val y -> c var y lookup'' f = proc var -> @@ -51,7 +53,7 @@ lookup'' f = proc var -> (proc (val,_) -> f -< val) (proc var -> fail -< fromString $ printf "Variable %s not bound" (show var)) -< (var,var) - +{-# INLINE lookup'' #-} -- | Run a computation in an extended environment. extendEnv' :: ArrowEnv var val env c => c a b -> c (var,val,a) b @@ -59,7 +61,9 @@ extendEnv' f = proc (x,y,a) -> do env <- getEnv -< () env' <- extendEnv -< (x,y,env) localEnv f -< (env',a) +{-# INLINE extendEnv' #-} -- | Add a list of bindings to the given environment. bindings :: (ArrowChoice c, ArrowEnv var val env c) => c ([(var,val)],env) env bindings = fold ((\(env,(x,y)) -> (x,y,env)) ^>> extendEnv) +{-# INLINE bindings #-} diff --git a/lib/src/Control/Arrow/Except.hs b/lib/src/Control/Arrow/Except.hs index 2f87e9fb..008ff23f 100644 --- a/lib/src/Control/Arrow/Except.hs +++ b/lib/src/Control/Arrow/Except.hs @@ -14,9 +14,10 @@ import Control.Arrow import Control.Arrow.Utils import GHC.Exts(Constraint) +import Data.Profunctor -- | Arrow-based interface for exception handling. -class Arrow c => ArrowExcept e c | c -> e where +class (Arrow c, Profunctor c) => ArrowExcept e c | c -> e where -- | Type class constraint used by the abstract instances to join arrow computations. type family Join (c :: * -> * -> *) x y :: Constraint @@ -33,19 +34,23 @@ class Arrow c => ArrowExcept e c | c -> e where -- | Simpler version of 'throw'. throw' :: ArrowExcept () c => c a b throw' = proc _ -> throw -< () +{-# INLINE throw' #-} -- | Simpler version of 'catch'. catch' :: (Join c (x,(x,e)) y, ArrowExcept e c) => c x y -> c e y -> c x y catch' f g = catch f (pi2 >>> g) +{-# INLINE catch' #-} -- | @'try' f g h@ executes @f@, if it succeeds the result is passed to -- @g@, if it fails the original input is passed to @h@. try :: (Join c (x,(x,e)) z, ArrowExcept e c) => c x y -> c y z -> c x z -> c x z try f g h = catch (f >>> g) (pi1 >>> h) +{-# INLINE try #-} -- | Picks the first computation that does not throw an exception. (<+>) :: (Join c (x,(x,e)) y, ArrowExcept e c) => c x y -> c x y -> c x y f <+> g = catch f (pi1 >>> g) +{-# INLINE (<+>) #-} -- | @'tryFirst' f g -< l@ executes @f@ on elements of @l@ until one of them does not throw an exception. -- In case @f@ throws an exception for all elements of @l@, @g@ is executed. @@ -53,7 +58,9 @@ tryFirst :: (Join c ((x,[x]),((x,[x]),e)) y, ArrowChoice c, ArrowExcept e c) => tryFirst f g = proc l -> case l of [] -> g -< () a:as -> try (f . pi1) id (tryFirst f g . pi2) -< (a,as) +{-# INLINE tryFirst #-} -- | A computation that always succeeds success :: ArrowExcept e c => c a a success = id +{-# INLINE success #-} diff --git a/lib/src/Control/Arrow/Fail.hs b/lib/src/Control/Arrow/Fail.hs index 74581a55..9f04b57a 100644 --- a/lib/src/Control/Arrow/Fail.hs +++ b/lib/src/Control/Arrow/Fail.hs @@ -10,9 +10,10 @@ import Prelude hiding (fail) import Control.Arrow import Control.Monad.Except (MonadError) import qualified Control.Monad.Except as M +import Data.Profunctor -- | Arrow-based interface for computations that can fail. -class Arrow c => ArrowFail e c | c -> e where +class (Arrow c, Profunctor c) => ArrowFail e c | c -> e where -- | Causes the computation to fail. In contrast to -- 'Control.Arrow.Except.ArrowExcept', this failure cannot be recovered from. @@ -24,3 +25,4 @@ instance MonadError e m => ArrowFail e (Kleisli m) where -- | Simpler version of 'fail'. fail' :: ArrowFail () c => c a b fail' = arr (const ()) >>> fail +{-# INLINE fail' #-} diff --git a/lib/src/Control/Arrow/Fix.hs b/lib/src/Control/Arrow/Fix.hs index c70d4632..664023d2 100644 --- a/lib/src/Control/Arrow/Fix.hs +++ b/lib/src/Control/Arrow/Fix.hs @@ -9,9 +9,10 @@ module Control.Arrow.Fix(ArrowFix(..),Fix,liftFix) where import Control.Arrow import Control.Arrow.Trans +import Data.Profunctor -- | Arrow-based interface for describing fixpoint computations. -class Arrow c => ArrowFix x y c where +class (Arrow c, Profunctor c) => ArrowFix x y c where -- | Computes the fixpoint of an arrow computation. fix :: (c x y -> c x y) -> c x y diff --git a/lib/src/Control/Arrow/Random.hs b/lib/src/Control/Arrow/Random.hs index 0ca43b26..92fcecba 100644 --- a/lib/src/Control/Arrow/Random.hs +++ b/lib/src/Control/Arrow/Random.hs @@ -2,6 +2,7 @@ module Control.Arrow.Random where import Control.Arrow +import Data.Profunctor -class Arrow c => ArrowRand v c where +class (Arrow c, Profunctor c) => ArrowRand v c where random :: c () v diff --git a/lib/src/Control/Arrow/Reader.hs b/lib/src/Control/Arrow/Reader.hs index de19f67b..982d4724 100644 --- a/lib/src/Control/Arrow/Reader.hs +++ b/lib/src/Control/Arrow/Reader.hs @@ -7,9 +7,10 @@ module Control.Arrow.Reader where import Control.Arrow import Control.Monad.Reader (MonadReader) import qualified Control.Monad.Reader as M +import Data.Profunctor -- | Arrow-based interface for read-only values. -class Arrow c => ArrowReader r c | c -> r where +class (Arrow c, Profunctor c) => ArrowReader r c | c -> r where -- | Retrieves the current read-only value. ask :: c () r -- | Runs a computation with a new value. diff --git a/lib/src/Control/Arrow/State.hs b/lib/src/Control/Arrow/State.hs index 1d482fc9..a121a07c 100644 --- a/lib/src/Control/Arrow/State.hs +++ b/lib/src/Control/Arrow/State.hs @@ -12,9 +12,10 @@ import Control.Arrow import Control.Arrow.Utils import Control.Monad.State (MonadState) import qualified Control.Monad.State as M +import Data.Profunctor -- | Arrow-based interface to describe stateful computations. -class Arrow c => ArrowState s c | c -> s where +class (Arrow c, Profunctor c) => ArrowState s c | c -> s where -- | Retrieves the current state. get :: c () s -- | Sets the current state. @@ -23,10 +24,12 @@ class Arrow c => ArrowState s c | c -> s where -- | run computation that modifies the current state. modify :: ArrowState s c => c (x,s) s -> c x () modify f = put <<< f <<< (id &&& const get) +{-# INLINE modify #-} -- | run computation that modifies the current state. modify' :: ArrowState s c => c (s,x) s -> c x () modify' f = put <<< f <<< (const get &&& id) +{-# INLINE modify' #-} instance MonadState s m => ArrowState s (Kleisli m) where get = Kleisli (P.const M.get) diff --git a/lib/src/Control/Arrow/Store.hs b/lib/src/Control/Arrow/Store.hs index a7604236..da8e2e62 100644 --- a/lib/src/Control/Arrow/Store.hs +++ b/lib/src/Control/Arrow/Store.hs @@ -12,12 +12,13 @@ import Control.Arrow import Control.Arrow.Fail import Text.Printf import Data.String +import Data.Profunctor import GHC.Exts(Constraint) -- | Arrow-based interface to describe computations that read from a store. -- The parameter `y` needs to be exposed, because abstract instances -- may need to join on `y`. -class Arrow c => ArrowStore var val c | c -> var, c -> val where +class (Arrow c, Profunctor c) => ArrowStore var val c | c -> var, c -> val where type family Join (c :: * -> * -> *) x y :: Constraint -- | Reads a value from the store. Fails if the binding is not in the current store. @@ -32,3 +33,4 @@ read' = proc var -> read (proc (val,_) -> returnA -< val) (proc var -> fail -< fromString $ printf "variable %s not bound" (show var)) -< (var,var) +{-# INLINE read' #-} diff --git a/lib/src/Control/Arrow/Trans.hs b/lib/src/Control/Arrow/Trans.hs index 059bde24..8f0621d0 100644 --- a/lib/src/Control/Arrow/Trans.hs +++ b/lib/src/Control/Arrow/Trans.hs @@ -2,16 +2,17 @@ module Control.Arrow.Trans where import Control.Arrow +import Data.Profunctor class ArrowLift t where - lift' :: Arrow 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. class ArrowTrans t where type Dom t x y :: * type Cod t x y :: * - lift :: Arrow c => c (Dom t x y) (Cod t x y) -> t c x y - unlift :: Arrow c => t c x y -> c (Dom t x y) (Cod t x y) + 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) type family Rep c x y diff --git a/lib/src/Control/Arrow/Transformer/Abstract/BoundedEnvironment.hs b/lib/src/Control/Arrow/Transformer/Abstract/BoundedEnvironment.hs index 0eb147bf..88e0945e 100644 --- a/lib/src/Control/Arrow/Transformer/Abstract/BoundedEnvironment.hs +++ b/lib/src/Control/Arrow/Transformer/Abstract/BoundedEnvironment.hs @@ -31,6 +31,12 @@ import Data.Identifiable import Data.Abstract.FiniteMap (Map) import qualified Data.Abstract.FiniteMap as M import Data.Abstract.Maybe(Maybe(..)) +import Data.Profunctor + +-- | Abstract domain for environments in which concrete environments +-- are approximated by a mapping from variables to addresses and a +-- mapping from addresses to values. The number of allocated addresses +-- allows to tune the precision and performance of the analysis. -- | Abstract domain for environments in which concrete environments -- are approximated by a mapping from variables to addresses and a @@ -40,10 +46,10 @@ import Data.Abstract.Maybe(Maybe(..)) -- Furthermore, closures and environments are defined mutually -- recursively. By only allowing a finite number of addresses, the -- abstract domain of closures and environments becomes finite. -newtype EnvT var addr val c x y = - EnvT ( ConstT (c (var,val,Map var addr val) addr) (ReaderT (Map var addr val) c) x y ) +newtype EnvT var addr val c x y = EnvT ( ConstT (c (var,val,Map var addr val) addr) (ReaderT (Map var addr val) c) x y ) + deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowState s, ArrowFail e, ArrowExcept e, ArrowJoin) -runEnvT :: (Show var, Identifiable var, Identifiable addr, Complete val, ArrowChoice c) +runEnvT :: (Show var, Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Profunctor c) => c (var,val,Map var addr val) addr -> EnvT var addr val c x y -> c ([(var,val)],x) y runEnvT alloc f = let EnvT f' = proc (bs,x) -> do @@ -51,6 +57,7 @@ runEnvT alloc f = env' <- bindings -< (bs,env) localEnv f -< (env',x) in (const (M.empty) &&& id) ^>> runReaderT (runConstT alloc f') +{-# INLINE runEnvT #-} instance ArrowTrans (EnvT var addr val) where type Dom (EnvT var addr val) x y = Dom (ReaderT (Map var addr val)) x y @@ -60,8 +67,9 @@ instance ArrowTrans (EnvT var addr val) where instance ArrowLift (EnvT var addr val) where lift' f = EnvT (lift' (lift' f)) + {-# INLINE lift' #-} -instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c) => +instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Profunctor c) => ArrowEnv var val (Map var addr val) (EnvT var addr val c) where type Join (EnvT var addr val c) x y = Complete (c (Map var addr val,x) y) lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do @@ -70,27 +78,27 @@ instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c) => Just val -> f -< (val,x) JustNothing val -> joined f g -< ((val,x),x) Nothing -> g -< x + {-# INLINE lookup #-} getEnv = EnvT ask + {-# INLINE getEnv #-} extendEnv = EnvT $ ConstT $ StaticT $ \alloc -> lift' $ M.insertBy alloc + {-# INLINE extendEnv #-} localEnv (EnvT f) = EnvT $ local f + {-# INLINE localEnv #-} instance ArrowReader r c => ArrowReader r (EnvT var addr val c) where ask = lift' ask + {-# INLINE ask #-} local (EnvT (ConstT (StaticT f))) = EnvT $ ConstT $ StaticT $ \alloc -> ReaderT $ (\(env,(r,x)) -> (r,(env,x))) ^>> local (runReaderT (f alloc)) + {-# INLINE local #-} -instance ArrowApply c => ArrowApply (EnvT var addr val c) where - app = EnvT $ (\(EnvT f,x) -> (f,x)) ^>> app +instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var addr val c) where + app = EnvT $ lmap (\(EnvT f,x) -> (f,x)) app + {-# INLINE app #-} 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) 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) -deriving instance Arrow c => Category (EnvT var addr val c) -deriving instance Arrow c => Arrow (EnvT var addr val c) -deriving instance ArrowChoice c => ArrowChoice (EnvT var addr val c) -deriving instance ArrowState s c => ArrowState s (EnvT var addr val c) -deriving instance ArrowFail e c => ArrowFail e (EnvT var addr val c) -deriving instance ArrowExcept e c => ArrowExcept e (EnvT var addr val c) -deriving instance ArrowJoin c => ArrowJoin (EnvT var addr val c) deriving instance PreOrd (c ((Map var addr val),x) y) => PreOrd (EnvT var addr val c x y) deriving instance Complete (c ((Map var addr val),x) y) => Complete (EnvT var addr val c x y) diff --git a/lib/src/Control/Arrow/Transformer/Abstract/Completion.hs b/lib/src/Control/Arrow/Transformer/Abstract/Completion.hs index 02c57d8d..d99944e1 100644 --- a/lib/src/Control/Arrow/Transformer/Abstract/Completion.hs +++ b/lib/src/Control/Arrow/Transformer/Abstract/Completion.hs @@ -9,6 +9,7 @@ module Control.Arrow.Transformer.Abstract.Completion(CompletionT(..)) where import Prelude hiding ((.),id,lookup,fail) +import Control.Applicative import Control.Arrow import Control.Arrow.Deduplicate import Control.Arrow.Environment as Env @@ -21,6 +22,7 @@ import Control.Arrow.Fix import Control.Arrow.Abstract.Join import Control.Category +import Data.Profunctor import Data.Abstract.FreeCompletion import Data.Monoidal import Data.Order hiding (lub) @@ -29,71 +31,109 @@ import Data.Order hiding (lub) -- E.g. allows to join a computation of type 'c x [y]'. newtype CompletionT c x y = CompletionT { runCompletionT :: c x (FreeCompletion y) } +instance (Profunctor c, Arrow c) => Profunctor (CompletionT c) where + dimap f g h = lift $ dimap f (fmap g) (unlift h) + {-# INLINE dimap #-} + lmap f h = lift $ lmap f (unlift h) + {-# INLINE lmap #-} + rmap g h = lift $ rmap (fmap g) (unlift h) + {-# INLINE rmap #-} + instance ArrowTrans CompletionT where type Dom CompletionT x y = x type Cod CompletionT x y = FreeCompletion y lift = CompletionT + {-# INLINE lift #-} unlift = runCompletionT + {-# INLINE unlift #-} instance ArrowLift CompletionT where - lift' f = CompletionT (f >>> arr Lower) + lift' f = CompletionT (rmap Lower f) + {-# INLINE lift' #-} -instance ArrowChoice c => Category (CompletionT c) where +instance (ArrowChoice c, Profunctor c) => Category (CompletionT c) where id = lift' id + {-# INLINE id #-} CompletionT f . CompletionT g = CompletionT $ proc x -> do g' <- g -< x case g' of Lower a -> f -< a Top -> returnA -< Top + {-# INLINE (.) #-} -instance ArrowChoice c => Arrow (CompletionT c) where +instance (ArrowChoice c, Profunctor c) => Arrow (CompletionT c) where arr = lift' . arr - first f = lift $ first (unlift f) >>^ strength1 - second f = lift $ second (unlift f) >>^ strength2 - -instance ArrowChoice c => ArrowChoice (CompletionT c) where - left (CompletionT f) = CompletionT $ left f >>^ strength1 - right (CompletionT f) = CompletionT $ right f >>^ strength2 - -instance (ArrowApply c, ArrowChoice c) => ArrowApply (CompletionT c) where - app = CompletionT $ first runCompletionT ^>> app - -instance (ArrowChoice c, ArrowState s c) => ArrowState s (CompletionT c) where + {-# INLINE arr #-} + first f = lift $ rmap strength1 (first (unlift f)) + {-# INLINE first #-} + second f = lift $ rmap strength2 (second (unlift f)) + {-# INLINE second #-} + f *** g = lift $ rmap (uncurry (liftA2 (,))) (unlift f *** unlift g) + {-# INLINE (***) #-} + f &&& g = lift $ rmap (uncurry (liftA2 (,))) (unlift f &&& unlift g) + {-# INLINE (&&&) #-} + +instance (ArrowChoice c, Profunctor c) => ArrowChoice (CompletionT c) where + left (CompletionT f) = CompletionT $ rmap strength1 (left f) + {-# INLINE left #-} + right (CompletionT f) = CompletionT $ rmap strength2 (right f) + {-# INLINE right #-} + +instance (ArrowApply c, ArrowChoice c, Profunctor c) => ArrowApply (CompletionT c) where + app = CompletionT $ lmap (first runCompletionT) app + {-# INLINE app #-} + +instance (ArrowChoice c, ArrowState s c, Profunctor c) => ArrowState s (CompletionT c) where get = lift' get + {-# INLINE get #-} put = lift' put + {-# INLINE put #-} instance (ArrowChoice c, ArrowFail e c) => ArrowFail e (CompletionT c) where fail = lift' fail + {-# INLINE fail #-} instance (ArrowChoice c, ArrowReader r c) => ArrowReader r (CompletionT c) where ask = lift' ask + {-# INLINE ask #-} local f = lift (local (unlift f)) + {-# INLINE local #-} instance (ArrowChoice c, ArrowEnv var val env c) => ArrowEnv var val env (CompletionT c) where type Join (CompletionT c) x y = Env.Join c (Dom CompletionT x y) (Cod CompletionT x y) lookup f g = lift (lookup (unlift f) (unlift g)) + {-# INLINE lookup #-} getEnv = lift' getEnv + {-# INLINE getEnv #-} extendEnv = lift' extendEnv + {-# INLINE extendEnv #-} localEnv f = lift (localEnv (unlift f)) + {-# INLINE localEnv #-} instance (ArrowChoice c, ArrowExcept e c) => ArrowExcept e (CompletionT c) where type Join (CompletionT c) x y = Exc.Join c (Dom CompletionT x y) (Cod CompletionT x y) throw = lift' throw + {-# INLINE throw #-} catch f g = lift $ catch (unlift f) (unlift g) + {-# INLINE catch #-} finally f g = lift $ finally (unlift f) (unlift g) + {-# INLINE finally #-} -instance ArrowChoice c => ArrowDeduplicate x y (CompletionT c) where +instance (ArrowChoice c, Profunctor c) => ArrowDeduplicate x y (CompletionT c) where dedup = returnA + {-# INLINE dedup #-} type instance Fix x y (CompletionT c) = CompletionT (Fix (Dom CompletionT x y) (Cod CompletionT x y) c) instance (ArrowChoice c, ArrowFix (Dom CompletionT x y) (Cod CompletionT x y) c) => ArrowFix x y (CompletionT c) where fix = liftFix + {-# INLINE fix #-} instance (ArrowChoice c, ArrowJoin c) => ArrowJoin (CompletionT c) where joinWith lub f g = lift $ joinWith join (unlift f) (unlift g) where join (Lower x) (Lower y) = Lower (lub x y) join Top _ = Top join _ Top = Top + {-# INLINE joinWith #-} deriving instance PreOrd (c x (FreeCompletion y)) => PreOrd (CompletionT c x y) deriving instance LowerBounded (c x (FreeCompletion y)) => LowerBounded (CompletionT c x y) diff --git a/lib/src/Control/Arrow/Transformer/Abstract/Contour.hs b/lib/src/Control/Arrow/Transformer/Abstract/Contour.hs index 887a3447..6744f384 100644 --- a/lib/src/Control/Arrow/Transformer/Abstract/Contour.hs +++ b/lib/src/Control/Arrow/Transformer/Abstract/Contour.hs @@ -27,50 +27,49 @@ import Control.Category import Data.Label import Data.Order import Data.CallString +import Data.Profunctor -- | Records the k-bounded call string. Meant to be used in -- conjunction with 'Abstract.BoundedEnvironment'. newtype ContourT lab c a b = ContourT (ReaderT (CallString lab) c a b) + deriving (Profunctor,Category,Arrow,ArrowLift,ArrowChoice, ArrowState s, + ArrowEnv x y env, ArrowFail e, ArrowExcept e, ArrowJoin) -- | Runs a computation that records a call string. The argument 'k' -- specifies the maximum length of a call string. All larger call -- strings are truncated to at most 'k' elements. -runContourT :: Arrow c => Int -> ContourT lab c a b -> c a b -runContourT k (ContourT (ReaderT f)) = (\a -> (empty k,a)) ^>> f +runContourT :: (Arrow c, Profunctor c) => Int -> ContourT lab c a b -> c a b +runContourT k (ContourT (ReaderT f)) = lmap (\a -> (empty k,a)) f +{-# INLINE runContourT #-} type instance Fix x y (ContourT lab c) = ContourT lab (Fix x y c) -instance (ArrowFix x y c, ArrowApply c, HasLabel x lab) => ArrowFix x y (ContourT lab c) where +instance (ArrowFix x y c, ArrowApply c, HasLabel x lab,Profunctor c) => ArrowFix x y (ContourT lab c) where -- Pushes the label of the last argument on the call string and truncate the call string in case it reached the maximum length fix f = ContourT $ ReaderT $ proc (c,x) -> fix (unwrap c . f . wrap) -<< x where - wrap :: Arrow c => c x y -> ContourT lab c x y + wrap :: (Arrow c, Profunctor c) => c x y -> ContourT lab c x y wrap = lift' - unwrap :: (HasLabel x lab, Arrow c) => CallString lab -> ContourT lab c x y -> c x y + unwrap :: (HasLabel x lab, Arrow c, Profunctor c) => CallString lab -> ContourT lab c x y -> c x y unwrap c (ContourT (ReaderT f')) = proc x -> do y <- f' -< (push (label x) c,x) returnA -< y + {-# INLINE fix #-} -instance Arrow c => ArrowAlloc (var,val,env) (var,CallString lab) (ContourT lab c) where +instance (Arrow c, Profunctor c) => ArrowAlloc (var,val,env) (var,CallString lab) (ContourT lab c) where -- | Return the variable together with the current call string as address. - alloc = ContourT $ ReaderT $ proc (l,(x,_,_)) -> returnA -< (x,l) + alloc = ContourT $ ReaderT $ arr $ \(l,(x,_,_)) -> (x,l) + {-# INLINE alloc #-} -instance ArrowApply c => ArrowApply (ContourT lab c) where - app = ContourT $ (\(ContourT f,x) -> (f,x)) ^>> app +instance (ArrowApply c, Profunctor c) => ArrowApply (ContourT lab c) where + app = ContourT $ lmap (\(ContourT f,x) -> (f,x)) app + {-# INLINE app #-} instance ArrowReader r c => ArrowReader r (ContourT lab c) where ask = lift' ask + {-# INLINE ask #-} local (ContourT (ReaderT f)) = ContourT $ ReaderT $ ((\(c,(r,x)) -> (r,(c,x))) ^>> local f) - -deriving instance Arrow c => Category (ContourT lab c) -deriving instance Arrow c => Arrow (ContourT lab c) -deriving instance ArrowLift (ContourT lab) -deriving instance ArrowChoice c => ArrowChoice (ContourT lab c) -deriving instance ArrowState s c => ArrowState s (ContourT lab c) -deriving instance ArrowEnv x y env c => ArrowEnv x y env (ContourT lab c) -deriving instance ArrowFail e c => ArrowFail e (ContourT lab c) -deriving instance ArrowExcept e c => ArrowExcept e (ContourT lab c) -deriving instance ArrowJoin c => ArrowJoin (ContourT lab c) + {-# INLINE local #-} deriving instance PreOrd (c (CallString lab,x) y) => PreOrd (ContourT lab c x y) deriving instance LowerBounded (c (CallString lab,x) y) => LowerBounded (ContourT lab c x y) diff --git a/lib/src/Control/Arrow/Transformer/Abstract/Environment.hs b/lib/src/Control/Arrow/Transformer/Abstract/Environment.hs index 34bd5c7b..969a79ec 100644 --- a/lib/src/Control/Arrow/Transformer/Abstract/Environment.hs +++ b/lib/src/Control/Arrow/Transformer/Abstract/Environment.hs @@ -30,16 +30,21 @@ import Control.Arrow.Environment import Control.Arrow.Fix import Control.Arrow.Abstract.Join +import Data.Profunctor newtype EnvT var val c x y = EnvT (ReaderT (Map var val) c x y) + deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowJoin, + ArrowState s, ArrowFail e, ArrowExcept e, ArrowStore var' val', ArrowConst k) -runEnvT :: Arrow c => EnvT var val c x y -> c (Map var val,x) y +runEnvT :: (Arrow c, Profunctor c) => EnvT var val c x y -> c (Map var val,x) y runEnvT = unlift +{-# INLINE runEnvT #-} -runEnvT' :: (Arrow c, Identifiable var) => EnvT var val c x y -> c ([(var,val)],x) y +runEnvT' :: (Arrow c, Profunctor c, Identifiable var) => EnvT var val c x y -> c ([(var,val)],x) y runEnvT' f = first M.fromList ^>> runEnvT f +{-# INLINE runEnvT' #-} -instance (Show var, Identifiable var, ArrowChoice c) => ArrowEnv var val (Map var val) (EnvT var val c) where +instance (Show var, Identifiable var, ArrowChoice c,Profunctor c) => ArrowEnv var val (Map var val) (EnvT var val c) where type Join (EnvT var val c) x y = (Complete (c (Map var val,x) y)) lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do env <- ask -< () @@ -47,30 +52,26 @@ instance (Show var, Identifiable var, ArrowChoice c) => ArrowEnv var val (Map va Just val -> f -< (val,x) JustNothing val -> joined f g -< ((val,x),x) Nothing -> g -< x + {-# INLINE lookup #-} getEnv = EnvT ask + {-# INLINE getEnv #-} extendEnv = arr $ \(x,y,env) -> M.insert x y env + {-# INLINE extendEnv #-} localEnv (EnvT f) = EnvT (local f) + {-# INLINE localEnv #-} -instance ArrowApply c => ArrowApply (EnvT var val c) where - app = EnvT $ (\(EnvT f,x) -> (f,x)) ^>> app +instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var val c) where + app = EnvT $ lmap (\(EnvT f,x) -> (f,x)) app + {-# INLINE app #-} instance ArrowReader r c => ArrowReader r (EnvT var val c) where ask = lift' ask - local f = lift $ (\(env,(r,x)) -> (r,(env,x))) ^>> local (unlift f) + {-# INLINE ask #-} + local f = lift $ lmap (\(env,(r,x)) -> (r,(env,x))) (local (unlift f)) + {-# INLINE local #-} type instance Fix x y (EnvT var val c) = EnvT var val (Fix (Dom (EnvT var val) x y) (Cod (EnvT var val) x y) c) deriving instance ArrowFix (Map var val,x) y c => ArrowFix x y (EnvT var val c) -deriving instance ArrowJoin c => ArrowJoin (EnvT var val c) -deriving instance Arrow c => Category (EnvT var val c) -deriving instance Arrow c => Arrow (EnvT var val c) -deriving instance ArrowTrans (EnvT var val) -deriving instance ArrowLift (EnvT var val) -deriving instance ArrowChoice c => ArrowChoice (EnvT var val c) -deriving instance ArrowState s c => ArrowState s (EnvT var val c) -deriving instance ArrowFail e c => ArrowFail e (EnvT var val c) -deriving instance ArrowExcept e c => ArrowExcept e (EnvT var val c) -deriving instance ArrowStore var val c => ArrowStore var val (EnvT var' val' c) -deriving instance ArrowConst x c => ArrowConst x (EnvT var val c) deriving instance PreOrd (c (Map var val,x) y) => PreOrd (EnvT var val c x y) deriving instance Complete (c (Map var val,x) y) => Complete (EnvT var val c x y) diff --git a/lib/src/Control/Arrow/Transformer/Abstract/Except.hs b/lib/src/Control/Arrow/Transformer/Abstract/Except.hs index c9b92837..ea3f4bb8 100644 --- a/lib/src/Control/Arrow/Transformer/Abstract/Except.hs +++ b/lib/src/Control/Arrow/Transformer/Abstract/Except.hs @@ -10,6 +10,7 @@ module Control.Arrow.Transformer.Abstract.Except(ExceptT(..)) where import Prelude hiding (id,lookup,(.),read,fail) +import Control.Applicative import Control.Arrow import Control.Arrow.Const import Control.Arrow.Deduplicate @@ -27,25 +28,35 @@ import Control.Category import Data.Abstract.Error import Data.Monoidal import Data.Order +import Data.Profunctor newtype ExceptT e c x y = ExceptT { runExceptT :: c x (Error e y)} -instance ArrowTrans (ExceptT e) where - type Dom (ExceptT e) x y = x - type Cod (ExceptT e) x y = Error e y - lift = ExceptT - unlift = runExceptT - -instance ArrowLift (ExceptT e) where - lift' f = ExceptT (f >>> arr Success) +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)) + throw = lift $ arr Fail + {-# INLINE throw #-} + catch f g = lift $ proc x -> do + e <- unlift f -< x + case e of + Success y -> returnA -< Success y + SuccessOrFail er y -> joined (arr Success) (unlift g) -< (y,(x,er)) + Fail er -> unlift g -< (x,er) + {-# INLINE catch #-} + finally f g = lift $ proc x -> do + e <- unlift f -< x + unlift g -< x + returnA -< e + {-# INLINE finally #-} instance (ArrowChoice c, ArrowJoin c, Complete e) => Category (ExceptT e c) where id = lift' id + {-# INLINE id #-} f . g = lift $ proc x -> do y <- unlift g -< x case y of Success y' -> unlift f -< y' - Fail e -> returnA -< Fail e + Fail e -> returnA -< Fail e SuccessOrFail e y' -> do -- Ideally we would like to write '(returnA -< Fail e) ⊔ (f -< y)', -- however this is not possible, because the result type of @@ -57,79 +68,104 @@ instance (ArrowChoice c, ArrowJoin c, Complete e) => Category (ExceptT e c) wher Fail e' -> Fail (e ⊔ e') SuccessOrFail e' z -> SuccessOrFail (e ⊔ e') z) id (unlift f) -< (Fail e,y') + {-# INLINE (.) #-} + +instance (Profunctor c, Arrow c) => Profunctor (ExceptT e c) where + dimap f g h = lift $ dimap f (fmap g) (unlift h) + {-# INLINE dimap #-} + lmap f h = lift $ lmap f (unlift h) + {-# INLINE lmap #-} + rmap g h = lift $ rmap (fmap g) (unlift h) + {-# INLINE rmap #-} + +instance ArrowLift (ExceptT e) where + lift' f = ExceptT (rmap Success f) + {-# INLINE lift' #-} + +instance ArrowTrans (ExceptT e) where + type Dom (ExceptT e) x y = x + type Cod (ExceptT e) x y = Error e y + lift = ExceptT + {-# INLINE lift #-} + unlift = runExceptT + {-# INLINE unlift #-} instance (ArrowChoice c, ArrowJoin c, Complete e) => Arrow (ExceptT e c) where arr f = lift' (arr f) - first f = lift $ first (unlift f) >>^ strength1 - second f = lift $ second (unlift f) >>^ strength2 + {-# INLINE arr #-} + first f = lift $ rmap strength1 (first (unlift f)) + {-# INLINE first #-} + second f = lift $ rmap strength2 (second (unlift f)) + {-# INLINE second #-} + f &&& g = lift $ rmap mstrength (unlift f &&& unlift g) + {-# INLINE (&&&) #-} + f *** g = lift $ rmap mstrength (unlift f *** unlift g) + {-# INLINE (***) #-} instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowChoice (ExceptT e c) where - left f = lift $ left (unlift f) >>^ strength1 - right f = lift $ right (unlift f) >>^ strength2 + left f = lift $ rmap strength1 (left (unlift f)) + {-# INLINE left #-} + right f = lift $ rmap strength2 (right (unlift f)) + {-# INLINE right #-} + f ||| g = lift $ unlift f ||| unlift g + {-# INLINE (|||) #-} + f +++ g = lift $ rmap mstrength $ unlift f +++ unlift g + {-# INLINE (+++) #-} instance (Complete e, ArrowJoin c, ArrowApply c, ArrowChoice c) => ArrowApply (ExceptT e c) where - app = lift $ first unlift ^>> app + app = lift $ lmap (first unlift) app + {-# INLINE app #-} instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowState s c) => ArrowState s (ExceptT e c) where get = lift' get + {-# INLINE get #-} put = lift' put + {-# INLINE put #-} instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowStore var val c) => ArrowStore var val (ExceptT e c) where type Join (ExceptT e c) x y = Store.Join c (Dom (ExceptT e) x y) (Cod (ExceptT e) x y) - read (ExceptT f) (ExceptT g) = ExceptT $ read f g + read f g = lift $ read (unlift f) (unlift g) + {-# INLINE read #-} write = lift' write + {-# INLINE write #-} instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowFail f c) => ArrowFail f (ExceptT e c) where fail = lift' fail - + {-# INLINE fail #-} instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowReader r c) => ArrowReader r (ExceptT e c) where ask = lift' ask + {-# INLINE ask #-} local f = lift (local (unlift f)) + {-# INLINE local #-} instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowEnv x y env c) => ArrowEnv x y env (ExceptT e c) where type Join (ExceptT e c) x y = Env.Join c (Dom (ExceptT e) x y) (Cod (ExceptT e) x y) lookup f g = lift $ lookup (unlift f) (unlift g) + {-# INLINE lookup #-} getEnv = lift' getEnv + {-# INLINE getEnv #-} extendEnv = lift' extendEnv + {-# INLINE extendEnv #-} localEnv f = lift (localEnv (unlift f)) - -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)) - throw = lift $ arr Fail - catch f g = lift $ proc x -> do - e <- unlift f -< x - case e of - Success y -> returnA -< Success y - SuccessOrFail er y -> joined (arr Success) (unlift g) -< (y,(x,er)) - Fail er -> unlift g -< (x,er) - finally f g = lift $ proc x -> do - e <- unlift f -< x - unlift g -< x - returnA -< e + {-# INLINE localEnv #-} type instance Fix x y (ExceptT e c) = ExceptT e (Fix (Dom (ExceptT e) x y) (Cod (ExceptT e) x y) c) instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowFix (Dom (ExceptT e) x y) (Cod (ExceptT e) x y) c) => ArrowFix x y (ExceptT e c) where fix = liftFix + {-# INLINE fix #-} instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowDeduplicate x y (ExceptT e c) where dedup = returnA + {-# INLINE dedup #-} instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowConst r c) => ArrowConst r (ExceptT e c) where askConst = lift' askConst + {-# INLINE askConst #-} instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowJoin (ExceptT e c) where - joinWith lub' f g = ExceptT $ joinWith (\r1 r2 -> case (r1, r2) of - (Success y1, Success y2) -> Success (y1 `lub'` y2) - (Success y1, SuccessOrFail e y2) -> SuccessOrFail e (y1 `lub'` y2) - (Success y, Fail e) -> SuccessOrFail e y - (SuccessOrFail e y1, Success y2) -> SuccessOrFail e (y1 `lub'` y2) - (SuccessOrFail e1 y1, SuccessOrFail e2 y2) -> SuccessOrFail (e1 ⊔ e2) (y1 `lub'` y2) - (SuccessOrFail e1 y, Fail e2) -> SuccessOrFail (e1 ⊔ e2) y - (Fail e, Success y) -> SuccessOrFail e y - (Fail e1, SuccessOrFail e2 y) -> SuccessOrFail (e1 ⊔ e2) y - (Fail e1, Fail e2) -> Fail (e1 ⊔ e2) - ) (unlift f) (unlift g) + joinWith lub' f g = ExceptT $ joinWith (widening (⊔) lub') (unlift f) (unlift g) + {-# INLINE joinWith #-} deriving instance PreOrd (c x (Error e y)) => PreOrd (ExceptT e c x y) deriving instance LowerBounded (c x (Error e y)) => LowerBounded (ExceptT e c x y) diff --git a/lib/src/Control/Arrow/Transformer/Abstract/Failure.hs b/lib/src/Control/Arrow/Transformer/Abstract/Failure.hs index fe2583bc..a4f471fb 100644 --- a/lib/src/Control/Arrow/Transformer/Abstract/Failure.hs +++ b/lib/src/Control/Arrow/Transformer/Abstract/Failure.hs @@ -10,6 +10,7 @@ module Control.Arrow.Transformer.Abstract.Failure(FailureT(..)) where import Prelude hiding (id,(.),lookup,read) +import Control.Applicative import Control.Arrow import Control.Arrow.Const import Control.Arrow.Deduplicate @@ -28,83 +29,123 @@ import Data.Abstract.Failure import Data.Order import Data.Monoidal import Data.Identifiable +import Data.Profunctor -- | Describes computations that can fail. newtype FailureT e c x y = FailureT { runFailureT :: c x (Failure e y) } -instance ArrowChoice c => ArrowFail e (FailureT e c) where +instance (ArrowChoice c, Profunctor c) => ArrowFail e (FailureT e c) where fail = lift $ arr Fail + {-# INLINE fail #-} + +instance (Profunctor c, Arrow c) => Profunctor (FailureT e c) where + dimap f g h = lift $ dimap f (fmap g) (unlift h) + {-# INLINE dimap #-} + lmap f h = lift $ lmap f (unlift h) + {-# INLINE lmap #-} + rmap g h = lift $ rmap (fmap g) (unlift h) + {-# INLINE rmap #-} + instance ArrowTrans (FailureT e) where type Dom (FailureT e) x y = x type Cod (FailureT e) x y = Failure e y lift = FailureT + {-# INLINE lift #-} unlift = runFailureT + {-# INLINE unlift #-} instance ArrowLift (FailureT e) where lift' f = lift (f >>> arr Success) + {-# INLINE lift' #-} -instance ArrowChoice c => Category (FailureT r c) where +instance (ArrowChoice c,Profunctor c) => Category (FailureT r c) where id = lift' id - f . g = lift $ unlift g >>> toEither ^>> arr Fail ||| unlift f + {-# INLINE id #-} + f . g = lift $ unlift g >>> lmap toEither (arr Fail ||| unlift f) + {-# INLINE (.) #-} -instance ArrowChoice c => Arrow (FailureT r c) where +instance (ArrowChoice c,Profunctor c) => Arrow (FailureT r c) where arr f = lift' (arr f) - first f = lift $ first (unlift f) >>^ strength1 - second f = lift $ second (unlift f) >>^ strength2 - -instance ArrowChoice c => ArrowChoice (FailureT r c) where - left f = lift $ left (unlift f) >>^ strength1 - right f = lift $ right (unlift f) >>^ strength2 + {-# INLINE arr #-} + first f = lift $ rmap strength1 (first (unlift f)) + {-# INLINE first #-} + second f = lift $ rmap strength2 (second (unlift f)) + {-# INLINE second #-} + f &&& g = lift $ rmap mstrength (unlift f &&& unlift g) + {-# INLINE (&&&) #-} + f *** g = lift $ rmap mstrength (unlift f *** unlift g) + {-# INLINE (***) #-} + +instance (ArrowChoice c, Profunctor c) => ArrowChoice (FailureT r c) where + left f = lift $ rmap strength1 $ left (unlift f) + {-# INLINE left #-} + right f = lift $ rmap strength2 $ right (unlift f) + {-# INLINE right #-} f ||| g = lift $ unlift f ||| unlift g - f +++ g = lift $ unlift f +++ unlift g >>^ from distribute + {-# INLINE (|||) #-} + f +++ g = lift $ rmap mstrength (unlift f +++ unlift g) + {-# INLINE (+++) #-} -instance (ArrowChoice c, ArrowApply c) => ArrowApply (FailureT e c) where - app = lift $ first unlift ^>> app +instance (ArrowChoice c, Profunctor c, ArrowApply c) => ArrowApply (FailureT e c) where + app = lift $ lmap (first unlift) app + {-# INLINE app #-} instance (ArrowChoice c, ArrowState s c) => ArrowState s (FailureT e c) where get = lift' get + {-# INLINE get #-} put = lift' put + {-# INLINE put #-} instance (ArrowChoice c, ArrowReader r c) => ArrowReader r (FailureT e c) where ask = lift' ask + {-# INLINE ask #-} local f = lift (local (unlift f)) + {-# INLINE local #-} instance (ArrowChoice c, ArrowEnv x y env c) => ArrowEnv x y env (FailureT e c) where type Join (FailureT e c) x y = Env.Join c (Dom (FailureT e) x y) (Cod (FailureT e) x y) lookup f g = lift $ lookup (unlift f) (unlift g) + {-# INLINE lookup #-} getEnv = lift' getEnv + {-# INLINE getEnv #-} extendEnv = lift' extendEnv + {-# INLINE extendEnv #-} localEnv f = lift (localEnv (unlift f)) + {-# INLINE localEnv #-} instance (ArrowChoice c, ArrowStore var val c) => ArrowStore var val (FailureT e c) where type Join (FailureT e c) x y = Store.Join c (Dom (FailureT e) x y) (Cod (FailureT e) x y) read f g = lift $ read (unlift f) (unlift g) + {-# INLINE read #-} write = lift' $ write + {-# INLINE write #-} type instance Fix x y (FailureT e c) = FailureT e (Fix (Dom (FailureT e) x y) (Cod (FailureT e) x y) c) instance (ArrowChoice c, ArrowFix (Dom (FailureT e) x y) (Cod (FailureT e) x y) c) => ArrowFix x y (FailureT e c) where fix = liftFix + {-# INLINE fix #-} instance (ArrowChoice c, ArrowExcept e c) => ArrowExcept e (FailureT e' c) where type Join (FailureT e' c) x y = Exc.Join c (Dom (FailureT e') x y) (Cod (FailureT e') x y) throw = lift' throw + {-# INLINE throw #-} catch f g = lift $ catch (unlift f) (unlift g) + {-# INLINE catch #-} finally f g = lift $ finally (unlift f) (unlift g) + {-# INLINE finally #-} instance (Identifiable e, ArrowChoice c, ArrowDeduplicate (Dom (FailureT e) x y) (Cod (FailureT e) x y) c) => ArrowDeduplicate x y (FailureT e c) where dedup f = lift (dedup (unlift f)) + {-# INLINE dedup #-} instance (ArrowChoice c, ArrowConst r c) => ArrowConst r (FailureT e c) where askConst = lift' askConst + {-# INLINE askConst #-} instance (ArrowJoin c, ArrowChoice c) => ArrowJoin (FailureT e c) where - joinWith lub' (FailureT f) (FailureT g) = FailureT $ joinWith (\r1 r2 -> case (r1, r2) of - (Success y1, Success y2) -> Success (y1 `lub'` y2) - (Success y, Fail _) -> Success y - (Fail _, Success y) -> Success y - (Fail e1, Fail _) -> Fail e1 - ) f g + joinWith lub' (FailureT f) (FailureT g) = FailureT $ joinWith (widening lub') f g + {-# INLINE joinWith #-} 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) diff --git a/lib/src/Control/Arrow/Transformer/Abstract/Fixpoint.hs b/lib/src/Control/Arrow/Transformer/Abstract/Fixpoint.hs index 0edd2311..fb16f787 100644 --- a/lib/src/Control/Arrow/Transformer/Abstract/Fixpoint.hs +++ b/lib/src/Control/Arrow/Transformer/Abstract/Fixpoint.hs @@ -18,19 +18,29 @@ import qualified Data.Function as F import Control.Arrow import Control.Arrow.Fix +import Control.Arrow.Reader +import Control.Arrow.State +import Control.Arrow.Trans +import Control.Arrow.Abstract.Terminating +import Control.Arrow.Transformer.Abstract.Stack +import Control.Arrow.Transformer.Reader +import Control.Arrow.Transformer.State +import Control.Arrow.Transformer.Const +import Control.Arrow.Transformer.Static +import Control.Arrow.Transformer.Abstract.Terminating import Control.Arrow.Abstract.Join import Control.Category -import Control.Monad.State hiding (fix) +import qualified Control.Monad.State as M -import Data.Abstract.Terminating hiding (widening) -import qualified Data.Abstract.Terminating as T -import Data.Abstract.Map (Map) -import qualified Data.Abstract.Map as M +import Data.Profunctor import Data.Order hiding (lub) import Data.Identifiable import Data.Monoidal import Data.Maybe - +import Data.Abstract.Terminating hiding (widening) +import qualified Data.Abstract.Terminating as T +import Data.Abstract.Map (Map) +import qualified Data.Abstract.Map as M import Data.Abstract.Widening (Widening) import qualified Data.Abstract.Widening as W import Data.Abstract.StackWidening (StackWidening) @@ -64,33 +74,44 @@ import Text.Printf -- 'Fix Expr Val (Reader Env (State Store (LeastFix Stack () ())))' -- evaluates to -- 'Reader Env (State Store (LeastFix Stack (Store,(Env,Expr)) (Store)))' -newtype FixT s a b c x y = FixT (Underlying s a b c x y) +type Cache a b = Map a (Terminating b) +newtype FixT s a b c x y = FixT (ConstT (Widening b) (StackT s a (ReaderT (Cache a b) (TerminatingT (StateT (Cache a b) c)))) x y) + deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTerminating) -type Underlying s a b c x y = (StackWidening s a, Widening b) -> c (((s a,Map a (Terminating b)), Map a (Terminating b)),x) (Map a (Terminating b), Terminating y) type instance Fix x y (FixT s () () c) = FixT s x y c -runFixT :: (Arrow c, Complete b) => FixT SW.Unit a b c x y -> c x (Terminating y) +runFixT :: (Complete b, ArrowChoice c, Profunctor c) => FixT SW.Unit a b c x y -> c x (Terminating y) runFixT f = runFixT' SW.finite W.finite f -runFixT' :: (Monoid (s a),Arrow c) => StackWidening s a -> Widening b -> FixT s a b c x y -> c x (Terminating y) -runFixT' sw w f = runFixT'' sw w f >>^ snd +runFixT' :: (Monoid (s a),ArrowChoice c, Profunctor c) => StackWidening s a -> Widening b -> FixT s a b c x y -> c x (Terminating y) +runFixT' sw w f = rmap snd (runFixT'' sw w f) -runFixT'' :: (Monoid (s a),Arrow c) => StackWidening s a -> Widening b -> FixT s a b c x y -> c x (Map a (Terminating b), Terminating y) -runFixT'' sw w (FixT f) = (\x -> (((mempty,M.empty),M.empty),x)) ^>> f (sw,w) +runFixT'' :: (Monoid (s a),ArrowChoice c, Profunctor c) => StackWidening s a -> Widening b -> FixT s a b c x y -> c x (Map a (Terminating b), Terminating y) +runFixT'' sw w (FixT f) = + lmap (\x -> (M.empty,(M.empty,x))) $ + runStateT + (runTerminatingT + (runReaderT + (runStackT (sw,mempty) + (runConstT w f)))) -liftFixT :: Arrow c => c x y -> FixT s a b c x y -liftFixT f = FixT $ \_ -> ((\((_,o),x) -> (o,x)) ^>> second (f >>^ Terminating)) +liftFixT :: (Arrow c, Profunctor c) => c x y -> FixT s a b c x y +liftFixT = lift' + +instance ArrowLift (FixT s a b) where + lift' f = FixT (ConstT (StaticT (const (StackT (ConstT (StaticT (const (ReaderT (TerminatingT (StateT (lmap snd (second (rmap Terminating f))))))))))))) #ifndef TRACE -instance (Identifiable x, PreOrd y, ArrowChoice c) => ArrowFix x y (FixT s x y c) where +instance (Identifiable x, PreOrd y, ArrowChoice c, Profunctor c) => ArrowFix x y (FixT s x y c) where fix f = proc x -> do old <- getCache -< () -- reset the current fixpoint cache setCache -< bottom -- recompute the fixpoint cache by calling 'f' and memoize its results. - y <- localOldCache (F.fix (memoize . f)) -< (old,x) + -- y <- localOldCache (F.fix (memoize . f)) -< (old,x) + y <- localOldCache (F.fix f) -< (old,x) new <- getCache -< () @@ -106,24 +127,25 @@ instance (Identifiable x, PreOrd y, ArrowChoice c) => ArrowFix x y (FixT s x y c -- | Memoizes the results of the interpreter function. In case a value -- has been computed before, the cached value is returned and will not -- be recomputed. -memoize :: (Identifiable x, PreOrd y, ArrowChoice c) => FixT s x y c x y -> FixT s x y c x y -memoize (FixT f) = FixT $ \(stackWidening,widening) -> proc (((stack,oldCache), newCache),x) -> do - case M.unsafeLookup x newCache of - -- In case the input was in the fixpoint cache, short-cut - -- recursion and return the cached value. - Just y -> returnA -< (newCache,y) - - -- In case the input was not in the fixpoint cache, initialize the - -- cache with previous knowledge about the result or ⊥, compute - -- the result of the function and update the fixpoint cache. - Nothing -> do - let (x',stack') = runState (stackWidening x) stack - yOld = fromMaybe bottom (M.unsafeLookup x' oldCache) - newCache' = M.insert x' yOld newCache - (newCache'',y) <- f (stackWidening,widening) -< (((stack',oldCache), newCache'),x') - let newCache''' = M.unsafeInsertWith (flip (T.widening widening)) x' y newCache'' - y' = fromJust (M.unsafeLookup x' newCache''') - returnA -< (newCache''',y') +-- memoize :: (Identifiable x, PreOrd y, ArrowChoice c) => FixT s x y c x y -> FixT s x y c x y +-- memoize (FixT f) = FixT $ \(stackWidening,widening) -> proc (((stack,oldCache), newCache),x) -> do +-- case M.unsafeLookup x newCache of +-- -- In case the input was in the fixpoint cache, short-cut +-- -- recursion and return the cached value. +-- Just y -> returnA -< (newCache,y) + +-- -- In case the input was not in the fixpoint cache, initialize the +-- -- cache with previous knowledge about the result or ⊥, compute +-- -- the result of the function and update the fixpoint cache. +-- Nothing -> do +-- let (x',stack') = runState (stackWidening x) stack +-- yOld = fromMaybe bottom (M.unsafeLookup x' oldCache) +-- newCache' = M.insert x' yOld newCache +-- (newCache'',y) <- f (stackWidening,widening) -< (((stack',oldCache), newCache'),x') +-- -- TODO: use insertLookup +-- let newCache''' = M.unsafeInsertWith (flip (T.widening widening)) x' y newCache'' +-- y' = fromJust (M.unsafeLookup x' newCache''') +-- returnA -< (newCache''',y') #else @@ -155,62 +177,35 @@ memoize (FixT f) = FixT $ \(stackWidening,widening) -> proc (((stack,inCache), o #endif -getCache :: Arrow c => FixT s x y c () (Map x (Terminating y)) -getCache = FixT $ \_ -> arr $ \((_,o),()) -> (o,return o) - -setCache :: Arrow c => FixT s x y c (Map x (Terminating y)) () -setCache = FixT $ \_ -> arr $ \((_,_),o) -> (o,return ()) - -localOldCache :: Arrow c => FixT s x y c x y -> FixT s x y c (Map x (Terminating y),x) y -localOldCache (FixT f) = FixT $ \w -> proc (((s,_),o),(i,x)) -> f w -< (((s,i),o),x) - -instance ArrowChoice c => Category (FixT s i o c) where - id = liftFixT id - FixT f . FixT g = FixT $ \w -> proc ((i,o),x) -> do - (o',y) <- g w -< ((i,o),x) - case y of - NonTerminating -> returnA -< (o',NonTerminating) - Terminating y' -> f w -< ((i,o'),y') - -instance ArrowChoice c => Arrow (FixT s i o c) where - arr f = liftFixT (arr f) - first (FixT f) = FixT $ \w -> to assoc ^>> first (f w) >>^ (\((o,x'),y) -> (o,strength1 (x',y))) - -instance ArrowChoice c => ArrowChoice (FixT s i o c) where - left (FixT f) = FixT $ \w -> proc ((i,o),e) -> case e of - Left x -> second (arr (fmap Left)) . f w -< ((i,o),x) - Right y -> returnA -< (o,return (Right y)) - right (FixT f) = FixT $ \w -> proc ((i,o),e) -> case e of - Left x -> returnA -< (o,return (Left x)) - Right y -> second (arr (fmap Right)) . f w -< ((i,o),y) - FixT f ||| FixT g = FixT $ \w -> proc ((i,o),e) -> case e of - Left x -> f w -< ((i,o),x) - Right y -> g w -< ((i,o),y) - -instance (ArrowChoice c, ArrowApply c) => ArrowApply (FixT s i o c) where - app = FixT $ \w -> (\(io,(FixT f,x)) -> (f w,(io,x))) ^>> app - -instance (Identifiable i, Complete o, ArrowJoin c, ArrowChoice c) => ArrowJoin (FixT s i o c) where - joinWith lub (FixT f) (FixT g) = FixT $ \w -> proc ((i,o),x) -> do - (o',t1) <- f w -< ((i,o),x) - (o'',t2) <- g w -< ((i,o'),x) - returnA -< (o'',case (t1,t2) of - (Terminating y',Terminating v') -> Terminating (lub y' v') - (Terminating y',NonTerminating) -> Terminating y' - (NonTerminating,Terminating v') -> Terminating v' - (NonTerminating,NonTerminating) -> NonTerminating) - -deriving instance (PreOrd (Underlying s a b c x y)) => PreOrd (FixT s a b c x y) -instance (Arrow c,PreOrd (Underlying s a b c x y),Complete y) => Complete (FixT s a b c x y) where - FixT f ⊔ FixT g = FixT $ \w -> proc ((i,o),x) -> do - (o',t1) <- f w -< ((i,o),x) - (o'',t2) <- g w -< ((i,o'),x) - returnA -< (o'',case (t1,t2) of - (Terminating y',Terminating v') -> Terminating (y' ⊔ v') - (Terminating y',NonTerminating) -> Terminating y' - (NonTerminating,Terminating v') -> Terminating v' - (NonTerminating,NonTerminating) -> NonTerminating) - -deriving instance (CoComplete (Underlying s a b c x y)) => CoComplete (FixT s a b c x y) -deriving instance (LowerBounded (Underlying s a b c x y)) => LowerBounded (FixT s a b c x y) -deriving instance (UpperBounded (Underlying s a b c x y)) => UpperBounded (FixT s a b c x y) +getCache :: (ArrowChoice c, Profunctor c) => FixT s x y c () (Cache x y) +getCache = FixT get +{-# INLINE getCache #-} + +setCache :: (ArrowChoice c, Profunctor c) => FixT s x y c (Map x (Terminating y)) () +setCache = FixT put +{-# INLINE setCache #-} + +localOldCache :: (ArrowChoice c, Profunctor c) => FixT s x y c x y -> FixT s x y c (Map x (Terminating y),x) y +localOldCache (FixT f) = FixT (local f) +{-# INLINE localOldCache #-} + +instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (FixT s i o c) where + app = FixT $ lmap (\(FixT f,x) -> (f,x)) app + {-# INLINE app #-} + +instance (Identifiable a, ArrowJoin c, ArrowChoice c) => ArrowJoin (FixT s a b c) where + joinWith lub f g = proc x -> do + y <- catchTerminating f -< x + y' <- catchTerminating g -< x + throwTerminating -< T.widening lub y y' + {-# INLINE joinWith #-} + +instance (Identifiable a,Complete y,ArrowJoin c, ArrowChoice c, PreOrd (Underlying a b c x y)) => Complete (FixT s a b c x y) where + f ⊔ g = joinWith (⊔) f g + {-# INLINE (⊔) #-} + +type Underlying a b c x y = (c (Map a (Terminating b), (Map a (Terminating b), x)) (Map a (Terminating b), Terminating y)) +deriving instance PreOrd (Underlying a b c x y) => PreOrd (FixT s a b c x y) +deriving instance CoComplete (Underlying a b c x y) => CoComplete (FixT s a b c x y) +deriving instance LowerBounded (Underlying a b c x y) => LowerBounded (FixT s a b c x y) +deriving instance UpperBounded (Underlying a b c x y) => UpperBounded (FixT s a b c x y) diff --git a/lib/src/Control/Arrow/Transformer/Abstract/Powerset.hs b/lib/src/Control/Arrow/Transformer/Abstract/Powerset.hs index ae00ed6c..56a0aa47 100644 --- a/lib/src/Control/Arrow/Transformer/Abstract/Powerset.hs +++ b/lib/src/Control/Arrow/Transformer/Abstract/Powerset.hs @@ -26,18 +26,30 @@ import Data.Monoidal import Data.Order import Data.Identifiable import Data.Sequence hiding (lookup) +import Data.Profunctor -- | Computation that produces a set of results. newtype PowT c x y = PowT { runPowT :: c x (A.Pow y)} +instance (Profunctor c, Arrow c) => Profunctor (PowT c) where + dimap f g h = lift $ dimap f (fmap g) (unlift h) + {-# INLINE dimap #-} + lmap f h = lift $ lmap f (unlift h) + {-# INLINE lmap #-} + rmap g h = lift $ rmap (fmap g) (unlift h) + {-# INLINE rmap #-} + instance ArrowTrans PowT where type Dom PowT x y = x type Cod PowT x y = A.Pow y lift = PowT + {-# INLINE lift #-} unlift = runPowT + {-# INLINE unlift #-} instance ArrowLift PowT where - lift' f = PowT $ f >>^ A.singleton + lift' f = lift $ rmap A.singleton f + {-# INLINE lift' #-} mapPow :: ArrowChoice c => c x y -> c (A.Pow x) (A.Pow y) mapPow f = proc (A.Pow s) -> case viewl s of @@ -47,21 +59,38 @@ mapPow f = proc (A.Pow s) -> case viewl s of A.Pow ps <- mapPow f -< A.Pow xs returnA -< A.Pow (p <| ps) -instance ArrowChoice c => Category (PowT c) where +instance (ArrowChoice c, Profunctor c) => Category (PowT c) where id = lift' id - PowT f . PowT g = PowT $ g >>> mapPow f >>^ join + {-# INLINE id #-} + f . g = lift $ rmap join (unlift g >>> mapPow (unlift f)) + {-# INLINE (.) #-} -instance ArrowChoice c => Arrow (PowT c) where +instance (ArrowChoice c, Profunctor c) => Arrow (PowT c) where arr f = lift' (arr f) - first (PowT f) = PowT $ first f >>^ \(pow,n) -> A.cartesian (pow, A.singleton n) - second (PowT f) = PowT $ second f >>^ \(n,pow) -> A.cartesian (A.singleton n, pow) - -instance ArrowChoice c => ArrowChoice (PowT c) where - left (PowT f) = PowT $ left f >>^ strength1 - right (PowT f) = PowT $ right f >>^ strength2 - -instance (ArrowChoice c, ArrowApply c) => ArrowApply (PowT c) where - app = PowT $ first runPowT ^>> app + {-# INLINE arr #-} + first f = lift $ rmap (\(pow,n) -> A.cartesian (pow, A.singleton n)) (first (unlift f)) + {-# INLINE first #-} + second f = lift $ rmap (\(n,pow) -> A.cartesian (A.singleton n, pow)) (second (unlift f)) + {-# INLINE second #-} + f &&& g = lift $ rmap A.cartesian (unlift f &&& unlift g) + {-# INLINE (&&&) #-} + f *** g = lift $ rmap A.cartesian (unlift f *** unlift g) + {-# INLINE (***) #-} + +instance (ArrowChoice c, Profunctor c) => ArrowChoice (PowT c) where + left f = lift $ rmap strength1 $ left (unlift f) + {-# INLINE left #-} + right f = lift $ rmap strength2 $ right (unlift f) + {-# INLINE right #-} + f ||| g = lift $ unlift f ||| unlift g + f +++ g = lift $ rmap merge $ unlift f +++ unlift g + where + merge :: Either (A.Pow a) (A.Pow b) -> A.Pow (Either a b) + merge (Left e) = fmap Left e + merge (Right e) = fmap Right e + +instance (ArrowChoice c, Profunctor c, ArrowApply c) => ArrowApply (PowT c) where + app = PowT $ lmap (first unlift) app instance (ArrowChoice c, ArrowReader r c) => ArrowReader r (PowT c) where ask = lift' ask diff --git a/lib/src/Control/Arrow/Transformer/Abstract/ReachingDefinitions.hs b/lib/src/Control/Arrow/Transformer/Abstract/ReachingDefinitions.hs index abf35ed8..80377c79 100644 --- a/lib/src/Control/Arrow/Transformer/Abstract/ReachingDefinitions.hs +++ b/lib/src/Control/Arrow/Transformer/Abstract/ReachingDefinitions.hs @@ -37,25 +37,33 @@ import Control.Arrow.Transformer.Reader import Data.Identifiable import Data.Order import Data.Label +import Data.Profunctor import Data.Abstract.DiscretePowerset(Pow) import qualified Data.Abstract.DiscretePowerset as P newtype ReachingDefsT lab c x y = ReachingDefsT (ReaderT (Maybe lab) c x y) + deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift, + ArrowFail e,ArrowExcept e,ArrowState s,ArrowEnv var val env, + ArrowCond val,ArrowJoin) -reachingDefsT :: Arrow c => c (Maybe lab,x) y -> ReachingDefsT lab c x y +reachingDefsT :: (Arrow c,Profunctor c) => c (Maybe lab,x) y -> ReachingDefsT lab c x y reachingDefsT = lift +{-# INLINE reachingDefsT #-} -runReachingDefsT :: Arrow c => ReachingDefsT lab c x y -> c (Maybe lab,x) y +runReachingDefsT :: (Arrow c,Profunctor c) => ReachingDefsT lab c x y -> c (Maybe lab,x) y runReachingDefsT = unlift +{-# INLINE runReachingDefsT #-} -runReachingDefsT' :: Arrow c => ReachingDefsT lab c x y -> c x y -runReachingDefsT' f = (\x -> (Nothing,x)) ^>> runReachingDefsT f +runReachingDefsT' :: (Arrow c,Profunctor c) => ReachingDefsT lab c x y -> c x y +runReachingDefsT' f = lmap (\x -> (Nothing,x)) (runReachingDefsT f) +{-# INLINE runReachingDefsT' #-} instance (Identifiable var, Identifiable lab, ArrowStore var (val,Pow lab) c) => ArrowStore var val (ReachingDefsT lab c) where type Join (ReachingDefsT lab c) ((val,x),x) y = Store.Join c (((val,Pow lab),Dom (ReachingDefsT lab) x y), Dom (ReachingDefsT lab) x y) (Cod (ReachingDefsT lab) x y) - read (ReachingDefsT f) (ReachingDefsT g) = ReachingDefsT $ read ((\((v,_::Pow lab),x) -> (v,x)) ^>> f) g - write = reachingDefsT $ proc (lab,(var,val)) -> - write -< (var,(val,P.fromMaybe lab)) + read (ReachingDefsT f) (ReachingDefsT g) = ReachingDefsT $ read (lmap (\((v,_::Pow lab),x) -> (v,x)) f) g + {-# INLINE read #-} + write = reachingDefsT $ lmap (\(lab,(var,val)) -> (var,(val,P.fromMaybe lab))) write + {-# INLINE write #-} type instance Fix x y (ReachingDefsT lab c) = ReachingDefsT lab (Fix x y c) instance (HasLabel x lab, Arrow c, ArrowFix x y c) => ArrowFix x y (ReachingDefsT lab c) where @@ -63,33 +71,22 @@ instance (HasLabel x lab, Arrow c, ArrowFix x y c) => ArrowFix x y (ReachingDefs where unwrap :: HasLabel x lab => ReachingDefsT lab c x y -> c x y unwrap f' = (Just . label &&& id) ^>> runReachingDefsT f' + {-# INLINE unwrap #-} + {-# INLINE fix #-} -instance ArrowApply c => ArrowApply (ReachingDefsT lab c) where - app = ReachingDefsT ((\(ReachingDefsT f,x) -> (f,x)) ^>> app) - -deriving instance ArrowTrans (ReachingDefsT lab) -instance ArrowLift (ReachingDefsT lab) where - lift' f = reachingDefsT (snd ^>> f) +instance (ArrowApply c,Profunctor c) => ArrowApply (ReachingDefsT lab c) where + app = ReachingDefsT (lmap (\(ReachingDefsT f,x) -> (f,x)) app) + {-# INLINE app #-} instance ArrowReader r c => ArrowReader r (ReachingDefsT lab c) where ask = lift' ask + {-# INLINE ask #-} local f = lift $ (\(m,(r,a)) -> (r,(m,a))) ^>> local (unlift f) + {-# INLINE local #-} instance ArrowAlloc x y c => ArrowAlloc x y (ReachingDefsT lab c) where alloc = lift' alloc - -instance ArrowRand v c => ArrowRand v (ReachingDefsT lab c) where - random = lift' random - -deriving instance Arrow c => Category (ReachingDefsT lab c) -deriving instance Arrow c => Arrow (ReachingDefsT lab c) -deriving instance ArrowChoice c => ArrowChoice (ReachingDefsT lab c) -deriving instance ArrowFail e c => ArrowFail e (ReachingDefsT lab c) -deriving instance ArrowExcept e c => ArrowExcept e (ReachingDefsT lab c) -deriving instance ArrowState s c => ArrowState s (ReachingDefsT lab c) -deriving instance ArrowEnv x y env c => ArrowEnv x y env (ReachingDefsT lab c) -deriving instance ArrowCond val c => ArrowCond val (ReachingDefsT lab c) -deriving instance ArrowJoin c => ArrowJoin (ReachingDefsT lab c) + {-# INLINE alloc #-} deriving instance PreOrd (c (Dom (ReachingDefsT lab) x y) (Cod (ReachingDefsT lab) x y)) => PreOrd (ReachingDefsT lab c x y) deriving instance LowerBounded (c (Dom (ReachingDefsT lab) x y) (Cod (ReachingDefsT lab) x y)) => LowerBounded (ReachingDefsT lab c x y) diff --git a/lib/src/Control/Arrow/Transformer/Abstract/Stack.hs b/lib/src/Control/Arrow/Transformer/Abstract/Stack.hs index 641961ad..6cb18259 100644 --- a/lib/src/Control/Arrow/Transformer/Abstract/Stack.hs +++ b/lib/src/Control/Arrow/Transformer/Abstract/Stack.hs @@ -3,7 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -module Control.Arrow.Transformer.Abstract.Stack(StackT,runStackT,runStackT') where +module Control.Arrow.Transformer.Abstract.Stack(StackT(..),runStackT,runStackT') where import Prelude hiding ((.)) @@ -11,31 +11,43 @@ import Control.Category import Control.Arrow import Control.Arrow.Fix import Control.Arrow.Trans +import Control.Arrow.State +import Control.Arrow.Reader import Control.Arrow.Abstract.Join +import Control.Arrow.Abstract.Terminating import Control.Arrow.Transformer.Const import Control.Arrow.Transformer.Static import qualified Control.Monad.State as M import Data.Order +import Data.Profunctor import Data.Abstract.StackWidening (StackWidening) newtype StackT s a c x y = StackT (ConstT (StackWidening s a,s a) c x y) - deriving (Category,Arrow,ArrowChoice,ArrowLift,ArrowJoin,PreOrd,Complete) -instance ArrowApply c => ArrowApply (StackT s a c) where app = StackT ((\(StackT f,x) -> (f,x)) ^>> app) + deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowLift,ArrowJoin, + ArrowState r,ArrowReader r,ArrowTerminating, + PreOrd,Complete,CoComplete,LowerBounded,UpperBounded) +instance (ArrowApply c,Profunctor c) => ArrowApply (StackT s a c) where + app = StackT (lmap (\(StackT f,x) -> (f,x)) app) + {-# INLINE app #-} runStackT :: Arrow c => (StackWidening s a,s a) -> StackT s a c x y -> c x y runStackT s (StackT f) = runConstT s f +{-# INLINE runStackT #-} runStackT' :: (Arrow c, Monoid (s a)) => StackWidening s a -> StackT s a c x y -> c x y runStackT' s = runStackT (s,mempty) +{-# INLINE runStackT' #-} stackT :: ((StackWidening s a,s a) -> c x y) -> StackT s a c x y stackT f = StackT $ ConstT $ StaticT $ f +{-# INLINE stackT #-} type instance Fix x y (StackT s () c) = StackT s x (Fix x y c) instance (ArrowApply c, ArrowFix x y c) => ArrowFix x y (StackT s x c) where fix f = stackT $ \(stackWidening,stack) -> proc x -> do let (x',stack') = M.runState (stackWidening x) stack fix (runStackT (stackWidening,stack') . f . lift') -<< x' + {-# INLINE fix #-} diff --git a/lib/src/Control/Arrow/Transformer/Abstract/Store.hs b/lib/src/Control/Arrow/Transformer/Abstract/Store.hs index 5c852607..5d1a5045 100644 --- a/lib/src/Control/Arrow/Transformer/Abstract/Store.hs +++ b/lib/src/Control/Arrow/Transformer/Abstract/Store.hs @@ -31,19 +31,26 @@ import qualified Data.Abstract.Map as M import Data.Order import Data.Identifiable import Data.Hashable +import Data.Profunctor newtype StoreT var val c x y = StoreT (StateT (Map var val) c x y) + deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift, + ArrowReader r, ArrowFail e, ArrowExcept e, ArrowEnv var val env, + ArrowConst r) runStoreT :: StoreT var val c x y -> c (Map var val, x) (Map var val, y) runStoreT (StoreT (StateT f)) = f +{-# INLINE runStoreT #-} evalStoreT :: Arrow c => StoreT var val c x y -> c (Map var val, x) y evalStoreT f = runStoreT f >>> pi2 +{-# INLINE evalStoreT #-} execStoreT :: Arrow c => StoreT var val c x y -> c (Map var val, x) (Map var val) execStoreT f = runStoreT f >>> pi1 +{-# INLINE execStoreT #-} -instance (Identifiable var, ArrowChoice c) => ArrowStore var val (StoreT var val c) where +instance (Identifiable var, ArrowChoice c, Profunctor c) => ArrowStore var val (StoreT var val c) where type Join (StoreT var val c) ((val,x),x) y = Complete (c (Map var val, ((val, x), x)) (Map var val, y)) read (StoreT f) (StoreT g) = StoreT $ proc (var,x) -> do s <- get -< () @@ -51,24 +58,18 @@ instance (Identifiable var, ArrowChoice c) => ArrowStore var val (StoreT var val Just val -> f -< (val,x) JustNothing val -> joined f g -< ((val,x),x) Nothing -> g -< x + {-# INLINE read #-} write = StoreT $ modify $ arr $ \((var,val),st) -> M.insert var val st + {-# INLINE write #-} instance ArrowState s c => ArrowState s (StoreT var val c) where get = lift' get + {-# INLINE get #-} put = lift' put + {-# INLINE put #-} deriving instance (Eq var,Hashable var,Complete val,ArrowJoin c) => ArrowJoin (StoreT var val c) -deriving instance Arrow c => Category (StoreT var val c) -deriving instance Arrow c => Arrow (StoreT var val c) -deriving instance ArrowChoice c => ArrowChoice (StoreT var val c) -deriving instance ArrowTrans (StoreT var val) -deriving instance ArrowLift (StoreT var val) -deriving instance ArrowReader r c => ArrowReader r (StoreT var val c) -deriving instance ArrowFail e c => ArrowFail e (StoreT var val c) -deriving instance ArrowExcept e c => ArrowExcept e (StoreT var val c) -deriving instance ArrowEnv x y env c => ArrowEnv x y env (StoreT var val c) -deriving instance ArrowConst x c => ArrowConst x (StoreT var val c) -instance ArrowApply c => ArrowApply (StoreT var val c) where app = StoreT $ (\(StoreT f,x) -> (f,x)) ^>> app +instance (ArrowApply c, Profunctor c) => ArrowApply (StoreT var val c) where app = StoreT $ lmap (\(StoreT f,x) -> (f,x)) app type instance Fix x y (StoreT var val c) = StoreT var val (Fix (Dom (StoreT var val) x y) (Cod (StoreT var val) x y) c) deriving instance ArrowFix (Dom (StoreT var val) x y) (Cod (StoreT var val) x y) c => ArrowFix x y (StoreT var val c) diff --git a/lib/src/Control/Arrow/Transformer/Abstract/Terminating.hs b/lib/src/Control/Arrow/Transformer/Abstract/Terminating.hs new file mode 100644 index 00000000..58711ac4 --- /dev/null +++ b/lib/src/Control/Arrow/Transformer/Abstract/Terminating.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +module Control.Arrow.Transformer.Abstract.Terminating(TerminatingT(..)) where + +import Prelude hiding (id,(.),lookup,fail) + +import Control.Arrow +import Control.Arrow.Const +import Control.Arrow.Trans +import Control.Arrow.State +import Control.Arrow.Reader +import Control.Arrow.Abstract.Terminating +import Control.Category + +import Data.Abstract.Terminating +import Data.Order +import Data.Monoidal +import Data.Profunctor + +-- | Arrow that propagates non-terminating computations. +newtype TerminatingT c x y = TerminatingT { runTerminatingT :: c x (Terminating y) } + +instance (ArrowChoice c,Profunctor c) => ArrowTerminating (TerminatingT c) where + throwTerminating = lift id + {-# INLINE throwTerminating #-} + catchTerminating f = lift $ rmap Terminating (unlift f) + {-# INLINE catchTerminating #-} + +instance ArrowTrans TerminatingT where + type Dom TerminatingT x y = x + type Cod TerminatingT x y = (Terminating y) + lift = TerminatingT + {-# INLINE lift #-} + unlift = runTerminatingT + {-# INLINE unlift #-} + +instance ArrowLift TerminatingT where + lift' f = lift $ rmap Terminating f + {-# INLINE lift' #-} + +instance (Profunctor c, Arrow c) => Profunctor (TerminatingT c) where + dimap f g h = lift $ dimap f (fmap g) (unlift h) + {-# INLINE dimap #-} + lmap f h = lift $ lmap f (unlift h) + {-# INLINE lmap #-} + rmap g h = lift $ rmap (fmap g) (unlift h) + {-# INLINE rmap #-} + +instance (ArrowChoice c, Profunctor c) => Category (TerminatingT c) where + id = lift' id + {-# INLINE id #-} + f . g = lift $ rmap toEither (unlift g) >>> arr (const NonTerminating) ||| unlift f + {-# INLINE (.) #-} + +instance (ArrowChoice c, Profunctor c) => Arrow (TerminatingT c) where + arr f = lift' (arr f) + {-# INLINE arr #-} + first f = lift $ rmap strength1 (first (unlift f)) + {-# INLINE first #-} + second f = lift $ rmap strength2 (second (unlift f)) + {-# INLINE second #-} + f &&& g = lift $ rmap mstrength (unlift f &&& unlift g) + {-# INLINE (&&&) #-} + f *** g = lift $ rmap mstrength (unlift f *** unlift g) + {-# INLINE (***) #-} + +instance (ArrowChoice c, Profunctor c) => ArrowChoice (TerminatingT c) where + left f = lift $ rmap strength1 $ left (unlift f) + {-# INLINE left #-} + right f = lift $ rmap strength2 $ right (unlift f) + {-# INLINE right #-} + f ||| g = lift $ unlift f ||| unlift g + {-# INLINE (|||) #-} + f +++ g = lift $ rmap mstrength (unlift f +++ unlift g) + {-# INLINE (+++) #-} + +instance (ArrowChoice c, Profunctor c, ArrowApply c) => ArrowApply (TerminatingT c) where + app = lift $ lmap (first unlift) app + {-# INLINE app #-} + +instance (ArrowChoice c, ArrowState s c) => ArrowState s (TerminatingT c) where + get = lift' get + {-# INLINE get #-} + put = lift' put + {-# INLINE put #-} + +instance (ArrowChoice c, ArrowReader r c) => ArrowReader r (TerminatingT c) where + ask = lift' ask + {-# INLINE ask #-} + local f = lift (local (unlift f)) + {-# INLINE local #-} + +instance (ArrowChoice c, ArrowConst x c) => ArrowConst x (TerminatingT c) where + askConst = lift' askConst + {-# INLINE askConst #-} + +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 Complete (c x (Terminating y)) => Complete (TerminatingT c x y) +deriving instance CoComplete (c x (Terminating y)) => CoComplete (TerminatingT c x y) +deriving instance UpperBounded (c x (Terminating y)) => UpperBounded (TerminatingT c x y) + diff --git a/lib/src/Control/Arrow/Transformer/Concrete/Environment.hs b/lib/src/Control/Arrow/Transformer/Concrete/Environment.hs index e2003bd7..61aa060c 100644 --- a/lib/src/Control/Arrow/Transformer/Concrete/Environment.hs +++ b/lib/src/Control/Arrow/Transformer/Concrete/Environment.hs @@ -13,6 +13,7 @@ import Prelude hiding ((.),read) import Data.Identifiable import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as M +import Data.Profunctor import Control.Category @@ -30,6 +31,9 @@ import Control.Arrow.Fix -- | Arrow transformer that adds an environment to a computation. newtype EnvT var val c x y = EnvT (ReaderT (HashMap var val) c x y) + deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowLift,ArrowTrans, + ArrowFail e,ArrowExcept e,ArrowState s,ArrowConst r, + ArrowStore var val) runEnvT :: (Arrow c) => EnvT var val c x y -> c (HashMap var val,x) y runEnvT (EnvT (ReaderT f)) = f @@ -37,7 +41,7 @@ runEnvT (EnvT (ReaderT f)) = f runEnvT' :: (Arrow c, Identifiable var) => EnvT var val c x y -> c ([(var,val)],x) y runEnvT' f = first M.fromList ^>> runEnvT f -instance (Identifiable var, ArrowChoice c) => ArrowEnv var val (HashMap var val) (EnvT var val c) where +instance (Identifiable var, ArrowChoice c, Profunctor c) => ArrowEnv var val (HashMap var val) (EnvT var val c) where type Join (EnvT var val c) x y = () lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do env <- ask -< () @@ -48,21 +52,11 @@ instance (Identifiable var, ArrowChoice c) => ArrowEnv var val (HashMap var val) extendEnv = arr $ \(x,y,env) -> M.insert x y env localEnv (EnvT f) = EnvT (local f) -instance ArrowApply c => ArrowApply (EnvT var val c) where - app = EnvT $ (\(EnvT f,x) -> (f,x)) ^>> app +instance (ArrowApply c,Profunctor c) => ArrowApply (EnvT var val c) where + app = EnvT $ lmap (\(EnvT f,x) -> (f,x)) app instance ArrowReader r c => ArrowReader r (EnvT var val c) where ask = lift' ask local (EnvT (ReaderT f)) = EnvT (ReaderT ((\(env,(r,x)) -> (r,(env,x))) ^>> local f)) -deriving instance Arrow c => Category (EnvT var val c) -deriving instance Arrow c => Arrow (EnvT var val c) -deriving instance ArrowLift (EnvT var val) -deriving instance ArrowTrans (EnvT var val) -deriving instance ArrowChoice c => ArrowChoice (EnvT var val c) -deriving instance ArrowState s c => ArrowState s (EnvT var val c) -deriving instance ArrowFail e c => ArrowFail e (EnvT var val c) -deriving instance ArrowExcept e c => ArrowExcept e (EnvT var val c) -deriving instance ArrowConst r c => ArrowConst r (EnvT var val c) -deriving instance ArrowStore var val c => ArrowStore var val (EnvT var' val' c) deriving instance ArrowFix (HashMap var val,x) y c => ArrowFix x y (EnvT var val c) diff --git a/lib/src/Control/Arrow/Transformer/Concrete/Except.hs b/lib/src/Control/Arrow/Transformer/Concrete/Except.hs index eebd09b8..a7834632 100644 --- a/lib/src/Control/Arrow/Transformer/Concrete/Except.hs +++ b/lib/src/Control/Arrow/Transformer/Concrete/Except.hs @@ -25,11 +25,12 @@ import Control.Category import Data.Concrete.Error import Data.Monoidal import Data.Identifiable +import Data.Profunctor -- | Arrow transformer that adds exceptions to the result of a computation newtype ExceptT e c x y = ExceptT { runExceptT :: c x (Error e y) } -instance ArrowChoice c => ArrowExcept e (ExceptT e c) where +instance (ArrowChoice c, Profunctor c) => ArrowExcept e (ExceptT e c) where type Join (ExceptT e c) x y = () throw = lift $ arr Fail @@ -45,6 +46,11 @@ instance ArrowChoice c => ArrowExcept e (ExceptT e c) where unlift g -< x returnA -< e +instance (Profunctor c, Arrow c) => Profunctor (ExceptT 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 ArrowTrans (ExceptT e) where type Dom (ExceptT e) x y = x type Cod (ExceptT e) x y = Error e y @@ -54,22 +60,22 @@ instance ArrowTrans (ExceptT e) where instance ArrowLift (ExceptT e) where lift' f = ExceptT (f >>> arr Success) -instance ArrowChoice c => Category (ExceptT r c) where +instance (ArrowChoice c, Profunctor c) => Category (ExceptT r c) where id = lift' id f . g = lift $ unlift g >>> toEither ^>> arr Fail ||| unlift f -instance ArrowChoice c => Arrow (ExceptT r c) where +instance (ArrowChoice c, Profunctor c) => Arrow (ExceptT r c) where arr f = lift' (arr f) first f = lift $ first (unlift f) >>^ strength1 second f = lift $ second (unlift f) >>^ strength2 -instance ArrowChoice c => ArrowChoice (ExceptT r c) where +instance (ArrowChoice c, Profunctor c) => ArrowChoice (ExceptT r c) where left f = lift $ left (unlift f) >>^ strength1 right f = lift $ right (unlift f) >>^ strength2 f ||| g = lift (unlift f ||| unlift g) f +++ g = lift $ unlift f +++ unlift g >>^ from distribute -instance (ArrowChoice c, ArrowApply c) => ArrowApply (ExceptT e c) where +instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (ExceptT e c) where app = lift $ first unlift ^>> app instance (ArrowChoice c, ArrowState s c) => ArrowState s (ExceptT e c) where diff --git a/lib/src/Control/Arrow/Transformer/Concrete/Failure.hs b/lib/src/Control/Arrow/Transformer/Concrete/Failure.hs index 094f5930..0f43fa1a 100644 --- a/lib/src/Control/Arrow/Transformer/Concrete/Failure.hs +++ b/lib/src/Control/Arrow/Transformer/Concrete/Failure.hs @@ -22,6 +22,7 @@ import Control.Arrow.State import Control.Arrow.Except as Exc import Control.Category +import Data.Profunctor import Data.Concrete.Failure import Data.Monoidal import Data.Identifiable @@ -29,9 +30,14 @@ import Data.Identifiable -- | Arrow transformer that adds failure to the result of a computation newtype FailureT e c x y = FailureT { runFailureT :: c x (Failure e y) } -instance ArrowChoice c => ArrowFail e (FailureT e c) where +instance (ArrowChoice c, Profunctor c) => ArrowFail e (FailureT e c) where fail = lift $ arr Fail +instance (Profunctor c, Arrow c) => Profunctor (FailureT 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 ArrowTrans (FailureT e) where type Dom (FailureT e) x y = x type Cod (FailureT e) x y = Failure e y @@ -41,22 +47,22 @@ instance ArrowTrans (FailureT e) where instance ArrowLift (FailureT e) where lift' f = lift (f >>> arr Success) -instance ArrowChoice c => Category (FailureT r c) where +instance (ArrowChoice c, Profunctor c) => Category (FailureT r c) where id = lift' id f . g = lift $ unlift g >>> toEither ^>> arr Fail ||| unlift f -instance ArrowChoice c => Arrow (FailureT r c) where +instance (ArrowChoice c, Profunctor c) => Arrow (FailureT r c) where arr f = lift' (arr f) first f = lift $ first (unlift f) >>^ strength1 second f = lift $ second (unlift f) >>^ strength2 -instance ArrowChoice c => ArrowChoice (FailureT r c) where +instance (ArrowChoice c, Profunctor c) => ArrowChoice (FailureT r c) where left f = lift $ left (unlift f) >>^ strength1 right f = lift $ right (unlift f) >>^ strength2 f ||| g = lift (unlift f ||| unlift g) f +++ g = lift $ unlift f +++ unlift g >>^ from distribute -instance (ArrowChoice c, ArrowApply c) => ArrowApply (FailureT e c) where +instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (FailureT e c) where app = FailureT $ first runFailureT ^>> app instance (ArrowChoice c, ArrowState s c) => ArrowState s (FailureT e c) where diff --git a/lib/src/Control/Arrow/Transformer/Concrete/Fixpoint.hs b/lib/src/Control/Arrow/Transformer/Concrete/Fixpoint.hs index 918be09f..1e46e2e1 100644 --- a/lib/src/Control/Arrow/Transformer/Concrete/Fixpoint.hs +++ b/lib/src/Control/Arrow/Transformer/Concrete/Fixpoint.hs @@ -10,11 +10,12 @@ import Control.Arrow.Fix import Control.Category import Control.Arrow +import Data.Profunctor -- | Arrow transformer that computes the fixpoint in the concrete interpreter. -newtype FixT a b c x y = FixT {runFixT :: c x y} deriving (Category,Arrow,ArrowChoice) +newtype FixT a b c x y = FixT {runFixT :: c x y} deriving (Profunctor,Category,Arrow,ArrowChoice) type instance Fix x y (FixT () () c) = FixT x y c -instance Arrow c => ArrowFix x y (FixT x y c) where +instance (Arrow c, Profunctor c) => ArrowFix x y (FixT x y c) where fix f = FixT $ runFixT (f (fix f)) diff --git a/lib/src/Control/Arrow/Transformer/Concrete/Random.hs b/lib/src/Control/Arrow/Transformer/Concrete/Random.hs index 98ab8ded..65de77fa 100644 --- a/lib/src/Control/Arrow/Transformer/Concrete/Random.hs +++ b/lib/src/Control/Arrow/Transformer/Concrete/Random.hs @@ -23,37 +23,31 @@ import Control.Arrow.Store import Control.Arrow.Transformer.State +import Data.Profunctor + import System.Random(StdGen,Random) import qualified System.Random as R newtype RandomT c x y = RandomT (StateT StdGen c x y) + deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift, + ArrowReader r, ArrowFail e, ArrowExcept e, + ArrowEnv var val env, ArrowStore var val, ArrowCond val) runRandomT :: RandomT c x y -> c (StdGen,x) (StdGen,y) runRandomT (RandomT (StateT f)) = f -instance (Random v, Arrow c) => ArrowRand v (RandomT c) where +instance (Random v, Arrow c, Profunctor c) => ArrowRand v (RandomT c) where random = RandomT $ proc () -> do gen <- get -< () let (v,gen') = R.random gen put -< gen' returnA -< v -deriving instance Arrow c => Category (RandomT c) -deriving instance Arrow c => Arrow (RandomT c) -deriving instance ArrowChoice c => ArrowChoice (RandomT c) -deriving instance ArrowTrans RandomT -deriving instance ArrowLift RandomT -deriving instance ArrowReader r c => ArrowReader r (RandomT c) -deriving instance ArrowFail e c => ArrowFail e (RandomT c) -deriving instance ArrowExcept e c => ArrowExcept e (RandomT c) -deriving instance ArrowEnv var val env c => ArrowEnv var val env (RandomT c) -deriving instance ArrowAlloc x y c => ArrowAlloc x y (RandomT c) -deriving instance ArrowCond val c => ArrowCond val (RandomT c) -deriving instance ArrowStore var val c => ArrowStore var val (RandomT c) - type instance Fix x y (RandomT c) = RandomT (Fix (Dom RandomT x y) (Cod RandomT x y) c) deriving instance (Arrow c, ArrowFix (Dom RandomT x y) (Cod RandomT x y) c) => ArrowFix x y (RandomT c) +deriving instance ArrowAlloc x y c => ArrowAlloc x y (RandomT c) + instance ArrowState s c => ArrowState s (RandomT c) where get = lift' get put = lift' put diff --git a/lib/src/Control/Arrow/Transformer/Concrete/Store.hs b/lib/src/Control/Arrow/Transformer/Concrete/Store.hs index 128b26ea..c0c45c8d 100644 --- a/lib/src/Control/Arrow/Transformer/Concrete/Store.hs +++ b/lib/src/Control/Arrow/Transformer/Concrete/Store.hs @@ -23,12 +23,15 @@ import Control.Arrow.Transformer.State import Control.Arrow.Utils import Control.Category +import Data.Profunctor import Data.HashMap.Lazy(HashMap) import qualified Data.HashMap.Lazy as S import Data.Identifiable -- | Arrow transformer that adds a store to a computation. newtype StoreT var val c x y = StoreT (StateT (HashMap var val) c x y) + deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift, + ArrowConst r, ArrowReader r, ArrowFail e, ArrowExcept e) -- | Execute a computation and only return the result value and store. runStoreT :: StoreT var val c x y -> c (HashMap var val, x) (HashMap var val, y) @@ -42,7 +45,7 @@ evalStoreT f = runStoreT f >>> pi2 execStoreT :: Arrow c => StoreT var val c x y -> c (HashMap var val, x) (HashMap var val) execStoreT f = runStoreT f >>> pi1 -instance (Identifiable var, ArrowChoice c) => ArrowStore var val (StoreT var val c) where +instance (Identifiable var, ArrowChoice c, Profunctor c) => ArrowStore var val (StoreT var val c) where type Join (StoreT var val c) x y = () read (StoreT f) (StoreT g) = StoreT $ proc (var,x) -> do s <- get -< () @@ -55,16 +58,7 @@ instance ArrowState s c => ArrowState s (StoreT var val c) where get = lift' get put = lift' put -deriving instance ArrowTrans (StoreT var val) -deriving instance ArrowLift (StoreT var val) -deriving instance Arrow c => Category (StoreT var val c) -deriving instance Arrow c => Arrow (StoreT var val c) -deriving instance ArrowChoice c => ArrowChoice (StoreT var val c) -instance ArrowApply c => ArrowApply (StoreT var val c) where app = StoreT ((\(StoreT f,x) -> (f,x)) ^>> app) -deriving instance ArrowConst r c => ArrowConst r (StoreT var val c) -deriving instance ArrowReader r c => ArrowReader r (StoreT var val c) -deriving instance ArrowFail e c => ArrowFail e (StoreT var val c) -deriving instance ArrowExcept e c => ArrowExcept e (StoreT var val c) +instance (ArrowApply c,Profunctor c) => ArrowApply (StoreT var val c) where app = StoreT ((\(StoreT f,x) -> (f,x)) ^>> app) type instance Fix x y (StoreT var val c) = StoreT var val (Fix (Dom (StoreT var val) x y) (Cod (StoreT var val) x y) c) deriving instance ArrowFix (Dom (StoreT var val) x y) (Cod (StoreT var val) x y) c => ArrowFix x y (StoreT var val c) diff --git a/lib/src/Control/Arrow/Transformer/Concrete/Trace.hs b/lib/src/Control/Arrow/Transformer/Concrete/Trace.hs index c9261a92..58f156db 100644 --- a/lib/src/Control/Arrow/Transformer/Concrete/Trace.hs +++ b/lib/src/Control/Arrow/Transformer/Concrete/Trace.hs @@ -17,6 +17,7 @@ import Control.Arrow.Writer import Control.Arrow.Trans import Control.Arrow.Transformer.Writer +import Data.Profunctor import Data.Sequence (Seq) import qualified Data.Sequence as S @@ -24,22 +25,19 @@ data Entry a b = Call a | Return b deriving (Show,Eq) type Log a b = Seq (Entry a b) newtype TraceT a b c x y = TraceT (WriterT (Log a b) c x y) + deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans) runTraceT :: TraceT a b c x y -> c x (Log a b,y) runTraceT (TraceT (WriterT f)) = f -deriving instance ArrowTrans (TraceT a b) -deriving instance Arrow c => Category (TraceT a b c) -deriving instance Arrow c => Arrow (TraceT a b c) -deriving instance ArrowChoice c => ArrowChoice (TraceT a b c) -instance ArrowApply c => ArrowApply (TraceT a b c) where +instance (ArrowApply c,Profunctor c) => ArrowApply (TraceT a b c) where app = TraceT $ (\(TraceT f,x) -> (f,x)) ^>> app type instance Fix x y (TraceT x y c) = TraceT x y (Fix (Dom (TraceT x y) x y) (Cod (TraceT x y) x y) c) instance ArrowFix (Dom (TraceT x y) x y) (Cod (TraceT x y) x y) c => ArrowFix x y (TraceT x y c) where fix f = TraceT $ fix (unwrap . f . TraceT) where - unwrap :: Arrow c => TraceT x y c x y -> WriterT (Log x y) c x y + unwrap :: (Arrow c,Profunctor c) => TraceT x y c x y -> WriterT (Log x y) c x y unwrap (TraceT g) = proc x -> do tell -< S.singleton (Call x) y <- g -< x diff --git a/lib/src/Control/Arrow/Transformer/Const.hs b/lib/src/Control/Arrow/Transformer/Const.hs index 0b0d86be..d25f7c5f 100644 --- a/lib/src/Control/Arrow/Transformer/Const.hs +++ b/lib/src/Control/Arrow/Transformer/Const.hs @@ -24,44 +24,36 @@ import Control.Arrow.State import Control.Arrow.Store import Control.Arrow.Const import Control.Arrow.Writer -import Control.Arrow.Transformer.Static import Control.Arrow.Abstract.Join +import Control.Arrow.Abstract.Terminating + +import Control.Arrow.Transformer.Static import Data.Order +import Data.Profunctor -- | Passes along constant data. newtype ConstT r c x y = ConstT (StaticT ((->) r) c x y) + deriving (Category,Profunctor,Arrow,ArrowChoice,ArrowJoin,ArrowLift, + ArrowState s,ArrowReader r',ArrowWriter w, + ArrowEnv var val env, ArrowStore var val, + ArrowFail e, ArrowExcept e, ArrowTerminating, + PreOrd, Complete, CoComplete, UpperBounded, LowerBounded) runConstT :: r -> ConstT r c x y -> c x y runConstT r (ConstT (StaticT f)) = f r +instance (Arrow c, Profunctor c) => ArrowConst r (ConstT r c) where + askConst = ConstT $ StaticT $ \r -> arr (const r) + {-# INLINE askConst #-} + type instance Fix x y (ConstT r c) = ConstT r (Fix x y c) instance ArrowFix x y c => ArrowFix x y (ConstT r c) where fix f = ConstT $ StaticT $ \r -> fix (runConstT r . f . lift') + {-# INLINE fix #-} -instance Arrow c => ArrowConst r (ConstT r c) where - askConst = ConstT $ StaticT $ \r -> arr (const r) - -instance ArrowApply c => ArrowApply (ConstT r c) where - app = ConstT $ StaticT $ \r -> (\(ConstT (StaticT f),x) -> (f r,x)) ^>> app +instance (ArrowApply c, Profunctor c) => ArrowApply (ConstT r c) where + app = ConstT $ StaticT $ \r -> lmap (\(ConstT (StaticT f),x) -> (f r,x)) app + {-# INLINE app #-} -deriving instance ArrowJoin c => ArrowJoin (ConstT r c) -deriving instance ArrowLift (ConstT r) -deriving instance Arrow c => Category (ConstT r c) -deriving instance Arrow c => Arrow (ConstT r c) -deriving instance ArrowChoice c => ArrowChoice (ConstT r c) -deriving instance ArrowLoop c => ArrowLoop (ConstT r c) -deriving instance ArrowState s c => ArrowState s (ConstT r c) -deriving instance ArrowReader r c => ArrowReader r (ConstT r' c) -deriving instance ArrowWriter w c => ArrowWriter w (ConstT r c) -deriving instance ArrowEnv var val env c => ArrowEnv var val env (ConstT r c) -deriving instance ArrowStore var val c => ArrowStore var val (ConstT r c) -deriving instance ArrowFail e c => ArrowFail e (ConstT r c) -deriving instance ArrowExcept e c => ArrowExcept e (ConstT r c) deriving instance ArrowDeduplicate x y c => ArrowDeduplicate x y (ConstT r c) - -deriving instance PreOrd (c x y) => PreOrd (ConstT r c x y) -deriving instance Complete (c x y) => Complete (ConstT r c x y) -deriving instance CoComplete (c x y) => CoComplete (ConstT r c x y) -deriving instance UpperBounded (c x y) => UpperBounded (ConstT r c x y) -deriving instance LowerBounded (c x y) => LowerBounded (ConstT r c x y) diff --git a/lib/src/Control/Arrow/Transformer/Cont.hs b/lib/src/Control/Arrow/Transformer/Cont.hs index 1ab6918d..cccdf61d 100644 --- a/lib/src/Control/Arrow/Transformer/Cont.hs +++ b/lib/src/Control/Arrow/Transformer/Cont.hs @@ -17,53 +17,84 @@ import Control.Arrow.Trans import Control.Arrow.Reader import Control.Arrow.State import Control.Arrow.Writer +-- import Control.Arrow.Conditional +import Data.Profunctor newtype ContT c x y = ContT { runContT :: forall r. c y r -> c x r } +instance Profunctor c => Profunctor (ContT c) where + dimap f g (ContT h) = ContT $ \k -> lmap f (h (lmap g k)) + {-# INLINE dimap #-} + lmap f (ContT h) = ContT $ \k -> lmap f (h k) + {-# INLINE lmap #-} + rmap g (ContT h) = ContT $ \k -> h (lmap g k) + {-# INLINE rmap #-} + instance Category (ContT c) where id = ContT id + {-# INLINE id #-} ContT f . ContT g = ContT (g . f) + {-# INLINE (.) #-} instance ArrowApply c => Arrow (ContT c) where arr f = ContT $ \k -> k . arr f + {-# INLINE arr #-} first (ContT f) = ContT $ \k -> proc (b,d) -> f (proc c -> k -< (c,d)) -<< b + {-# INLINE first #-} second (ContT f) = ContT $ \k -> proc (d,b) -> f (proc c -> k -< (d,c)) -<< b + {-# INLINE second #-} ContT f &&& ContT g = ContT $ \k -> proc b -> f (proc c1 -> g (proc c2 -> k -< (c1,c2)) -<< b) -<< b + {-# INLINE (&&&) #-} ContT f *** ContT g = ContT $ \k -> proc (b1,b2) -> f (proc c1 -> g (proc c2 -> k -< (c1,c2)) -<< b2) -<< b1 + {-# INLINE (***) #-} -instance (ArrowApply c, ArrowChoice c) => ArrowChoice (ContT c) where - left (ContT f) = ContT $ \k -> f (k . arr Left) ||| (k . arr Right) - right (ContT f) = ContT $ \k -> (k . arr Left) ||| f (k . arr Right) +instance (ArrowApply c, ArrowChoice c, Profunctor c) => ArrowChoice (ContT c) where + left (ContT f) = ContT $ \k -> f (lmap Left k) ||| (lmap Right k) + {-# INLINE left #-} + right (ContT f) = ContT $ \k -> (lmap Left k) ||| f (lmap Right k) + {-# INLINE right #-} ContT f ||| ContT g = ContT $ \k -> f k ||| g k - ContT f +++ ContT g = ContT $ \k -> f (k . arr Left) ||| g (k . arr Right) + {-# INLINE (|||) #-} + ContT f +++ ContT g = ContT $ \k -> f (lmap Left k) ||| g (lmap Right k) + {-# INLINE (+++) #-} type instance Fix x y (ContT c) = ContT (Fix (Dom ContT x y) (Cod ContT x y) c) instance (ArrowApply c, ArrowFix x y c) => ArrowFix x y (ContT c) where fix = liftFix + {-# INLINE fix #-} -- | Lift and unlift proof the yoneda lemma. instance ArrowTrans ContT where type Dom ContT x y = x type Cod ContT x y = y lift f = ContT $ \k -> k . f + {-# INLINE lift #-} unlift (ContT f) = f id + {-# INLINE unlift #-} instance ArrowLift ContT where lift' f = ContT $ \k -> k . f + {-# INLINE lift' #-} instance (ArrowApply c, ArrowState s c) => ArrowState s (ContT c) where get = lift' get + {-# INLINE get #-} put = lift' put + {-# INLINE put #-} instance (ArrowApply c, ArrowReader s c) => ArrowReader s (ContT c) where ask = lift' ask + {-# INLINE ask #-} local (ContT f) = ContT $ \k -> local (f k) + {-# INLINE local #-} instance (ArrowApply c, ArrowWriter w c) => ArrowWriter w (ContT c) where tell = lift' tell + {-# INLINE tell #-} instance (ArrowApply c, ArrowFail e c) => ArrowFail e (ContT c) where fail = lift' fail + {-# INLINE fail #-} -- instance (ArrowApply c, ArrowCond v c) => ArrowCond v (ContT c) where -- type Join (ContT c) x y = Cond.Join c (Dom1 ContT x y) (Cod1 ContT x y) diff --git a/lib/src/Control/Arrow/Transformer/Reader.hs b/lib/src/Control/Arrow/Transformer/Reader.hs index 2208d58c..42b40926 100644 --- a/lib/src/Control/Arrow/Transformer/Reader.hs +++ b/lib/src/Control/Arrow/Transformer/Reader.hs @@ -25,91 +25,146 @@ import Control.Arrow.Trans import Control.Arrow.Writer import Control.Arrow.Utils import Control.Arrow.Abstract.Join +import Control.Arrow.Abstract.Terminating import Control.Category +import Data.Profunctor import Data.Order hiding (lub) import Data.Monoidal -- Due to "Generalising Monads to Arrows", by John Hughes, in Science of Computer Programming 37. newtype ReaderT r c x y = ReaderT { runReaderT :: c (r,x) y } +instance (Profunctor c, Arrow c) => Profunctor (ReaderT r c) where + dimap f g h = lift $ dimap (second f) g (unlift h) + {-# INLINE dimap #-} + lmap f h = lift $ lmap (second f) (unlift h) + {-# INLINE lmap #-} + rmap g h = lift $ rmap g (unlift h) + {-# INLINE rmap #-} + instance ArrowTrans (ReaderT r) where type Dom (ReaderT r) x y = (r,x) type Cod (ReaderT r) x y = y lift = ReaderT + {-# INLINE lift #-} unlift = runReaderT + {-# INLINE unlift #-} instance ArrowLift (ReaderT r) where lift' f = ReaderT (pi2 >>> f) + {-# INLINE lift' #-} -instance Arrow c => Category (ReaderT r c) where +instance (Arrow c, Profunctor c) => Category (ReaderT r c) where id = lift' id - f . g = lift $ (\(r,x) -> (r,(r,x))) ^>> unlift f . second (unlift g) + {-# INLINE id #-} + f . g = lift $ lmap (\(r,x) -> (r,(r,x))) (unlift f . second (unlift g)) + {-# INLINE (.) #-} -instance Arrow c => Arrow (ReaderT r c) where +instance (Arrow c, Profunctor c) => Arrow (ReaderT r c) where arr f = lift' (arr f) - first f = lift $ (\(r,(b,d)) -> ((r,b),d)) ^>> first (unlift f) - second f = lift $ (\(r,(b,d)) -> (b,(r,d))) ^>> second (unlift f) + {-# INLINE arr #-} + first f = lift $ lmap (\(r,(b,d)) -> ((r,b),d)) $ first (unlift f) + {-# INLINE first #-} + second f = lift $ lmap (\(r,(b,d)) -> (b,(r,d))) $ second (unlift f) + {-# INLINE second #-} f &&& g = lift $ unlift f &&& unlift g - f *** g = lift $ (\(r,(b,d)) -> ((r,b),(r,d))) ^>> unlift f *** unlift g - -instance ArrowChoice c => ArrowChoice (ReaderT r c) where - left f = lift $ to distribute ^>> mmap id pi2 ^>> left (unlift f) - right f = lift $ to distribute ^>> mmap pi2 id ^>> right (unlift f) - f +++ g = lift $ to distribute ^>> unlift f +++ unlift g - f ||| g = lift $ to distribute ^>> unlift f ||| unlift g - -instance ArrowApply c => ArrowApply (ReaderT r c) where - app = lift $ (\(r,(f,b)) -> (unlift f,(r,b))) ^>> app - -instance Arrow c => ArrowReader r (ReaderT r c) where + {-# INLINE (&&&) #-} + f *** g = lift $ lmap (\(r,(b,d)) -> ((r,b),(r,d))) $ unlift f *** unlift g + {-# INLINE (***) #-} + +instance (ArrowChoice c, Profunctor c) => ArrowChoice (ReaderT r c) where + left f = lift $ lmap (to distribute >>> mmap id pi2) $ left (unlift f) + {-# INLINE left #-} + right f = lift $ lmap (to distribute >>> mmap pi2 id) $ right (unlift f) + {-# INLINE right #-} + f +++ g = lift $ lmap (to distribute) $ unlift f +++ unlift g + {-# INLINE (+++) #-} + f ||| g = lift $ lmap (to distribute) $ unlift f ||| unlift g + {-# INLINE (|||) #-} + +instance (ArrowApply c, Profunctor c) => ArrowApply (ReaderT r c) where + app = lift $ lmap (\(r,(f,b)) -> (unlift f,(r,b))) app + {-# INLINE app #-} + +instance (Arrow c, Profunctor c) => ArrowReader r (ReaderT r c) where ask = lift pi1 - local f = lift $ (\(_,(r,x)) -> (r,x)) ^>> unlift f + {-# INLINE ask #-} + local f = lift $ lmap (\(_,(r,x)) -> (r,x)) (unlift f) + {-# INLINE local #-} instance ArrowState s c => ArrowState s (ReaderT r c) where get = lift' get + {-# INLINE get #-} put = lift' put + {-# INLINE put #-} instance ArrowWriter w c => ArrowWriter w (ReaderT r c) where tell = lift' tell + {-# INLINE tell #-} instance ArrowFail e c => ArrowFail e (ReaderT r c) where fail = lift' fail + {-# INLINE fail #-} + +instance ArrowTerminating c => ArrowTerminating (ReaderT r c) where + throwTerminating = lift' throwTerminating + {-# INLINE throwTerminating #-} + catchTerminating f = lift $ catchTerminating (unlift f) + {-# INLINE catchTerminating #-} instance ArrowEnv var val env c => ArrowEnv var val env (ReaderT r c) where type instance Join (ReaderT r c) ((val,x),x) y = Env.Join c ((val,Dom (ReaderT r) x y),Dom (ReaderT r) x y) (Cod (ReaderT r) x y) - lookup f g = lift $ (\(r,(v,a)) -> (v,(r,a))) ^>> lookup ((\(v,(r,a)) -> (r,(v,a))) ^>> unlift f) (unlift g) + lookup f g = lift $ lmap (\(r,(v,a)) -> (v,(r,a))) + $ lookup (lmap (\(v,(r,a)) -> (r,(v,a))) (unlift f)) (unlift g) + {-# INLINE lookup #-} getEnv = lift' getEnv + {-# INLINE getEnv #-} extendEnv = lift' extendEnv - localEnv f = lift ((\(r,(env,a)) -> (env,(r,a))) ^>> localEnv (unlift f)) + {-# INLINE extendEnv #-} + localEnv f = lift $ lmap (\(r,(env,a)) -> (env,(r,a))) $ localEnv (unlift f) + {-# INLINE localEnv #-} instance ArrowStore var val c => ArrowStore var val (ReaderT r c) where type instance Join (ReaderT r c) ((val,x),x) y = Store.Join c ((val,Dom (ReaderT r) x y),Dom (ReaderT r) x y) (Cod (ReaderT r) x y) - read f g = lift $ (\(r,(v,a)) -> (v,(r,a))) ^>> read ((\(v,(r,a)) -> (r,(v,a))) ^>> unlift f) (unlift g) + read f g = lift $ lmap (\(r,(v,a)) -> (v,(r,a))) + $ read (lmap (\(v,(r,a)) -> (r,(v,a))) (unlift f)) (unlift g) + {-# INLINE read #-} write = lift' write + {-# INLINE write #-} type instance Fix x y (ReaderT r c) = ReaderT r (Fix (Dom (ReaderT r) x y) (Cod (ReaderT r) x y) c) instance ArrowFix (Dom (ReaderT r) x y) (Cod (ReaderT r) x y) c => ArrowFix x y (ReaderT r c) where fix = liftFix + {-# INLINE fix #-} instance ArrowExcept e c => ArrowExcept e (ReaderT r c) where type instance Join (ReaderT r c) (x,(x,e)) y = Exc.Join c (Dom (ReaderT r) x y,(Dom (ReaderT r) x y,e)) (Cod (ReaderT r) x y) throw = lift' throw - catch f g = lift $ catch (unlift f) (from assoc ^>> unlift g) + {-# INLINE throw #-} + catch f g = lift $ catch (unlift f) (lmap (from assoc) (unlift g)) + {-# INLINE catch #-} finally f g = lift $ finally (unlift f) (unlift g) + {-# INLINE finally #-} instance ArrowDeduplicate (r, x) y c => ArrowDeduplicate x y (ReaderT r c) where dedup f = lift (dedup (unlift f)) + {-# INLINE dedup #-} instance ArrowJoin c => ArrowJoin (ReaderT r c) where joinWith lub f g = lift $ joinWith lub (unlift f) (unlift g) + {-# INLINE joinWith #-} instance ArrowConst x c => ArrowConst x (ReaderT r c) where askConst = lift' askConst + {-# INLINE askConst #-} instance ArrowCond v c => ArrowCond v (ReaderT r c) where type instance Join (ReaderT r c) (x,y) z = Cond.Join c (Dom (ReaderT r) x z,Dom (ReaderT r) y z) (Cod (ReaderT r) (x,y) z) - if_ f g = lift $ (\(r,(v,(x,y))) -> (v,((r,x),(r,y)))) ^>> if_ (unlift f) (unlift g) + if_ f g = lift $ lmap (\(r,(v,(x,y))) -> (v,((r,x),(r,y)))) + $ if_ (unlift f) (unlift g) + {-# INLINE if_ #-} + deriving instance PreOrd (c (r,x) y) => PreOrd (ReaderT r c x y) deriving instance LowerBounded (c (r,x) y) => LowerBounded (ReaderT r c x y) diff --git a/lib/src/Control/Arrow/Transformer/State.hs b/lib/src/Control/Arrow/Transformer/State.hs index ce49f2b1..eed7aba4 100644 --- a/lib/src/Control/Arrow/Transformer/State.hs +++ b/lib/src/Control/Arrow/Transformer/State.hs @@ -33,100 +33,155 @@ import Control.Category import Data.Hashable import Data.Order hiding (lub) import Data.Monoidal +import Data.Profunctor -- Due to "Generalising Monads to Arrows", by John Hughes, in Science of Computer Programming 37. newtype StateT s c x y = StateT { runStateT :: c (s,x) (s,y) } evalStateT :: Arrow c => StateT s c x y -> c (s,x) y evalStateT f = runStateT f >>> pi2 +{-# INLINE evalStateT #-} execStateT :: Arrow c => StateT s c x y -> c (s,x) s execStateT f = runStateT f >>> pi1 +{-# INLINE execStateT #-} + +instance (Profunctor c, Arrow c) => Profunctor (StateT s c) where + dimap f g h = lift $ dimap (second f) (second g) (unlift h) + {-# INLINE dimap #-} + lmap f h = lift $ lmap (second f) (unlift h) + {-# INLINE lmap #-} + rmap g h = lift $ rmap (second g) (unlift h) + {-# INLINE rmap #-} instance ArrowTrans (StateT s) where type Dom (StateT s) x y = (s,x) type Cod (StateT s) x y = (s,y) lift = StateT + {-# INLINE lift #-} unlift = runStateT + {-# INLINE unlift #-} instance ArrowLift (StateT s) where lift' f = lift (second f) + {-# INLINE lift' #-} -instance Arrow c => Category (StateT s c) where +instance (Arrow c, Profunctor c) => Category (StateT s c) where id = lift' id + {-# INLINE id #-} f . g = lift (unlift f . unlift g) + {-# INLINE (.) #-} -instance Arrow c => Arrow (StateT s c) where +instance (Arrow c, Profunctor c) => Arrow (StateT s c) where arr f = lift' (arr f) - first f = lift $ (\(s,(b,c)) -> ((s,b),c)) ^>> first (unlift f) >>^ strength1 - second f = lift $ (\(s,(a,b)) -> (a,(s,b))) ^>> second (unlift f) >>^ strength2 - f &&& g = lift $ (\(s,x) -> ((s,x),x)) ^>> first (unlift f) >>> (\((s,y),x) -> ((s,x),y)) ^>> first (unlift g) >>^ (\((s,z),y) -> (s,(y,z))) - f *** g = lift $ (\(s,(x,y)) -> ((s,x),y)) ^>> first (unlift f) >>> (\((s,y),x) -> ((s,x),y)) ^>> first (unlift g) >>^ (\((s,z),y) -> (s,(y,z))) - -instance ArrowChoice c => ArrowChoice (StateT s c) where - left f = lift (to distribute ^>> left (unlift f) >>^ from distribute) - right f = lift (to distribute ^>> right (unlift f) >>^ from distribute) - f +++ g = lift $ to distribute ^>> unlift f +++ unlift g >>^ from distribute - f ||| g = lift $ to distribute ^>> unlift f ||| unlift g - -instance ArrowApply c => ArrowApply (StateT s c) where - app = StateT $ (\(s,(StateT f,b)) -> (f,(s,b))) ^>> app - -instance Arrow c => ArrowState s (StateT s c) where + {-# INLINE arr #-} + first f = lift $ dimap (\(s,(b,c)) -> ((s,b),c)) strength1 (first (unlift f)) + {-# INLINE first #-} + second f = lift $ dimap (\(s,(a,b)) -> (a,(s,b))) strength2 (second (unlift f)) + {-# INLINE second #-} + f &&& g = lift $ dimap (\(s,x) -> ((s,x),x)) (\((s,y),x) -> ((s,x),y)) (first (unlift f)) + >>> rmap (\((s,z),y) -> (s,(y,z))) (first (unlift g)) + {-# INLINE (&&&) #-} + f *** g = lift $ dimap (\(s,(x,y)) -> ((s,x),y)) (\((s,y),x) -> ((s,x),y)) (first (unlift f)) + >>> rmap (\((s,z),y) -> (s,(y,z))) (first (unlift g)) + {-# INLINE (***) #-} + +instance (ArrowChoice c, Profunctor c) => ArrowChoice (StateT s c) where + left f = lift $ dimap (to distribute) (from distribute) (left (unlift f)) + {-# INLINE left #-} + right f = lift $ dimap (to distribute) (from distribute) (right (unlift f)) + {-# INLINE right #-} + f +++ g = lift $ dimap (to distribute) (from distribute) (unlift f +++ unlift g) + {-# INLINE (+++) #-} + f ||| g = lift $ lmap (to distribute) (unlift f ||| unlift g) + {-# INLINE (|||) #-} + +instance (ArrowApply c, Profunctor c) => ArrowApply (StateT s c) where + app = StateT $ lmap (\(s,(StateT f,b)) -> (f,(s,b))) app + {-# INLINE app #-} + +instance (Arrow c, Profunctor c) => ArrowState s (StateT s c) where get = StateT (arr (\(a,()) -> (a,a))) + {-# INLINE get #-} put = StateT (arr (\(_,s) -> (s,()))) + {-# INLINE put #-} -instance ArrowFail e c => ArrowFail e (StateT s c) where + +instance (ArrowFail e c, Profunctor c) => ArrowFail e (StateT s c) where fail = lift' fail + {-# INLINE fail #-} instance ArrowReader r c => ArrowReader r (StateT s c) where ask = lift' ask - local f = lift $ (\(s,(r,x)) -> (r,(s,x))) ^>> local (unlift f) + {-# INLINE ask #-} + local f = lift $ lmap (\(s,(r,x)) -> (r,(s,x))) (local (unlift f)) + {-# INLINE local #-} instance ArrowWriter w c => ArrowWriter w (StateT s c) where tell = lift' tell + {-# INLINE tell #-} instance (ArrowEnv var val env c) => ArrowEnv var val env (StateT s c) where type instance Join (StateT s c) ((val,x),x) y = Env.Join c ((val,Dom (StateT s) x y),Dom (StateT s) x y) (Cod (StateT s) x y) - lookup f g = lift $ (\(s,(v,a)) -> (v,(s,a))) ^>> lookup ((\(v,(s,a)) -> (s,(v,a))) ^>> unlift f) (unlift g) + lookup f g = lift $ lmap (\(s,(v,a)) -> (v,(s,a))) + $ lookup (lmap (\(v,(s,a)) -> (s,(v,a))) (unlift f)) + (unlift g) + {-# INLINE lookup #-} getEnv = lift' getEnv + {-# INLINE getEnv #-} extendEnv = lift' extendEnv - localEnv f = lift ((\(r,(env,a)) -> (env,(r,a))) ^>> localEnv (unlift f)) + {-# INLINE extendEnv #-} + localEnv f = lift $ lmap (\(r,(env,a)) -> (env,(r,a))) (localEnv (unlift f)) + {-# INLINE localEnv #-} instance (ArrowStore var val c) => ArrowStore var val (StateT s c) where type instance Join (StateT s c) ((val,x),x) y = Store.Join c ((val,Dom (StateT s) x y),Dom (StateT s) x y) (Cod (StateT s) x y) - read f g = lift $ (\(s,(v,a)) -> (v,(s,a))) ^>> read ((\(v,(s,a)) -> (s,(v,a))) ^>> unlift f) (unlift g) + read f g = lift $ lmap (\(s,(v,a)) -> (v,(s,a))) + $ read (lmap (\(v,(s,a)) -> (s,(v,a))) (unlift f)) + (unlift g) + {-# INLINE read #-} write = lift' write + {-# INLINE write #-} +type instance Fix x y (StateT s c) = StateT s (Fix (Dom (StateT s) x y) (Cod (StateT s) x y) c) instance ArrowFix (s,x) (s,y) c => ArrowFix x y (StateT s c) where fix = liftFix + {-# INLINE fix #-} instance (ArrowExcept e c) => ArrowExcept e (StateT s c) where type instance Join (StateT s c) (x,(x,e)) y = Exc.Join c (Dom (StateT s) x y,(Dom (StateT s) x y,e)) (Cod (StateT s) x y) throw = lift' throw - catch f g = lift $ catch (unlift f) (from assoc ^>> unlift g) + {-# INLINE throw #-} + catch f g = lift $ catch (unlift f) (lmap (from assoc) (unlift g)) + {-# INLINE catch #-} finally f g = lift $ finally (unlift f) (unlift g) + {-# INLINE finally #-} -type instance Fix x y (StateT s c) = StateT s (Fix (Dom (StateT s) x y) (Cod (StateT s) x y) c) instance (Eq s, Hashable s, ArrowDeduplicate (Dom (StateT s) x y) (Cod (StateT s) x y) c) => ArrowDeduplicate x y (StateT s c) where dedup f = lift (dedup (unlift f)) + {-# INLINE dedup #-} instance (ArrowJoin c, Complete s) => ArrowJoin (StateT s c) where joinWith lub f g = lift $ joinWith (\(s1,z1) (s2,z2) -> (s1⊔s2,lub z1 z2)) (unlift f) (unlift g) + {-# INLINE joinWith #-} instance ArrowConst x c => ArrowConst x (StateT s c) where askConst = lift' askConst + {-# INLINE askConst #-} instance ArrowAlloc x y c => ArrowAlloc x y (StateT s c) where alloc = lift' alloc + {-# INLINE alloc #-} instance (ArrowCond v c) => ArrowCond v (StateT s c) where type instance Join (StateT s c) (x,y) z = Cond.Join c ((s,x),(s,y)) (s,z) - if_ f g = lift $ (\(s,(v,(x,y))) -> (v,((s,x),(s,y)))) ^>> if_ (unlift f) (unlift g) + if_ f g = lift $ lmap (\(s,(v,(x,y))) -> (v,((s,x),(s,y)))) (if_ (unlift f) (unlift g)) + {-# INLINE if_ #-} instance ArrowRand v c => ArrowRand v (StateT s c) where random = lift' random + {-# INLINE random #-} deriving instance PreOrd (c (s,x) (s,y)) => PreOrd (StateT s c x y) deriving instance LowerBounded (c (s,x) (s,y)) => LowerBounded (StateT s c x y) diff --git a/lib/src/Control/Arrow/Transformer/Static.hs b/lib/src/Control/Arrow/Transformer/Static.hs index 7b588897..4f854ee5 100644 --- a/lib/src/Control/Arrow/Transformer/Static.hs +++ b/lib/src/Control/Arrow/Transformer/Static.hs @@ -24,75 +24,112 @@ import Control.Arrow.State import Control.Arrow.Store as Store import Control.Arrow.Writer import Control.Arrow.Abstract.Join +import Control.Arrow.Abstract.Terminating +import Data.Profunctor import Data.Order hiding (lub) -- Due to https://hackage.haskell.org/package/arrows/docs/Control-Arrow-Transformer-StaticT.html -newtype StaticT f c x y = StaticT { runStaticT :: f (c x y)} +newtype StaticT f c x y = StaticT { runStaticT :: f (c x y) } + deriving (PreOrd,Complete,CoComplete,UpperBounded,LowerBounded) + +instance (Applicative f, Profunctor c) => Profunctor (StaticT f c) where + dimap f g (StaticT h) = StaticT $ dimap f g <$> h + {-# INLINE dimap #-} + lmap f (StaticT h) = StaticT $ lmap f <$> h + {-# INLINE lmap #-} + rmap g (StaticT h) = StaticT $ rmap g <$> h + {-# INLINE rmap #-} instance Applicative f => ArrowLift (StaticT f) where lift' = StaticT . pure + {-# INLINE lift' #-} -instance (Applicative f, Arrow c) => Category (StaticT f c) where +instance (Applicative f, Arrow c, Profunctor c) => Category (StaticT f c) where id = lift' id + {-# INLINE id #-} StaticT f . StaticT g = StaticT $ (.) <$> f <*> g + {-# INLINE (.) #-} -instance (Applicative f, Arrow c) => Arrow (StaticT f c) where +instance (Applicative f, Arrow c, Profunctor c) => Arrow (StaticT f c) where arr = lift' . arr + {-# INLINE arr #-} first (StaticT f) = StaticT $ first <$> f + {-# INLINE first #-} second (StaticT f) = StaticT $ second <$> f + {-# INLINE second #-} StaticT f *** StaticT g = StaticT $ (***) <$> f <*> g + {-# INLINE (***) #-} StaticT f &&& StaticT g = StaticT $ (&&&) <$> f <*> g + {-# INLINE (&&&) #-} -instance (Applicative f, ArrowChoice c) => ArrowChoice (StaticT f c) where +instance (Applicative f, ArrowChoice c, Profunctor c) => ArrowChoice (StaticT f c) where left (StaticT f) = StaticT $ left <$> f + {-# INLINE left #-} right (StaticT f) = StaticT $ right <$> f + {-# INLINE right #-} StaticT f +++ StaticT g = StaticT $ (+++) <$> f <*> g + {-# INLINE (+++) #-} StaticT f ||| StaticT g = StaticT $ (|||) <$> f <*> g + {-# INLINE (|||) #-} instance (Applicative f, ArrowState s c) => ArrowState s (StaticT f c) where get = lift' get + {-# INLINE get #-} put = lift' put + {-# INLINE put #-} instance (Applicative f, ArrowReader r c) => ArrowReader r (StaticT f c) where ask = lift' ask + {-# INLINE ask #-} local (StaticT f) = StaticT $ local <$> f + {-# INLINE local #-} instance (Applicative f, ArrowWriter w c) => ArrowWriter w (StaticT f c) where tell = lift' tell + {-# INLINE tell #-} instance (Applicative f, ArrowFail e c) => ArrowFail e (StaticT f c) where fail = lift' fail + {-# INLINE fail #-} + +instance (Applicative f, ArrowTerminating c) => ArrowTerminating (StaticT f c) where + throwTerminating = lift' throwTerminating + {-# INLINE throwTerminating #-} + catchTerminating (StaticT f) = StaticT $ catchTerminating <$> f + {-# INLINE catchTerminating #-} instance (Applicative f, ArrowExcept e c) => ArrowExcept e (StaticT f c) where type Join (StaticT f c) x y = Exc.Join c x y throw = lift' throw + {-# INLINE throw #-} catch (StaticT f) (StaticT g) = StaticT $ catch <$> f <*> g + {-# INLINE catch #-} finally (StaticT f) (StaticT g) = StaticT $ finally <$> f <*> g + {-# INLINE finally #-} instance (Applicative f, ArrowEnv var val env c) => ArrowEnv var val env (StaticT f c) where type Join (StaticT f c) x y = Env.Join c x y lookup (StaticT f) (StaticT g) = StaticT $ lookup <$> f <*> g + {-# INLINE lookup #-} getEnv = lift' getEnv + {-# INLINE getEnv #-} extendEnv = lift' extendEnv + {-# INLINE extendEnv #-} localEnv (StaticT f) = StaticT $ localEnv <$> f + {-# INLINE localEnv #-} instance (Applicative f, ArrowStore var val c) => ArrowStore var val (StaticT f c) where type Join (StaticT f c) x y = Store.Join c x y read (StaticT f) (StaticT g) = StaticT $ read <$> f <*> g + {-# INLINE read #-} write = lift' write - -instance (Applicative f, ArrowLoop c) => ArrowLoop (StaticT f c) where - loop (StaticT f) = StaticT (loop <$> f) + {-# INLINE write #-} instance (Applicative f, ArrowJoin c) => ArrowJoin (StaticT f c) where joinWith lub (StaticT f) (StaticT g) = StaticT $ joinWith lub <$> f <*> g + {-# INLINE joinWith #-} instance (Applicative f, ArrowDeduplicate x y c) => ArrowDeduplicate x y (StaticT f c) where dedup (StaticT f) = StaticT (dedup <$> f) - -deriving instance PreOrd (f (c x y)) => PreOrd (StaticT f c x y) -deriving instance Complete (f (c x y)) => Complete (StaticT f c x y) -deriving instance CoComplete (f (c x y)) => CoComplete (StaticT f c x y) -deriving instance UpperBounded (f (c x y)) => UpperBounded (StaticT f c x y) -deriving instance LowerBounded (f (c x y)) => LowerBounded (StaticT f c x y) + {-# INLINE dedup #-} diff --git a/lib/src/Control/Arrow/Transformer/Writer.hs b/lib/src/Control/Arrow/Transformer/Writer.hs index c7ffaa5d..f634b0df 100644 --- a/lib/src/Control/Arrow/Transformer/Writer.hs +++ b/lib/src/Control/Arrow/Transformer/Writer.hs @@ -25,92 +25,136 @@ import Control.Arrow.Environment as Env import Control.Arrow.Writer import Control.Arrow.Abstract.Join +import Data.Profunctor import Data.Monoidal import Data.Order hiding (lub) newtype WriterT w c x y = WriterT { runWriterT :: c x (w,y) } +instance (Profunctor c, Arrow c) => Profunctor (WriterT w c) where + dimap f g h = lift $ dimap f (second g) (unlift h) + {-# INLINE dimap #-} + lmap f h = lift $ lmap f (unlift h) + {-# INLINE lmap #-} + rmap g h = lift $ rmap (second g) (unlift h) + {-# INLINE rmap #-} + instance ArrowTrans (WriterT w) where type Dom (WriterT w) x y = x type Cod (WriterT w) x y = (w,y) lift = WriterT + {-# INLINE lift #-} unlift = runWriterT + {-# INLINE unlift #-} instance Monoid w => ArrowLift (WriterT w) where lift' f = lift (arr (const mempty) &&& f) + {-# INLINE lift' #-} -instance (Monoid w, Arrow c) => Category (WriterT w c) where +instance (Monoid w, Arrow c, Profunctor c) => Category (WriterT w c) where id = lift (arr mempty &&& id) - g . f = lift $ unlift f >>> second (unlift g) >>^ \(w1,(w2,z)) -> (w1 <> w2,z) + {-# INLINE id #-} + g . f = lift $ rmap (\(w1,(w2,z)) -> (w1 <> w2,z)) (unlift f >>> second (unlift g)) + {-# INLINE (.) #-} -- proc x -> do -- (w1,y) <- f -< x -- (w2,z) <- g -< y -- returnA -< (w1 <> w2,z) -instance (Monoid w, Arrow c) => Arrow (WriterT w c) where +instance (Monoid w, Arrow c, Profunctor c) => Arrow (WriterT w c) where arr f = lift (arr mempty &&& arr f) - first f = lift (first (unlift f) >>^ (\((w,b),d) -> (w,(b,d)))) - second g = lift (second (unlift g) >>^ (\(d,(w,b)) -> (w,(d,b)))) - f *** g = lift (unlift f *** unlift g >>^ (\((w1,b),(w2,d)) -> (w1 <> w2,(b,d)))) - f &&& g = lift (unlift f &&& unlift g >>^ (\((w1,b),(w2,d)) -> (w1 <> w2,(b,d)))) - -instance (Monoid w, ArrowChoice c) => ArrowChoice (WriterT w c) where - left f = lift (left (unlift f) >>^ (\e -> case e of Left (w,x) -> (w,Left x); Right y -> (mempty,Right y))) - right f = lift (right (unlift f) >>^ (\e -> case e of Left x -> (mempty,Left x); Right (w,y) -> (w,Right y))) - f ||| g = lift (unlift f ||| unlift g) - f +++ g = lift (unlift f +++ unlift g >>^ from distribute) - -instance (Monoid w, ArrowApply c) => ArrowApply (WriterT w c) where - app = lift $ (\(f,x) -> (unlift f,x)) ^>> app + {-# INLINE arr #-} + first f = lift $ rmap (\((w,b),d) -> (w,(b,d))) (first (unlift f)) + {-# INLINE first #-} + second g = lift $ rmap (\(d,(w,b)) -> (w,(d,b))) (second (unlift g)) + {-# INLINE second #-} + f *** g = lift $ rmap (\((w1,b),(w2,d)) -> (w1 <> w2,(b,d))) (unlift f *** unlift g) + {-# INLINE (***) #-} + f &&& g = lift $ rmap (\((w1,b),(w2,d)) -> (w1 <> w2,(b,d))) (unlift f &&& unlift g) + {-# INLINE (&&&) #-} + +instance (Monoid w, ArrowChoice c, Profunctor c) => ArrowChoice (WriterT w c) where + left f = lift $ rmap (\e -> case e of Left (w,x) -> (w,Left x); Right y -> (mempty,Right y)) (left (unlift f)) + {-# INLINE left #-} + right f = lift $ rmap (\e -> case e of Left x -> (mempty,Left x); Right (w,y) -> (w,Right y)) (right (unlift f)) + {-# INLINE right #-} + f ||| g = lift $ unlift f ||| unlift g + {-# INLINE (|||) #-} + f +++ g = lift $ rmap (from distribute) (unlift f +++ unlift g) + {-# INLINE (+++) #-} + +instance (Monoid w, ArrowApply c, Profunctor c) => ArrowApply (WriterT w c) where + app = lift $ lmap (\(f,x) -> (unlift f,x)) app + {-# INLINE app #-} instance (Monoid w, ArrowState s c) => ArrowState s (WriterT w c) where get = lift' get + {-# INLINE get #-} put = lift' put + {-# INLINE put #-} -instance (Monoid w, Arrow c) => ArrowWriter w (WriterT w c) where +instance (Monoid w, Arrow c, Profunctor c) => ArrowWriter w (WriterT w c) where tell = lift (arr (\w -> (w,()))) + {-# INLINE tell #-} instance (Monoid w, ArrowFail e c) => ArrowFail e (WriterT w c) where fail = lift' fail + {-# INLINE fail #-} instance (Monoid w, ArrowExcept e c) => ArrowExcept e (WriterT w c) where type Join (WriterT w c) x y = Exc.Join c (Dom (WriterT w) x y) (Cod (WriterT w) x y) throw = lift' throw + {-# INLINE throw #-} catch f g = lift $ catch (unlift f) (unlift g) + {-# INLINE catch #-} finally f g = lift $ finally (unlift f) (unlift g) + {-# INLINE finally #-} instance (Monoid w, ArrowReader r c) => ArrowReader r (WriterT w c) where ask = lift' ask + {-# INLINE ask #-} local f = lift (local (unlift f)) + {-# INLINE local #-} instance (Monoid w, ArrowEnv x y env c) => ArrowEnv x y env (WriterT w c) where type Join (WriterT w c) x y = Env.Join c (Dom (WriterT w) x y) (Cod (WriterT w) x y) lookup f g = lift $ lookup (unlift f) (unlift g) + {-# INLINE lookup #-} getEnv = lift' getEnv + {-# INLINE getEnv #-} extendEnv = lift' extendEnv + {-# INLINE extendEnv #-} localEnv f = lift (localEnv (unlift f)) + {-# INLINE localEnv #-} instance (Monoid w, ArrowStore var val c) => ArrowStore var val (WriterT w c) where type Join (WriterT w c) x y = Store.Join c (Dom (WriterT w) x y) (Cod (WriterT w) x y) read f g = lift $ read (unlift f) (unlift g) + {-# INLINE read #-} write = lift' write + {-# INLINE write #-} type instance Fix x y (WriterT w c) = WriterT w (Fix (Dom (WriterT w) x y) (Cod (WriterT w) x y) c) instance (Monoid w, ArrowFix x (w,y) c) => ArrowFix x y (WriterT w c) where fix = liftFix + {-# INLINE fix #-} instance (Monoid w, Complete w, ArrowJoin c) => ArrowJoin (WriterT w c) where joinWith lub f g = lift $ joinWith (\(w1,z1) (w2,z2) -> (w1 ⊔ w2, lub z1 z2)) (unlift f) (unlift g) + {-# INLINE joinWith #-} instance (Monoid w, ArrowAlloc x y c) => ArrowAlloc x y (WriterT w c) where alloc = lift' alloc + {-# INLINE alloc #-} instance (Monoid w, ArrowCond v c) => ArrowCond v (WriterT w c) where type Join (WriterT w c) x y = Cond.Join c (Dom (WriterT w) x y) (Cod (WriterT w) x y) if_ f g = lift $ if_ (unlift f) (unlift g) + {-# INLINE if_ #-} instance (Monoid w, ArrowRand v c) => ArrowRand v (WriterT w c) where random = lift' random + {-# INLINE random #-} deriving instance PreOrd (c x (w,y)) => PreOrd (WriterT w c x y) deriving instance LowerBounded (c x (w,y)) => LowerBounded (WriterT w c x y) diff --git a/lib/src/Control/Arrow/Utils.hs b/lib/src/Control/Arrow/Utils.hs index 080d173b..d1a91b99 100644 --- a/lib/src/Control/Arrow/Utils.hs +++ b/lib/src/Control/Arrow/Utils.hs @@ -20,18 +20,22 @@ void :: Arrow c => c x y -> c x () void f = proc x -> do _ <- f -< x returnA -< () +{-# INLINE void #-} infixr 1 &&> (&&>) :: Arrow c => c a () -> c a b -> c a b f &&> g = f &&& g >>> arr snd +{-# INLINE (&&>) #-} -- | Projects the first component of a product. pi1 :: Arrow c => c (x,y) x pi1 = arr fst +{-# INLINE pi1 #-} -- | Projects the second component of a product. pi2 :: Arrow c => c (x,y) y pi2 = arr snd +{-# INLINE pi2 #-} -- | Zips two lists together. zipWith :: ArrowChoice c => c (x,y) z -> c ([x],[y]) [z] @@ -51,7 +55,9 @@ fold f = proc (l,a) -> case l of -- | Duplicates the current value. duplicate :: Arrow c => c x (x,x) duplicate = arr (\x -> (x,x)) +{-# INLINE duplicate #-} -- | creates a computation that always returns the same value. const :: Arrow c => c () x -> c y x const f = arr (\_ -> ()) >>> f +{-# INLINE const #-} diff --git a/lib/src/Control/Arrow/Writer.hs b/lib/src/Control/Arrow/Writer.hs index 5496333e..c4c9c70b 100644 --- a/lib/src/Control/Arrow/Writer.hs +++ b/lib/src/Control/Arrow/Writer.hs @@ -3,6 +3,7 @@ module Control.Arrow.Writer where import Control.Arrow +import Data.Profunctor -class Arrow c => ArrowWriter w c | c -> w where +class (Arrow c, Profunctor c) => ArrowWriter w c | c -> w where tell :: c w () diff --git a/lib/src/Data/Abstract/Error.hs b/lib/src/Data/Abstract/Error.hs index c34faab9..717264df 100644 --- a/lib/src/Data/Abstract/Error.hs +++ b/lib/src/Data/Abstract/Error.hs @@ -10,12 +10,13 @@ import Control.Arrow import Control.Monad import Control.DeepSeq -import Data.Abstract.FreeCompletion +import Data.Abstract.FreeCompletion (FreeCompletion(..)) import Data.Abstract.Widening import Data.Bifunctor import Data.Hashable import Data.Order import Data.Traversable +import Data.Monoidal import GHC.Generics (Generic, Generic1) @@ -43,16 +44,7 @@ instance (PreOrd e, PreOrd a) => PreOrd (Error e a) where (_, _) -> False instance (Complete e, Complete a) => Complete (Error e a) where - m1 ⊔ m2 = case (m1,m2) of - (Success x, Success y) -> Success (x ⊔ y) - (Success x, Fail e) -> SuccessOrFail e x - (Fail e, Success y) -> SuccessOrFail e y - (Fail e, Fail e') -> Fail (e ⊔ e') - (SuccessOrFail e x, Success y) -> SuccessOrFail e (x ⊔ y) - (Success x, SuccessOrFail e y) -> SuccessOrFail e (x ⊔ y) - (SuccessOrFail e x, Fail e') -> SuccessOrFail (e ⊔ e') x - (Fail e, SuccessOrFail e' y) -> SuccessOrFail (e ⊔ e') y - (SuccessOrFail e x, SuccessOrFail e' y) -> SuccessOrFail (e ⊔ e') (x ⊔ y) + (⊔) = widening (⊔) (⊔) widening :: Widening e -> Widening a -> Widening (Error e a) widening we wa m1 m2 = case (m1,m2) of @@ -123,6 +115,21 @@ instance Traversable (Error e) where traverse _ (Fail e) = pure (Fail e) traverse f (SuccessOrFail e x) = SuccessOrFail e <$> f x +instance Complete e => StrongMonad (Error e) (,) where + mstrength (Success _,Fail e) = Fail e + mstrength (Fail e,Fail e') = Fail (e ⊔ e') + mstrength (SuccessOrFail e _,Fail e') = Fail (e ⊔ e') + + mstrength (Success x,Success y) = Success (x,y) + mstrength (Fail e,Success _) = Fail e + mstrength (SuccessOrFail e x,Success y) = SuccessOrFail e (x,y) + + mstrength (Success x,SuccessOrFail e y) = SuccessOrFail e (x,y) + mstrength (Fail e,SuccessOrFail e' _) = Fail (e ⊔ e') + mstrength (SuccessOrFail e x,SuccessOrFail e' y) = SuccessOrFail (e ⊔ e') (x,y) + {-# INLINE mstrength #-} + + fromMaybe :: Maybe a -> Error () a fromMaybe m = case m of Just a -> Success a diff --git a/lib/src/Data/Abstract/Failure.hs b/lib/src/Data/Abstract/Failure.hs index 1352e474..f17aa618 100644 --- a/lib/src/Data/Abstract/Failure.hs +++ b/lib/src/Data/Abstract/Failure.hs @@ -85,26 +85,32 @@ instance Monad (Failure e) where fromFailure :: a -> Failure e a -> a fromFailure _ (Success a) = a fromFailure a (Fail _) = a +{-# INLINE fromFailure #-} fromEither :: Either e a -> Failure e a fromEither (Left e) = Fail e fromEither (Right a) = Success a +{-# INLINE fromEither #-} toEither :: Failure e a -> Either e a toEither (Fail e) = Left e toEither (Success a) = Right a +{-# INLINE toEither #-} fromMaybe :: Maybe a -> Failure () a fromMaybe Nothing = Fail () fromMaybe (Just a) = Success a +{-# INLINE fromMaybe #-} toMaybe :: Failure e a -> Maybe a toMaybe (Fail _) = Nothing toMaybe (Success a) = Just a +{-# INLINE toMaybe #-} instance Monoidal Failure where mmap f _ (Fail x) = Fail (f x) mmap _ g (Success y) = Success (g y) + {-# INLINE mmap #-} assoc = Iso assocTo assocFrom where @@ -112,55 +118,83 @@ instance Monoidal Failure where assocTo (Fail a) = Fail (Fail a) assocTo (Success (Fail b)) = Fail (Success b) assocTo (Success (Success c)) = Success c + {-# INLINE assocTo #-} assocFrom :: Failure (Failure a b) c -> Failure a (Failure b c) assocFrom (Fail (Fail a)) = Fail a assocFrom (Fail (Success b)) = Success (Fail b) assocFrom (Success c) = Success (Success c) + {-# INLINE assocFrom #-} + {-# INLINE assoc #-} instance Symmetric Failure where commute (Fail a) = Success a commute (Success a) = Fail a + {-# INLINE commute #-} instance Applicative f => Strong f Failure where - strength (Success a) = pure $ Success a - strength (Fail a) = Fail <$> a - -instance Distributive (,) Failure where - distribute = Iso distTo distFrom - where - distTo :: (a,Failure b c) -> Failure (a,b) (a,c) - distTo (a,Fail b) = Fail (a,b) - distTo (a,Success c) = Success (a,c) - - distFrom :: Failure (a,b) (a,c) -> (a,Failure b c) - distFrom (Fail (a,b)) = (a,Fail b) - distFrom (Success (a,c)) = (a,Success c) - -instance Distributive Either Failure where - distribute = Iso distTo distFrom - where - distTo :: Either a (Failure b c) -> Failure (Either a b) (Either a c) - distTo (Left a) = Fail (Left a) - distTo (Right (Fail b)) = Fail (Right b) - distTo (Right (Success c)) = Success (Right c) + strength1 (Success a) = pure $ Success a + strength1 (Fail a) = Fail <$> a + {-# INLINE strength1 #-} + strength2 (Success a) = Success <$> a + strength2 (Fail a) = pure $ Fail a + {-# INLINE strength2 #-} + +instance Applicative f => StrongMonad f Failure where + mstrength (Success a) = fmap Success a + mstrength (Fail a) = fmap Fail a + {-# INLINE mstrength #-} + +instance StrongMonad (Failure e) (,) where + mstrength (Success a,Success b) = Success (a,b) + mstrength (Fail e,_) = Fail e + mstrength (_,Fail e) = Fail e + {-# INLINE mstrength #-} + +-- instance Distributive (,) Failure where +-- distribute = Iso distTo distFrom +-- where +-- distTo :: (a,Failure b c) -> Failure (a,b) (a,c) +-- distTo (a,Fail b) = Fail (a,b) +-- distTo (a,Success c) = Success (a,c) +-- {-# INLINE distTo #-} + +-- distFrom :: Failure (a,b) (a,c) -> (a,Failure b c) +-- distFrom (Fail (a,b)) = (a,Fail b) +-- distFrom (Success (a,c)) = (a,Success c) +-- {-# INLINE distFrom #-} +-- {-# INLINE distribute #-} + +-- instance Distributive Either Failure where +-- distribute = Iso distTo distFrom +-- where +-- distTo :: Either a (Failure b c) -> Failure (Either a b) (Either a c) +-- distTo (Left a) = Fail (Left a) +-- distTo (Right (Fail b)) = Fail (Right b) +-- distTo (Right (Success c)) = Success (Right c) +-- {-# INLINE distTo #-} - distFrom :: Failure (Either a b) (Either a c) -> Either a (Failure b c) - distFrom (Fail (Left a)) = Left a - distFrom (Fail (Right b)) = Right (Fail b) - distFrom (Success (Left a)) = Left a - distFrom (Success (Right c)) = Right (Success c) - -instance Distributive Failure Either where - distribute = Iso distTo distFrom - where - distTo :: Failure a (Either b c) -> Either (Failure a b) (Failure a c) - distTo (Fail a) = Right (Fail a) - distTo (Success (Left b)) = Left (Success b) - distTo (Success (Right c)) = Right (Success c) +-- distFrom :: Failure (Either a b) (Either a c) -> Either a (Failure b c) +-- distFrom (Fail (Left a)) = Left a +-- distFrom (Fail (Right b)) = Right (Fail b) +-- distFrom (Success (Left a)) = Left a +-- distFrom (Success (Right c)) = Right (Success c) +-- {-# INLINE distFrom #-} +-- {-# INLINE distribute #-} + +-- instance Distributive Failure Either where +-- distribute = Iso distTo distFrom +-- where +-- distTo :: Failure a (Either b c) -> Either (Failure a b) (Failure a c) +-- distTo (Fail a) = Right (Fail a) +-- distTo (Success (Left b)) = Left (Success b) +-- distTo (Success (Right c)) = Right (Success c) +-- {-# INLINE distTo #-} - distFrom :: Either (Failure a b) (Failure a c) -> Failure a (Either b c) - distFrom (Left (Fail a)) = Fail a - distFrom (Left (Success b)) = Success (Left b) - distFrom (Right (Fail a)) = Fail a - distFrom (Right (Success c)) = Success (Right c) +-- distFrom :: Either (Failure a b) (Failure a c) -> Failure a (Either b c) +-- distFrom (Left (Fail a)) = Fail a +-- distFrom (Left (Success b)) = Success (Left b) +-- distFrom (Right (Fail a)) = Fail a +-- distFrom (Right (Success c)) = Success (Right c) +-- {-# INLINE distFrom #-} +-- {-# INLINE distribute #-} diff --git a/lib/src/Data/Abstract/Terminating.hs b/lib/src/Data/Abstract/Terminating.hs index ed940e27..36f83da6 100644 --- a/lib/src/Data/Abstract/Terminating.hs +++ b/lib/src/Data/Abstract/Terminating.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Data.Abstract.Terminating where import Control.Monad @@ -9,6 +10,7 @@ import Control.DeepSeq import Data.Order import Data.Abstract.Widening +import Data.Monoidal import GHC.Generics @@ -75,6 +77,11 @@ widening _ (Terminating a) NonTerminating = (Terminating a) widening _ NonTerminating (Terminating b) = (Terminating b) widening w (Terminating a) (Terminating b) = Terminating (w a b) +instance StrongMonad Terminating (,) where + mstrength (NonTerminating,_) = NonTerminating + mstrength (_,NonTerminating) = NonTerminating + mstrength (Terminating a,Terminating b) = Terminating (a,b) + instance Num a => Num (Terminating a) where (+) = liftA2 (+) (*) = liftA2 (*) @@ -87,7 +94,3 @@ instance Fractional a => Fractional (Terminating a) where (/) = liftA2 (/) fromRational = pure . fromRational -distributeEither :: Either (Terminating a) (Terminating b) -> Terminating (Either a b) -distributeEither (Left (Terminating a)) = Terminating (Left a) -distributeEither (Right (Terminating a)) = Terminating (Right a) -distributeEither _ = NonTerminating diff --git a/lib/src/Data/Monoidal.hs b/lib/src/Data/Monoidal.hs index 41a7c423..e73d3e43 100644 --- a/lib/src/Data/Monoidal.hs +++ b/lib/src/Data/Monoidal.hs @@ -30,22 +30,25 @@ instance Monoidal Either where assocFrom (Right c) = Right (Right c) class Strong f m where - strength :: f a `m` b -> f (a `m` b) - -strength1 :: (Strong f m) => f a `m` b -> f (a `m` b) -strength1 = strength -{-# INLINE strength1 #-} - -strength2 :: (Symmetric m, Strong f m, Functor f) => a `m` f b -> f (a `m` b) -strength2 = fmap commute . strength . commute -{-# INLINE strength2 #-} + strength1 :: f a `m` b -> f (a `m` b) + strength2 :: a `m` f b -> f (a `m` b) instance Functor f => Strong f (,) where - strength (f,b) = fmap (\a -> (a,b)) f + strength1 (f,b) = fmap (\a -> (a,b)) f + strength2 (a,f) = fmap (\b -> (a,b)) f instance Applicative f => Strong f Either where - strength (Left f) = fmap Left f - strength (Right b) = pure (Right b) + strength1 (Left f) = fmap Left f + strength1 (Right b) = pure (Right b) + strength2 (Left a) = pure (Left a) + strength2 (Right f) = fmap Right f + +class Strong f m => StrongMonad f m where + mstrength :: f a `m` f b -> f (a `m` b) + +instance Applicative f => StrongMonad f Either where + mstrength (Left a) = fmap Left a + mstrength (Right b) = fmap Right b class Monoidal m => Symmetric m where commute :: a `m` b -> b `m` a diff --git a/stratego/package.yaml b/stratego/package.yaml index f5db5627..c1796f91 100644 --- a/stratego/package.yaml +++ b/stratego/package.yaml @@ -4,6 +4,12 @@ license: BSD3 maintainer: Sven Keidel category: Language +flags: + case-studies: + description: Enable case studies for stratego + default: False + manual: True + dependencies: - base - attoparsec @@ -11,6 +17,7 @@ dependencies: - deepseq - fgl - hashable + - profunctors - mtl - sturdy-lib - text @@ -34,6 +41,12 @@ executables: - pretty - vector - criterion + when: + condition: flag(case-studies) + then: + buildable: true + else: + buildable: false benchmarks: sort-semantics: diff --git a/stratego/src/ConcreteSemantics.hs b/stratego/src/ConcreteSemantics.hs index 6df4d924..245b6da6 100644 --- a/stratego/src/ConcreteSemantics.hs +++ b/stratego/src/ConcreteSemantics.hs @@ -46,6 +46,7 @@ import Data.Hashable import Data.String (IsString(..)) import Data.Term (TermUtils(..)) import Data.Text (Text) +import Data.Profunctor import Test.QuickCheck @@ -61,7 +62,7 @@ newtype TermEnv = TermEnv (HashMap TermVar Term) deriving (Show,Eq,Hashable) -- | Concrete interpreter arrow give access to the strategy -- environment, term environment, and handles anonymous exceptions. newtype Interp a b = Interp (ReaderT StratEnv (StateT TermEnv (ExceptT () (FailureT String (->)))) a b) - deriving (Category,Arrow,ArrowChoice,ArrowApply) + deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowApply) -- | Executes a concrete interpreter computation. runInterp :: Interp a b -> StratEnv -> TermEnv -> a -> Failure String (Error () (TermEnv,b)) diff --git a/stratego/src/GrammarSemantics.hs b/stratego/src/GrammarSemantics.hs index fa2641bf..fdb69d76 100644 --- a/stratego/src/GrammarSemantics.hs +++ b/stratego/src/GrammarSemantics.hs @@ -58,6 +58,7 @@ import Data.Monoidal import Data.Order import Data.Term import Data.Text (Text) +import Data.Profunctor import TreeAutomata @@ -128,6 +129,7 @@ createGrammar ctx = grammar startSymbol prods prods = M.fromList $ startProd : map toProd (LM.toList (sorts ctx)) ++ builtins -- Instances ----------------------------------------------------------------------------------------- +deriving instance Profunctor (Interp s) deriving instance Category (Interp s) deriving instance Arrow (Interp s) deriving instance ArrowChoice (Interp s) diff --git a/stratego/src/SortSemantics.hs b/stratego/src/SortSemantics.hs index 64f2e3e9..46eecb63 100644 --- a/stratego/src/SortSemantics.hs +++ b/stratego/src/SortSemantics.hs @@ -66,6 +66,7 @@ import Data.Foldable (foldr') import Data.Hashable import Data.Monoidal import Data.Order +import Data.Profunctor -- import Test.QuickCheck hiding (Success) import Text.Printf @@ -164,13 +165,14 @@ eval' i s = runInterp' (Shared.eval' s) i -- Instances ----------------------------------------------------------------------------------------- type instance Fix x y (SortT c) = SortT (Fix x y c) newtype SortT c x y = SortT { runSortT :: c x y } - deriving (Category,Arrow,ArrowChoice,ArrowExcept e,ArrowReader r,ArrowState s,ArrowFail e,ArrowJoin,ArrowConst ctx) + deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowExcept e,ArrowReader r,ArrowState s,ArrowFail e,ArrowJoin,ArrowConst ctx) instance ArrowReader StratEnv c => HasStratEnv (SortT c) where - readStratEnv = proc _ -> - ask -< () + readStratEnv = proc _ -> ask -< () + {-# INLINE readStratEnv #-} localStratEnv senv f = proc a -> local f -< (senv,a) + {-# INLINE localStratEnv #-} instance (ArrowChoice c, ArrowApply c, ArrowJoin c, ArrowConst Context c, ArrowExcept () c) => IsTerm Term (SortT c) where @@ -281,9 +283,18 @@ instance ArrowTrans SortT where type Dom SortT x y = x type Cod SortT x y = y lift = SortT + {-# INLINE lift #-} unlift = runSortT -instance ArrowApply c => ArrowApply (SortT c) where app = SortT (first unlift ^>> app) -instance ArrowFix x y c => ArrowFix x y (SortT c) where fix = liftFix + {-# INLINE unlift #-} + +instance (ArrowApply c,Profunctor c) => ArrowApply (SortT c) where + app = SortT (lmap (first unlift) app) + {-# INLINE app #-} + +instance ArrowFix x y c => ArrowFix x y (SortT c) where + fix = liftFix + {-# INLINE fix #-} + deriving instance ArrowDeduplicate x y c => ArrowDeduplicate x y (SortT c) instance Complete (FreeCompletion Term) where @@ -296,15 +307,21 @@ instance Complete (FreeCompletion TermEnv) where instance (ArrowChoice c, ArrowJoin c, ArrowState TermEnv c) => IsTermEnv TermEnv Term (SortT c) where getTermEnv = get + {-# INLINE getTermEnv #-} putTermEnv = put + {-# INLINE putTermEnv #-} lookupTermVar f g = proc (v,env,ex) -> case S.lookup v env of A.Just t -> f -< t A.Nothing -> g -< ex A.JustNothing t -> (f -< t) <⊔> (g -< ex) + {-# INLINE lookupTermVar #-} insertTerm = arr $ \(v,t,env) -> S.insert v t env + {-# INLINE insertTerm #-} deleteTermVars = arr $ \(vars,env) -> foldr' S.delete env vars + {-# INLINE deleteTermVars #-} unionTermEnvs = arr (\(vars,e1,e2) -> S.union e1 (foldr' S.delete e2 vars)) + {-# INLINE unionTermEnvs #-} -- alphaTerm :: Context -> C.Pow C.Term -> Term diff --git a/stratego/src/WildcardSemantics.hs b/stratego/src/WildcardSemantics.hs index 3b36b956..73117627 100644 --- a/stratego/src/WildcardSemantics.hs +++ b/stratego/src/WildcardSemantics.hs @@ -56,6 +56,7 @@ import Data.Monoidal import Data.Order import Data.Term import Data.Text (Text) +import Data.Profunctor import Test.QuickCheck hiding (Success) import Text.Printf @@ -106,6 +107,7 @@ eval :: Int -> Strat -> StratEnv -> TermEnv -> Term -> Terminating (A.Pow (Failu eval i s = runInterp (eval' s) i -- Instances ----------------------------------------------------------------------------------------- +deriving instance Profunctor (Interp s) deriving instance Category (Interp s) deriving instance Arrow (Interp s) deriving instance ArrowChoice (Interp s) -- GitLab