Free Arrow

free-category.cabal

@@ -22,6 +22,7 @@ source-repository head
 
 library
   exposed-modules:
+      Control.Arrow.Free
       Control.Category.Free
   other-modules:
       Paths_free_category
@@ -50,8 +51,8 @@ library
     , free-algebras >= 0.0.5.1
   ghc-options:
     -Wall
-    -Wincomplete-record-updates
-    -Wincomplete-uni-patterns
-    -Wredundant-constraints
-    -Wno-deprecations
+    -fwarn-incomplete-record-updates
+    -fwarn-incomplete-uni-patterns
+    -fwarn-redundant-constraints
+    -fwarn-deprecations
   default-language: Haskell2010

src/Control/Arrow/Free.hs

@@ -0,0 +1,111 @@
+{-# LANGUAGE GADTs #-}
+module Control.Arrow.Free
+  ( -- * Free arrow
+    Arr (..)
+    -- * Free arrow (CPS style)
+  , A (..)
+  , fromA
+  , toA
+    -- * Free interface re-exports 
+  , FreeAlgebra2 (..)
+  , wrapFree2
+  , foldFree2
+  , hoistFree2
+  , joinFree2
+  , bindFree2
+  ) where
+
+import           Prelude hiding (id, (.))
+import           Control.Arrow (Arrow (..))
+import           Control.Category (Category (..))
+import           Control.Algebra.Free2
+  ( AlgebraType0
+  , AlgebraType
+  , FreeAlgebra2 (..)
+  , proof
+  , wrapFree2
+  , foldFree2
+  , hoistFree2
+  , hoistFreeH2
+  , joinFree2
+  , bindFree2
+  )
+
+data Arr f a b where
+  Id    :: Arr f a a
+  (:.:) :: f b c     -> Arr f a b -> Arr f a c
+  Arr   :: (b -> c)  -> Arr f a b -> Arr f a c
+  Prod  :: Arr f a b -> Arr f a c -> Arr f a (b, c)
+
+instance Category (Arr f) where
+  id = Id
+  Id         . f  = f
+  f          . Id = f
+  (f :.: g)  . h  = f :.: (g . h)
+  (Arr f g)  . h  = Arr f (g . h)
+  (Prod f g) . h  = Prod (f . h) (g . h)
+
+instance Arrow (Arr f) where
+  arr f     = Arr f Id
+  first bc  = Prod (bc . arr fst) (arr snd)
+  second bc = Prod (arr fst) (bc . arr snd)
+  ab *** xy = Prod (ab . arr fst) (xy . arr snd)
+  (&&&)     = Prod
+
+type instance AlgebraType0 Arr f = ()
+type instance AlgebraType  Arr c = Arrow c
+
+instance FreeAlgebra2 Arr where
+  liftFree2 = \fab -> fab :.: Id
+  {-# INLINE liftFree2 #-}
+
+  foldNatFree2 _   Id = id
+  foldNatFree2 fun (bc :.: ab) = fun bc . foldNatFree2 fun ab
+  foldNatFree2 fun (Arr f g)   = arr f  . foldNatFree2 fun g
+  foldNatFree2 fun (Prod f g)  = foldNatFree2 fun f &&& foldNatFree2 fun g
+  {-# INLINE foldNatFree2 #-}
+
+  codom2  = proof
+  forget2 = proof
+
+newtype A f a b
+  = A { runA :: forall r. Arrow r
+             => (forall x y. f x y -> r x y)
+             -> r a b
+      }
+
+-- |
+-- Isomorphism from @'Arr'@ to @'A'@, which is a specialisation of
+-- @'hoistFreeH2'@.
+toA :: Arr f a b -> A f a b
+toA = hoistFreeH2
+{-# INLINE toA #-}
+
+-- |
+-- Inverse of @'fromA'@, which also is a specialisatin of @'hoistFreeH2'@.
+fromA :: A f a b -> Arr f a b
+fromA = hoistFreeH2
+{-# INLINE fromA #-}
+
+instance Category (A f) where
+  id = A (const id)
+  A f . A g = A $ \k -> f k . g k
+
+instance Arrow (A f) where
+  arr f = A (const (arr f))
+  A f *** A g  = A $ \k -> f k *** g k
+  first  (A f) = A $ \k -> first (f k)
+  second (A f) = A $ \k -> second (f k)
+
+type instance AlgebraType0 A f = ()
+type instance AlgebraType  A c = Arrow c
+
+instance FreeAlgebra2 A where
+  liftFree2 = \fab -> A $ \k -> k fab
+  {-# INLINE liftFree2 #-}
+
+  foldNatFree2 fun (A f) = f fun
+  {-# INLINE foldNatFree2 #-}
+
+  codom2  = proof
+  forget2 = proof

src/Control/Category/Free.hs

@@ -8,7 +8,7 @@ module Control.Category.Free
     , toC
     , fromC
 
-    -- * Free interface re-exports
+      -- * Free interface re-exports
     , FreeAlgebra2 (..)
     , wrapFree2
     , foldFree2
@@ -19,7 +19,7 @@ module Control.Category.Free
     where
 
 import           Prelude hiding (id, (.))
-import           Control.Category (Category (..), (<<<))
+import           Control.Category (Category (..))
 import           Control.Algebra.Free2
   ( AlgebraType0
   , AlgebraType
@@ -50,12 +50,12 @@ import           Data.Semigroup.SSet (SSet (..))
 -- The same performance concerns that apply to @'Control.Monad.Free.Free'@
 -- apply to this encoding of a free category.
 data Cat :: (* -> * -> *) -> * -> * -> * where
-  Id :: Cat f a a
+  Id    :: Cat f a a
   (:.:) :: f b c -> Cat f a b -> Cat f a c
 
 instance Category (Cat f) where
   id = Id
-  Id . ys = ys
+  Id         . ys = ys
   (x :.: xs) . ys = x :.: (xs . ys)
 
 infixr 9 :.:
@@ -102,7 +102,7 @@ instance FreeAlgebra2 Cat where
   {-# INLINE liftFree2 #-}
 
   foldNatFree2 _   Id          = id
-  foldNatFree2 fun (bc :.: ab) = fun bc <<< foldNatFree2 fun ab
+  foldNatFree2 fun (bc :.: ab) = fun bc . foldNatFree2 fun ab
   {-# INLINE foldNatFree2 #-}
 
   codom2  = proof
@@ -125,7 +125,7 @@ instance Category (C f) where
   C bc . C ab = C $ \k -> bc k . ab k
 
 -- |
--- Isomorphism between @'Cat'@ to @'C'@, which is a specialisation of
+-- Isomorphism from @'Cat'@ to @'C'@, which is a specialisation of
 -- @'hoistFreeH2'@.
 toC :: Cat f a b -> C f a b
 toC = hoistFreeH2