[add] NonDet example.

[fix] Improve performance of the streaming.

README.md

@@ -238,6 +238,72 @@ End
 
 The complete code example can be found at [heftia-effects/Example/Stream/Main.hs](https://github.com/sayo-hs/heftia/blob/v0.5.0/heftia-effects/Example/Stream/Main.hs).
 
+### Aggregating File Sizes Using Non-Deterministic Computation
+
+The following is an extract of the main parts from an example of non-deterministic computation. For the full code, please refer to [heftia-effects/Example/NonDet/Main.hs](https://github.com/sayo-hs/heftia/blob/v0.5.0/heftia-effects/Example/NonDet/Main.hs).
+
+```haskell
+-- | Aggregate the sizes of all files under the given path
+totalFileSize
+    :: (Choose <| ef, Empty <| ef, FileSystem <| ef, Throw NotADir <| ef, IO <| ef)
+    => FilePath
+    -> Eff '[] ef (Sum Integer)
+totalFileSize path = do
+    entities :: [FilePath] <- listDirectory path & joinEither
+    entity :: FilePath <- choice entities -- Non-deterministically "pick" one item from the list
+    let path' = path </> entity
+
+    liftIO $ putStrLn $ "Found " <> path'
+
+    getFileSize path' >>= \case
+        Right size -> pure $ Sum size
+        Left NotAFile -> do
+            totalFileSize path'
+
+main :: IO ()
+main = runEff
+    . runThrowIO @EntryNotFound
+    . runThrowIO @NotADir
+    . runDummyFS exampleRoot
+    $ do
+        total <- runNonDetMonoid pure (totalFileSize ".")
+        liftIO $ print total
+
+-- | Effect for file system operations
+data FileSystem a where
+    ListDirectory :: FilePath -> FileSystem (Either NotADir [FilePath])
+    GetFileSize :: FilePath -> FileSystem (Either NotAFile Integer)
+
+{- |
+Interpreter for the FileSystem effect that virtualizes the file system in memory
+based on a given FSTree, instead of performing actual IO.
+-}
+runDummyFS
+    :: (Throw EntryNotFound <| ef, Throw NotADir <| ef)
+    => FSTree
+    -> Eff eh (FileSystem ': ef) ~> Eff eh ef
+runDummyFS root = interpret \case
+    ListDirectory path ->
+        lookupFS path root <&> \case
+            Dir entries -> Right $ Map.keys entries
+            File _ -> Left NotADir
+    GetFileSize path ->
+        lookupFS path root <&> \case
+            File size -> Right size
+            Dir _ -> Left NotAFile
+```
+
+```
+>>> main
+Found ./README.md
+Found ./src
+Found ./src/Bar.hs
+Found ./src/Foo.hs
+Found ./test
+Found ./test/Baz.hs
+Sum {getSum = 10000}
+```
+
 ## Documentation
 A detailed explanation of usage and semantics is available in [Haddock](https://hackage.haskell.org/package/heftia-0.4.0.0/docs/Control-Monad-Hefty.html).
 The example codes are located in the [heftia-effects/Example/](https://github.com/sayo-hs/heftia/tree/v0.5.0/heftia-effects/Example) directory.

heftia-effects/Example/NonDet/Main.hs

@@ -0,0 +1,153 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
+
+-- SPDX-License-Identifier: MPL-2.0
+
+module Main where
+
+import Control.Monad.Hefty (
+    Eff,
+    interpret,
+    liftIO,
+    makeEffectF,
+    runEff,
+    (&),
+    type (<:),
+    type (<|),
+    type (~>),
+ )
+import Control.Monad.Hefty.Except (Throw, joinEither, runThrowIO, throw)
+import Control.Monad.Hefty.NonDet (Choose, Empty, choice, runNonDetMonoid)
+import Data.Function (fix)
+import Data.Functor ((<&>))
+import Data.Map (Map)
+import Data.Map qualified as Map
+import Data.Monoid (Sum (Sum))
+import System.FilePath (splitDirectories, (</>))
+import UnliftIO (Exception)
+
+-- | Effect for file system operations
+data FileSystem a where
+    ListDirectory :: FilePath -> FileSystem (Either NotADir [FilePath])
+    GetFileSize :: FilePath -> FileSystem (Either NotAFile Integer)
+
+-- | Exception for when a directory was expected but found a file
+data NotAFile = NotAFile
+
+-- | Exception for when a file was expected but found a directory
+data NotADir = NotADir
+    deriving (Show)
+    deriving anyclass (Exception)
+
+makeEffectF [''FileSystem]
+
+-- | Exception for when an entry does not exist at the specified path
+data EntryNotFound = EntryNotFound
+    deriving (Show)
+    deriving anyclass (Exception)
+
+-- | Aggregate the sizes of all files under the given path
+totalFileSize
+    :: (Choose <| ef, Empty <| ef, FileSystem <| ef, Throw NotADir <| ef, IO <| ef)
+    => FilePath
+    -> Eff '[] ef (Sum Integer)
+totalFileSize path = do
+    entities :: [FilePath] <- listDirectory path & joinEither
+    entity :: FilePath <- choice entities -- Non-deterministically "pick" one item from the list
+    let path' = path </> entity
+
+    liftIO $ putStrLn $ "Found " <> path'
+
+    getFileSize path' >>= \case
+        Right size -> pure $ Sum size
+        Left NotAFile -> do
+            totalFileSize path'
+
+main :: IO ()
+main = runEff
+    . runThrowIO @EntryNotFound
+    . runThrowIO @NotADir
+    . runDummyFS exampleRoot
+    $ do
+        total <- runNonDetMonoid pure (totalFileSize ".")
+        liftIO $ print total
+
+{-
+>>> main
+Found ./README.md
+Found ./src
+Found ./src/Bar.hs
+Found ./src/Foo.hs
+Found ./test
+Found ./test/Baz.hs
+Sum {getSum = 10000}
+-}
+
+-- | Example directory structure used this time
+exampleRoot :: FSTree
+exampleRoot =
+    dir
+        [
+            ( "."
+            , dir
+                [
+                    ( "src"
+                    , dir
+                        [ ("Bar.hs", File 1000)
+                        , ("Foo.hs", File 2000)
+                        ]
+                    )
+                ,
+                    ( "test"
+                    , dir
+                        [ ("Baz.hs", File 3000)
+                        ]
+                    )
+                , ("README.md", File 4000)
+                ]
+            )
+        ]
+  where
+    dir :: [(FilePath, FSTree)] -> FSTree
+    dir = Dir . Map.fromList
+
+-- | Directory structure
+data FSTree
+    = Dir {entries :: Map FilePath FSTree}
+    | File {fileSize :: Integer}
+
+{- |
+Interpreter for the FileSystem effect that virtualizes the file system in memory
+based on a given FSTree, instead of performing actual IO.
+-}
+runDummyFS
+    :: (Throw EntryNotFound <| ef, Throw NotADir <| ef)
+    => FSTree
+    -> Eff eh (FileSystem ': ef) ~> Eff eh ef
+runDummyFS root = interpret \case
+    ListDirectory path ->
+        lookupFS path root <&> \case
+            Dir entries -> Right $ Map.keys entries
+            File _ -> Left NotADir
+    GetFileSize path ->
+        lookupFS path root <&> \case
+            File size -> Right size
+            Dir _ -> Left NotAFile
+
+-- | Lookup the directory structure by path
+lookupFS
+    :: (Throw EntryNotFound <: m, Throw NotADir <: m, Monad m)
+    => FilePath
+    -> FSTree
+    -> m FSTree
+lookupFS path =
+    splitDirectories path & fix \dive -> \case
+        [] -> pure
+        dirName : restPath -> \case
+            Dir currentDir -> do
+                case currentDir Map.!? dirName of
+                    Just restTree -> dive restPath restTree
+                    Nothing -> throw EntryNotFound
+            File _ -> throw NotADir

heftia-effects/heftia-effects.cabal

@@ -243,6 +243,16 @@ executable Stream
     build-depends:
         heftia-effects,
 
+executable NonDet
+    import: common-base
+
+    main-is: Main.hs
+    hs-source-dirs: Example/NonDet
+    build-depends:
+        heftia-effects,
+        text,
+        filepath,
+
 benchmark heftia-bench
     import: common-base
 

heftia-effects/src/Control/Monad/Hefty/Concurrent/Stream.hs

@@ -27,6 +27,7 @@ import Control.Monad.Hefty (
     (&),
     type (<<|),
     type (<|),
+    type (~>),
  )
 import Control.Monad.Hefty.Concurrent.Parallel (Parallel, liftP2)
 import Control.Monad.Hefty.Input
@@ -49,8 +50,15 @@ import UnliftIO (
 import UnliftIO.Concurrent (forkIO, killThread)
 
 data Machinery eh ef ans i o where
-    Unit :: forall i o ans eh ef. Eff eh (Input i ': Output o ': ef) ans -> Machinery eh ef ans i o
-    Connect :: forall a b c ans eh ef. Machinery eh ef ans a b -> Machinery eh ef ans b c -> Machinery eh ef ans a c
+    Unit
+        :: forall i o ans eh ef
+         . Eff eh (Input i ': Output o ': ef) ans
+        -> Machinery eh ef ans i o
+    Connect
+        :: forall a b c ans eh ef
+         . Machinery eh ef ans a b
+        -> Machinery eh ef ans b c
+        -> Machinery eh ef ans a c
 
 instance Category (Machinery eh ef ans) where
     id :: forall a. Machinery eh ef ans a a
@@ -68,7 +76,10 @@ instance Arrow (Machinery '[] ef ans) where
         Unit . forever $
             input @b >>= output . f
 
-    first :: forall b c d. Machinery '[] ef ans b c -> Machinery '[] ef ans (b, d) (c, d)
+    first
+        :: forall b c d
+         . Machinery '[] ef ans b c
+        -> Machinery '[] ef ans (b, d) (c, d)
     first = \case
         Unit m -> Unit $ evalState (Left Seq.Empty) $ buffering m
         Connect a b -> Connect (first a) (first b)
@@ -153,10 +164,17 @@ runMachinery
      . (Parallel <<| eh, Semigroup ans)
     => Machinery '[] ef ans i o
     -> Eff eh ef (MachineStatus (Eff eh ef) ans i o)
-runMachinery = \case
-    Unit m -> runMachine $ machine m
-    Connect a b -> do
-        liftP2 (,) (runMachinery a) (runMachinery b) >>= loop
+runMachinery = runMachineryL . mviewl
+
+runMachineryL
+    :: forall i o ans eh ef
+     . (Parallel <<| eh, Semigroup ans)
+    => MachineryViewL '[] ef ans i o
+    -> Eff eh ef (MachineStatus (Eff eh ef) ans i o)
+runMachineryL = \case
+    MOne m -> runMachine $ machine m
+    MCons m ms -> do
+        liftP2 (,) (runMachine $ machine m) (runMachinery ms) >>= loop
       where
         loop = \case
             (Terminated ans, Terminated ans') -> pure $ Terminated $ ans <> ans'
@@ -206,12 +224,18 @@ runMachineryIO
     -> (o -> Eff eh ef ())
     -> Machinery eh ef ans i o
     -> Eff eh ef ans
-runMachineryIO i o = \case
-    Unit m ->
-        m
-            & interpret (\Input -> raise i)
-            & interpret (\(Output x) -> o x)
-    Connect a b ->
+runMachineryIO i o = runMachineryIOL i o . mviewl
+
+runMachineryIOL
+    :: forall i o ans eh ef
+     . (UnliftIO <<| eh, IO <| ef)
+    => Eff eh ef i
+    -> (o -> Eff eh ef ())
+    -> MachineryViewL eh ef ans i o
+    -> Eff eh ef ans
+runMachineryIOL i o = \case
+    MOne m -> runUnit o m
+    MCons a b ->
         withRunInIO \run -> do
             chan <- newEmptyTMVarIO
             ans <- newEmptyTMVarIO
@@ -220,11 +244,17 @@ runMachineryIO i o = \case
                         x <- restore $ run m
                         atomically $ putTMVar ans x
 
-                t1 <- runThread $ runMachineryIO i (liftIO . atomically . putTMVar chan) a
+                t1 <- runThread $ runUnit (liftIO . atomically . putTMVar chan) a
                 t2 <- runThread $ runMachineryIO (liftIO . atomically $ takeTMVar chan) o b
 
                 atomically (readTMVar ans)
                     <* uninterruptibleMask_ (killThread t1 *> killThread t2)
+  where
+    runUnit :: (o' -> Eff eh ef ()) -> Eff eh (Input i ': Output o' ': ef) ~> Eff eh ef
+    runUnit o' m =
+        m
+            & interpret (\Input -> raise i)
+            & interpret (\(Output x) -> o' x)
 
 runMachineryIO_
     :: forall ans eh ef
@@ -233,3 +263,34 @@ runMachineryIO_
     -> Eff eh ef ans
 runMachineryIO_ = runMachineryIO (pure ()) (const $ pure ())
 {-# INLINE runMachineryIO_ #-}
+
+-- Inspired by https://hackage.haskell.org/package/freer-simple-1.2.1.2/docs/Data-FTCQueue.html
+
+{- |
+Left view deconstruction data structure for Machinery Pipeline.
+
+This allows the number of generated threads to be reduced to the number of machine units.
+-}
+data MachineryViewL eh ef ans i o where
+    MOne
+        :: forall i o ans eh ef
+         . Eff eh (Input i ': Output o ': ef) ans
+        -> MachineryViewL eh ef ans i o
+    MCons
+        :: forall a b c ans eh ef
+         . Eff eh (Input a ': Output b ': ef) ans
+        -> Machinery eh ef ans b c
+        -> MachineryViewL eh ef ans a c
+
+-- | Left view deconstruction for Machinery Pipeline. [average O(1)]
+mviewl :: Machinery eh ef ans i o -> MachineryViewL eh ef ans i o
+mviewl = \case
+    Unit m -> MOne m
+    Connect a b -> connect a b
+  where
+    connect
+        :: Machinery eh ef ans a b
+        -> Machinery eh ef ans b c
+        -> MachineryViewL eh ef ans a c
+    connect (Unit m) r = m `MCons` r
+    connect (Connect a b) r = connect a (Connect b r)

heftia-effects/src/Control/Monad/Hefty/NonDet.hs

@@ -125,6 +125,16 @@ branch a b = do
 
 infixl 3 `branch`
 
+choice :: (Choose <| ef, Empty <| ef) => [a] -> Eff eh ef a
+choice = \case
+    [] -> empty
+    x : xs -> pure x `branch` choice xs
+
+choiceH :: (ChooseH <<| eh, Empty <| ef) => [a] -> Eff eh ef a
+choiceH = \case
+    [] -> empty
+    x : xs -> pure x <|> choiceH xs
+
 runNonDetIO
     :: (UnliftIO <<| eh, IO <| ef)
     => Eff (ChooseH ': eh) (Empty ': ef) a