diff --git a/.githooks/pre-commit b/.githooks/pre-commit old mode 100644 new mode 100755 index 6dda1fe..2606d55 --- a/.githooks/pre-commit +++ b/.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; diff --git a/flake.nix b/flake.nix index cf5afe7..f3736fd 100644 --- a/flake.nix +++ b/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 + ]; + }; + }); } diff --git a/free-monads/free-monads.cabal b/free-monads/free-monads.cabal index 47848f9..c63e4bf 100644 --- a/free-monads/free-monads.cabal +++ b/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 diff --git a/free-monads/src/Control/Monad/Free.hs b/free-monads/src/Control/Monad/Free.hs new file mode 100644 index 0000000..78d1496 --- /dev/null +++ b/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 ()