yaftee (empty) → 0.1.0.0

raw patch · 7 files changed

+197/−0 lines, 7 filesdep +basedep +ftcqueuedep +higher-order-freer-monadsetup-changed

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

Files

CHANGELOG.md +11/−0
LICENSE +26/−0
README.md +3/−0
Setup.hs +2/−0
src/Control/Monad/Yaftee/Eff.hs +91/−0
test/Spec.hs +2/−0
yaftee.cabal +62/−0

+ CHANGELOG.md view

@@ -0,0 +1,11 @@+# Changelog for `yaftee`++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,3 @@+# try-yaftee++see package yaftee-basic-monads and yaftee-conduit

+ Setup.hs view

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

+ src/Control/Monad/Yaftee/Eff.hs view

@@ -0,0 +1,91 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LAnGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Monad.Yaftee.Eff (++	-- * TYPE++	E,++	-- * INJECTION++	eff, effBase, effh,++	-- * PROJECTION++	run, runM, ++	-- * HANDLE RELAY++	handleRelay, handleRelayS, interpose++	) where++import Control.Monad.Fix+import Control.Monad.HigherFreer qualified as HFreer+import Control.HigherOpenUnion qualified as Union+import Data.HigherFunctor qualified as HFunctor+import Data.FTCQueue qualified as Q++type E effs = HFreer.H (Union.U effs)++eff :: Union.Member (Union.FromFirst t) effs => t a -> E effs i o a+eff = (HFreer.:>>= Q.singleton HFreer.Pure) . Union.inj++effBase :: Union.Base (Union.FromFirst t) effs => t a -> E effs i o a+effBase = (HFreer.:>>= Q.singleton HFreer.Pure) . Union.injBase++effh :: Union.Member h effs => h (E effs) i o a -> E effs i o a+effh = (HFreer.:>>= Q.singleton HFreer.Pure) . Union.injh++run :: E '[] i o a -> a+run (HFreer.Pure x) = x+run _ = error "bad"++runM :: Monad m => E '[Union.FromFirst m] i o a -> m a+runM (HFreer.Pure x) = pure x+runM (u HFreer.:>>= q) = runM . (q HFreer.$) =<< Union.extract u++handleRelay :: forall f t effs i o a .+	HFunctor.Loose (Union.U effs) =>+	(forall x . x -> f x) -> (forall x . f x -> x) ->+	(forall x i' o' y . t x -> (x -> E effs i' o' (f y)) -> E effs i' o' (f y)) ->+	E ((Union.FromFirst t) ': effs) i o a -> E effs i o (f a)+handleRelay mk gx h = fix \go -> \case+	HFreer.Pure x -> HFreer.Pure $ mk x+	u HFreer.:>>= q -> case Union.decomp u of+		Left u' -> HFunctor.map (handleRelay mk gx h) mk u' HFreer.:>>=+			Q.singleton \x -> go $ q HFreer.$ gx x+		Right (Union.FromFirst x k) -> h x ((go HFreer.. q) . k)++handleRelayS :: forall f s t effs i o a .+	HFunctor.Loose (Union.U effs) =>+	(forall x . s -> x -> f s x) ->+	(forall x . f s x -> s) -> (forall x . f s x -> x) ->+	(forall x i' o' y .+		t x -> (x -> s -> E effs i' o' y) -> s -> E effs i' o' y) ->+	E ((Union.FromFirst t) ': effs) i o a -> s -> E effs i o (f s a)+handleRelayS mk gs gx h m s0 = ($ m) . ($ s0) $ fix \go s -> \case+	HFreer.Pure x -> HFreer.Pure $ mk s x+	u HFreer.:>>= q -> case Union.decomp u of+		Left u' -> HFunctor.map+				(flip (handleRelayS mk gs gx h) s) (s `mk`) u'+			HFreer.:>>= Q.singleton \xs ->+				go (gs xs) $ q HFreer.$ gx xs+		Right (Union.FromFirst x k) ->+			h x (\x' s' -> (go s' HFreer.. q) . k $ x') s++interpose :: forall eff effs i o a b .+	Union.Member (Union.FromFirst eff) effs =>+	(a -> E effs i o b) ->+	(forall v . eff v -> (v -> E effs i o b) -> E effs i o b) -> E effs i o a -> E effs i o b+interpose ret h = fix \go -> \case+	HFreer.Pure x -> ret x+	u HFreer.:>>= q -> case Union.prj u of+		Just (Union.FromFirst x k) -> h x ((go HFreer.. q) . k)+		_ -> u HFreer.:>>= Q.singleton (go HFreer.. q)

+ test/Spec.hs view

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

+ yaftee.cabal view

@@ -0,0 +1,62 @@+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+version:        0.1.0.0+synopsis:       Yet Another heFTy-inspired Extensible Effect+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/yaftee#readme>+category:       Control+homepage:       https://github.com/YoshikuniJujo/yaftee#readme+bug-reports:    https://github.com/YoshikuniJujo/yaftee/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++library+  exposed-modules:+      Control.Monad.Yaftee.Eff+  other-modules:+      Paths_yaftee+  autogen-modules:+      Paths_yaftee+  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.*+  default-language: Haskell2010++test-suite yaftee-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_yaftee+  autogen-modules:+      Paths_yaftee+  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+  default-language: Haskell2010