Commit b7226241 authored by Sven Keidel's avatar Sven Keidel

refactor fixpoint algos

parent 8543baf9
Pipeline #13925 passed with stages
in 25 minutes and 47 seconds
{-# LANGUAGE MultiParamTypeClasses #-}
module Control.Arrow.Abstract.Cache where
import Control.Arrow
import Data.Abstract.Widening (Stable)
import Data.Profunctor
class (Profunctor c, Arrow c) => ArrowCache a b c where
lookup :: c a b
update :: c (a,b) (Stable,b)
cached :: c a b -> c a b
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
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, Profunctor c) => ArrowDeduplicate x y c where
dedup :: c x y -> c x y
instance ArrowDeduplicate x y (->) where
dedup = returnA
......@@ -5,7 +5,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DefaultSignatures #-}
module Control.Arrow.Fix(ArrowFix(..),Fix,liftFix) where
module Control.Arrow.Fix(ArrowFix(..),Fix,liftFix,IterationStrategy) where
import Control.Arrow
import Control.Arrow.Trans
......@@ -25,3 +25,6 @@ instance ArrowFix x y (->) where
liftFix :: (Arrow c, Profunctor c, ArrowFix (Dom t x y) (Cod t x y) c,ArrowTrans t) => (t c x y -> t c x y) -> t c x y
liftFix f = lift $ fix (unlift . f . lift)
{-# INLINE liftFix #-}
type IterationStrategy c a b = c a b -> c a b
{-# LANGUAGE Arrows #-}
module Control.Arrow.Abstract.Join where
module Control.Arrow.Order where
import Prelude hiding ((.))
......@@ -7,37 +7,35 @@ import Control.Arrow
import Data.Order(Complete(..))
import Data.Profunctor
class (Arrow c, Profunctor c) => ArrowJoin c where
class (Arrow c, Profunctor c) => ArrowLowerBounded c where
bottom :: c x y
class (Arrow c, Profunctor c) => ArrowComplete c where
-- | Join two arrow computation with the provided upper bound operator.
--
-- Laws:
-- @
-- joinWith (⊔) f g = joined f g
-- @
joinWith :: (y -> y -> y) -> c x y -> c x y -> c x y
join :: (y -> y -> y) -> c x y -> c x y -> c x y
joinWith' :: (ArrowJoin c) => (y -> y -> y) -> c x y -> c x' y -> c (x,x') y
joinWith' lub f g = joinWith lub (lmap fst f) (lmap snd g)
join' :: (ArrowComplete c) => (y -> y -> y) -> c x y -> c x' y -> c (x,x') y
join' lub f g = join lub (lmap fst f) (lmap snd g)
(<>) :: (ArrowJoin c, Complete y) => c x y -> c x y -> c x y
(<>) = joinWith ()
(<>) :: (ArrowComplete c, Complete y) => c x y -> c x y -> c x y
(<>) = join ()
-- | Joins a list of arguments. Use it with idiom brackets:
-- @
-- let a = ...; b = ...; xs = ...
-- (| joinList (returnA -< a) (\x -> f -< x+b) |) xs
-- @
joinList :: (ArrowChoice c, ArrowJoin c, Complete y) => c (e,s) y -> c (e,(x,s)) y -> c (e,([x],s)) y
joinList :: (ArrowChoice c, ArrowComplete c, Complete y) => c (e,s) y -> c (e,(x,s)) y -> c (e,([x],s)) y
joinList empty f = proc (e,(l,s)) -> case l of
[] -> empty -< (e,s)
[x] -> f -< (e,(x,s))
(x:xs) -> (f -< (e,(x,s))) <> (joinList empty f -< (e,(xs,s)))
joinList1 :: (ArrowChoice c, ArrowJoin c, Complete y) => c (e,(x,s)) y -> c (e,([x],s)) y
joinList1 :: (ArrowChoice c, ArrowLowerBounded c, ArrowComplete c, Complete y) => c (e,(x,s)) y -> c (e,([x],s)) y
joinList1 f = proc (e,(l,s)) -> case l of
[] -> returnA -< error "empty list"
[] -> bottom -< ()
[x] -> f -< (e,(x,s))
(x:xs) -> (f -< (e,(x,s))) <> (joinList1 f -< (e,(xs,s)))
instance ArrowJoin (->) where
joinWith lub f g = \x -> lub (f x) (g x)
instance ArrowComplete (->) where
join lub f g = \x -> lub (f x) (g x)
......@@ -4,6 +4,14 @@ module Control.Arrow.Trans where
import Control.Arrow
import Data.Profunctor
class (Arrow c, Profunctor c) => ArrowRun c where
type Rep c x y
run :: c x y -> Rep c x y
instance ArrowRun (->) where
type Rep (->) x y = x -> y
run = id
class ArrowLift t where
lift' :: (Arrow c, Profunctor c) => c x y -> t c x y
......
......@@ -20,23 +20,20 @@ import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Abstract.Join
import Control.Arrow.Order
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Static
import Control.Arrow.Transformer.Reader
import Control.Category
import Data.Order
import Data.Order (Complete)
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.
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
-- | Abstract domain for environments in which concrete environments
-- are approximated by a mapping from variables to addresses and a
......@@ -47,9 +44,9 @@ import Data.Profunctor
-- 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 )
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowState s, ArrowFail e, ArrowExcept e, ArrowJoin)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowState s, ArrowFail e, ArrowExcept e, ArrowLowerBounded, ArrowComplete)
runEnvT :: (Show var, Identifiable var, Identifiable addr, Complete val, ArrowJoin c, ArrowChoice c, Profunctor c)
runEnvT :: (Identifiable var, Identifiable addr, Complete val, ArrowComplete c, 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
......@@ -58,6 +55,10 @@ runEnvT alloc f =
localEnv f -< (env',x)
in (const (M.empty) &&& id) ^>> runReaderT (runConstT alloc f')
instance (Identifiable var, Identifiable addr, Complete val, ArrowComplete c, ArrowChoice c, ArrowRun c) => ArrowRun (EnvT var addr val c) where
type Rep (EnvT var addr val c) x y = c (var,val,Map var addr val) addr -> Rep c ([(var,val)],x) y
run f alloc = run (runEnvT alloc f)
instance ArrowTrans (EnvT var addr val) where
type Dom (EnvT var addr val) x y = Dom (ReaderT (Map var addr val)) x y
type Cod (EnvT var addr val) x y = Cod (ReaderT (Map var addr val)) x y
......@@ -67,7 +68,7 @@ instance ArrowTrans (EnvT var addr val) where
instance ArrowLift (EnvT var addr val) where
lift' f = EnvT (lift' (lift' f))
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, ArrowJoin c, Profunctor c) =>
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, ArrowComplete 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 y)
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
......@@ -86,7 +87,7 @@ instance ArrowReader r c => ArrowReader r (EnvT var addr val c) where
EnvT $ ConstT $ StaticT $ \alloc -> ReaderT $ (\(env,(r,x)) -> (r,(env,x))) ^>> local (runReaderT (f alloc))
instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var addr val c) where
app = EnvT $ lmap (\(EnvT f,x) -> (f,x)) app
app = EnvT (app .# first coerce)
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)
......@@ -10,7 +10,6 @@ module Control.Arrow.Transformer.Abstract.Completion(CompletionT,runCompletionT)
import Prelude hiding ((.),id,lookup,fail)
import Control.Arrow
import Control.Arrow.Deduplicate
import Control.Arrow.Environment
import Control.Arrow.Except
import Control.Arrow.Fail
......@@ -20,30 +19,36 @@ import Control.Arrow.State
import Control.Arrow.Store
import Control.Arrow.Trans
import Control.Arrow.Const
import Control.Arrow.Abstract.Join
import Control.Arrow.Order
import Control.Arrow.Transformer.Kleisli
import Control.Category
import Data.Profunctor
import Data.Abstract.FreeCompletion
import Data.Identifiable
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
-- | Allows to describe computations over non-completely ordered types.
-- E.g. allows to join a computation of type 'c x [y]'.
newtype CompletionT c x y = CompletionT { unCompletionT :: KleisliT FreeCompletion c x y }
newtype CompletionT c x y = CompletionT (KleisliT FreeCompletion c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowState s, ArrowReader r,
ArrowConst r, ArrowEnv a b e, ArrowStore a b, ArrowFail e, ArrowExcept e)
ArrowConst r, ArrowEnv a b e, ArrowStore a b, ArrowFail e, ArrowExcept e, ArrowRun)
runCompletionT :: CompletionT c x y -> c x (FreeCompletion y)
runCompletionT = runKleisliT . unCompletionT
runCompletionT = coerce
{-# INLINE runCompletionT #-}
instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (CompletionT c) where app = lift $ lmap (first unlift) app
instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (CompletionT c) where
app = lift (app .# first coerce)
type instance Fix x y (CompletionT c) = CompletionT (Fix (Dom (CompletionT) x y) (Cod (CompletionT) x y) c)
deriving instance (ArrowChoice c, ArrowFix (Dom (CompletionT) x y) (Cod (CompletionT) x y) c) => ArrowFix x y (CompletionT c)
deriving instance (Identifiable (Cod CompletionT x y), ArrowChoice c, ArrowDeduplicate (Dom CompletionT x y) (Cod CompletionT x y) c) => ArrowDeduplicate x y (CompletionT c)
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
instance (ArrowChoice c, ArrowLowerBounded c) => ArrowLowerBounded (CompletionT c) where
bottom = lift $ bottom
instance (ArrowChoice c, ArrowComplete c) => ArrowComplete (CompletionT c) where
join lub f g = lift $ join joinVal (unlift f) (unlift g)
where joinVal (Lower x) (Lower y) = Lower (lub x y)
joinVal Top _ = Top
joinVal _ Top = Top
......@@ -19,7 +19,7 @@ import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Abstract.Join
import Control.Arrow.Order
import Control.Arrow.Transformer.Reader
import Control.Category
......@@ -27,18 +27,26 @@ import Control.Category
import Data.Label
import Data.CallString
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
-- | 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)
ArrowEnv x y env, ArrowFail e, ArrowExcept e, ArrowLowerBounded, ArrowComplete)
-- | 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, Profunctor c) => Int -> ContourT lab c a b -> c a b
runContourT k (ContourT (ReaderT f)) = lmap (\a -> (empty k,a)) f
{-# INLINE runContourT #-}
instance ArrowRun c => ArrowRun (ContourT lab c) where
type Rep (ContourT lab c) x y = Int -> Rep c x y
run f i = run (runContourT i f)
{-# INLINE run #-}
type instance Fix x y (ContourT lab c) = ContourT lab (Fix x y c)
instance (ArrowFix x y c, ArrowApply c, HasLabel x lab,Profunctor c) => ArrowFix x y (ContourT lab c) where
......@@ -58,7 +66,7 @@ instance (Arrow c, Profunctor c) => ArrowAlloc (var,val,env) (var,CallString lab
alloc = ContourT $ ReaderT $ arr $ \(l,(x,_,_)) -> (x,l)
instance (ArrowApply c, Profunctor c) => ArrowApply (ContourT lab c) where
app = ContourT $ lmap (\(ContourT f,x) -> (f,x)) app
app = ContourT (app .# first coerce)
instance ArrowReader r c => ArrowReader r (ContourT lab c) where
ask = lift' ask
......
......@@ -10,12 +10,6 @@ module Control.Arrow.Transformer.Abstract.Environment where
import Prelude hiding ((.),read,Maybe(..))
import Data.Order
import Data.Identifiable
import Data.Abstract.Maybe
import Data.Abstract.StrongMap (Map)
import qualified Data.Abstract.StrongMap as M
import Control.Category
import Control.Arrow
import Control.Arrow.Const
......@@ -28,34 +22,43 @@ import Control.Arrow.Except
import Control.Arrow.Trans
import Control.Arrow.Environment
import Control.Arrow.Fix
import Control.Arrow.Order
import Control.Arrow.Abstract.Join
import Data.Order(UpperBounded, Complete)
import Data.Identifiable
import Data.Abstract.Maybe
import Data.Abstract.StrongMap (Map)
import qualified Data.Abstract.StrongMap as M
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
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)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowLowerBounded, ArrowComplete,
ArrowState s, ArrowFail e, ArrowExcept e, ArrowStore var' val', ArrowConst k, ArrowRun)
runEnvT :: (Arrow c, Profunctor c) => EnvT var val c x y -> c (Map var val,x) y
runEnvT = unlift
runEnvT = coerce
{-# INLINE runEnvT #-}
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
runEnvT' f = lmap (first M.fromList) (runEnvT f)
{-# INLINE runEnvT' #-}
instance (Identifiable var, UpperBounded val, ArrowChoice c, ArrowJoin c, Profunctor c) => ArrowEnv var val (Map var val) (EnvT var val c) where
type Join (EnvT var val c) x y = (Complete y)
instance (Identifiable var, UpperBounded val, ArrowChoice c, ArrowComplete c, Profunctor c) => ArrowEnv var val (Map var val) (EnvT var val c) where
type Join (EnvT var val c) x y = Complete y
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
env <- ask -< ()
case M.lookup' var env of
Just val -> f -< (val,x)
JustNothing val -> (f -< (val,x)) <> (g -< x)
Nothing -> g -< x
JustNothing val -> (f -< (val,x)) <> (g -< x)
getEnv = EnvT ask
extendEnv = arr $ \(x,y,env) -> M.insert x y env
localEnv (EnvT f) = EnvT (local f)
instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var val c) where
app = EnvT $ lmap (\(EnvT f,x) -> (f,x)) app
app = EnvT (app .# first coerce)
instance ArrowReader r c => ArrowReader r (EnvT var val c) where
ask = lift' ask
......
......@@ -12,7 +12,6 @@ import Prelude hiding (id,lookup,(.),read,fail)
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Deduplicate
import Control.Arrow.Environment as Env
import Control.Arrow.Fail
import Control.Arrow.Trans
......@@ -21,31 +20,38 @@ import Control.Arrow.State
import Control.Arrow.Store as Store
import Control.Arrow.Except as Exc
import Control.Arrow.Fix
import Control.Arrow.Abstract.Join
import Control.Arrow.Order
import Control.Arrow.Transformer.Kleisli
import Control.Category
import Data.Order
import Data.Profunctor
import Data.Identifiable
import Data.Abstract.Error
import Data.Abstract.Widening (toJoin2)
newtype ErrorT e c x y = ErrorT { unErrorT :: KleisliT (Error e) c x y }
import qualified Data.Order as O
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
newtype ErrorT e c x y = ErrorT (KleisliT (Error e) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowState s, ArrowReader r,
ArrowConst r, ArrowEnv a b e', ArrowStore a b, ArrowExcept e')
ArrowConst r, ArrowEnv a b e', ArrowStore a b, ArrowExcept e', ArrowRun)
runErrorT :: ErrorT e c x y -> c x (Error e y)
runErrorT = runKleisliT . unErrorT
runErrorT = coerce
{-# INLINE runErrorT #-}
instance (ArrowChoice c, Profunctor c) => ArrowFail e (ErrorT e c) where
fail = lift $ arr Fail
instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (ErrorT e c) where app = lift $ lmap (first unlift) app
instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (ErrorT e c) where
app = lift (app .# first coerce)
type instance Fix x y (ErrorT e c) = ErrorT e (Fix (Dom (ErrorT e) x y) (Cod (ErrorT e) x y) c)
deriving instance (ArrowChoice c, ArrowFix (Dom (ErrorT e) x y) (Cod (ErrorT e) x y) c) => ArrowFix x y (ErrorT e c)
deriving instance (Identifiable (Cod (ErrorT e) x y), ArrowChoice c, ArrowDeduplicate (Dom (ErrorT e) x y) (Cod (ErrorT e) x y) c) => ArrowDeduplicate x y (ErrorT e c)
instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowJoin (ErrorT e c) where
joinWith lub' f g = lift $ joinWith (toJoin2 widening () lub') (unlift f) (unlift g)
instance (ArrowChoice c, ArrowLowerBounded c) => ArrowLowerBounded (ErrorT e c) where
bottom = lift bottom
instance (O.Complete e, ArrowComplete c, ArrowChoice c) => ArrowComplete (ErrorT e c) where
join lub f g = lift $ join (toJoin2 widening (O.) lub) (unlift f) (unlift g)
......@@ -12,7 +12,6 @@ import Prelude hiding (id,lookup,(.),read,fail)
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Deduplicate
import Control.Arrow.Environment as Env
import Control.Arrow.Fail
import Control.Arrow.Trans
......@@ -21,25 +20,28 @@ import Control.Arrow.State
import Control.Arrow.Store as Store
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Abstract.Join
import Control.Arrow.Order
import Control.Arrow.Transformer.Kleisli
import Control.Category
import Data.Identifiable
import Data.Order
import Data.Profunctor
import Data.Abstract.Except
import Data.Abstract.Widening (toJoin2)
import Data.Order(Complete)
import qualified Data.Order as O
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
newtype ExceptT e c x y = ExceptT (KleisliT (Except e) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowState s, ArrowReader r,
ArrowConst r, ArrowEnv a b e', ArrowStore a b, ArrowFail e')
ArrowConst r, ArrowEnv a b e', ArrowStore a b, ArrowFail e', ArrowRun)
runExceptT :: ExceptT e c x y -> c x (Except e y)
runExceptT = coerce
{-# INLINE runExceptT #-}
instance (ArrowChoice c, Complete e, ArrowJoin c) => ArrowExcept e (ExceptT e c) where
instance (Complete e, ArrowChoice c, ArrowComplete c) => ArrowExcept e (ExceptT e c) where
type Join (ExceptT e c) (y,(x,e)) z = Complete (Except e z)
throw = lift $ arr Fail
try f g h = lift $ proc x -> do
......@@ -49,11 +51,12 @@ instance (ArrowChoice c, Complete e, ArrowJoin c) => ArrowExcept e (ExceptT e c)
Fail er -> unlift h -< (x,er)
SuccessOrFail er y -> (unlift g -< y) <> (unlift h -< (x,er))
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (ExceptT e c) where app = lift $ lmap (first unlift) app
instance (Complete e, ArrowComplete c, ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (ExceptT e c) where
app = lift (app .# first coerce)
type instance Fix x y (ExceptT e c) = ExceptT e (Fix (Dom (ExceptT e) x y) (Cod (ExceptT e) x y) c)
deriving 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)
deriving instance (Complete e, ArrowJoin c, Identifiable (Cod (ExceptT e) x y), ArrowChoice c, ArrowDeduplicate (Dom (ExceptT e) x y) (Cod (ExceptT e) x y) c) => ArrowDeduplicate x y (ExceptT e c)
deriving instance (Complete e, ArrowComplete c, ArrowChoice c, ArrowFix (Dom (ExceptT e) x y) (Cod (ExceptT e) x y) c) => ArrowFix x y (ExceptT e c)
instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowJoin (ExceptT e c) where
joinWith lub' f g = lift $ joinWith (toJoin2 widening () lub') (unlift f) (unlift g)
instance (Complete e, ArrowComplete c, ArrowChoice c) => ArrowComplete (ExceptT e c) where
join lub f g = lift $ join (toJoin2 widening (O.) lub) (unlift f) (unlift g)
......@@ -13,7 +13,6 @@ import Prelude hiding (id,(.),lookup,read)
import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Deduplicate
import Control.Arrow.Environment as Env
import Control.Arrow.Fail
import Control.Arrow.Fix
......@@ -22,29 +21,34 @@ import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Store as Store
import Control.Arrow.Except as Exc
import Control.Arrow.Abstract.Join
import Control.Arrow.Order
import Control.Arrow.Transformer.Kleisli
import Data.Identifiable
import Data.Profunctor
import Data.Abstract.Failure
import Data.Abstract.Widening (toJoin)
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
-- | Describes computations that can fail.
newtype FailureT e c x y = FailureT { unFailureT :: KleisliT (Failure e) c x y }
newtype FailureT e c x y = FailureT (KleisliT (Failure e) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowState s, ArrowReader r,
ArrowConst r, ArrowEnv a b e', ArrowStore a b, ArrowExcept e')
ArrowConst r, ArrowEnv a b e', ArrowStore a b, ArrowExcept e', ArrowRun)
runFailureT :: FailureT e c x y -> c x (Failure e y)
runFailureT = runKleisliT . unFailureT
runFailureT = coerce
{-# INLINE runFailureT #-}
instance (ArrowChoice c, Profunctor c) => ArrowFail e (FailureT e c) where
fail = lift $ arr Fail
instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (FailureT e c) where app = lift $ lmap (first unlift) app
instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (FailureT e c) where
app = lift (app .# first coerce)
type instance Fix x y (FailureT e c) = FailureT e (Fix (Dom (FailureT e) x y) (Cod (FailureT e) x y) c)
deriving instance (ArrowChoice c, ArrowFix (Dom (FailureT e) x y) (Cod (FailureT e) x y) c) => ArrowFix x y (FailureT e c)
deriving instance (Identifiable (Cod (FailureT e) x y), ArrowChoice c, ArrowDeduplicate (Dom (FailureT e) x y) (Cod (FailureT e) x y) c) => ArrowDeduplicate x y (FailureT e c)
deriving instance (ArrowChoice c, ArrowFix (Dom (FailureT e) x y) (Cod (FailureT e) x y) c) =>
ArrowFix x y (FailureT e c)
instance (ArrowJoin c, ArrowChoice c) => ArrowJoin (FailureT e c) where
joinWith lub' f g = lift $ joinWith (toJoin widening lub') (unlift f) (unlift g)
instance (ArrowComplete c, ArrowChoice c) => ArrowComplete (FailureT e c) where
join lub f g = lift $ join (toJoin widening lub) (unlift f) (unlift g)
......@@ -9,7 +9,7 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module Control.Arrow.Transformer.Abstract.Fix(FixT,runFixT,runFixT') where
module Control.Arrow.Transformer.Abstract.Fix(FixT,runFixT) where
import Prelude hiding (id,(.),const,head,iterate,lookup)
......@@ -17,33 +17,39 @@ import Control.Category
import Control.Arrow hiding (loop)
import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.Abstract.Join
import Control.Arrow.Order
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Static
import Data.Identifiable
import Data.Order
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
import Data.Abstract.IterationStrategy
newtype FixT a b c x y = FixT { unFixT :: ConstT (IterationStrategy c a b) c x y }
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowJoin)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowComplete)
runFixT :: (Identifiable a, PreOrd b, Profunctor c, ArrowRun t)
=> IterationStrategy (t c) a b -> FixT a b (t c) x y -> c x y
runFixT iterationStrat f = run (runFixT' iterationStrat f)
-- runFixT :: (Identifiable a, PreOrd b, Profunctor c, ArrowRun t)
-- => IterationStrategy (t c) a b -> FixT a b (t c) x y -> c x y
-- runFixT iterationStrat f = run (runFixT' iterationStrat f)
runFixT' :: (Identifiable a, PreOrd b)
runFixT :: (Identifiable a, PreOrd b)
=> IterationStrategy c a b -> FixT a b c x y -> c x y
runFixT' iterationStrat (FixT f) = (runConstT iterationStrat f)
runFixT iterationStrat (FixT f) = runConstT iterationStrat f
{-# INLINE runFixT #-}
instance ArrowRun c => ArrowRun (FixT a b c) where
type Rep (FixT a b c) x y = IterationStrategy c a b -> Rep c x y
run (FixT f) iterationStrat = run (runConstT iterationStrat f)
{-# INLINE run #-}
type instance Fix x y (FixT () () c) = FixT x y c
instance (Identifiable a, LowerBounded b, Profunctor c,ArrowChoice c,ArrowApply c) => ArrowFix a b (FixT a b c) where
type instance Fix x y (FixT _ _ c) = FixT x y c
instance (Profunctor c,ArrowChoice c,ArrowApply c) => ArrowFix a b (FixT a b c) where
fix f = iterationStrategy (f (fix f))
instance (Profunctor c,ArrowApply c) => ArrowApply (FixT a b c) where app = FixT (lmap (first coerce) app)
instance (Profunctor c,ArrowApply c) => ArrowApply (FixT a b c) where
app = FixT (app .# first coerce)
instance ArrowLift (FixT a b) where
lift' = FixT . lift'
......