Include Eff examples

.envrc

@@ -0,0 +1 @@
+use flake

app-eff-test/Test.hs

@@ -0,0 +1,70 @@
+module Test (main) where
+
+import Books qualified as B
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.IORef
+import Eff
+import Main (Console (..), dbBooksRepository, main')
+import Test.Hspec
+
+writerConsole :: [String] -> Eff (Console ::: es) a -> Eff es (a, [String])
+writerConsole inputs inner = do
+  inputsRef <- liftIO $ newIORef inputs
+  outputsRef <- liftIO $ newIORef []
+  let console =
+        Console
+          { _askString = \prompt -> liftIO $ do
+              modifyIORef' outputsRef (prompt :)
+              (i : is) <- readIORef inputsRef
+              modifyIORef' inputsRef (const is)
+              return i
+          , _writeString = \s -> liftIO $ do
+              modifyIORef' outputsRef (s :)
+          }
+  a <- using console $ do inner
+  outputs <- liftIO $ reverse <$> readIORef outputsRef
+  return (a, outputs)
+
+main :: IO ()
+main = hspec $ do
+  around (B.withDB ":memory:") $ do
+    it "Showing a message when no books are found" $ \db -> do
+      (_, output) <-
+        runEff
+          . using (dbBooksRepository db)
+          . use (writerConsole ["Pri", ""])
+          $ main'
+
+      output
+        `shouldBe` [ "Welcome to the Library"
+                   , "Search: "
+                   , "No books found for: Pri"
+                   , "Search: "
+                   , "Bye!"
+                   ]
+
+    it "User can perform searches and exit" $ \db -> do
+      let books =
+            [ B.Book {B.title = "Pride and Prejudice", B.author = "Jane Austen"}
+            , B.Book {B.title = "1984", B.author = "George Orwell"}
+            , B.Book {B.title = "Frankenstein", B.author = "Mary Shelley"}
+            ]
+      forM_ books $ B.addBook db
+
+      (_, output) <-
+        runEff
+          . using (dbBooksRepository db)
+          . use (writerConsole ["en", "or", ""])
+          $ main'
+
+      output
+        `shouldBe` [ "Welcome to the Library"
+                   , "Search: "
+                   , " * Pride and Prejudice, Jane Austen"
+                   , " * Frankenstein, Mary Shelley"
+                   , "Search: "
+                   , " * 1984, George Orwell"
+                   , "Search: "
+                   , "Bye!"
+                   ]

app-eff/Eff.hs

@@ -0,0 +1,93 @@
+module Eff
+  ( Eff
+  , runEff
+  , liftIO
+  , unliftIO
+  , request
+  , locally
+  , using
+  , usingM
+  , use
+  , useM
+  , (:::) (..)
+  , (:>) (..)
+  ) where
+
+import Control.Monad.IO.Class
+
+----------------------------------------
+-- `Eff` monad, essentially `ReaderT env IO`
+
+newtype Eff es a = MkEff (es -> IO a)
+
+instance Functor (Eff es) where
+  fmap f (MkEff ea) = MkEff $ \env -> do
+    a <- ea env
+    let b = f a
+    return b
+
+instance Applicative (Eff es) where
+  pure x = MkEff $ \_ -> return x
+  MkEff eab <*> MkEff ea = MkEff $ \env -> do
+    ab <- eab env
+    a <- ea env
+    let b = ab a
+    return b
+
+instance Monad (Eff es) where
+  return = pure
+  MkEff ea >>= faeb = MkEff $ \env -> do
+    a <- ea env
+    let (MkEff eb) = faeb a
+    eb env
+
+instance MonadIO (Eff es) where
+  liftIO io = MkEff $ const io
+
+runEff :: Eff () a -> IO a
+runEff (MkEff run) = run ()
+
+unliftIO :: ((forall a. Eff es a -> IO a) -> IO b) -> Eff es b
+unliftIO f = MkEff $ \env -> f (\(MkEff run) -> run env)
+
+request :: (e :> es) => Eff es e
+request = extract <$> MkEff return
+
+locally :: (e :> es) => (e -> e) -> Eff es a -> Eff es a
+locally f (MkEff run) = MkEff $ \env -> run (alter f env)
+
+using :: e -> Eff (e ::: es) a -> Eff es a
+using impl (MkEff run) = MkEff $ \env -> run (impl ::: env)
+
+usingM :: Eff es e -> Eff (e ::: es) a -> Eff es a
+usingM implM inner = implM >>= \impl -> using impl inner
+
+use :: (e -> Eff es a) -> e -> Eff es a
+use f = f
+
+useM :: Eff es (e -> Eff es a) -> e -> Eff es a
+useM fM inner = fM >>= \f -> f inner
+
+----------------------------------------
+-- Minimal `Has` class `(:>)` with a custom tuple as heterogeneous lists
+
+data a ::: b = (:::) !a !b
+
+infixr 1 :::
+
+class a :> t where
+  {-# MINIMAL extract, alter #-}
+  extract :: t -> a
+  alter :: (a -> a) -> t -> t
+
+instance a :> a where
+  extract a = a
+  alter f = f
+
+instance {-# OVERLAPPING #-} a :> (a ::: x) where
+  extract (a ::: _) = a
+  alter f (a ::: x) = f a ::: x
+
+instance {-# OVERLAPPABLE #-} (a :> r) => a :> (l ::: r) where
+  extract (_ ::: r) = extract r
+  alter f (l ::: r) = l ::: alter f r

app-eff/Main.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Main where
+
+import Books (Book, BookDB)
+import Books qualified
+import Control.Monad (forM_)
+import Control.Monad.Fix (fix)
+import Eff
+import System.IO
+
+data Console = Console
+  { _askString :: forall es. String -> Eff es String
+  , _writeString :: forall es. String -> Eff es ()
+  }
+
+askString :: (Console :> es) => String -> Eff es String
+askString s = request >>= \Console {..} -> _askString s
+
+writeString :: (Console :> es) => String -> Eff es ()
+writeString s = request >>= \Console {..} -> _writeString s
+
+stdConsole :: Console
+stdConsole =
+  Console
+    { _askString = \prompt -> liftIO $ do
+        putStr prompt
+        hFlush stdout
+        getLine
+    , _writeString = liftIO . putStrLn
+    }
+
+data BooksRepository = BooksRepository
+  { _findBook :: forall es. String -> Eff es [Book]
+  , _addBook :: forall es. Book -> Eff es ()
+  }
+
+findBook :: (BooksRepository :> es) => String -> Eff es [Book]
+findBook query = request >>= \BooksRepository {..} -> _findBook query
+
+addBook :: (BooksRepository :> es) => Book -> Eff es ()
+addBook book = request >>= \BooksRepository {..} -> _addBook book
+
+dbBooksRepository :: BookDB -> BooksRepository
+dbBooksRepository db =
+  BooksRepository
+    { _findBook = liftIO . db.findBook
+    , _addBook = liftIO . db.addBook
+    }
+
+main :: IO ()
+main = do
+  Books.withDB "./books.db" $ \db -> do
+    runEff $ using (dbBooksRepository db) $ using stdConsole $ do
+      main'
+
+main' :: (Console :> es, BooksRepository :> es) => Eff es ()
+main' = do
+  writeString "Welcome to the Library"
+  fix $ \loop -> do
+    query <- askString "Search: "
+    case query of
+      "" ->
+        writeString "Bye!"
+      _ -> do
+        books <- findBook query
+        if null books
+          then writeString $ "No books found for: " <> query
+          else forM_ books prettyPrintBook
+        loop
+  where
+    prettyPrintBook book = writeString $ " * " <> book.title <> ", " <> book.author

cabal.project.local

@@ -0,0 +1,3 @@
+ignore-project: False
+tests: True
+test-show-details: direct

flake.nix

@@ -0,0 +1,22 @@
+{
+  inputs = {
+    nixpkgs.url = "github:NixOS/nixpkgs/a343533bccc62400e8a9560423486a3b6c11a23b";
+    mkshell-minimal.url = "github:viperML/mkshell-minimal";
+    utils.url = "github:numtide/flake-utils";
+  };
+  outputs = { self, nixpkgs, mkshell-minimal, utils }: utils.lib.eachDefaultSystem (system:
+    let
+      pkgs = nixpkgs.legacyPackages.${system};
+      mkShell = mkshell-minimal pkgs;
+    in
+    {
+      devShell = mkShell {
+        buildInputs = with pkgs; [
+          ghc
+          cabal-install
+          haskell-language-server
+        ];
+      };
+    }
+  );
+}

lambda-library.cabal

@@ -16,7 +16,7 @@ common warnings
     ghc-options: -Wall
 
 common defaults
-    default-extensions: 
+    default-extensions:
         OverloadedStrings,
         OverloadedRecordDot
     build-depends:
@@ -59,8 +59,8 @@ test-suite app1-test
     other-modules:
         Support
     build-depends:
-        bytestring >= 0.11.5 && < 0.12, 
-        utf8-string >= 1.0.2 && < 1.1, 
+        bytestring >= 0.11.5 && < 0.12,
+        utf8-string >= 1.0.2 && < 1.1,
         main-tester >= 0.2.0 && < 0.3
 
 executable app2
@@ -128,6 +128,21 @@ test-suite app5-test
         Support
         App
 
+executable app-eff
+    import:           warnings, app
+    main-is:          Main.hs
+    hs-source-dirs:   app-eff
+    other-modules:
+        Eff
+
+test-suite app-eff-test
+    import:           warnings, app-test
+    type:             exitcode-stdio-1.0
+    main-is:          Test.hs
+    hs-source-dirs:   app-eff, app-eff-test
+    other-modules:
+        Eff
+
 executable app-bluefin
     import:           warnings, app
     main-is:          Main.hs