From 1ac4005b76415f6b77858a43448479eb2d3ee56e Mon Sep 17 00:00:00 2001 From: Lautaro Emanuel Date: Mon, 24 Mar 2025 19:15:57 -0300 Subject: [PATCH 1/9] Add Nix flake --- .envrc | 1 + flake.lock | 77 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ flake.nix | 22 ++++++++++++++++ 3 files changed, 100 insertions(+) create mode 100644 .envrc create mode 100644 flake.lock create mode 100644 flake.nix diff --git a/.envrc b/.envrc new file mode 100644 index 0000000..3550a30 --- /dev/null +++ b/.envrc @@ -0,0 +1 @@ +use flake diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..14e5837 --- /dev/null +++ b/flake.lock @@ -0,0 +1,77 @@ +{ + "nodes": { + "mkshell-minimal": { + "locked": { + "lastModified": 1700988624, + "narHash": "sha256-KJyiF67zVYOBkNltKhJATfSj+gfRFX9dSFIWDEBy2nQ=", + "owner": "viperML", + "repo": "mkshell-minimal", + "rev": "6b0868be06da900b5fe6ece05616b84e3cbd7944", + "type": "github" + }, + "original": { + "owner": "viperML", + "repo": "mkshell-minimal", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1709905912, + "narHash": "sha256-TofHtnlrOBCxtSZ9nnlsTybDnQXUmQrlIleXF1RQAwQ=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "a343533bccc62400e8a9560423486a3b6c11a23b", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "a343533bccc62400e8a9560423486a3b6c11a23b", + "type": "github" + } + }, + "root": { + "inputs": { + "mkshell-minimal": "mkshell-minimal", + "nixpkgs": "nixpkgs", + "utils": "utils" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + }, + "utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1726560853, + "narHash": "sha256-X6rJYSESBVr3hBoH0WbKE5KvhPU5bloyZ2L4K60/fPQ=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "c1dfcf08411b08f6b8615f7d8971a2bfa81d5e8a", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..164c690 --- /dev/null +++ b/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 + ]; + }; + } + ); +} From 1a1884051cec73d17f6598276144b82e35f4c56c Mon Sep 17 00:00:00 2001 From: Lautaro Emanuel Date: Tue, 25 Mar 2025 13:16:32 -0300 Subject: [PATCH 2/9] Enable tests --- cabal.project.local | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 cabal.project.local diff --git a/cabal.project.local b/cabal.project.local new file mode 100644 index 0000000..0432756 --- /dev/null +++ b/cabal.project.local @@ -0,0 +1,2 @@ +ignore-project: False +tests: True From 27c90d431522e0c4f0f7d4a6b5f881ed50870fc4 Mon Sep 17 00:00:00 2001 From: Lautaro Emanuel Date: Tue, 25 Mar 2025 13:16:48 -0300 Subject: [PATCH 3/9] Add `app-eff` and `app-eff-test` --- lambda-library.cabal | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/lambda-library.cabal b/lambda-library.cabal index 5bdb889..2473746 100644 --- a/lambda-library.cabal +++ b/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 From ba0b749c3b430e76f42dbe479b99616e827fd9d5 Mon Sep 17 00:00:00 2001 From: Lautaro Emanuel Date: Tue, 25 Mar 2025 13:17:09 -0300 Subject: [PATCH 4/9] Minimal `Eff` - Does not include any effect --- app-eff/Eff.hs | 93 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 93 insertions(+) create mode 100644 app-eff/Eff.hs diff --git a/app-eff/Eff.hs b/app-eff/Eff.hs new file mode 100644 index 0000000..dee5894 --- /dev/null +++ b/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 From 815ab924afcb63f7ebf1e8e1abb119b52c76144b Mon Sep 17 00:00:00 2001 From: Lautaro Emanuel Date: Tue, 25 Mar 2025 13:17:34 -0300 Subject: [PATCH 5/9] Initial `Eff` implementation --- app-eff-test/Test.hs | 64 +++++++++++++++++++++++++++++++++++++++ app-eff/Main.hs | 72 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 136 insertions(+) create mode 100644 app-eff-test/Test.hs create mode 100644 app-eff/Main.hs diff --git a/app-eff-test/Test.hs b/app-eff-test/Test.hs new file mode 100644 index 0000000..eb5204d --- /dev/null +++ b/app-eff-test/Test.hs @@ -0,0 +1,64 @@ +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 ([String], a) +writerConsole inputs inner = do + inputsRef <- liftIO $ newIORef inputs + outputsRef <- liftIO $ newIORef [] + let console = + Console + { _askString = \_ -> liftIO $ do + (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 (outputs, a) + +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" + , "No books found for: Pri" + , "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" + , " * Pride and Prejudice, Jane Austen" + , " * Frankenstein, Mary Shelley" + , " * 1984, George Orwell" + , "Bye!" + ] diff --git a/app-eff/Main.hs b/app-eff/Main.hs new file mode 100644 index 0000000..fc6dd7e --- /dev/null +++ b/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 () + } + +dbBooksRepository :: BookDB -> BooksRepository +dbBooksRepository db = + BooksRepository + { _findBook = liftIO . db.findBook + , _addBook = liftIO . db.addBook + } + +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 + +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 From c47e760c75c965b0525798c8d2cbd1328c077076 Mon Sep 17 00:00:00 2001 From: Lautaro Emanuel Date: Tue, 25 Mar 2025 13:20:46 -0300 Subject: [PATCH 6/9] Use `direct` test details --- cabal.project.local | 1 + 1 file changed, 1 insertion(+) diff --git a/cabal.project.local b/cabal.project.local index 0432756..c8e7df1 100644 --- a/cabal.project.local +++ b/cabal.project.local @@ -1,2 +1,3 @@ ignore-project: False tests: True +test-show-details: direct From d5a6eb582764325fda2e78d818ac8f1d4fa266fb Mon Sep 17 00:00:00 2001 From: Lautaro Emanuel Date: Tue, 25 Mar 2025 13:36:32 -0300 Subject: [PATCH 7/9] Include the `Search: ` prompt --- app-eff-test/Test.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/app-eff-test/Test.hs b/app-eff-test/Test.hs index eb5204d..15eca27 100644 --- a/app-eff-test/Test.hs +++ b/app-eff-test/Test.hs @@ -14,7 +14,8 @@ writerConsole inputs inner = do outputsRef <- liftIO $ newIORef [] let console = Console - { _askString = \_ -> liftIO $ do + { _askString = \prompt -> liftIO $ do + modifyIORef' outputsRef (prompt :) (i : is) <- readIORef inputsRef modifyIORef' inputsRef (const is) return i @@ -37,7 +38,9 @@ main = hspec $ do output `shouldBe` [ "Welcome to the Library" + , "Search: " , "No books found for: Pri" + , "Search: " , "Bye!" ] @@ -57,8 +60,11 @@ main = hspec $ do output `shouldBe` [ "Welcome to the Library" + , "Search: " , " * Pride and Prejudice, Jane Austen" , " * Frankenstein, Mary Shelley" + , "Search: " , " * 1984, George Orwell" + , "Search: " , "Bye!" ] From 0127cca0512f1f9dc22a62f522fea19eb1f94265 Mon Sep 17 00:00:00 2001 From: Lautaro Emanuel Date: Tue, 25 Mar 2025 13:38:40 -0300 Subject: [PATCH 8/9] Move code around --- app-eff/Main.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/app-eff/Main.hs b/app-eff/Main.hs index fc6dd7e..ceb6db6 100644 --- a/app-eff/Main.hs +++ b/app-eff/Main.hs @@ -35,6 +35,12 @@ data BooksRepository = BooksRepository , _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 @@ -42,12 +48,6 @@ dbBooksRepository db = , _addBook = liftIO . db.addBook } -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 - main :: IO () main = do Books.withDB "./books.db" $ \db -> do From 89d7e2fc85fa03151eb83a9cdb011331c04aa853 Mon Sep 17 00:00:00 2001 From: Lautaro Emanuel Date: Tue, 25 Mar 2025 13:39:57 -0300 Subject: [PATCH 9/9] Match `State` parameter order --- app-eff-test/Test.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/app-eff-test/Test.hs b/app-eff-test/Test.hs index 15eca27..3bfeae9 100644 --- a/app-eff-test/Test.hs +++ b/app-eff-test/Test.hs @@ -8,7 +8,7 @@ import Eff import Main (Console (..), dbBooksRepository, main') import Test.Hspec -writerConsole :: [String] -> Eff (Console ::: es) a -> Eff es ([String], a) +writerConsole :: [String] -> Eff (Console ::: es) a -> Eff es (a, [String]) writerConsole inputs inner = do inputsRef <- liftIO $ newIORef inputs outputsRef <- liftIO $ newIORef [] @@ -24,13 +24,13 @@ writerConsole inputs inner = do } a <- using console $ do inner outputs <- liftIO $ reverse <$> readIORef outputsRef - return (outputs, a) + 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, _) <- + (_, output) <- runEff . using (dbBooksRepository db) . use (writerConsole ["Pri", ""]) @@ -52,7 +52,7 @@ main = hspec $ do ] forM_ books $ B.addBook db - (output, _) <- + (_, output) <- runEff . using (dbBooksRepository db) . use (writerConsole ["en", "or", ""])