freer-par-monad (empty) → 0.1.0.0

raw patch · 12 files changed

+377/−0 lines, 12 filesdep +basedep +freer-par-monadsetup-changed

Dependencies added: base, freer-par-monad

Files

• CHANGELOG.md +11/−0
• LICENSE +30/−0
• README.md +1/−0
• Setup.hs +2/−0
• freer-par-monad.cabal +60/−0
• src/Control/Monad/Freer/Par.hs +146/−0
• src/Control/Monad/Freer/Par/FTCQueue.hs +25/−0
• src/Control/Monad/Freer/Par/Funable.hs +24/−0
• src/Control/Monad/Freer/Par/Internal/Id.hs +11/−0
• src/Control/Monad/Freer/Par/Sequence.hs +51/−0
• src/Control/Monad/Freer/Par/TaggableFunction.hs +14/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,11 @@+# Changelog for `freer-par-monad`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD

@@ -0,0 +1,30 @@+Copyright Yoshikuni Jujo (c) 2023++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Yoshikuni Jujo nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,1 @@+# freer-par-monad

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,60 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name:           freer-par-monad+version:        0.1.0.0+synopsis:       Freer par monad+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/freer-par-monad#readme>+category:       Monads+homepage:       https://github.com/YoshikuniJujo/freer-par-monad#readme+bug-reports:    https://github.com/YoshikuniJujo/freer-par-monad/issues+author:         Yoshikuni Jujo+maintainer:     yoshikuni.jujo@gmail.com+copyright:      Copyright (c) 2023 Yoshikuni Jujo+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/YoshikuniJujo/freer-par-monad++library+  exposed-modules:+      Control.Monad.Freer.Par+      Control.Monad.Freer.Par.FTCQueue+      Control.Monad.Freer.Par.Funable+      Control.Monad.Freer.Par.Sequence+      Control.Monad.Freer.Par.TaggableFunction+  other-modules:+      Control.Monad.Freer.Par.Internal.Id+      Paths_freer_par_monad+  autogen-modules:+      Paths_freer_par_monad+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+  default-language: Haskell2010++test-suite freer-par-monad-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_freer_par_monad+  autogen-modules:+      Paths_freer_par_monad+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , freer-par-monad+  default-language: Haskell2010

@@ -0,0 +1,146 @@+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE RankNTypes, PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Monad.Freer.Par (+	-- * Freer+	-- ** Type+	Freer, Fun,+	-- ** Pattern+	pattern Pure, pattern (:>>=), pattern (:=<<),+	-- ** Bind+	(>>>=), (=<<<),+	-- ** Apply+	app, appPar,+	-- * Tagged+	Tagged, runTagged, tag ) where++import Control.Arrow (first, (&&&), (>>>))+import Control.Monad.Freer.Par.Sequence (Sequence(..), ViewL(..), (|>), mapS)+import Control.Monad.Freer.Par.Funable (Funable(..), Taggable(..), sameTag)+import Control.Monad.Freer.Par.Internal.Id (Id(..))+import Numeric.Natural (Natural)+import Unsafe.Coerce (unsafeCoerce)++---------------------------------------------------------------------------++-- * PARALLEL FREER+--	+ TYPE AND MONAD+--	+ PATTERN+--	+ BIND+--	+ APPLICATION+-- * TAGGED++---------------------------------------------------------------------------+-- PARALLEL FREER+---------------------------------------------------------------------------++-- TYPE AND MONAD++infixl 7 ::>>=++data Freer s sq (f :: (* -> *) -> * -> * -> *) t a =+	Pure_ a | forall x . t x ::>>= sq (f (Freer s sq f t)) x a++freer :: (a -> b) -> (forall x . t x -> sq (f (Freer s sq f t)) x a -> b) ->+	Freer s sq f t a -> b+freer p b = \case Pure_ x -> p x; t ::>>= k -> t `b` k++instance (Sequence sq, Funable f) => Functor (Freer s sq f t) where+	fmap f = freer (Pure_ . f) \t k -> t ::>>= k |> fun (Pure_ . f)++instance (Sequence sq, Funable f) => Applicative (Freer s sq f t) where+	pure = Pure_+	mf <*> (flip (<$>) -> ax) = freer ax (\t -> (t ::>>=) . (|> fun ax)) mf++instance (Sequence sq, Funable f) => Monad (Freer s sq f t) where+	m >>= f = freer f (\t -> (t ::>>=) . (|> fun f)) m++newtype Fun s sq f t a b = Fun { unFun :: sq (f (Freer s sq f t)) a b }++-- PATTERN++pattern Pure :: a -> Freer s sq f t a+pattern Pure x <- Pure_ x++{-# COMPLETE Pure, (:>>=) #-}++pattern (:>>=) :: t x -> Fun s sq f t x a -> Freer s sq f t a+pattern t :>>= k <- t ::>>= (Fun -> k)++{-# COMPLETE Pure, (:=<<) #-}++pattern (:=<<) :: Fun s sq f t x a -> t x -> Freer s sq f t a+pattern k :=<< t <- t ::>>= (Fun -> k)++-- BIND++infixl 7 >>>=++(>>>=) :: (Sequence sq, Funable f) =>+	t a -> (a -> Freer s sq f t b) -> Freer s sq f t b+(>>>=) m = (m ::>>=) . singleton . fun++infixr 7 =<<<++(=<<<) :: (Sequence sq, Funable f) =>+	(a -> Freer s sq f t b) -> t a -> Freer s sq f t b+(=<<<) = flip (>>>=)++-- APPLICATION++app :: (Sequence sq, Funable f) => Fun s sq f t a b -> a -> Freer s sq f t b+app = aps . unFun++appPar :: (Sequence sq, Funable f, Taggable f) =>+	Fun s sq f t a b -> Fun s sq f t a b -> a ->+	(Freer s sq f t b, Freer s sq f t b)+Fun l `appPar` Fun r = l `apsPar` r++aps :: (Sequence sq, Funable f) =>+	sq (f (Freer s sq f t)) a b -> a -> Freer s sq f t b+aps = viewl >>> \case EmptyL -> pure; f :<| fs -> aps' f fs++aps' :: (Sequence sq, Funable f) =>+	f (Freer s sq f t) a x ->+	sq (f (Freer s sq f t)) x b -> a -> Freer s sq f t b+aps' f fs = (f $$) >>> \case Pure_ y -> fs `aps` y; t ::>>= k -> t ::>>= k >< fs++apsPar :: (Sequence sq, Funable f, Taggable f) =>+	sq (f (Freer s sq f t)) a b -> sq (f (Freer s sq f t)) a b -> a ->+	(Freer s sq f t b, Freer s sq f t b)+(l `apsPar` r) x = case (viewl l, viewl r) of+	(EmptyL, EmptyL) -> (pure x, pure x)+	(EmptyL, g :<| gs) -> (pure x, aps' g gs x)+	(f :<| fs, EmptyL) -> (aps' f fs x, pure x)+	(f :<| fs, g :<| gs@(unsafeCoerce -> gs'))+		| getTag f `sameTag` getTag g -> case f $$ x of+			Pure_ y -> fs `apsPar` gs' $ y+			t ::>>= k -> (t ::>>= k >< fs, t ::>>= k >< gs')+		| otherwise -> (aps' f fs x, aps' g gs x)++---------------------------------------------------------------------------+-- TAGGED+---------------------------------------------------------------------------++newtype Tagged s a = Tagged { unTagged :: Natural -> (a, Natural) }++instance Functor (Tagged s) where f `fmap` Tagged k = Tagged $ (f `first`) . k++instance Applicative (Tagged s) where+	pure = Tagged . (,)+	Tagged k <*> (flip (<$>) -> ax) =+		Tagged $ uncurry unTagged . (ax `first`) . k++instance Monad (Tagged s) where+	Tagged k >>= f = Tagged $ uncurry unTagged . (f `first`) . k++runTagged :: (forall s . Tagged s a) -> a+runTagged (Tagged k) = fst $ k 0++tag :: (Sequence sq, Funable f, Taggable f) =>+	Freer s sq f t a -> Tagged s (Freer s sq f t a)+tag m@(Pure_ _) = pure m+tag (t ::>>= k) = (t ::>>=) <$> ((<$> Tagged (Id &&& succ)) . putTag) `mapS` k

@@ -0,0 +1,25 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Monad.Freer.Par.FTCQueue (+	-- * FTCQueue+	FTCQueue ) where++import Control.Arrow ((>>>))+import Control.Monad.Freer.Par.Sequence (Sequence(..), ViewL(..))++---------------------------------------------------------------------------++data FTCQueue cat a b where+	Empty :: FTCQueue cat a a+	Node :: FTCQueue cat a b ->+		cat b c -> FTCQueue cat c d -> FTCQueue cat a d++instance Sequence FTCQueue where+	empty = Empty; singleton x = Node Empty x Empty+	(><) l = viewl >>> \case EmptyL -> l; x :<| r -> Node l x r+	viewl = \case Empty -> EmptyL; Node l x r -> vwl l x r++vwl :: FTCQueue cat a b -> cat b c -> FTCQueue cat c d -> ViewL FTCQueue cat a d+vwl Empty x r = x :<| r; vwl (Node ll x lr) y r = vwl ll x $ Node lr y r

@@ -0,0 +1,24 @@+{-# LANGUAGE KindSignatures #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Monad.Freer.Par.Funable (+	-- ** Funable+	Funable(..),+	-- ** Taggable+	Taggable(..), Tag(..), sameTag, Id ) where++import Control.Monad.Freer.Par.Internal.Id (Id)++---------------------------------------------------------------------------++class Funable f where+	fun :: (a -> m b) -> f m a b+	($$) :: Applicative m => f m a b -> a -> m b++class Taggable (t :: (* -> *) -> * -> * -> *) where+	getTag :: t m a b -> Tag; putTag :: t m a b -> Id -> t m a b++data Tag = NoTag | Tag Id deriving Show++sameTag :: Tag -> Tag -> Bool+l `sameTag` r | Tag i <- l, Tag j <- r = i == j | otherwise = False

@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Monad.Freer.Par.Internal.Id (+	-- * Id+	Id(..) ) where++import Numeric.Natural (Natural)++---------------------------------------------------------------------------++newtype Id = Id Natural deriving (Show, Eq)

@@ -0,0 +1,51 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Monad.Freer.Par.Sequence (+	-- * Sequence and ViewL+	Sequence(..), ViewL(..),+	-- * Combinator+	(<|), (|>), mapS ) where++import Control.Arrow ((>>>))++---------------------------------------------------------------------------++-- * SEQUENCE AND VIEWL+-- * COMBINATOR++---------------------------------------------------------------------------+-- SEQUENCE AND VIEWL+---------------------------------------------------------------------------++infixr 8 ><++class Sequence sq where+	empty :: sq cat a a; singleton :: cat a b -> sq cat a b+	(><) :: sq cat a b -> sq cat b c -> sq cat a c+	viewl :: sq cat a b -> ViewL sq cat a b++data ViewL sq cat a b where+	EmptyL :: ViewL sq cat a a+	(:<|) :: cat a x -> sq cat x b -> ViewL sq cat a b++---------------------------------------------------------------------------+-- COMBINATOR+---------------------------------------------------------------------------++infixr 8 <|++(<|) :: Sequence sq => cat a b -> sq cat b c -> sq cat a c+c <| s = singleton c >< s++infixl 8 |>++(|>) :: Sequence sq => sq cat a b -> cat b c -> sq cat a c+s |> c = s >< singleton c++mapS :: (Applicative f, Sequence sq) =>+	(forall x y . cat x y -> f (cat x y)) -> sq cat a b -> f (sq cat a b)+mapS f = viewl >>> \case+	EmptyL -> pure empty; c :<| s -> (<|) <$> f c <*> f `mapS` s

@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Monad.Freer.Par.TaggableFunction (+	-- * TaggableFun+	TaggableFun ) where++import Control.Monad.Freer.Par.Funable (Funable(..), Taggable(..), Tag(..))++---------------------------------------------------------------------------++data TaggableFun m a b = Fun { tag :: Tag, unFun :: a -> m b }++instance Funable TaggableFun where fun = Fun NoTag; ($$) = unFun+instance Taggable TaggableFun where putTag f i = f { tag = Tag i }; getTag = tag

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"