Free monads, first pass.

.githooks/pre-commit

@@ -1,4 +1,4 @@
-#!/usr/bin/env bash
+#!/bin/bash
 set -e
 
 filesToFormat=$(
@@ -8,6 +8,6 @@ filesToFormat=$(
 
 for path in $filesToFormat
 do
-  google-java-format --replace $path
+  ormolu --mode inplace $path
   git add $path
 done;

flake.nix

@@ -9,42 +9,32 @@
     };
   };
 
-  outputs = { self, nixpkgs, flake-utils }: {
-    overlay = final: prev: {
-      hello-world = prev.haskellPackages.callCabal2nix "hello-world" self { };
-    };
-  } // (flake-utils.lib.eachDefaultSystem (system:
-    let
-      pkgs = import nixpkgs {
-        inherit system;
-        overlays = [ self.overlay ];
-      };
+  outputs = { self, nixpkgs, flake-utils }:
+    flake-utils.lib.eachDefaultSystem (system:
+      let
+        pkgs = import nixpkgs { inherit system; };
 
-      haskell = {
-        ghc = pkgs.haskellPackages.ghc;
-        hls = pkgs.haskell-language-server.override {
-          supportedGhcVersions = [ "8107" ];
+        haskell = {
+          ghc = pkgs.haskellPackages.ghc;
+          hls = pkgs.haskell-language-server.override {
+            supportedGhcVersions = [ "8107" ];
+          };
         };
-      };
-    in
-    with pkgs; {
-      packages = { inherit hello-world; };
-
-      defaultPackage = self.packages.${system}.hello-world;
-
-      devShell = mkShell {
-        buildInputs = lib.attrValues self.packages.${system} ++ [
-          haskell.ghc
-          haskell.hls
-          gdb
-          # GHC depends on LANG so need this package to properly interpret our
-          # files with e.g. tasty-discover.
-          # https://www.reddit.com/r/Nix/comments/jyczts/nixshell_locale_issue/
-          glibcLocales
-          haskellPackages.cabal-install
-          haskellPackages.ormolu
-          haskellPackages.tasty-discover
-        ];
-      };
-    }));
+      in
+      with pkgs; {
+        devShell = mkShell {
+          buildInputs = [
+            haskell.ghc
+            haskell.hls
+            gdb
+            # GHC depends on LANG so need this package to properly interpret our
+            # files with e.g. tasty-discover.
+            # https://www.reddit.com/r/Nix/comments/jyczts/nixshell_locale_issue/
+            glibcLocales
+            haskellPackages.cabal-install
+            haskellPackages.ormolu
+            haskellPackages.tasty-discover
+          ];
+        };
+      });
 }

free-monads/free-monads.cabal

@@ -77,3 +77,4 @@ common free-monads-common
 library
   import:             free-monads-common
   hs-source-dirs:     src
+  exposed-modules:    Control.Monad.Free

free-monads/src/Control/Monad/Free.hs

@@ -0,0 +1,187 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Control.Monad.Free
+  ( -- * First pass
+    NonEmptyList (..),
+    onePlusTwo,
+    onePlusTwo',
+    onePlusTwo'',
+    runNonEmptyList,
+
+    -- * Second pass
+    NonEmptyList' (..),
+    twoPlusThree,
+    runNonEmptyList',
+
+    -- * Third pass
+    NonEmptyList'' (..),
+    threePlusFour,
+    runNonEmptyList'',
+
+    -- * Free Monad
+    Free (..),
+    monadicAp,
+
+    -- * Teletype
+    Teletype (..),
+    read,
+    write,
+    readThenWrite,
+    runReadThenWrite,
+  )
+where
+
+import Prelude hiding (Last)
+
+{-# ANN module "HLINT: ignore Use let" #-}
+
+{-# ANN module "HLINT: ignore Use <$>" #-}
+
+-- ========================================
+-- First Pass
+-- ========================================
+
+-- |
+--
+-- >>> runIdentity onePlusTwo'
+-- 3
+onePlusTwo :: forall m. Monad m => m Int
+onePlusTwo = do
+  a <- pure 1
+  b <- pure 2
+  pure (a + b)
+
+onePlusTwo' :: forall m. Monad m => m Int
+onePlusTwo' = pure 1 >>= (\a -> pure 2 >>= (\b -> pure (a + b)))
+
+data NonEmptyList a = Last a | Cons a (a -> NonEmptyList a)
+
+onePlusTwo'' :: NonEmptyList Int
+onePlusTwo'' = Cons 1 (\a -> Cons 2 (\b -> Last (a + b)))
+
+-- |
+--
+-- >>> runNonEmptyList onePlusTwo''
+-- 3
+runNonEmptyList :: NonEmptyList Int -> Int
+runNonEmptyList (Last a) = a
+runNonEmptyList (Cons a f) = runNonEmptyList (f a)
+
+-- ========================================
+-- Second Pass
+-- ========================================
+
+data NonEmptyList' f a = Last' a | Cons' a (f (NonEmptyList' f a))
+
+instance (Functor f) => Functor (NonEmptyList' f) where
+  fmap f (Last' a) = Last' (f a)
+  fmap f (Cons' a g) = Cons' (f a) (fmap (fmap f) g)
+
+twoPlusThree :: NonEmptyList' (Reader Int) Int
+twoPlusThree =
+  Cons'
+    2
+    ( reader
+        ( \a ->
+            Cons'
+              3
+              (reader (\b -> Last' (a + b)))
+        )
+    )
+
+-- |
+--
+-- >>> runNonEmptyList' twoPlusThree
+-- 5
+runNonEmptyList' :: NonEmptyList' (Reader Int) Int -> Int
+runNonEmptyList' (Last' a) = a
+runNonEmptyList' (Cons' a f) = runNonEmptyList' (runReader f a)
+
+-- ========================================
+-- Third Pass
+-- ========================================
+
+data Wrap a b c = Wrap a (b c) deriving (Functor)
+
+data NonEmptyList'' f a = Last'' a | Cons'' (f (NonEmptyList'' f a))
+  deriving (Functor)
+
+threePlusFour :: NonEmptyList'' (Wrap Int (Reader Int)) Int
+threePlusFour =
+  Cons''
+    ( Wrap
+        3
+        ( reader
+            ( \a ->
+                Cons''
+                  (Wrap 4 (reader (\b -> Last'' (a + b))))
+            )
+        )
+    )
+
+-- |
+--
+-- >>> runNonEmptyList'' threePlusFour
+-- 5
+runNonEmptyList'' :: NonEmptyList'' (Wrap Int (Reader Int)) Int -> Int
+runNonEmptyList'' (Last'' a) = a
+runNonEmptyList'' (Cons'' (Wrap a f)) = runNonEmptyList'' (runReader f a)
+
+instance (Functor f) => Applicative (NonEmptyList'' f)
+
+-- Intentionally empty so the @Monad@ instance compiles.
+
+instance (Functor f) => Monad (NonEmptyList'' f) where
+  Last'' a >>= g = g a
+  Cons'' f >>= g = Cons'' (fmap (>>= g) f)
+
+-- ========================================
+-- Free Monad
+-- ========================================
+
+-- | The traditional representation of a free monad.
+data Free f a = Pure a | Free (f (Free f a))
+
+deriving instance (Show (f (Free f a)), Show a) => Show (Free f a)
+
+instance (Functor f) => Functor (Free f) where
+  fmap f (Pure a) = Pure (f a)
+  fmap f (Free g) = Free (fmap (fmap f) g)
+
+monadicAp :: forall f a b. Functor f => Free f (a -> b) -> Free f a -> Free f b
+monadicAp f g = do
+  f' <- f
+  g' <- g
+  pure (f' g')
+
+instance (Functor f) => Applicative (Free f) where
+  pure = Pure
+
+  Pure f <*> g = fmap f g
+  Free f <*> g = Free (fmap (<*> g) f)
+
+instance (Functor f) => Monad (Free f) where
+  Pure a >>= g = g a
+  Free f >>= g = Free (fmap (>>= g) f)
+
+-- ========================================
+-- Teletype
+-- ========================================
+
+data Teletype a = Read a | Write String a deriving (Functor, Show)
+
+read :: Free Teletype String
+read = Free (Read (Pure "hello"))
+
+write :: String -> Free Teletype ()
+write s = Free (Write s (Pure ()))
+
+readThenWrite :: Free Teletype ()
+readThenWrite = do
+  input <- read
+  write input
+
+runReadThenWrite :: Free Teletype () -> IO ()
+runReadThenWrite (Free (Write s f)) = putStrLn s >> runReadThenWrite f
+runReadThenWrite (Free (Read f)) = runReadThenWrite f
+runReadThenWrite (Pure _) = pure ()