linear-free (empty) → 0.1.0.0

raw patch · 5 files changed

+243/−0 lines, 5 filesdep +QuickCheckdep +basedep +containers

Dependencies added: QuickCheck, base, containers, hspec, linear-base, linear-free

Files

CHANGELOG.md +5/−0
LICENSE +20/−0
linear-free.cabal +46/−0
src/Control/Monad/Free/Linear.hs +89/−0
test/Main.hs +83/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Revision history for linear-free++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

+ LICENSE view

@@ -0,0 +1,20 @@+Copyright (c) 2025 Joosep Jääger++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

+ linear-free.cabal view

@@ -0,0 +1,46 @@+cabal-version:      3.0+name:               linear-free+version:            0.1.0.0+synopsis:           Linear free monads+description:        +  This package implements free monads on top of `linear-base`. Linear free monads +  are useful to implement domain specific languages that for example have to +  keep track of resources.+license:            MIT+license-file:       LICENSE+author:             Joosep Jääger+maintainer:         joosep.jaager@gmail.com+category:           Control+build-type:         Simple+extra-doc-files:    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/Soupstraw/linear-free.git++common warnings+    ghc-options: -Wall++library+    import:           warnings+    exposed-modules:+      Control.Monad.Free.Linear+    build-depends:    +      base >=4.16 && <5,+      linear-base ^>=0.5,+    hs-source-dirs:   src+    default-language: Haskell2010++test-suite linear-free-test+    import:           warnings+    default-language: Haskell2010+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          Main.hs+    build-depends:+      base >=4.16 && <5,+      containers,+      hspec,+      linear-base,+      linear-free,+      QuickCheck

+ src/Control/Monad/Free/Linear.hs view

@@ -0,0 +1,89 @@+{-# 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

+ test/Main.hs view

@@ -0,0 +1,83 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Main (main) where++import qualified Control.Functor.Linear as Control+import qualified Control.Functor.Linear as Linear+import Control.Monad.Free.Linear (FreeL (..), liftF)+import qualified Data.Functor.Linear as Data+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Prelude.Linear hiding ((.))+import qualified Prelude.Linear as L+import Test.Hspec (describe, hspec, it, shouldBe)+import qualified Prelude as Base++data ProductType+  = Eggs+  | Milk+  | Flour+  | Dough+  | Pancake+  deriving (Base.Eq, Base.Ord, Show)++newtype ProductId = ProductId Int++data RecipeF a where+  Buy :: ProductType -> (ProductId %1 -> a) %1 -> RecipeF a+  Combine :: ProductType -> [ProductId] %1 -> (ProductId %1 -> a) %1 -> RecipeF a+  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++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++buy :: ProductType -> Recipe ProductId+buy t = liftF $ Buy t id++combine :: ProductType -> [ProductId] %1 -> Recipe ProductId+combine t ps = liftF $ Combine t ps id++cook :: ProductType -> ProductId %1 -> Recipe ProductId+cook t p = liftF $ Cook t p id++pancakeRecipe :: Recipe ProductId+pancakeRecipe = Linear.do+  eggs <- buy Eggs+  milk <- buy Milk+  flour <- buy Flour+  dough <- combine Dough [eggs, milk, flour]+  pancake <- cook Pancake dough+  Linear.pure pancake++gatherIngredients :: Recipe a -> Map ProductType Int+gatherIngredients (Pure _) = Map.empty+gatherIngredients (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+  where+    -- Doesn't matter what we put here, it will not be used anyways+    productId = ProductId 0++main :: IO ()+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)+        ]