diff --git a/linear-base.cabal b/linear-base.cabal index 3771d360..712e1b9e 100644 --- a/linear-base.cabal +++ b/linear-base.cabal @@ -1,5 +1,5 @@ name: linear-base -version: 0.1.1 +version: 0.1.2 cabal-version: >=1.10 homepage: https://github.com/tweag/linear-base#README license: MIT @@ -22,6 +22,8 @@ library hs-source-dirs: src exposed-modules: Control.Monad.IO.Class.Linear + Control.Arrow.Linear + Control.Category.Linear Control.Functor.Linear Control.Functor.Linear.Internal.Class Control.Functor.Linear.Internal.Instances diff --git a/src/Control/Arrow/Linear.hs b/src/Control/Arrow/Linear.hs new file mode 100644 index 00000000..52661419 --- /dev/null +++ b/src/Control/Arrow/Linear.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Control.Arrow.Linear ( + -- | Arrows + Arrow(..), + Kleisli(..), + -- | Derived function + (^>>), (>>^), (>>>), returnA, + -- | Right-to-left variants + (<<^), (^<<), (<<<), + -- | Arrow Application + ArrowApply(..), + -- | Feedback + ArrowLoop(..) + +) where + +import Control.Category.Linear ( (<<<), (>>>), Category(..) ) +import Control.Functor.Linear as Control +import Data.Profunctor.Kleisli.Linear (Kleisli(..)) +import Data.Unrestricted.Linear ( Dupable(dup2) ) +import GHC.Exts(FUN) +import GHC.Types (Multiplicity(One)) + +-- | A linear Arrow +class Category a => Arrow a where + -- | Lift function to an arrow + arr :: (b %1 -> c) %1 -> a b c + + -- | Send the first component of the input through the argument + -- arrow, and copy the rest unchanged to the output. + first :: a b c %1 -> a (b,d) (c,d) + first = (*** id) + + -- | A mirror image of 'first'. + -- + -- The default definition may be overridden with a more efficient + -- version if desired. + second :: a b c %1 -> a (d,b) (d,c) + second = (id ***) + + -- | Split the input between the two argument arrows and combine + -- their output. Note that this is in general not a functor. + -- + -- The default definition may be overridden with a more efficient + -- version if desired. + (***) :: a b c %1 -> a b' c' %1 -> a (b,b') (c,c') + f *** g = first f >>> arr swap >>> first g >>> arr swap + where + swap :: (x,y) %1 -> (y,x) + swap (x,y) = (y,x) + infixr 3 *** + + -- | Fanout: send the input to both argument arrows and combine + -- their output. + -- + -- This requires the input to be `Dupable` + (&&&) :: (Dupable b) => a b c %1 -> a b c' %1 -> a b (c,c') + f &&& g = arr dup2 >>> (f *** g) + +class Arrow a => ArrowLoop a where + loop :: a (b,d) (c,d) %1 -> a b c + + +-- | Some arrows allow application of arrow inputs to other inputs. +-- Instances should satisfy the following laws: +-- +-- * @'first' ('arr' (\\x -> 'arr' (\\y -> (x,y)))) >>> 'app' = 'id'@ +-- +-- * @'first' ('arr' (g >>>)) >>> 'app' = 'second' g >>> 'app'@ +-- +-- * @'first' ('arr' (>>> h)) >>> 'app' = 'app' >>> h@ +-- +-- Such arrows are equivalent to monads (see 'ArrowMonad'). +class Arrow a => ArrowApply a where + app :: a (a b c, b) c + + +-- Need category instance for (FUN 'Many) +returnA :: Arrow a => a b b +returnA = arr id + +-- Derived combinators + + +-- | Pre-composition with a pure function. +(^>>) :: Arrow a => (b %1 -> c) %1 -> a c d %1 -> a b d +f ^>> a = arr f >>> a +infixr 1 ^>> + +-- | Post-composition with a pure function. +(>>^) :: Arrow a => a b c %1 -> (c %1 -> d) %1 -> a b d +a >>^ f = a >>> arr f +infixr 1 >>^ + +-- Right to left variants + +-- | Pre-composition with a pure function (right-to-left variant). +(<<^) :: Arrow a => a c d %1 -> (b %1 -> c) %1 -> a b d +a <<^ f = a <<< arr f +infixr 1 <<^ + +-- | Post-composition with a pure function (right-to-left variant). +(^<<) :: Arrow a => (c %1 -> d) %1 -> a b c %1 -> a b d +f ^<< a = arr f <<< a +infixr 1 ^<< + + +instance Arrow (FUN 'One) where + arr f = f + (f *** g) (x,y) = (f x, g y) + -- | NOTE: `~(x,y)` is the NonLinear pattern match + + +instance ArrowApply (FUN 'One) where + app (f,x) = f x + + +instance Monad m => Arrow (Kleisli m) where + arr f = Kleisli (return . f) + first (Kleisli f) = Kleisli (\ (b,d) -> f b >>= \c -> return (c,d)) + second (Kleisli f) = Kleisli (\ (d,b) -> f b >>= \c -> return (d,c)) + + +instance Monad m => ArrowApply (Kleisli m) where + app = Kleisli (\(Kleisli f, x) -> f x) diff --git a/src/Control/Category/Linear.hs b/src/Control/Category/Linear.hs new file mode 100644 index 00000000..a7c0f3e4 --- /dev/null +++ b/src/Control/Category/Linear.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Control.Category.Linear where + +import qualified Prelude.Linear +import GHC.Exts(FUN) +import GHC.Types (Multiplicity(One)) +import Control.Functor.Linear as Control +import Data.Profunctor.Kleisli.Linear (Kleisli(..)) + +class Category cat where + id :: cat a a + (.) :: cat b c %1 -> cat a b %1 -> cat a c + infixr 9 . + +-- | Left-to-right composition +(>>>) :: Category cat => cat a b %1 -> cat b c %1 -> cat a c +f >>> g = (Control.Category.Linear..) g f +infixr 1 >>> +{-# INLINE (>>>) #-} + +-- | Right-to-left composition +(<<<) :: Category cat => cat b c %1 -> cat a b %1 -> cat a c +(<<<) = (Control.Category.Linear..) +infixr 1 <<< + + +instance Category (FUN 'One) where + id = Prelude.Linear.id + (.) = (Prelude.Linear..) + + +instance Monad m => Category (Kleisli m) where + id = Kleisli return + (Kleisli f) . (Kleisli g) = Kleisli (\b -> g b >>= f)