linear-free 0.1.0.0 → 0.1.1.0

raw patch · 7 files changed

+280/−111 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• linear-free.cabal +13/−2
• src/Control/Linear/Applicative/Free.hs +63/−0
• src/Control/Linear/Monad/Free.hs +84/−0
• src/Control/Linear/Monad/Free/Church.hs +88/−0
• src/Control/Monad/Free/Linear.hs +0/−89
• test/Main.hs +27/−20

@@ -1,5 +1,10 @@ # Revision history for linear-free +## 0.1.1.0++* Added `Control.Linear.Monad.Free.Church`+* Added `Control.Linear.Applicative.Free`+ ## 0.1.0.0 -- YYYY-mm-dd  * First version. Released on an unsuspecting world.

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               linear-free-version:            0.1.0.0+version:            0.1.1.0 synopsis:           Linear free monads description:           This package implements free monads on top of `linear-base`. Linear free monads @@ -24,12 +24,23 @@ library     import:           warnings     exposed-modules:-      Control.Monad.Free.Linear+      Control.Linear.Applicative.Free+      Control.Linear.Monad.Free+      Control.Linear.Monad.Free.Church     build-depends:           base >=4.16 && <5,       linear-base ^>=0.5,     hs-source-dirs:   src     default-language: Haskell2010+    default-extensions:+      DeriveGeneric+      FlexibleInstances+      GADTs+      LambdaCase+      LinearTypes+      MultiParamTypeClasses+      RankNTypes+      NoImplicitPrelude  test-suite linear-free-test     import:           warnings

@@ -0,0 +1,63 @@+module Control.Linear.Applicative.Free (+  Ap (..),+  runApD,+  runAp,+  runAp_,+  liftAp,+  iterAp,+  hoistAp,+  retractAp,+) where++import qualified Control.Functor.Linear as Control+import qualified Data.Functor.Linear as Data+import Prelude.Linear++data Ap f a where+  Pure :: a %1 -> Ap f a+  Ap :: f a %1 -> Ap f (a %1 -> b) %1 -> Ap f b++instance Data.Functor f => Data.Functor (Ap f) where+  fmap f (Pure x) = Pure $ f x+  fmap f (Ap x mf) = Ap x $ (f .) Data.<$> mf++instance Control.Functor f => Control.Functor (Ap f) where+  fmap f (Pure x) = Pure $ f x+  fmap f (Ap x mf) = Ap x $ ((.) f) Control.<$> mf++instance Control.Functor f => Data.Applicative (Ap f) where+  pure = Pure+  (Pure f) <*> x = Control.fmap f x+  (Ap y f) <*> x = Ap y ((flip Control.<$> f) Data.<*> x)++instance Control.Functor f => Control.Applicative (Ap f) where+  pure = Pure+  (Pure f) <*> x = Control.fmap f x+  (Ap y f) <*> x = Ap y ((flip Control.<$> f) Data.<*> x)++runApD :: Data.Applicative g => (forall x. f x %1 -> g x) -> Ap f a -> g a+runApD _ (Pure x) = Data.pure x+runApD f (Ap x g) = runApD f g Data.<*> f x++runAp :: Control.Applicative g => (forall x. f x %1 -> g x) -> Ap f a %1 -> g a+runAp _ (Pure x) = Control.pure x+runAp f (Ap x g) = runAp f g Control.<*> f x++runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m+runAp_ _ (Pure _) = mempty+runAp_ f (Ap x g) = f x <> runAp_ f g++liftAp :: f a %1 -> Ap f a+liftAp x = Ap x $ Pure id++iterAp :: Control.Functor g => (g a %1 -> a) -> Ap g a %1 -> a+iterAp _ (Pure x) = x+iterAp f (Ap x g) = f (iterAp f . ((Control.<*>) g) . Pure Control.<$> x)++hoistAp :: (forall a. f a %1 -> g a) -> Ap f b %1 -> Ap g b+hoistAp _ (Pure x) = Pure x+hoistAp f (Ap x g) = Ap (f x) (hoistAp f g)++retractAp :: Control.Applicative f => Ap f a %1 -> f a+retractAp (Pure x) = Control.pure x+retractAp (Ap x g) = retractAp g Control.<*> x

@@ -0,0 +1,84 @@+module Control.Linear.Monad.Free (+  MonadFree (..),+  Free (..),+  iter,+  retract,+  hoistFree,+  foldFree,+  unfold,+  liftF,+) where++import qualified Control.Functor.Linear as Control+import qualified Data.Functor.Linear as Data+import GHC.Generics (Generic, Generic1)+import Prelude.Linear++class Control.Monad m => MonadFree f m where+  wrap :: f (m a) %1 -> m a++data Free f a where+  Pure :: a %1 -> Free f a+  Free :: f (Free f a) %1 -> Free f a+  deriving (Generic, Generic1)++instance Data.Functor f => Data.Functor (Free f) where+  fmap f (Pure x) = Pure $ f x+  fmap f (Free m) = Free $ Data.fmap (Data.fmap f) m++instance Control.Functor f => Control.Functor (Free f) where+  fmap f (Pure x) = Pure $ f x+  fmap f (Free m) = Free $ Control.fmap (Control.fmap f) m++instance Control.Functor f => Data.Applicative (Free f) where+  {-# INLINE pure #-}+  pure = Pure++  Pure a <*> Pure b = Pure $ a b+  Pure a <*> Free mb = Free $ Control.fmap a Control.<$> mb+  Free ma <*> b = Free $ (Control.<*> b) Control.<$> ma++instance Control.Functor f => Control.Applicative (Free f) where+  {-# INLINE pure #-}+  pure = Pure++  Pure a <*> Pure b = Pure $ a b+  Pure a <*> Free mb = Free $ Control.fmap a Control.<$> mb+  Free ma <*> b = Free $ (Control.<*> b) Control.<$> ma++instance Control.Functor f => Control.Monad (Free f) where+  Pure x >>= f = f x+  Free m >>= f = Free ((Control.>>= f) Control.<$> m)++instance Control.Functor f => MonadFree f (Free f) where+  {-# INLINE wrap #-}+  wrap = Free++instance Data.Traversable f => Data.Traversable (Free f) where+  traverse f (Pure x) = Pure Data.<$> f x+  traverse f (Free m) = Free Data.<$> Data.traverse (Data.traverse f) m++retract :: Control.Monad f => Free f a %1 -> f a+retract (Pure x) = Control.pure x+retract (Free m) = m Control.>>= retract++iter :: Control.Functor f => (f a %1 -> a) -> Free f a %1 -> a+iter _ (Pure x) = x+iter f (Free m) = f $ iter f Control.<$> m++hoistFree ::+  Control.Functor g => (forall a. f a %1 -> g a) -> Free f b %1 -> Free g b+hoistFree _ (Pure x) = Pure x+hoistFree f (Free m) = Free $ hoistFree f Control.<$> f m++foldFree :: Control.Monad m => (forall x. f x %1 -> m x) -> Free f a %1 -> m a+foldFree _ (Pure x) = Control.pure x+foldFree f (Free m) = f m Control.>>= foldFree f++unfold :: Control.Functor f => (b %1 -> Either a (f b)) -> b %1 -> Free f a+unfold f b = case f b of+  Left x -> Pure x+  Right m -> Free $ unfold f Control.<$> m++liftF :: (Control.Functor f, MonadFree f m) => f a %1 -> m a+liftF = wrap . Control.fmap Control.pure

@@ -0,0 +1,88 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Control.Linear.Monad.Free.Church (+  F (..),+  runF,+  improve,+  fromF,+  iter,+  iterM,+  toF,+  retract,+  hoistF,+  foldF,+  liftF,+) where++import qualified Control.Functor.Linear as Control+import Control.Linear.Monad.Free (Free (..), MonadFree (..))+import qualified Data.Functor.Linear as Data+import GHC.Num.Integer ()+import Prelude.Linear+import qualified Prelude.Linear as L++newtype F f a where+  F :: (forall r. (a %1 -> r) %1 -> (f r %1 -> r) -> r) %1 -> F f a++runF :: F f a %1 -> (a %1 -> r) %1 -> (f r %1 -> r) -> r+runF (F m) p b = m p b++instance Data.Functor f => Data.Functor (F f) where+  fmap f (F m) = F (\p b -> m (p . f) b)++instance Data.Functor f => Control.Functor (F f) where+  fmap f (F m) = F (\p b -> m (p . f) b)++instance Data.Functor f => Data.Applicative (F f) where+  {-# INLINE pure #-}+  pure x = F (\p _ -> p x)++  F f <*> F g = F (\p b -> f (\a -> g (p L.. a) b) b)++instance Data.Functor f => Control.Applicative (F f) where+  {-# INLINE pure #-}+  pure x = F (\p _ -> p x)++  F f <*> F g = F (\p b -> f (\a -> g (p L.. a) b) b)++instance Data.Functor f => Control.Monad (F f) where+  F m >>= f = F (\p b -> m (\x -> runF (f x) p b) b)++instance Control.Functor f => MonadFree f (F f) where+  wrap f = F (\p b -> b (Control.fmap (\(F m) -> m p b) f))++instance (Control.Functor f, Data.Traversable f) => Data.Traversable (F f) where+  traverse f m = runF m (Data.fmap Control.return . f) (Data.fmap wrap . Data.sequenceA)++improve ::+  forall f a.+  Control.Functor f =>+  (forall m. MonadFree f m => m a) %1 ->+  Free f a+improve f = fromF @_ @f f++fromF :: forall m f a. MonadFree f m => F f a %1 -> m a+fromF (F m) = m Control.return wrap++iter :: (f a %1 -> a) -> F f a %1 -> a+iter f (F m) = m id f++iterM :: Control.Applicative m => (f (m a) %1 -> m a) -> F f a %1 -> m a+iterM f (F m) = m Control.pure f++toF :: Control.Functor f => Free f a %1 -> F f a+toF (Pure x) = F (\p _ -> p x)+toF (Free f) = wrap (toF Control.<$> f)++retract :: Control.Monad m => F m a %1 -> m a+retract (F m) = m Control.pure Control.join++hoistF :: (forall x. f x %1 -> g x) -> F f a %1 -> F g a+hoistF f (F m) = F (\p b -> m p (\x -> b (f x)))++foldF :: Control.Monad m => (forall x. f x %1 -> m x) -> F f a %1 -> m a+foldF f (F m) = m Control.pure (\x -> Control.join $ f x)++liftF :: (Data.Functor f, MonadFree f m) => f a %1 -> m a+liftF x = wrap (Control.pure Data.<$> x)

@@ -1,89 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Control.Monad.Free.Linear (-  MonadFreeL (..),-  FreeL (..),-  iter,-  retract,-  hoistFree,-  foldFree,-  unfold,-  liftF,-) where--import qualified Control.Functor.Linear as Control-import qualified Data.Functor.Linear as Data-import GHC.Generics (Generic)-import Prelude.Linear--class Control.Monad m => MonadFreeL f m where-  wrap :: f (m a) %1 -> m a--data FreeL f a where-  Pure :: a %1 -> FreeL f a-  Free :: f (FreeL f a) %1 -> FreeL f a-  deriving (Generic)--instance Data.Functor f => Data.Functor (FreeL f) where-  fmap f (Pure x) = Pure $ f x-  fmap f (Free m) = Free $ Data.fmap (Data.fmap f) m--instance Control.Functor f => Control.Functor (FreeL f) where-  fmap f (Pure x) = Pure $ f x-  fmap f (Free m) = Free $ Control.fmap (Control.fmap f) m--instance Control.Functor f => Data.Applicative (FreeL f) where-  {-# INLINE pure #-}-  pure = Pure--  Pure a <*> Pure b = Pure $ a b-  Pure a <*> Free mb = Free $ Control.fmap a Control.<$> mb-  Free ma <*> b = Free $ (Control.<*> b) Control.<$> ma--instance Control.Functor f => Control.Applicative (FreeL f) where-  {-# INLINE pure #-}-  pure = Pure--  Pure a <*> Pure b = Pure $ a b-  Pure a <*> Free mb = Free $ Control.fmap a Control.<$> mb-  Free ma <*> b = Free $ (Control.<*> b) Control.<$> ma--instance Control.Functor f => Control.Monad (FreeL f) where-  Pure x >>= f = f x-  Free m >>= f = Free ((Control.>>= f) Control.<$> m)--instance Control.Functor f => MonadFreeL f (FreeL f) where-  {-# INLINE wrap #-}-  wrap = Free--retract :: Control.Monad f => FreeL f a %1 -> f a-retract (Pure x) = Control.pure x-retract (Free m) = m Control.>>= retract--iter :: Control.Functor f => (f a %1 -> a) -> FreeL f a %1 -> a-iter _ (Pure x) = x-iter f (Free m) = f $ iter f Control.<$> m--hoistFree ::-  Control.Functor g => (forall a. f a %1 -> g a) -> FreeL f b %1 -> FreeL g b-hoistFree _ (Pure x) = Pure x-hoistFree f (Free m) = Free $ hoistFree f Control.<$> f m--foldFree :: Control.Monad m => (forall x. f x %1 -> m x) -> FreeL f a %1 -> m a-foldFree _ (Pure x) = Control.pure x-foldFree f (Free m) = f m Control.>>= foldFree f--unfold :: Control.Functor f => (b %1 -> Either a (f b)) -> b %1 -> FreeL f a-unfold f b = case f b of-  Left x -> Pure x-  Right m -> Free $ unfold f Control.<$> m--liftF :: (Control.Functor f, MonadFreeL f m) => f a %1 -> m a-liftF = wrap . Control.fmap Control.pure

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE QualifiedDo #-}@@ -8,7 +9,8 @@  import qualified Control.Functor.Linear as Control import qualified Control.Functor.Linear as Linear-import Control.Monad.Free.Linear (FreeL (..), liftF)+import qualified Control.Linear.Monad.Free as Linear+import qualified Control.Linear.Monad.Free.Church as LC import qualified Data.Functor.Linear as Data import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map@@ -22,7 +24,7 @@   | Milk   | Flour   | Dough-  | Pancake+  | Pancakes   deriving (Base.Eq, Base.Ord, Show)  newtype ProductId = ProductId Int@@ -33,25 +35,29 @@   Cook :: ProductType -> ProductId %1 -> (ProductId %1 -> a) %1 -> RecipeF a  instance Data.Functor RecipeF where-  fmap f (Buy t c) = Buy t $ f L.. c-  fmap f (Combine t cs c) = Combine t cs $ f L.. c-  fmap f (Cook t p c) = Cook t p $ f L.. c+  fmap = forget Control.fmap  instance Control.Functor RecipeF where   fmap f (Buy t c) = Buy t $ f L.. c   fmap f (Combine t cs c) = Combine t cs $ f L.. c   fmap f (Cook t p c) = Cook t p $ f L.. c -type Recipe a = FreeL RecipeF a+class MonadRecipe m where+  buy :: ProductType -> m ProductId+  combine :: ProductType -> [ProductId] %1 -> m ProductId+  cook :: ProductType -> ProductId %1 -> m ProductId -buy :: ProductType -> Recipe ProductId-buy t = liftF $ Buy t id+type Recipe a = Linear.Free RecipeF a -combine :: ProductType -> [ProductId] %1 -> Recipe ProductId-combine t ps = liftF $ Combine t ps id+instance MonadRecipe (Linear.Free RecipeF) where+  buy t = Linear.liftF $ Buy t id+  combine t ps = Linear.liftF $ Combine t ps id+  cook t p = Linear.liftF $ Cook t p id -cook :: ProductType -> ProductId %1 -> Recipe ProductId-cook t p = liftF $ Cook t p id+instance MonadRecipe (LC.F RecipeF) where+  buy t = LC.liftF $ Buy t id+  combine t ps = LC.liftF $ Combine t ps id+  cook t p = LC.liftF $ Cook t p id  pancakeRecipe :: Recipe ProductId pancakeRecipe = Linear.do@@ -59,12 +65,12 @@   milk <- buy Milk   flour <- buy Flour   dough <- combine Dough [eggs, milk, flour]-  pancake <- cook Pancake dough+  pancake <- cook Pancakes dough   Linear.pure pancake  gatherIngredients :: Recipe a -> Map ProductType Int-gatherIngredients (Pure _) = Map.empty-gatherIngredients (Free x) = case x of+gatherIngredients (Linear.Pure _) = Map.empty+gatherIngredients (Linear.Free x) = case x of   Buy t c -> Map.insertWith (Base.+) t 1 $ gatherIngredients (c productId)   Combine _ _ c -> gatherIngredients $ c productId   Cook _ _ c -> gatherIngredients $ c productId@@ -76,8 +82,9 @@ main = hspec $ describe "Linear free monad" $ do   describe "pancake recipe example" $ do     it "can gather the ingredients" $ do-      gatherIngredients pancakeRecipe `shouldBe` Map.fromList-        [ (Eggs, 1)-        , (Milk, 1)-        , (Flour, 1)-        ]+      gatherIngredients pancakeRecipe+        `shouldBe` Map.fromList+          [ (Eggs, 1)+          , (Milk, 1)+          , (Flour, 1)+          ]