1
Fork 0

Free monads, first pass.

main
Joshua Potter 2022-03-11 11:36:13 -05:00
parent eca0b9ddc3
commit 02a3b4f715
4 changed files with 216 additions and 38 deletions

4
.githooks/pre-commit Normal file → Executable file
View File

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

View File

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

View File

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

View File

@ -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 ()