Commit c6894fe5 authored by Sven Keidel's avatar Sven Keidel

add ST arrow

parent d7a53c78
Pipeline #30165 failed with stages
in 24 minutes and 48 seconds
......@@ -11,6 +11,7 @@ dependencies:
- containers
- comonad
- hashable
- hashtables
- mtl
- random
- text
......
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Primitive where
import Control.Arrow
import Control.Arrow.Trans
import Data.Profunctor
import GHC.Exts
class (Arrow c, Profunctor c) => ArrowPrimitive c where
type PrimState c :: *
primitive :: ((# State# (PrimState c), x #) -> (# State# (PrimState c), y #)) -> c x y
default primitive :: (c ~ t c', PrimState c ~ PrimState c', ArrowLift t, ArrowPrimitive c')
=> ((# State# (PrimState c), x #) -> (# State# (PrimState c), y #)) -> c x y
primitive f = lift' (primitive f)
{-# INLINE primitive #-}
......@@ -11,7 +11,7 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Control.Arrow.Transformer.Abstract.Fix.Cache where
module Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable where
import Prelude hiding (pred,lookup,map,head,iterate,(.),id,truncate,elem,product,(**))
......
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Control.Arrow.Transformer.Abstract.Fix.Cache.Mutable where
import Prelude hiding ((.))
import Control.Category
import Control.Arrow
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Trans
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable (Widening)
import Data.Coerce
import Data.Order
import Data.Profunctor
import Data.Profunctor.Unsafe
newtype CacheT cache a b c x y = CacheT { unCacheT :: ConstT (Widening (cache c a b), cache c a b) c x y}
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowPrimitive)
instance ArrowTrans (CacheT cache a b c) where
type Underlying (CacheT cache a b c) x y = (Widening (cache c a b), cache c a b) -> c x y
lift = CacheT . lift
unlift f = unlift (unCacheT f)
{-# INLINE lift #-}
{-# INLINE unlift #-}
instance ArrowLift (CacheT cache a b) where
lift' = CacheT . lift'
{-# INLINE lift' #-}
instance (ArrowRun c) => ArrowRun (CacheT cache a b c) where
type Run (CacheT cache a b c) x y = Widening (cache c a b) -> cache c a b -> Run c x y
run f widen cache = run (unlift f (widen,cache))
{-# INLINE run #-}
instance (Complete y, ArrowEffectCommutative c) => ArrowComplete y (CacheT cache a b c) where
CacheT f <> CacheT g = CacheT $ rmap (uncurry ()) (f &&& g)
{-# INLINE (<⊔>) #-}
instance (Profunctor c, ArrowApply c) => ArrowApply (CacheT cache a b c) where
app = CacheT (app .# first coerce)
{-# INLINE app #-}
instance ArrowEffectCommutative c => ArrowEffectCommutative (CacheT cache a b c)
newtype Cache c a b = Cache (HashMap a (Stable,b))
......@@ -17,6 +17,7 @@ import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Monad
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Reader as Reader
import Control.Arrow.State as State
import Control.Arrow.Store as Store
......@@ -30,10 +31,9 @@ import Control.Comonad
newtype CokleisliT f c x y = CokleisliT { runCokleisliT :: c (f x) y }
instance (ArrowComonad f c, ArrowRun c) => ArrowRun (CokleisliT f c) where
type Run (CokleisliT f c) x y = Run c (f x) y
instance ArrowTrans (CokleisliT f c) where
type Underlying (CokleisliT f c) x y = c (f x) y
instance (ArrowComonad f c, ArrowRun c) => ArrowRun (CokleisliT f c) where type Run (CokleisliT f c) x y = Run c (f x) y
instance ArrowTrans (CokleisliT f c) where type Underlying (CokleisliT f c) x y = c (f x) y
instance (ArrowComonad f c, ArrowPrimitive c) => ArrowPrimitive (CokleisliT f c) where type PrimState (CokleisliT f c) = PrimState c
instance Comonad f => ArrowLift (CokleisliT f) where
lift' f = lift $ lmap extract f
......
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
......@@ -24,6 +27,7 @@ import Control.Arrow.Fix.Chaotic
import Control.Arrow.Fix.Context
import Control.Arrow.Fix.Stack
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Store
......@@ -37,7 +41,7 @@ import Data.Coerce
-- | Passes along constant data.
newtype ConstT r c x y = ConstT (StaticT ((->) r) c x y)
deriving (Category,Profunctor,Arrow,ArrowChoice,ArrowLowerBounded,ArrowLift,ArrowJoin,
deriving (Category,Profunctor,Arrow,ArrowChoice,ArrowLowerBounded,ArrowLift,ArrowJoin,ArrowPrimitive,
ArrowState s,ArrowReader r',ArrowWriter w, ArrowLetRec var val,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore var val,
ArrowFail e, ArrowExcept e,
......
......@@ -15,6 +15,7 @@ import Control.Arrow.Cont
import Control.Arrow.Fix
import Control.Arrow.Fail
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.State
......@@ -46,6 +47,9 @@ instance ArrowLift (ContT r) where
lift' f = ContT $ \k -> k . f
{-# INLINE lift' #-}
instance (ArrowApply c, ArrowPrimitive c) => ArrowPrimitive (ContT r c) where
type PrimState (ContT r c) = PrimState c
instance Profunctor c => Profunctor (ContT r c) where
dimap f g h = lift $ \k -> lmap f (unlift h (lmap g k))
lmap f h = lift $ \k -> lmap f (unlift h k)
......
......@@ -20,6 +20,7 @@ import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Monad
import Control.Arrow.Order as Ord
import Control.Arrow.Primitive as Prim
import Control.Arrow.Reader as Reader
import Control.Arrow.State as State
import Control.Arrow.Store as Store
......@@ -35,6 +36,7 @@ newtype KleisliT f c x y = KleisliT { runKleisliT :: c x (f y) }
instance (ArrowMonad f c, ArrowRun c) => ArrowRun (KleisliT f c) where type Run (KleisliT f c) x y = Run c x (f y)
instance ArrowTrans (KleisliT f c) where type Underlying (KleisliT f c) x y = c x (f y)
instance (ArrowMonad f c, ArrowPrimitive c) => ArrowPrimitive (KleisliT f c) where type PrimState (KleisliT f c) = PrimState c
instance Monad f => ArrowLift (KleisliT f) where
lift' f = lift $ rmap return f
......
......@@ -21,6 +21,7 @@ import Control.Arrow.Fix.Parallel as Parallel
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Context as Context
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Reader as Reader
import Control.Arrow.State as State
import Control.Arrow.Store as Store
......@@ -37,6 +38,7 @@ newtype ReaderT r c x y = ReaderT { runReaderT :: c (r,x) y }
instance ArrowRun c => ArrowRun (ReaderT r c) where type Run (ReaderT r c) x y = Run c (r,x) y
instance ArrowTrans (ReaderT r c) where type Underlying (ReaderT r c) x y = c (r,x) y
instance (ArrowPrimitive c) => ArrowPrimitive (ReaderT s c) where type PrimState (ReaderT s c) = PrimState c
instance (Profunctor c) => Profunctor (ReaderT r c) where
dimap f g h = lift $ dimap (second f) g (unlift h)
......
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.ST(ST(..)) where
import Prelude hiding (id,(.),lookup,read,fail)
import Control.Category
import Control.Arrow
import Control.Arrow.Order
import Control.Arrow.Trans
import Control.Arrow.Primitive
import Unsafe.Coerce
import qualified Data.Order as O
import Data.Profunctor hiding (Strong(..))
import Data.Profunctor.Unsafe
import GHC.Exts
-- Arrow version of the ST monad (https://hackage.haskell.org/package/base/docs/Control-Monad-ST.html).
newtype ST s x y = ST { runST :: (# State# s, x #) -> (# State# s, y #) }
instance ArrowPrimitive (ST s) where
type PrimState (ST s) = s
primitive = lift
{-# INLINE primitive #-}
instance ArrowRun (ST RealWorld) where
type Run (ST RealWorld) x y = x -> y
run (ST f) x = case runRW# (\s -> f (# s, x #)) of { (# _, y #) -> y }
{-# NOINLINE run #-}
instance ArrowTrans (ST s) where
type Underlying (ST s) x y = (# State# s, x #) -> (# State# s, y #)
instance Profunctor (ST s) where
dimap f g h = arr g . h . arr f
lmap f h = h . arr f
rmap g h = arr g . h
f .# _ = f `seq` unsafeCoerce f
_ #. g = g `seq` unsafeCoerce g
{-# INLINE dimap #-}
{-# INLINE lmap #-}
{-# INLINE rmap #-}
{-# INLINE ( .# ) #-}
{-# INLINE ( #. ) #-}
instance Category (ST c) where
id = lift $ \x -> x
f . g = lift $ \x -> unlift f (unlift g x)
{-# INLINE id #-}
{-# INLINE (.) #-}
instance Arrow (ST s) where
arr f = lift $ \(# s, x #) -> (# s, f x #)
first f = lift $ \(# s, (x,z) #) -> case unlift f (# s, x #) of { (# s', y #) -> (# s', (y,z) #)}
second f = lift $ \(# s, (z,x) #) -> case unlift f (# s, x #) of { (# s', y #) -> (# s', (z,y) #)}
f &&& g = lift $ \(# s, x #) -> case unlift f (# s, x #) of { (# s', y #) -> case unlift g (# s', x #) of { (# s'', z #) -> (# s'', (y,z) #)}}
f *** g = lift $ \(# s, (x,x') #) -> case unlift f (# s, x #) of { (# s', y #) -> case unlift g (# s', x' #) of { (# s'', z #) -> (# s'', (y,z) #)}}
{-# INLINE arr #-}
{-# INLINE first #-}
{-# INLINE second #-}
{-# INLINE (&&&) #-}
{-# INLINE (***) #-}
instance ArrowChoice (ST s) where
left f = lift $ \t -> case t of
(# s, Left x #) -> case unlift f (# s, x #) of
(# s', x' #) -> (# s', Left x' #)
(# s, Right y #) -> (# s, Right y #)
right f = lift $ \t -> case t of
(# s, Left x #) -> (# s, Left x #)
(# s, Right y #) -> case unlift f (# s, y #) of
(# s', y' #) -> (# s', Right y' #)
f ||| g = lift $ \t -> case t of
(# s, Left x #) -> unlift f (# s, x #)
(# s, Right y #) -> unlift g (# s, y #)
f +++ g = lift $ \t -> case t of
(# s, Left x #) -> case unlift f (# s, x #) of
(# s', x' #) -> (# s', Left x' #)
(# s, Right y #) -> case unlift g (# s, y #) of
(# s', y' #) -> (# s', Right y' #)
{-# INLINE left #-}
{-# INLINE right #-}
{-# INLINE (+++) #-}
{-# INLINE (|||) #-}
instance ArrowApply (ST s) where
app = lift $ \(# s, (f,x) #) -> unlift f (# s, x #)
{-# INLINE app #-}
instance ArrowEffectCommutative (ST s)
instance O.Complete y => ArrowComplete y (ST s) where
f <> g = lift $ \(# s, x #) -> case unlift f (# s, x #) of (# s', y #) -> case unlift g (# s', x #) of (# s'' , y' #) -> (# s'', y O. y' #)
{-# INLINE (<⊔>) #-}
......@@ -23,6 +23,7 @@ import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Context as Context
import Control.Arrow.Fix.Widening
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Random
import Control.Arrow.Reader as Reader
import Control.Arrow.State as State
......@@ -55,6 +56,7 @@ withStateT f = lift (second (unlift f))
instance ArrowRun c => ArrowRun (StateT s c) where type Run (StateT s c) x y = Run c (s,x) (s,y)
instance ArrowTrans (StateT s c) where type Underlying (StateT s c) x y = c (s,x) (s,y)
instance (ArrowPrimitive c) => ArrowPrimitive (StateT s c) where type PrimState (StateT s c) = PrimState c
instance (Profunctor c) => Profunctor (StateT s c) where
dimap f g h = lift $ dimap (second' f) (second' g) (unlift h)
......
......@@ -19,6 +19,7 @@ import Control.Arrow.Closure as Cls
import Control.Arrow.Except as Exc
import Control.Arrow.Fail
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Reader as Reader
import Control.Arrow.State as State
import Control.Arrow.Store as Store
......@@ -38,6 +39,10 @@ instance (Applicative f, ArrowRun c) => ArrowRun (StaticT f c) where
{-# INLINE run #-}
{-# SPECIALIZE instance (ArrowRun c) => ArrowRun (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowPrimitive c) => ArrowPrimitive (StaticT f c) where
type PrimState (StaticT f c) = PrimState c
{-# SPECIALIZE instance (ArrowPrimitive c) => ArrowPrimitive (StaticT ((->) r) c) #-}
instance (Applicative f) => ArrowTrans (StaticT f c) where
type Underlying (StaticT f c) x y = f (c x y)
......
......@@ -22,6 +22,7 @@ import Control.Arrow.Except as Exc
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Random
import Control.Arrow.Reader as Reader
import Control.Arrow.State as State
......@@ -47,6 +48,9 @@ instance (Monoid w,ArrowRun c) => ArrowRun (WriterT w c) where
instance ArrowTrans (WriterT w c) where
type Underlying (WriterT w c) x y = c x (w,y)
instance (Monoid w,ArrowPrimitive c) => ArrowPrimitive (WriterT w c) where
type PrimState (WriterT w c) = PrimState c
instance (Profunctor c) => Profunctor (WriterT w c) where
dimap f g h = lift $ dimap f (second g) (unlift h)
lmap f h = lift $ lmap f (unlift h)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment