packages feed

yaftee-basic-monads (empty) → 0.1.0.0

raw patch · 15 files changed

+990/−0 lines, 15 filesdep +basedep +ftcqueuedep +higher-order-freer-monadsetup-changed

Dependencies added: base, ftcqueue, higher-order-freer-monad, higher-order-open-union, yaftee, yaftee-basic-monads

Files

+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `yaftee-basic-monads`++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
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2025 Yoshikuni Jujo++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1.  Redistributions of source code must retain the above copyright notice, this+    list of conditions and the following disclaimer.++2.  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.++3.  Neither the name of the copyright holder nor the names of its 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 HOLDER 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.
+ README.md view
@@ -0,0 +1,278 @@+# yaftee-basic-monads++## Reader, Writer and State++### Reader++```Haskell:TryYaftee/Reader.hs+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module TryYaftee.Reader where++import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.Yaftee.Reader qualified as Reader+import Control.Monad.Yaftee.IO qualified as IO+import Control.HigherOpenUnion qualified as U++run :: Monad m => Eff.E '[Reader.R Int, U.FromFirst m] i o a -> m a+run = Eff.runM . (`Reader.run` 123)++sample :: (U.Member (Reader.R Int) es, U.Base IO.I es) => Eff.E es i o ()+sample = do+	e <- Reader.ask @Int+	IO.print e+	Reader.local @Int (* 2) do+		e' <- Reader.ask @Int+		IO.print e'+```++### Writer++```Haskell:TryYaftee/Writer.hs+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module TryYaftee.Writer where++import Control.Monad+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.Yaftee.Writer qualified as Writer+import Control.Monad.Yaftee.IO qualified as IO+import Control.HigherOpenUnion qualified as U++action :: IO ((), [String])+action = run @[String] getLines++run :: Monoid w => Eff.E '[Writer.W w, IO.I] i o r -> IO (r, w)+run = Eff.runM . Writer.run++getLines :: (U.Member (Writer.W [String]) es, U.Base IO.I es) => Eff.E es i o ()+getLines = IO.getLine >>= \ln ->+	when (not $ null ln) (Writer.tell [ln] >> getLines)+```++### State++```Haskell:TryYaftee/State.hs+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module TryYaftee.State where++import Control.Monad+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.Yaftee.Reader qualified as Reader+import Control.Monad.Yaftee.State qualified as State+import Control.HigherOpenUnion qualified as U++sample :: ((), Int)+sample = run @Int 3 5 $ increaseNTimes 7++run :: d -> a -> Eff.E '[Reader.R d, State.S a] i o r -> (r, a)+run d x0 = Eff.run . (`State.run` x0) . (`Reader.run` d)++increase ::+	(U.Member (Reader.R Int) es, U.Member (State.S Int) es) =>+	Eff.E es i o ()+increase = do+	d <- Reader.ask @Int+	State.modify (+ d)++increaseNTimes :: (U.Member (Reader.R Int) es, U.Member (State.S Int) es) =>+	Int -> Eff.E es i o ()+increaseNTimes n = replicateM_ n increase+```++## Except and Fail++### Except++```Haskell:TryYaftee/Except.hs+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module TryYaftee.State where++import Control.Monad+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.Yaftee.Reader qualified as Reader+import Control.Monad.Yaftee.State qualified as State+import Control.HigherOpenUnion qualified as U++sample :: ((), Int)+sample = run @Int 3 5 $ increaseNTimes 7++run :: d -> a -> Eff.E '[Reader.R d, State.S a] i o r -> (r, a)+run d x0 = Eff.run . (`State.run` x0) . (`Reader.run` d)++increase ::+	(U.Member (Reader.R Int) es, U.Member (State.S Int) es) =>+	Eff.E es i o ()+increase = do+	d <- Reader.ask @Int+	State.modify (+ d)++increaseNTimes :: (U.Member (Reader.R Int) es, U.Member (State.S Int) es) =>+	Int -> Eff.E es i o ()+increaseNTimes n = replicateM_ n increase+```++### Fail++```Haskell:TryYaftee/Fail.hs+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIOnS_GHC -Wall -fno-warn-tabs #-}++module TryYaftee.Fail where++import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.Yaftee.Except qualified as Except+import Control.Monad.Yaftee.Fail qualified as Fail+import Control.Monad.Yaftee.IO qualified as IO+import Control.HigherOpenUnion qualified as U+import Control.Exception++run :: Monad m => Eff.E '[Fail.F, U.FromFirst m] i o a -> m (Either String a)+run = Eff.runM . Fail.run++runIO :: Eff.E '[Fail.F, Except.E ErrorCall, IO.I] i o a -> IO a+runIO = Eff.runM+	. Except.runIO . Fail.runExc ErrorCall (\(ErrorCall str) -> str)++sample0 :: MonadFail m => m ()+sample0 = do+	fail "foobar"++catch :: (U.Member Fail.F es, U.Base IO.I es) =>+	Eff.E es i o () -> Eff.E es i o ()+catch = (`Fail.catch` \msg -> IO.putStrLn $ "FAIL OCCUR: " ++ msg)+```++## NonDet++```Haskell:TryYaftee/NonDet.hs+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module TryYaftee.NonDet where++import Control.Applicative+import Control.Monad+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.Yaftee.NonDet qualified as NonDet++run :: (Traversable f, MonadPlus f) => Eff.E '[NonDet.N] i o r -> f r+run = Eff.run . NonDet.run++foo :: Alternative f => f Int+foo = pure 123++bar :: Alternative f => f Int+bar = empty++foobar :: Alternative f => f Int+foobar = foo <|> bar+```++## Base Monad++### IO++### ST++```Haskell:TryYaftee/ST.hs+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications, RankNTypes #-}+{-# LANGUAGE RequiredTypeArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module TryYaftee.ST where++import Control.Monad+import Control.Monad.ST+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.Yaftee.Reader qualified as Reader+import Control.Monad.Yaftee.ST qualified as ST+import Control.HigherOpenUnion qualified as U+import Data.STRef++run :: Eff.E '[Reader.R a, ST.S s] i o r -> a -> ST s r+run m d = Eff.runM $ Reader.run m d++increase :: (U.Member (Reader.R Int) es, U.Base (ST.S s) es) =>+	STRef s Int -> Eff.E es i o ()+increase r = do+	d <- Reader.ask+	ST.modifyRef' r (+ d)++increaseNTimes :: forall s ->+	(U.Member (Reader.R Int) es, U.Base (ST.S s) es) =>+	Int -> Int -> Eff.E es i o Int+increaseNTimes s n x0 = do+	r <- ST.newRef @s x0+	replicateM_ n (increase r)+	ST.readRef r++sample :: forall s . ST s Int+sample = run @Int (increaseNTimes s 3 5) 2+```++## Trace++```Haskell:TryYaftee/Trace.hs+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications, RankNTypes #-}+{-# LANGUAGE RequiredTypeArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module TryYaftee.ST where++import Control.Monad+import Control.Monad.ST+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.Yaftee.Reader qualified as Reader+import Control.Monad.Yaftee.ST qualified as ST+import Control.HigherOpenUnion qualified as U+import Data.STRef++run :: Eff.E '[Reader.R a, ST.S s] i o r -> a -> ST s r+run m d = Eff.runM $ Reader.run m d++increase :: (U.Member (Reader.R Int) es, U.Base (ST.S s) es) =>+	STRef s Int -> Eff.E es i o ()+increase r = do+	d <- Reader.ask+	ST.modifyRef' r (+ d)++increaseNTimes :: forall s ->+	(U.Member (Reader.R Int) es, U.Base (ST.S s) es) =>+	Int -> Int -> Eff.E es i o Int+increaseNTimes s n x0 = do+	r <- ST.newRef @s x0+	replicateM_ n (increase r)+	ST.readRef r++sample :: forall s . ST s Int+sample = run @Int (increaseNTimes s 3 5) 2+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Control/Monad/Yaftee/Except.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ExplicitForAll, TypeApplications #-}+{-# LANGUAGE RequiredTypeArguments #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Monad.Yaftee.Except (++-- * NORMAL++E, throw, catch, run, runExc, runIO, fromIO,++-- * NAMED++Named, throwN, catchN, runN, runExcN, runION, fromION,++-- * TOOLS++fromJust, getLeft, getRight++) where++import GHC.TypeLits+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.Yaftee.IO qualified as IO+import Control.Monad.HigherFreer qualified as F+import Control.HigherOpenUnion qualified as Union+import Control.Exception qualified as IO+import Data.Kind+import Data.Functor.Identity+import Data.HigherFunctor qualified as HFunctor+import Data.FTCQueue qualified as Q++-- * NORMAL++type E = Named ""++throw :: Union.Member (E e) effs => e -> Eff.E effs i o a+throw = throwN ""++catch :: Union.Member (E e) effs =>+	Eff.E effs i o a -> (e -> Eff.E effs i o a) -> Eff.E effs i o a+catch = catchN ""++run :: forall e effs i o a . HFunctor.Loose (Union.U effs) =>+	Eff.E (E e ': effs) i o a -> Eff.E effs i o (Either e a)+run = runN++runExc :: forall e e' effs i o a .+	(HFunctor.Loose (Union.U effs), Union.Member (E e') effs) =>+	(e -> e') -> (e' -> e) -> Eff.E (E e ': effs) i o a -> Eff.E effs i o a+runExc = runExcN ""++runIO :: IO.Exception e => Eff.E '[E e, IO.I] i o a -> Eff.E '[IO.I] i o a+runIO = runION++fromIO :: forall e ->+	(IO.Exception e, Union.Member (E e) es, Union.Base IO.I es) =>+	IO a -> Eff.E es i o a+fromIO e = fromION "" e++-- * NAMED++data Named (nm :: Symbol) e (f :: Type -> Type -> Type -> Type) i o a where+	Throw :: forall nm e f a i o . e -> Named nm e f i o a+	Catch :: forall nm e f a i o .+		f i o a -> (e -> f i o a) -> Named nm e f i o a++instance HFunctor.Tight (Named nm e) where+	mapT _ _ (Throw e) = Throw e+	mapT f _ (m `Catch` h) = (f m) `Catch` \e -> f $ h e++instance HFunctor.Loose (Named nm e)++throwN :: forall nm -> Union.Member (Named nm e) effs => e -> Eff.E effs i o a+throwN nm = Eff.effh . Throw @nm++catchN :: forall nm -> Union.Member (Named nm e) effs =>+	Eff.E effs i o a -> (e -> Eff.E effs i o a) -> Eff.E effs i o a+catchN nm = (Eff.effh .) . Catch @nm++runN :: forall nm e effs i o a . HFunctor.Loose (Union.U effs) =>+	Eff.E (Named nm e ': effs) i o a -> Eff.E effs i o (Either e a)+runN = \case+	F.Pure x -> F.Pure $ Right x+	u F.:>>= q -> case Union.decomp u of+		Left u' -> HFunctor.map runN Right u' F.:>>=+			Q.singleton (either (F.Pure . Left) (runN F.. q))+		Right (Throw e) -> F.Pure $ Left e+		Right (m `Catch` h) -> either (F.Pure . Left) (runN F.. q)+			=<< either (runN . h) (F.Pure . Right) =<< runN m++runExcN :: forall nm e e' effs i o a . forall nm' ->+	(HFunctor.Loose (Union.U effs), Union.Member (Named nm' e') effs) =>+	(e -> e') -> (e' -> e) ->+	Eff.E (Named nm e ': effs) i o a -> Eff.E effs i o a+runExcN nm' c c' = \case+	F.Pure x -> F.Pure x+	u F.:>>= q -> case Union.decomp u of+		Left u' -> HFunctor.map ((Identity <$>) . runExcN nm' c c')+				Identity u' F.:>>=+			Q.singleton ((runExcN nm' c c' F.. q) . runIdentity)+		Right (Throw e) -> throwN nm' $ c e+		Right (m `Catch` h) -> runExcN nm' c c' F.. q =<< catchN nm'+			(runExcN nm' c c' m) (runExcN nm' c c' . h . c')++runION :: IO.Exception e =>+	Eff.E '[Named nm e, IO.I] i o a -> Eff.E '[IO.I] i o a+runION = \case+	F.Pure x -> F.Pure x+	u F.:>>= q -> case Union.decomp u of+		Left u' -> HFunctor.map ((Identity <$>) . runION) Identity u'+			F.:>>= Q.singleton ((runION F.. q) . runIdentity)+		Right (Throw e) -> Eff.effBase $ IO.throwIO e+		Right (m `Catch` h) ->+			runION F.. q =<< runION m `cch` (runION . h)+	where m `cch` h = Eff.effBase $ Eff.runM m `IO.catch` (Eff.runM . h)++fromJust :: Union.Member (E e) es => e -> Maybe a -> Eff.E es i o a+fromJust e = \case Nothing -> throw e; Just x -> pure x++getLeft :: Union.Member (E e) es => e -> Either a b -> Eff.E es i o a+getLeft e = \case Left r -> pure r; Right _ -> throw e++getRight :: Union.Member (E e) es => e -> Either a b -> Eff.E es i o b+getRight e = \case Left _ -> throw e; Right r -> pure r++fromION :: forall (nm :: Symbol) -> forall e ->+	(IO.Exception e, Union.Member (Named nm e) es, Union.Base IO.I es) =>+	IO r -> Eff.E es i o r+fromION nm e act = either (throwN nm) pure =<< Eff.effBase (IO.try @e act)
+ src/Control/Monad/Yaftee/Fail.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE RequiredTypeArguments #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Monad.Yaftee.Fail (+	F, run, catch, runExc, runExcN) where++import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.Yaftee.Except qualified as Except+import Control.Monad.HigherFreer qualified as F+import Control.HigherOpenUnion qualified as U+import Data.Functor.Identity+import Data.HigherFunctor qualified as HFunctor+import Data.FTCQueue qualified as Q++type F = U.Fail++run :: HFunctor.Loose (U.U effs) =>+	Eff.E (F ': effs) i o a -> Eff.E effs i o (Either String a)+run = \case+	F.Pure x -> F.Pure $ Right x+	u F.:>>= q -> case U.decomp u of+		Left u' -> HFunctor.map run Right u' F.:>>=+			Q.singleton (either (F.Pure . Left) (run F.. q))+		Right (U.Fail m) -> F.Pure $ Left m+		Right (m `U.FailCatch` h) -> either (F.Pure . Left) (run F.. q)+			=<< either (run . h) (F.Pure . Right) =<< run m++catch :: U.Member F effs =>+	Eff.E effs i o a -> (String -> Eff.E effs i o a) -> Eff.E effs i o a+catch = (Eff.effh .) . U.FailCatch++runExc :: (HFunctor.Loose (U.U effs), U.Member (Except.E e) effs) =>+	(String -> e) -> (e -> String) -> Eff.E (F ': effs) i o a -> Eff.E effs i o a+runExc = runExcN ""++runExcN :: forall e effs i o a . forall nm -> (+	HFunctor.Loose (U.U effs),+	U.Member (Except.Named nm e) effs ) =>+	(String -> e) -> (e -> String) -> Eff.E (F ': effs) i o a -> Eff.E effs i o a+runExcN nm err err' = \case+	F.Pure x -> F.Pure x+	u F.:>>= q -> case U.decomp u of+		Left u' -> HFunctor.map ((Identity <$>) . runExcN nm err err')+				Identity u' F.:>>=+			Q.singleton (runExcN nm err err' . (q F.$) . runIdentity)+		Right (U.Fail m) -> Except.throwN nm $ err m+		Right (m `U.FailCatch` h) ->+			runExcN nm err err' F.. q =<< Except.catchN nm+				(runExcN nm err err' m) (runExcN nm err err' . h . err')
+ src/Control/Monad/Yaftee/IO.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE FlexibleContexts #-}++module Control.Monad.Yaftee.IO (++-- * TYPE++I,++-- * STANDARD INPUT/OUTPUT++putChar, putStr, putStrLn, print, getChar, getLine,++-- * HANDLE++hPutChar, hPutStr, hPutStrLn, hPrint, hGetChar, hGetLine++) where++import Prelude ((.), Show, IO, String, Char)+import Prelude qualified as P+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.HigherOpenUnion qualified as Union+import System.IO (Handle)+import System.IO qualified as SIO++-- * TYPE++type I = Union.FromFirst IO++-- * STANDARD INPUT/OUTPUT++putChar :: Union.Base I effs => Char -> Eff.E effs i o ()+putChar = Eff.effBase . P.putChar++putStr, putStrLn :: Union.Base I effs => String -> Eff.E effs i o ()+putStr = Eff.effBase . P.putStr+putStrLn = Eff.effBase . P.putStrLn++print :: (Show a, Union.Base I effs) => a -> Eff.E effs i o ()+print = Eff.effBase . P.print++getChar :: Union.Base I effs => Eff.E effs i o Char+getChar = Eff.effBase P.getChar++getLine :: Union.Base I effs => Eff.E effs i o String+getLine = Eff.effBase P.getLine++-- * HANDLE++hPutChar :: Union.Base I effs => Handle -> Char -> Eff.E effs i o ()+hPutChar = (Eff.effBase .) . SIO.hPutChar++hPutStr, hPutStrLn :: Union.Base I effs => Handle -> String -> Eff.E effs i o ()+hPutStr = (Eff.effBase .) . SIO.hPutStr+hPutStrLn = (Eff.effBase .) . SIO.hPutStrLn++hPrint :: (Show a, Union.Base I effs) => Handle -> a -> Eff.E effs i o ()+hPrint = (Eff.effBase .) . SIO.hPrint++hGetChar :: Union.Base I effs => Handle -> Eff.E effs i o Char+hGetChar = Eff.effBase . SIO.hGetChar++hGetLine :: Union.Base I effs => Handle -> Eff.E effs i o String+hGetLine = Eff.effBase . SIO.hGetLine
+ src/Control/Monad/Yaftee/NonDet.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Monad.Yaftee.NonDet (N, run) where++import Control.Applicative+import Control.Monad+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.HigherFreer qualified as F+import Control.HigherOpenUnion qualified as Union+import Data.HigherFunctor qualified as HFunctor+import Data.FTCQueue qualified as Q++type N = Union.FromFirst Union.NonDet++run :: forall f effs i o a .+	(HFunctor.Loose (Union.U effs), Traversable f, MonadPlus f) =>+	Eff.E (N ': effs) i o a -> Eff.E effs i o (f a)+run = \case+	F.Pure x -> F.Pure $ pure x+	u F.:>>= q -> case Union.decomp u of+		Left u' -> HFunctor.map run pure u' F.:>>=+			Q.singleton ((join <$>) . ((run . (q F.$)) `traverse`))+		Right (Union.FromFirst Union.MZero _) -> pure empty+		Right (Union.FromFirst Union.MPlus k) ->+			(<|>) <$> run (q F.$ k False) <*> run (q F.$ k True)
+ src/Control/Monad/Yaftee/Reader.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE RequiredTypeArguments #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Monad.Yaftee.Reader (++	-- * NORMAL++	R, ask, local, run,++	-- * NAMED++	Named, askN, localN, runN++	) where++import GHC.TypeLits+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.HigherFreer qualified as F+import Control.HigherOpenUnion qualified as Union+import Data.Kind+import Data.Functor.Identity+import Data.HigherFunctor qualified as HFunctor+import Data.FTCQueue qualified as Q++-- * NORMAL++type R e = Named "" e++ask :: Union.Member (R e) effs => Eff.E effs i o e+ask = askN ""++local :: forall e effs i o a . Union.Member (R e) effs =>+	(e -> e) -> Eff.E effs i o a -> Eff.E effs i o a+local = localN ""++run :: forall e effs i o a . HFunctor.Loose (Union.U effs) =>+	Eff.E (R e ': effs) i o a -> e -> Eff.E effs  i o a+run = runN++-- * NAMED++data Named (nm :: Symbol) e (f :: Type -> Type -> Type -> Type) i o a where+	Ask :: forall nm e f i o . Named nm e f i o e+	Local :: forall nm e f i o a . (e -> e) -> f i o a -> Named nm e f i o a++askN :: forall nm -> Union.Member (Named nm e) effs => Eff.E effs i o e+askN nm = Eff.effh (Ask @nm)++localN :: forall nm -> Union.Member (Named nm e) effs =>+	(e -> e) -> Eff.E effs i o a -> Eff.E effs i o a+localN nm = (Eff.effh .) . Local @nm++runN :: forall nm e effs i o a . HFunctor.Loose (Union.U effs) =>+	Eff.E (Named nm e ': effs) i o a -> e -> Eff.E effs i o a+m `runN` e = case m of+	F.Pure x -> F.Pure x+	u F.:>>= q -> case Union.decomp u of+		Left u' -> HFunctor.map ((Identity <$>) . (`runN` e)) Identity u' F.:>>=+			Q.singleton (((`runN` e) F.. q) . runIdentity)+		Right Ask -> (q F.$ e) `runN` e+		Right (Local f a) ->  (`runN` e) F.. q =<< a `runN` f e
+ src/Control/Monad/Yaftee/ST.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Monad.Yaftee.ST (++	-- * TYPE++	S,++	-- * REF++	newRef, readRef, writeRef, modifyRef, modifyRef',++	) where++import Prelude hiding (read)+import Control.Monad.ST qualified as ST+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.HigherOpenUnion qualified as Union+import Data.STRef qualified as ST++type (S s) = Union.FromFirst (ST.ST s)++newRef :: forall s effs i o a .+	Union.Base (S s) effs => a -> Eff.E effs i o (ST.STRef s a)+newRef = Eff.effBase . ST.newSTRef++readRef :: forall s effs i o a .+	Union.Base (S s) effs => ST.STRef s a -> Eff.E effs i o a+readRef = Eff.effBase . ST.readSTRef++writeRef :: forall s effs i o a .+	Union.Base (S s) effs => ST.STRef s a -> a -> Eff.E effs i o ()+writeRef = (Eff.effBase .) . ST.writeSTRef++modifyRef, modifyRef' :: forall s effs i o a .+	Union.Base (S s) effs => ST.STRef s a -> (a -> a) -> Eff.E effs i o ()+modifyRef = (Eff.effBase .) . ST.modifySTRef+modifyRef' = (Eff.effBase .) . ST.modifySTRef'
+ src/Control/Monad/Yaftee/State.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-}+{-# LANGUAGE ExplicitForAll, TypeApplications #-}+{-# LANGUAGE RequiredTypeArguments #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Monad.Yaftee.State (++-- * NORMAL++S, get, gets, put, modify, modify', getsModify, run,++-- * NAMED++Named, getN, getsN, putN, modifyN, modifyN', getsModifyN, runN++) where++import GHC.TypeLits+import Control.Monad+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.HigherOpenUnion qualified as Union+import Data.HigherFunctor qualified as HFunctor++-- * NORMAL++type S s = Named "" s++get :: Union.Member (S s) effs => Eff.E effs i o s+get = getN ""++gets :: Union.Member (S s) effs => (s -> a) -> Eff.E effs i o a+gets = getsN ""++put :: Union.Member (S s) effs => s -> Eff.E effs i o ()+put = putN ""++modify, modify' :: Union.Member (S s) effs => (s -> s) -> Eff.E effs i o ()+modify = modifyN ""+modify' = modifyN' ""++getsModify :: Union.Member (S s) effs =>+	(s -> Maybe (a, s)) -> Eff.E effs i o (Maybe a)+getsModify = getsModifyN ""++run :: HFunctor.Loose (Union.U effs) =>+	Eff.E (S s ': effs) i o a -> s -> Eff.E effs i o (a, s)+run = runN++-- * NAMED++type Named nm s = Union.FromFirst (Named_ nm s)++data Named_ (nm :: Symbol) s a where+	Get :: Named_ nm s s; Put :: forall nm s . !s -> Named_ nm s ()+	Modify :: forall nm s . (s -> s) -> Named_ nm s ()+	GetsModify :: forall nm s a . (s -> Maybe (a, s)) -> Named_ nm s (Maybe a)++getN :: forall s effs i o .+	forall nm -> Union.Member (Named nm s) effs => Eff.E effs i o s+getN nm = Eff.eff (Get @nm)++getsN :: forall s effs i o a . forall nm ->+	Union.Member (Named nm s) effs => (s -> a) -> Eff.E effs i o a+getsN nm f = f <$> getN nm++putN :: forall s effs i o . forall nm ->+	Union.Member (Named nm s) effs => s -> Eff.E effs i o ()+putN nm = Eff.eff . Put @nm++{-+modifyN :: forall nm -> Union.Member (Named nm s) effs =>+	(s -> s) -> Eff.E effs i o ()+modifyN nm = Eff.eff . Modify @nm+-}++modifyN :: forall nm -> Union.Member (Named nm s) effs =>+	(s -> s) -> Eff.E effs i o ()+modifyN nm f = void $ getsModifyN nm (Just . (() ,) . f)++modifyN' :: forall nm -> Union.Member (Named nm s) effs =>+	(s -> s) -> Eff.E effs i o ()+modifyN' nm f = putN nm . f =<< getN nm++getsModifyN :: forall nm -> Union.Member (Named nm s) effs =>+	(s -> Maybe (a, s)) -> Eff.E effs i o (Maybe a)+getsModifyN nm = Eff.eff . GetsModify @nm++runN :: forall nm effs s i o a .+	HFunctor.Loose (Union.U effs) =>+	Eff.E (Named nm s ': effs) i o a -> s -> Eff.E effs i o (a, s)+runN = ((uncurry (flip (,)) <$>) .) .  Eff.handleRelayS (,) fst snd \st k s ->+	case st of+		Get -> k s $! s; Put s' -> k () s'; Modify f -> k () $! (f $! s)+		GetsModify f -> case f s of+			Nothing -> k Nothing s+			Just (x, s') -> k (Just x) s'
+ src/Control/Monad/Yaftee/Trace.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++{-# LANGUAGE TypeOperators #-}++module Control.Monad.Yaftee.Trace (T, trace, run, runIO, ignore) where++import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.Yaftee.IO qualified as IO+import Control.Monad.HigherFreer qualified as HFreer+import Control.HigherOpenUnion qualified as Union++import Control.Monad.HigherFreer qualified as F+import Data.HigherFunctor qualified as HFunctor+import Data.FTCQueue qualified as Q+import Data.Functor.Identity++type T = Union.FromFirst T_+data T_ a where T_ :: String -> T_ ()++trace :: Union.Member T effs => String -> Eff.E effs i o ()+trace = Eff.eff . T_++run :: Eff.E '[T] i o a -> IO a+run = \case+	HFreer.Pure x -> pure x+	u HFreer.:>>= q -> case Union.extracth u of+		Union.FromFirst (T_ s) k -> putStrLn s >> run (q HFreer.$ k ())++runIO :: (HFunctor.Loose (Union.U es), Union.Base IO.I es) =>+	Eff.E (T ': es) i o r -> Eff.E es i o r+runIO = \case+	HFreer.Pure x -> HFreer.Pure x+	u F.:>>= q -> case Union.decomp u of+		Left u' -> HFunctor.map ((Identity <$>) . runIO) Identity u'+			F.:>>= Q.singleton ((runIO F.. q) . runIdentity)+		Right (Union.FromFirst (T_ tr) k) -> do+			IO.putStrLn tr+			runIO HFreer.. q $ k ()++ignore ::+	HFunctor.Loose (Union.U es) =>+	Eff.E (T ': es) i o r -> Eff.E es i o r+ignore = \case+	HFreer.Pure x -> HFreer.Pure x+	u F.:>>= q -> case Union.decomp u of+		Left u' -> HFunctor.map ((Identity <$>) . ignore) Identity u'+			F.:>>= Q.singleton ((ignore F.. q) . runIdentity)+		Right (Union.FromFirst (T_ _) k) -> ignore HFreer.. q $ k ()
+ src/Control/Monad/Yaftee/Writer.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, TupleSections #-}+{-# LANGUAGE ExplicitForAll, TypeApplications #-}+{-# LANGUAGE RequiredTypeArguments #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Monad.Yaftee.Writer (++	-- * NORMAL+	+	W, tell, run,++	-- * NAMED++	Named, tellN, runN++	) where++import GHC.TypeLits+import Control.Arrow+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.HigherOpenUnion qualified as Union+import Data.HigherFunctor qualified as HFunctor++-- * NORMAL++type W w = Named "" w++tell :: Union.Member (W w) effs => w -> Eff.E effs i o ()+tell = tellN ""++run :: (Monoid w, HFunctor.Loose (Union.U effs)) =>+	Eff.E (W w ': effs) i o a -> Eff.E effs i o (a, w)+run = runN++-- * NAMED++type Named nm w = Union.FromFirst (Named_ nm w)+data Named_ (nm :: Symbol) w a where TellN :: forall nm w . w -> Named_ nm w ()++tellN :: forall nm -> Union.Member (Named nm w) effs => w -> Eff.E effs i o ()+tellN nm = Eff.eff . TellN @nm++runN :: forall nm w effs i o a . (Monoid w, HFunctor.Loose (Union.U effs)) =>+	Eff.E (Named nm w ': effs) i o a -> Eff.E effs i o (a, w)+runN = (uncurry (flip (,)) <$>)+	. Eff.handleRelay (mempty ,) snd \(TellN w) k -> ((w <>) `first`) <$> k ()
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"
+ yaftee-basic-monads.cabal view
@@ -0,0 +1,72 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.38.1.+--+-- see: https://github.com/sol/hpack++name:           yaftee-basic-monads+version:        0.1.0.0+synopsis:       Basic monads implemented on Yaftee+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/yaftee-basic-monads#readme>+category:       Category+homepage:       https://github.com/YoshikuniJujo/yaftee-basic-monads#readme+bug-reports:    https://github.com/YoshikuniJujo/yaftee-basic-monads/issues+author:         Yoshikuni Jujo+maintainer:     yoshikuni.jujo@gmail.com+copyright:      Copyright (c) 2025 Yoshikuni Jujo+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+extra-doc-files:+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/YoshikuniJujo/yaftee-basic-monads++library+  exposed-modules:+      Control.Monad.Yaftee.Except+      Control.Monad.Yaftee.Fail+      Control.Monad.Yaftee.IO+      Control.Monad.Yaftee.NonDet+      Control.Monad.Yaftee.Reader+      Control.Monad.Yaftee.ST+      Control.Monad.Yaftee.State+      Control.Monad.Yaftee.Trace+      Control.Monad.Yaftee.Writer+  other-modules:+      Paths_yaftee_basic_monads+  autogen-modules:+      Paths_yaftee_basic_monads+  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+    , ftcqueue ==0.1.*+    , higher-order-freer-monad ==0.1.*+    , higher-order-open-union ==0.1.*+    , yaftee ==0.1.*+  default-language: Haskell2010++test-suite yaftee-basic-monads-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_yaftee_basic_monads+  autogen-modules:+      Paths_yaftee_basic_monads+  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+    , ftcqueue ==0.1.*+    , higher-order-freer-monad ==0.1.*+    , higher-order-open-union ==0.1.*+    , yaftee ==0.1.*+    , yaftee-basic-monads+  default-language: Haskell2010