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/app-eff-test/Test.hs b/app-eff-test/Test.hs new file mode 100644 index 0000000..3bfeae9 --- /dev/null +++ b/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!" + ] 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 diff --git a/app-eff/Main.hs b/app-eff/Main.hs new file mode 100644 index 0000000..ceb6db6 --- /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 () + } + +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 diff --git a/cabal.project.local b/cabal.project.local new file mode 100644 index 0000000..c8e7df1 --- /dev/null +++ b/cabal.project.local @@ -0,0 +1,3 @@ +ignore-project: False +tests: True +test-show-details: direct 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 + ]; + }; + } + ); +} 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