inline all typeclass methods and implement Profunctor arrows

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:

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

lib/src/Control/Arrow/Abstract/Terminating.hs

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

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

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

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

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

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

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

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

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

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

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.

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)

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

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

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)

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

@@ -9,6 +9,7 @@ module Control.Arrow.Transformer.Abstract.Completion(CompletionT(..)) where