Projects docs

This is a collection of docs generated for several projects.

Developers roadmap

Extensions:

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE InstanceSigs #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}

Imports

import Control.Monad.Fix (fix)
import Language.Haskell.TH.Syntax (Dec, Quasi, runQ)

main = undefined

Kinds

DataKinds - src
- What is the data type promotion?
  - promote terms to type level like '[1,2,3]
Are types with promoted kinds inhabited?
- inhabited types (types that have at least 1 value) are of kind Type
ConstraintKinds - Constraints as first-class citizens
```
type Stringy a = (Read a, Show a)
```
Symbol - a compile-time string
- UnconsSymbol
- typed-interpolation - a good parsing example.

Functional dependencies

Set a relation between types. Make one type correspond to another type

class (Monad m) => MonadError e m | m -> e where
  throwError :: e -> m a
  catchError :: m a -> (e -> m a) -> m a

Problem (src):

we want a MonadReader typeclass where there is only a single instance per m, and we know the env parameter that will be available from each m.

Approach 1:

MultiParamTypeClasses let us specify explicitly what the env is

FunctionalDependencies allow us to constrain ourselves to a single instance.

newtype PersonReader a = PersonReader { runPersonReader :: Person -> a } deriving Functor

class MonadReader env m | m -> env where
  ask :: m env

instance MonadReader Person PersonReader where
  ask = PersonReader $ \env -> env

instance MonadReader env (Reader env) where
  ask = Reader $ \env -> env

greeting :: PersonReader String
greeting = do
  person <- ask
  -- Here, derives that `person :: Person`
  -- from `instance MonadReader Person PersonReader`
  -- via fundep `m -> env` and `ask :: m env`
  pure $ show person

Approach 2:

TypeFamilies

class MonadReader m where
  -- use an associated type
  type Env m
  ask :: m (Env m)

data Person
newtype PersonReader a = PersonReader (a -> a)

-- `m (Env m)` calculates to `PersonReader Person`
instance MonadReader PersonReader where
  type Env PersonReader = Person
  ask :: PersonReader (Env PersonReader)
  ask = PersonReader id

Laziness

Bang patterns

{-# LANGUAGE BangPatterns #-}

addBang :: Int -> Int -> Int
addBang !x !y = x + y

-- equivalent to
addSeq :: Int -> Int -> Int
addSeq x y = x `seq` y `seq` x + y

$! - strict application
Thunk is an unevaluated expression - src
- free variables in an unevaluated expr
- when evaluated, the pointers to it will point to the result
- a dead thunk is garbage collected
Expression forms - src
- Normal form
  
  An expression in normal form is fully evaluated, and no sub-expression could be evaluated any further (i.e. it contains no un-evaluated thunks).
- Weak head normal form
  
  An expression in weak head normal form has been evaluated to the outermost data constructor or lambda abstraction (the head).
```
(1 + 1, 2 + 2)       -- the outermost part is the data constructor (,)
\x -> 2 + 2
```
a `seq` b - eval a to WHNF, return b
a `deepseq` b - eval a to NF, return b
force b = b `deepseq` b - eval b to NF and return b
- If we have let a = force b, a is not in NF
- To get a in NF, we need to !a
Thunks, Sharing, Laziness via ghc-viz (available in nixpkgs)
safe-exceptions
- force impure exceptions using tryAnyDeep and NFData.

Fix combinator

ex13 :: [Int] -> Int
ex13 =
  fix
    ( \t c ->
        \case
          (a0 : a1 : as) -> t (c + fromEnum (signum a0 /= signum a1)) (a1 : as)
          _ -> c
    )
    0

-- >>>ex13 [-3,0,2,0,5]
-- 4

File IO

There are several representations of text in Haskell - ByteString, Text, String
ByteString can contain both human-readable or binary data that mustn't be mixed
Also, there are many file encodings. Use UTF-8 to be safe
One can encode standard data types into a ByteString using Data.ByteString.Builder
LBS reads files in chunks. Can be used for streaming
hGet reads a given number of bytes from a handle
stdout and stdin are files
Can set buffering mode on a handle: hSetBuffering stdout NoBuffering

Debugging

Debug.Trace
breakpoint - src
- put breakpoints into an app (see TryBreakpoint)
- inspect variables visible at a breakpoint
- freeze other threads (GHC 9.2.x+)

Monoid

List comprehension

Skip elements

On a flag

_deepClone :: Bool
_deepClone = True

s1 :: [String]
s1 = ["--deepClone" | _deepClone]

On a pattern fail

catMaybes :: [Maybe a] -> [a]
catMaybes ls = [x | Just x <- ls]

Template Haskell

capture haddocks
- getDoc

print the structure of an expression

ex2 :: (Quasi a) => a [Dec]
ex2 = runQ [d|decl :: Int; decl = 1 + 2|]

-- >>>ex2
-- [SigD decl_0 (ConT GHC.Types.Int),ValD (VarP decl_0) (NormalB (InfixE (Just (LitE (IntegerL 1))) (VarE GHC.Num.+) (Just (LitE (IntegerL 2))))) []]

Higher-Kinded Data

Defaulting fields in a record (via HKD) - GH
Higher-Kinded Data

Generics

Higher-Kinded Data
aeson converts data to generic representation.
- Its functions for parsing use selector names, modify them via options, then convert to or parse JSON.

QualifiedDo

Qualified do: rebind your do-notation the right way

example

{-# LANGUAGE QualifiedDo #-}

module Main where

import Data.Function((&))

(>>=) = (&)

foo :: Int
foo = Main.do
  z <- (3, 4)
  (x, s) <- z
  x

main = print foo

Effects

Effectful

effectful
- Talk at Lambda
- Сервер с servant, esqueleto, effectful - YT
- News site back-end - GH
- Effects may be pure - runPureEff

UnliftIO

Demystifying MonadBaseControl
- Capture the action’s input state and close over it.
- Package up the action’s output state with its result and run it.
- Restore the action’s output state into the enclosing transformer.
- Return the action’s result.

Handle pattern

src
Take functions from a given environment, e.g. from ReaderT

Data

large-records
Avoid quadratic Core size - advice

Nix

To keep completions in share, need to modify justStaticExecutables so that it doesn't remove share.

Misc

Радости и горести побед над C: делаем конфетку из прототипа wc на хаскеле
- hwc
Parsing with Haskell
- Part 1
Haskell CI with caching - src
string-interpolate - src
- UTF-8 string interpolation
ViewPatterns

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Try.Aeson.HKD where

import Control.Lens (Identity, non, (&), (^.))
import Data.Aeson
import Data.Aeson.TH (deriveJSON)
import Data.Kind
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as NE
import Fcf (Eval, Exp)
import GHC.Generics

data ORBEParty f = ORBEParty
  { infants :: Eval (f Int)
  , children :: Eval (f Int)
  , adults :: Eval (f Int)
  }
  deriving (Generic)

data MyIdentity :: a -> Exp a
data MyMaybe :: a -> Exp a

type instance Eval (MyIdentity a) = a
type instance Eval (MyMaybe a) = Maybe (NonEmpty a)

instance FromJSON (ORBEParty MyMaybe)
deriving instance Show (ORBEParty MyIdentity)
deriving instance Show (ORBEParty MyMaybe)

t1 = "{ \"adults\": [3] }" & decode @(ORBEParty MyMaybe)

-- >>> t1
-- Just (ORBEParty {infants = Nothing, children = Nothing, adults = Just (3 :| [])})

toDefault :: ORBEParty MyMaybe -> ORBEParty MyIdentity
toDefault ORBEParty{..} =
  ORBEParty
    { infants = maybe 1 NE.head infants
    , children = maybe 1 NE.head children
    , adults = maybe 1 NE.head adults
    }

data Party = Party
  { adults :: Maybe Int
  , children :: Maybe (NonEmpty Int)
  , infants :: Maybe Int
  }
  deriving (Generic, Show)

deriveJSON defaultOptions ''Party

t = "{ \"adults\": 3, \"children\" : [] }" & decode @Party

-- >>> t
-- Nothing

large-anon: Practical scalable anonymous records for Haskell

source

TODO: example with generic lens (issue)

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedRecordUpdate #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
{-# OPTIONS_GHC -fplugin=Data.Record.Anon.Plugin #-}

module Try.Data.LargeAnon where

import Data.Record.Anon
import Data.Record.Anon.Overloading
import Data.Record.Anon.Simple

magenta :: Record ["red" := Double, "green" := Double, "blue" := Double]
magenta = ANON{red = 1, green = 0, blue = 1}

purple :: Record '["red" ':= Double, "green" ':= Integer, "blue" ':= Double]
purple = insert #red 0.5 $ insert #green 0 $ insert #blue 0.5 empty

b :: Double
b = purple.blue

-- >>> b
-- 0.5

reduceRed :: (RowHasField "red" r Double) => Record r -> Record r
reduceRed c = c{red = c.red * 0.9}

ex1 :: Record '["red" ':= Double, "green" ':= Double, "blue" ':= Double]
ex1 = reduceRed magenta


-- TODO how to show?

-- >>> ex1
-- No instance for (AllFields
--                    '[ "red" ':= Double, "green" ':= Double, "blue" ':= Double] Show)
--   arising from a use of `evalPrint'
-- In a stmt of an interactive GHCi command: evalPrint it_a1SAw

{-# OPTIONS_GHC -fplugin Debug.Breakpoint #-}

module Try.Debug.Breakpoint where

import Debug.Breakpoint (breakpointIO)

main :: IO ()
main = do
  putStrLn "Type something!"
  x <- getLine
  let y = 2 :: Int
      z = id :: Bool -> Bool
  breakpointIO
  pure ()

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Try.Effectful.Dynamic where

import Control.Exception (IOException)
import Control.Monad (replicateM)
import Control.Monad.Catch (catch)
import Control.Monad.Cont (MonadIO (..))
import Data.Char (chr)
import Data.Map.Strict qualified as M
import Effectful (Dispatch (..), DispatchOf, Eff, Effect, IOE, runEff, runPureEff, type (:>))
import Effectful.Dispatch.Dynamic (HasCallStack, interpret, localSeqUnlift, localSeqUnliftIO, reinterpret, send)
import Effectful.Error.Dynamic
import Effectful.State.Static.Local
import GHC.Clock (getMonotonicTime)
import System.IO qualified as IO
import Prelude hiding (readFile)

data FileSystem :: Effect where
  ReadFile :: FilePath -> FileSystem m String
  WriteFile :: FilePath -> String -> FileSystem m ()

type instance DispatchOf FileSystem = Dynamic

readFile :: (HasCallStack, FileSystem :> es) => FilePath -> Eff es String
readFile path = send (ReadFile path)

writeFile :: (HasCallStack, FileSystem :> es) => FilePath -> String -> Eff es ()
writeFile path content = send (WriteFile path content)

newtype FsError = FsError String deriving (Show)

runFileSystemIO :: (IOE :> es, Error FsError :> es) => Eff (FileSystem : es) a -> Eff es a
runFileSystemIO = interpret $ \_ -> \case
  ReadFile path -> adapt $ IO.readFile path
  WriteFile path contents -> adapt $ IO.writeFile path contents
 where
  adapt m = liftIO m `catch` \(e :: IOException) -> throwError . FsError $ show e

runFileSystemPure :: Error FsError :> es => M.Map FilePath String -> Eff (FileSystem : es) a -> Eff es a
runFileSystemPure fs0 = reinterpret (evalState fs0) $ \_ -> \case
  ReadFile path ->
    gets (M.lookup path) >>= \case
      Just contents -> pure contents
      Nothing -> throwError . FsError $ "File not found: " ++ show path
  WriteFile path contents -> modify $ M.insert path contents

action :: (FileSystem :> es) => Eff es Bool
action = do
  file <- readFile "nix-managed.cabal"
  pure $ not (null file)

-- >>>:t action
-- action :: (FileSystem :> es) => Eff es Bool

-- >>>runEff . runError @FsError . runFileSystemIO $ action
-- Right True

-- >>>runPureEff . runErrorNoCallStack @FsError . runFileSystemPure M.empty $ action
-- Left (FsError "File not found: \"nix-managed.cabal\"")

data Profiling :: Effect where
  Profile :: String -> m a -> Profiling m a

type instance DispatchOf Profiling = Dynamic

profile :: (HasCallStack, Profiling :> es) => String -> Eff es a -> Eff es a
profile label action = send (Profile label action)

runProfiling :: IOE :> es => Eff (Profiling : es) a -> Eff es a
runProfiling = interpret $ \env -> \case
  Profile label action -> localSeqUnliftIO env $ \unlift -> do
    t1 <- getMonotonicTime
    r <- unlift action
    t2 <- getMonotonicTime
    putStrLn $ "Action '" ++ label ++ "' took " ++ show (t2 - t1) ++ " seconds."
    pure r

runNoProfiling :: Eff (Profiling : es) a -> Eff es a
runNoProfiling = interpret $ \env -> \case
  Profile label action -> localSeqUnlift env $ \unlift -> unlift action

action1 :: (Profiling :> es, IOE :> es) => Eff es ()
action1 = profile "greet" . liftIO $ putStrLn "Hello!"

testProfiling :: IO ()
testProfiling = runEff . runProfiling $ action1

testNoProfiling :: IO ()
testNoProfiling = runEff . runNoProfiling $ action1

class Monad m => MonadRNG m where
  randomInt :: m Int

randomString :: MonadRNG m => Int -> m String
randomString n = map chr <$> replicateM n randomInt

data RNG :: Effect where
  RandomInt :: RNG m Int

type instance DispatchOf RNG = Dynamic

instance RNG :> es => MonadRNG (Eff es) where
  randomInt :: (RNG :> es) => Eff es Int
  randomInt = send RandomInt

runDummyRNG :: Eff (RNG : es) a -> Eff es a
runDummyRNG = interpret $ \_ -> \case
  RandomInt -> pure 55

testDummy :: IO String
testDummy = runEff . runDummyRNG $ randomString 3

{-# HLINT ignore "Use tuple-section" #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

module Try.Exceptions.Exceptions where

import Control.Monad.Logger.CallStack
import Data.String.Interpolate
import GHC.Enum (Enum (..))
import UnliftIO (finally, timeout, tryAny)
import UnliftIO.Concurrent

oneSecond, fiveSeconds :: Int
oneSecond = 1000000
fiveSeconds = 5000000

main :: IO ()
main = runStdoutLoggingT do
  res <- timeout oneSecond $ do
    logInfo [i|Inside the timeout|]
    res <-
      tryAny $
        threadDelay fiveSeconds
          `finally` logInfo "Inside the finally"
    logInfo [i|Result: #{res}|]
  logInfo [i|After timeout: #{res}|]

module Try.Exceptions.Theory where

Exceptions

Safe exception handling
- Types of exceptions:
  - synchronous - generated in IO, thrown inside a single thread. Allow recovery and cleanup
  - asynchronous - generated from outside a thread. Allow cleanup, but no recovery
  - impure - generated in a pure code, thrown when a thunk gets evaluated.
    - Example: error
[Exceptions and concurrency] - YT
- use [safe-exceptions]

From Haskell in Depth (Chapter 7)

Avoid using exceptions when possible
Due to laziness, an exception in an expression doesn't happen until that expression gets evaluated.
A thread can be killed by other threads or the runtime system (due to memory exhaustion, etc.)
Types of exceptions:
- programmable
  - used in pure monad stacks (e.g., ExceptT)
- extensible
  - Extensions thrown anywhere, caught only in IO
  - Supported by the GHC runtime system
  - imprecise exceptions - thrown in pure code, order unspecified by the runtime system
  - All exceptions have an instance of Exception and are values of the SomeException type
packages - exceptions, safe-exceptions

{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Avoid lambda" #-}
{-# HLINT ignore "Use section" #-}
{-# HLINT ignore "Redundant lambda" #-}
{-# HLINT ignore "Redundant bracket" #-}

module Try.Functions.Composition where

import Control.Monad.Fix (fix)

-- Is
-- (. (+)) . (.) . (*)
-- equivalent to
-- \a b c -> a * (b + c)
-- ?

-- (.) :: (b -> c) -> (a -> b) -> a -> c

s = (. (+)) . (.) . (*)

-- infixr 9  .
-- f . g . h ~ f . (g . h)
s1 = (. (+)) . ((.) . (*))

-- (.) f g = \x -> f (g x)
s2 = (. (+)) . (\x -> (.) ((*) x))

-- f . g = \x -> f (g x)
s3 = \y -> (. (+)) ((\x -> (.) ((*) x)) y)

-- a = \x -> b ~ a x = b
s4 y = (. (+)) ((\x -> (.) ((*) x)) y)

-- (\x -> f) y ~ [y/x]f
s5 y = (. (+)) ((.) ((*) y))

-- (\a b -> a `op` b) f = \b -> f `op` b
-- (.) f = \g -> f . g
s6 y = (. (+)) (\z -> ((*) y) . z)

-- (.) f g = \x -> f (g x)
s7 y = (. (+)) (\z i -> ((*) y) (z i))

-- (\a b -> a `op` b) f ~ \b -> f `op` b
-- (*) f = \g -> f * g
s8 y = (. (+)) (\z i -> y * z i)

-- (`op` g) f ~ f `op` g
-- (. (+)) f ~ f . (+)
s9 y = (\z i -> y * z i) . (+)

-- f . g ~ \x -> f (g x)
s10 y = \p -> (\z i -> y * z i) ((+) p)

s11 y p = (\z i -> y * z i) ((+) p)

-- (\x -> f) y ~ [y/x]f
s12 y p = \i -> y * ((+) p) i

-- a = \x -> b ~ a x = b
s13 y p i = y * (p + i)

-- alpha reduction
s14 a b c = a * (b + c)

-- >>> s1 3 5 6 == s12 3 5 6
-- True

-- >>> s1 4 98 12 == s12 4 98 12
-- True

{-# LANGUAGE LambdaCase #-}

module Try.Functions.Folds where

import Control.Monad.Fix (fix)
import Data.List (scanl')

calc l1 = reverse $ fix (\go s acc -> \case (x : xs) -> go (s - x) (s : acc) xs; [] -> s : acc) (sum l1) [] l1

-- >>> calc [3,5,6]
-- [14,11,6,0]

calc1 l1 = reverse $ scanr (flip (-)) (sum l1) (reverse l1)

-- >>> calc1 [3,5,6]
-- [14,11,6,0]

calc2 l1 = scanl' (-) (sum l1) l1

-- >>> calc2 [3,5,6]
-- [14,11,6,0]

module Try.Functions.General (main) where

import Data.Function ((&))

-- How to declare a function? What are the function declaration parts?
-- What is the type (type signature) of a function?
main :: IO ()
main = putStrLn "Hello, world!"

-- Is it possible to declare a function without specifying its type signature? Can it cause problems, and if so, which ones?

-- But I want a Monoid
f1 :: Semigroup a => a -> a
f1 a = a <> a

-- How and when the let... in... expression is used?
f2 :: Num a => a -> a
f2 a = let b = 3 in a + b

-- How and when the where... clause is used?
f3 :: Integer
f3 = h'
 where
  h' = 3

-- Function application:

-- What is the difference between the following ways to apply a function:
-- f x (function application syntax), $ operator, & operator?
f4 :: (a -> b -> c) -> c
f4 s = t4
 where
  x = undefined :: a
  y = undefined :: b
  -- left assoc
  _ = s x
  -- left assoc
  _ = x & s
  t3 :: a -> b
  t3 _ = y
  -- right assoc
  t4 = s x $ t3 x

-- Why do they exist?
-- To apply functions in syntactically different ways

-- What is their precedence and associativity?
-- function application - left assoc, precedence 10 - https://stackoverflow.com/a/71032921
-- infixl 1 &
-- infixr 0 $

-- What is partial application?

-- What functions can be applied partially?
-- Those having at least one argument

-- Why there are no function arguments with default values in Haskell?
-- Functions should be total in arguments

-- Sectioning:
-- What is section?
-- https://wiki.haskell.org/Section_of_an_infix_operator

-- Which functions could be used in sections?
-- Any infix

-- Could you use other than binary functions in sections?
-- Yes. Due to the right associativity of function type

f5 :: a -> b -> c -> d
f5 = undefined
 where
  x = undefined :: a
  y = undefined :: b
  g = (x `f5`) y

-- Function application precedence:

-- What are the possible values for precedence in Haskell?
-- 1 - 9

-- What is associativity of operators?
-- It defines how to parenthesize the expressions using that operator
-- 3 * 4 * 5 -> (3 * 4) * 5

-- How does it differ from associativity as a mathemathical property?
-- Mathematical associativity property states that for an operator *
-- (a * b) * c = a * (b * c)

-- Is the function application syntax associative? In other words, is (a b) c identical to a (b c)?
-- No

-- What are the possible values for associativity in Haskell?
-- infixl, infixr

-- Function composition:
-- How function composition operator is declared? What are its precedence and associativity?
-- infixr 9 .

f6 :: c -> c
f6 = id . id

-- Is function composition mathematically associative?
-- Yes

f7 :: (c -> d) -> (b -> c) -> (a -> b) -> (a -> d)
f7 x y z = n1
 where
  n1 = (x . y) . z
  n2 = x . (y . z)

-- What is a tail recursion?
-- It's when the recursive call is the last statement executed by the function

-- What is a tail call optimization?
-- Turn recursion into a loop

-- Can you give examples of functions with and without tail call optimization?
f8 :: (Eq t, Num t) => t -> t
f8 0 = 0
f8 n = n + f8 (n - 1)

-- https://stackoverflow.com/a/13052612
f9 :: (Eq t, Num t) => t -> t -> t
f9 0 acc = acc
f9 n acc = f9 (n - 1) $! (acc + n)

Reinterpreting effects

This article assumes you are already familiar with defining effects and their handlers.

One of the nice aspects of effects is that they can support multiple effect handlers. Effects only specify actions, they don't actually perform them. Therefore, it's possible to "reinterpret" effects. There are multiple senses in which an effect can be reinterpreted:

Implementing an effect in terms of other effects. "Reinterpreting" effects is a powerful tool for cleanly dividing implementations into the relevant abstraction layers with minimal leakage of implementation details.
Rewriting an effect and/or performing actions with the effect value and then performing the originally intended effect. This technique is conceptually similar to the middleware pattern commonly used in web applications. This known as interposition (see works by Oleg Kiselyov et al.)

Let's explore both of these effect interpretation strategies with a small motivating example:

✨ We would like to implement a client library for an HTTP-based API that provides interesting cat facts. ✨

Let's break down some of the properties of the API client that would be desirable for a production use case:

We would like to have our cat facts API be able to support different cat fact data sources in the future.
We would like to be able to mock failure conditions (such as network connectivity issues) for testing purposes.
We would like to be able to track timing metrics for how quickly we can retrieve cat facts.

Initial setup

{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GADTs,
GeneralizedNewtypeDeriving, KindSignatures, OverloadedStrings, MultiParamTypeClasses,
RankNTypes, TypeApplications, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
module Try.FusedEffects.ReinterpretingEffects( main, main1, main2) where
-- from base
import Control.Applicative
import Data.Foldable (traverse_)
import Control.Exception (throwIO)
import Data.Kind (Type)
-- from fused-effects
import Control.Algebra
import Control.Carrier.Reader
import Control.Carrier.Error.Either
import Control.Carrier.Interpret
-- from transformers
import Control.Monad.IO.Class
-- From aeson
import Data.Aeson
-- From bytestring
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as L
-- From time
import Data.Time.Clock
-- From http-client
import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Client.Internal (Response(..), ResponseClose(..))
-- From http-client-tls
import qualified Network.HTTP.Client.TLS as HTTP
-- From http-types
import Network.HTTP.Types

Since one of the best parts about effects is being able to think at a domain language level,let's start with defining the desired data which we wish to retrieve and an interface that feels natural to work with:

-- | The basic fact that we will retrieve.
newtype CatFact = CatFact
  { catFact :: String
  }
  deriving (Show)

instance FromJSON CatFact where
  parseJSON = withObject "CatFact" (\o -> CatFact <$> o .: "text")

-- | Our high level effect type that will be able to target different data sources.
data CatFactClient (m :: Type -> Type) k where
  ListFacts ::
    -- | Number of facts to fetch
    Int ->
    CatFactClient m [CatFact]

listFacts :: Has CatFactClient sig m => Int -> m [CatFact]
listFacts n = send (ListFacts n)

Now that we have our very simple DSL in place, let's think about the underlying API: we know that it's an HTTP-based system, so let's introduce the notion of a handler that is provided a request and hands back an HTTP response.

data Http (m :: Type -> Type) k where
  SendRequest :: HTTP.Request -> Http m (HTTP.Response L.ByteString)

sendRequest :: Has Http sig m => HTTP.Request -> m (HTTP.Response L.ByteString)
sendRequest r = send (SendRequest r)

The listFacts function provides the ‘what’ of this API, and the sendRequest function provides the ‘how’. In decomposing this problem into a set of effects, each responsible for a single layer of the original problem description, we provide ourselves with a flexible, composable vocabulary rather than a single monolithic action.

"Stacking" effects

The production use-case

Now that we have these two mini-DSL effect types established, we need to stitch them together.

Let's take a moment to think about what could go wrong with an HTTP API from which we plan to fetch some JSON and convert it into a list of CatFacts.

We can conceive that the server might occasionally return a malformed JSON response:

newtype JsonParseError = JsonParseError String
  deriving (Show, Eq)

decodeOrThrow :: (Has (Throw JsonParseError) sig m, FromJSON a) => L.ByteString -> m a
decodeOrThrow = either (throwError . JsonParseError) pure . eitherDecode

A more HTTP-centric issue is that we might receive a content type we can't use. In this case, anything that's not application/json:

newtype InvalidContentType = InvalidContentType String
  deriving (Show, Eq)

Now we need to support fetching JSON given an HTTP request. We have no guarantee that an arbitrary HTTP request will actually return JSON, so for this implementation we have to account for failure conditions. This provides a great opportunity to see how effect handlers can actually rely on multiple underlying effects!

newtype CatFactsApi m a = CatFactsApi {runCatFactsApi :: m a}
  deriving
    ( Monad
    , Functor
    , Applicative
    , MonadIO
    , Alternative
    )

catFactsEndpoint :: HTTP.Request
catFactsEndpoint = HTTP.parseRequest_ "https://cat-fact.herokuapp.com/facts/random"

instance
  ( Has Http sig m
  , Has (Throw JsonParseError) sig m
  , Has (Throw InvalidContentType) sig m
  , Algebra sig m
  ) =>
  Algebra (CatFactClient :+: sig) (CatFactsApi m)
  where
  alg hdl sig ctx = case sig of
    L (ListFacts numberOfFacts) -> do
      resp <- sendRequest (catFactsEndpoint{HTTP.queryString = "?amount=" <> B.pack (show numberOfFacts)})
      case lookup hContentType (HTTP.responseHeaders resp) of
        Just "application/json; charset=utf-8" -> (<$ ctx) <$> decodeOrThrow (HTTP.responseBody resp)
        other -> throwError (InvalidContentType (show other))
    R other -> CatFactsApi (alg (runCatFactsApi . hdl) other ctx)

We implement a CatFacts effect handler that depends on three underlying effects:

Http - we need to be able to make requests
Throw JsonParseError - we need to be able to signal that some aspect of the JSON wasn't what we expected.
Throw InvalidContentType - we need to be able to signal what we got wasn't JSON at all!

The nice aspect of this is that we have neatly contained the failure scenarios to their relevant strata rather than leaking them into the higher-level abstraction (listFacts)!

Now we need to support performing HTTP requests:

newtype HttpClient m a = HttpClient {runHttp :: m a}
  deriving
    ( Monad
    , Functor
    , Applicative
    , MonadIO
    , Alternative
    )

instance (MonadIO m, Algebra sig m) => Algebra (Http :+: sig) (HttpClient m) where
  alg hdl sig ctx = case sig of
    L (SendRequest req) -> (<$ ctx) <$> liftIO (HTTP.getGlobalManager >>= HTTP.httpLbs req)
    R other -> HttpClient (alg (runHttp . hdl) other ctx)

Note for the above code snippets how the CatFactsApi carrier delegates fetching JSON to any other effect that supports retrieving JSON given an HTTP request specification.

Note as well that CatFactsApi itself doesn't know how to perform an HTTP request. It delegates the request itself to a handler that implements the Algebra class for (Http :+: sig).

Putting it all together for the actual production use case:

handlePrint :: Either InvalidContentType (Either JsonParseError [CatFact]) -> IO ()
handlePrint r =
  case r of
    Left invalidContentTypeError -> print invalidContentTypeError
    Right ok -> case ok of
      Left jsonParseError -> print jsonParseError
      Right facts -> traverse_ (putStrLn . catFact) facts

catFactsRunner :: Has Http sig m => m (Either InvalidContentType (Either JsonParseError [CatFact]))
catFactsRunner =
  runError @InvalidContentType $
    runError @JsonParseError $
      runCatFactsApi $
        listFacts 10

main :: IO ()
main = runHttp catFactsRunner >>= handlePrint

Produces:

The Bengal is the result of crossbreeding between domestic cats and Asian leopard cats, and its name is derived from the scientific name for the Asian leopard cat (Felis bengalensis).
A happy cat holds her tail high and steady.
Kittens remain with their mother till the age of 9 weeks.
Recent studies have shown that cats can see blue and green. There is disagreement as to whether they can see red.
A steady diet of dog food may cause blindness in your cat - it lacks taurine.
Cat owners are 25% likely to pick George Harrison as their favorite Beatle.
The catnip plant contains an oil called hepetalactone which does for cats what marijuana does to some people. Not all cats react to it those that do appear to enter a trancelike state. A positive reaction takes the form of the cat sniffing the catnip, then licking, biting, chewing it, rub & rolling on it repeatedly, purring, meowing & even leaping in the air.
The color of the points in Siamese cats is heat related. Cool areas are darker.
Cats have free-floating clavicle bones that attach their shoulders to their forelimbs, which allows them to squeeze through very small spaces.
Wikipedia has a recording of a cat meowing, because why not?

Testing with alternative effect handlers

Per point 2. of our initial implementation criteria, we want to be able to simulate failure cases for testing purposes. This is a great case for swapping in an alternative effect handler for our HTTP layer.

This time let's go from the bottom up. In situations where IO is involved, failure scenarios tend to surface from least-pure parts of code. In this case, we should therefore implement some facilities to experiment with the most failure-prone area: the network itself.

newtype MockHttpClient m a = MockHttpClient {runMockHttpClient :: ReaderC (HTTP.Request -> IO (HTTP.Response L.ByteString)) m a}
  deriving
    ( Monad
    , Functor
    , Applicative
    , MonadIO
    , Alternative
    )

runMockHttp :: (HTTP.Request -> IO (HTTP.Response L.ByteString)) -> MockHttpClient m a -> m a
runMockHttp responder m = runReader responder (runMockHttpClient m)

instance (MonadIO m, Algebra sig m) => Algebra (Http :+: sig) (MockHttpClient m) where
  alg hdl sig ctx = case sig of
    L (SendRequest req) -> do
      responder <- MockHttpClient ask
      (<$ ctx) <$> liftIO (responder req)
    R other -> MockHttpClient (alg (runMockHttpClient . hdl) (R other) ctx)

faultyNetwork :: HTTP.Request -> IO (HTTP.Response L.ByteString)
faultyNetwork req = throwIO (HTTP.HttpExceptionRequest req HTTP.ConnectionTimeout)

wrongContentType :: HTTP.Request -> IO (HTTP.Response L.ByteString)
wrongContentType req = pure resp
 where
  resp =
    Response
      { responseStatus = ok200
      , responseVersion = http11
      , responseHeaders = [("Content-Type", "text/xml")]
      , responseBody = "[{\"text\": \"Cats are not dogs\"}]"
      , responseCookieJar = mempty
      , responseClose' = ResponseClose (pure ())
      , responseOriginalRequest = req
      }

badJson :: HTTP.Request -> IO (HTTP.Response L.ByteString)
badJson req =
  pure
    Response
      { responseStatus = ok200
      , responseVersion = http11
      , responseHeaders = [("Content-Type", "application/json; charset=utf-8")]
      , responseBody = "{}"
      , responseCookieJar = mempty
      , responseClose' = ResponseClose (pure ())
      , responseOriginalRequest = req
      }

Let's update our main function and watch it in action:

main1 :: IO ()
main1 = do
  -- Should return JsonParseError
  runMockHttp badJson catFactsRunner >>= handlePrint
  -- Should return InvalidContentType
  runMockHttp wrongContentType catFactsRunner >>= handlePrint

Which returns:

JsonParseError "Error in $: parsing [] failed, expected Array, but encountered Object"
InvalidContentType "Just \"text/xml\""

With effects, we have fine-grained ways of testing slices of our API. All that's needed to turn an integration test into a unit test or vice versa is a different set of Algebra-implementing effect handlers!

Observing & altering effects

Building new effect handling algebras can be a little bit verbose. In simpler situations, we may want to simply operate on an effect without having to implement a whole new Algebra instance. We still have yet to build a solution to tracking operational metrics (like request timings), so let's look at how to build a sort of "effect middleware" using InterpretC.

InterpretC is an effect carrier that is intended for prototyping new effects that passes a callback function each occurence of the specified effect type that is called via send. One trick that can be useful is to intercept an effect, operate on the effect, and then re-send the effect (a.k.a. interposition). In other words, it's perfectly valid to have multiple handlers for the same effect type and dispatch to the ones higher in the effect stack! Let's use this approach to time and log our HTTP requests:

traceHttp ::
  (Has Http sig m, MonadIO m) =>
  (forall s. Reifies s (Interpreter Http m) => InterpretC s Http m a) ->
  m a
traceHttp = runInterpret $ \_ (SendRequest req) ctx -> do
  startTime <- liftIO getCurrentTime
  liftIO (putStr (B.unpack (HTTP.path req) ++ " ... "))
  -- Pass the request on to something that actually knows how to respond.
  resp <- sendRequest req
  -- Once the actual response is obtained,
  -- we can capture the end time and status of the response.
  endTime <- liftIO getCurrentTime
  let timeSpent = endTime `diffUTCTime` startTime
  liftIO $ putStrLn ("[" ++ show (statusCode $ HTTP.responseStatus resp) ++ "] took " ++ show timeSpent ++ "\n\n")
  pure (resp <$ ctx)

Updating our main function once more:

main2 :: IO ()
main2 = runHttp (traceHttp catFactsRunner) >>= handlePrint

Returns:

/facts/random ... [200] took 0.979107082s

Cats have a special scent organ located in the roof of their mouth, called the Jacobson's organ. It analyzes smells - and is the reason why you will sometimes see your cat "sneer" (called the flehmen response or flehming) when they encounter a strong odor.
It's important for cats to have regular ear exams—this is something you can do at home! Gently fold back the ears and look into the ear canal. The inner ear should be pale pink with little to no earwax. If you notice redness, swelling, discharge, or a lot of earwax, it's time to see a veterinarian.
Siamese kittens are born white because of the heat inside the mother's uterus before birth. This heat keeps the kittens' hair from darkening on the points.
Declawing a cat is the same as cutting a human's fingers off at the knuckle. There are several alternatives to a complete declawing, including trimming or a less radical (though more involved) surgery to remove the claws. Instead, train your cat to use a scratching post.
There is a species of cat smaller than the average housecat. It is native to Africa and it is the Black-footed cat (Felis nigripes). Its top weight is 5.5 pounds.
Gatos.
Cats are the most interesting mammals on earth.
Cats have free-floating clavicle bones that attach their shoulders to their forelimbs, which allows them to squeeze through very small spaces.
Fossil records from two million years ago show evidence of jaguars.
Since cats are so good at hiding illness, even a single instance of a symptom should be taken very seriously.

Conclusion

Reviewing our initial criteria, we have an eminently extensible system that lets us maintain a healthy separation of concerns– All while still allowing non-invasive behavior changes through the ability to intercept, rewrite, and resend effects!

We would like to have our cat facts API be able to support different cat fact data sources in the future.
We would like to be able to mock failure conditions (such as network connectivity issues) for testing purposes.
We would like to be able to track timing metrics for how quickly we can retrieve cat facts.

Mission accomplished

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}

module Try.FusedEffects.UndoIO (
  main1,
  main,
) where

import Control.Algebra (Algebra (alg), send, type (:+:) (L, R))
import Control.Applicative (Alternative)
import Control.Carrier.Error.Either (Catch, Has, Throw, catchError, runError, throwError)
import Control.Carrier.Fail.Either qualified as Fail
import Control.Carrier.Lift (sendM)
import Control.Carrier.State.Strict (StateC (..), runState)
import Control.Effect.Exception (Lift, bracket, try)
import Control.Exception.Lifted qualified as CL (bracket, catch, try)
import Control.Monad (MonadPlus, replicateM_)
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
import Control.Monad.Catch qualified as CE
import Control.Monad.Except (runExceptT)
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.State.Strict (MonadTrans (..))
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.Trans.Writer (WriterT (..))
import Control.Monad.Trans.Writer qualified as W (WriterT)
import Control.Monad.Writer.Class qualified as WC (MonadWriter, tell)
import Data.Data (Typeable)
import Data.Foldable (sequenceA_)
import Data.Functor (($>))
import Data.Functor.Identity (Identity (..))
import Data.Kind (Type)

data WriterStack w (m :: Type -> Type) k where
  Tell :: w -> WriterStack w m ()
  Listen :: m a -> WriterStack w m (w, a)
  Censor :: (w -> w) -> m a -> WriterStack w m a

tell :: forall w m sig. Has (WriterStack w) sig m => w -> m ()
tell = send . Tell

listen :: Has (WriterStack w) sig m => m a -> m (w, a)
listen = send . Listen

censor :: Has (WriterStack w) sig m => (w -> w) -> m a -> m a
censor f = send . Censor f

newtype WriterStackC w m a = WriterStackC {runWriterStackC :: StateC w m a}
  deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans)

runWriterStack :: forall w a m. Monoid w => WriterStackC w m a -> m (w, a)
runWriterStack (WriterStackC m) = runState mempty m

execWriterStack :: forall w a m. (Monoid w, Functor m) => WriterStackC w m a -> m w
execWriterStack = fmap fst . runWriterStack

instance (Monoid w, Algebra sig m) => Algebra (WriterStack w :+: sig) (WriterStackC w m) where
  alg hdl sig ctx =
    -- this is just to observe the type of hdl
    let hdl1 = hdl
     in WriterStackC $ case sig of
          L writer -> StateC $ \w -> case writer of
            Tell w1 -> do
              let !w2 = w1 <> w
              return (w2, ctx)
            Listen m -> do
              (w1, a) <- runWriterStack (hdl (m <$ ctx))
              let !w2 = w1 <> w
              return (w2, (w1,) <$> a)
            Censor f m -> do
              (w1, a) <- runWriterStack (hdl (m <$ ctx))
              let !w2 = f w1 <> w
              return (w2, a)
          R other -> alg (runWriterStackC . hdl) (R other) ctx

tell1 :: (Has (WriterStack [a]) sig m) => a -> m ()
tell1 a = tell [a]

l :: [Int]
l = (4 :: Int) <$ ([3, 2, 5] :: [Int]) $> 5

-- >>> l
-- [5,5,5]

type Log = [Int]

sl2 :: Log
sl2 = take 5 $
  (runIdentity . execWriterStack) do
    replicateM_ 1000000 (let !a = tell ([3] :: [Int]) in a)

-- >>> s2
-- [3,3,3,3,3]

someActions :: forall m sig. (MonadIO m, Has (WriterStack [Int]) sig m, Has (WriterStack [IO ()]) sig m) => m ()
someActions = do
  tell @[Int] [1, 2]
  tell @[IO ()] [putStr "world!\n"]
  tell @[IO ()] [putStr "Hello, "]

main1 :: IO ()
main1 = do
  s <- (fst <$>) $ runWriterStack @[IO ()] . runWriterStack @[Int] @() $ someActions
  sequenceA_ s

main :: IO ()
main = print "Hello, world!"

Writer and exceptions

Using `Lift IO`

data FileError = WriteError FilePath | ReadError FilePath deriving (Typeable, Show)

instance CE.Exception FileError

someActions1 :: forall m sig. (Has (Lift IO) sig m, Has (Throw FileError) sig m, Has (Catch FileError) sig m, Has (WriterStack [IO ()]) sig m) => m ()
someActions1 = flip catchError (\(_ :: FileError) -> tell @[IO ()] [putStr "Not hello, "]) do
  tell @[IO ()] [putStr "world!\n"]
  _ :: Either CE.SomeException () <-
    try $
      bracket
        (sendM $ readFile "SomeFile")
        (\_ -> tell @[IO ()] [print "File is here!"])
        (\_ -> tell @[IO ()] [print "File is not here!"])
  _ <- throwError $ ReadError "No such file"
  tell @[IO ()] [putStr "Hello, "]

main2 :: IO ()
main2 = do
  s <- (fst <$>) $ runWriterStack @[IO ()] . runError @FileError $ someActions1
  sequenceA_ s

main3 :: IO ()
main3 = do
  s <- runError @FileError . runWriterStack @[IO ()] $ someActions1
  case s of
    Left x -> print x
    Right (x, _) -> sequenceA_ x

Trying `mtl` stack

Still, Writer's log doesn't go into handlers

newtype MyStack e w a = MyStack {runMyStack :: ExceptT e (W.WriterT w IO) a}
  deriving (Functor, Applicative, Monad, WC.MonadWriter w, MonadIO, MonadMask, MonadCatch, MonadThrow)

someActions2 :: MyStack FileError [IO ()] ()
someActions2 = flip CE.catch (\(_ :: FileError) -> WC.tell [putStr "Not hello, "]) do
  WC.tell [putStr "world!\n"]
  _ :: Either CE.SomeException () <-
    CE.try $
      CE.bracket
        (liftIO $ readFile "SomeFile")
        (\_ -> WC.tell [putStr "File is here!"])
        (\_ -> WC.tell [putStr "File is not here!"])
  _ <- CE.throwM $ ReadError "No such file"
  WC.tell [putStr "Hello, "]
  return ()

main4 :: IO ()
main4 = do
  s <- (snd <$>) $ runWriterT . runExceptT . runMyStack $ someActions2
  sequenceA_ s

Trying lifted-base

someActions3 :: forall m sig. (MonadBaseControl IO m, Has (Lift IO) sig m, Has (Throw FileError) sig m, Has (WriterStack [IO ()]) sig m) => m ()
someActions3 = flip CL.catch (\(_ :: FileError) -> tell @[IO ()] [putStr "Not hello, "]) do
  tell @[IO ()] [putStr "world!\n"]
  _ :: Either CE.SomeException () <-
    CL.try $
      CL.bracket
        (sendM $ readFile "SomeFile")
        (\_ -> tell @[IO ()] [print "File is here!"])
        (\_ -> tell @[IO ()] [print "File is not here!"])
  _ <- throwError $ ReadError "No such file"
  tell @[IO ()] [putStr "Hello, "]

-- main5 :: IO ()
-- main5 = do
--   s <- (fst <$>) $ runWriterStack @[IO ()] . runError @FileError $ someActions3
--   sequenceA_ s

increment :: Int -> Int
increment x = x + 1

wrappedInt :: Maybe Int
wrappedInt = Just 3

wrappedIncrement :: Maybe (Int -> Int)
wrappedIncrement = Just increment

s1 :: (Int -> Int) -> (Maybe Int -> Maybe Int)
s1 = fmap

s1' :: (Int -> Int) -> (Maybe Int -> Maybe Int)
s1' = undefined

s2 :: Maybe (Int -> Int) -> (Maybe Int -> Maybe Int)
s2 = (<*>)

s2' :: Maybe (Int -> Int) -> (Maybe Int -> Maybe Int)
s2' = undefined

wrappingIncrement :: Int -> Maybe Int
wrappingIncrement x = Just (increment x)

s3 :: Int -> Maybe Int
s3 = pure

s3' :: Int -> Maybe Int
s3' = undefined

s4 :: Maybe Int -> (Int -> Maybe Int) -> Maybe Int
s4 = (>>=)

s4' :: Maybe Int -> (Int -> Maybe Int) -> Maybe Int
s4' = undefined

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Try.GADT.GADT where

GADTs

Wikibooks (src):

With GADTs, a constructor for Foo a is not obliged to return Foo a; it can return any Foo blah that you can think of.
```
data TrueGadtFoo a where
  MkTrueGadtFoo :: a -> TrueGadtFoo Int
```
- Still, need to use a relevant data constructor
```
data Foo where
  MkFoo :: Bar Int -- This will not typecheck
```
Support record syntax - src
- example
Is it considered a good practice to put constraints in consructors inside GADT declaration?
- No. Use a compiler to derive instances like Functor, put constraints in functions.

Heterogeneous list

src

data HList_ xs where
  HNil_ :: HList_ '[]
  (:::) :: a -> HList_ as -> HList_ (a ': as)

infixr 6 :::

hex :: HList_ '[Char, Integer, String]
hex = 'a' ::: 1 ::: "hello" ::: HNil_

Non-empty list

data Empty
data NonEmpty

data SafeList a b where
  Nil :: SafeList a Empty
  Cons :: a -> SafeList a b -> SafeList a NonEmpty

safeHead :: SafeList a NonEmpty -> a
safeHead (Cons a _) = a

safeTail :: SafeList a b -> a
safeTail (Cons a Nil) = a
safeTail (Cons _ b) = safeTail b

st1 :: Integer
st1 = safeTail $ Cons 3 (Cons 4 Nil)

-- >>>st1
-- 4

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ImpredicativeTypes #-}

module Try.Generics.Generics () where

import Data.Kind (Type)
import GHC.Generics (Generic, Rep)

data Tree a = Leaf a | Node (Tree a) (Tree a)
  deriving (Generic)

-- >>>:kind! forall a. Rep (Tree a)
-- forall a. Rep (Tree a) :: * -> *
-- = M1
--     D
--     ('MetaData "Tree" "TryGenerics" "main" 'False)
--     (M1
--        C
--        ('MetaCons "Leaf" 'PrefixI 'False)
--        (M1
--           S
--           ('MetaSel
--              'Nothing 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)
--           (K1 R a))
--      :+: M1
--            C
--            ('MetaCons "Node" 'PrefixI 'False)
--            (M1
--               S
--               ('MetaSel
--                  'Nothing 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)
--               (K1 R (Tree a))
--             :*: M1
--                   S
--                   ('MetaSel
--                      'Nothing 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)
--                   (K1 R (Tree a))))

-- no generic instance
data Empty1

-- >>>:kind! Rep Empty1
-- Rep Empty1 :: * -> *
-- = Rep Empty1

-- has generic instance
data Empty2 deriving (Generic)

-- >>>:kind! Rep Empty2
-- Rep Empty2 :: * -> *
-- = M1 D ('MetaData "Empty2" "TryGenerics" "main" 'False) V1

-- >>>:kind! Rep Bool
-- Rep Bool :: * -> *
-- = M1
--     D
--     ('MetaData "Bool" "GHC.Types" "ghc-prim" 'False)
--     (M1 C ('MetaCons "False" 'PrefixI 'False) U1
--      :+: M1 C ('MetaCons "True" 'PrefixI 'False) U1)

Representation of types with many constructors or many fields

data ManyFields a b c d e f g h i = A1 a b c d e f g h i deriving (Generic)

-- >>>:kind! forall a b c d e f g h i. Rep (ManyFields a b c d e f g h i)
-- forall a b c d e f g h i. Rep (ManyFields a b c d e f g h i) :: *
--                                                                 -> *
-- = M1
--     D
--     ('MetaData "ManyFields" "Try.Generics" "main" 'False)
--     (M1
--        C
--        ('MetaCons "A1" 'PrefixI 'False)
--        (((M1
--             S
--             ('MetaSel
--                'Nothing 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)
--             (K1 R a)
--           :*: M1
--                 S
--                 ('MetaSel
--                    'Nothing 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)
--                 (K1 R b))
--          :*: (M1
--                 S
--                 ('MetaSel
--                    'Nothing 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)
--                 (K1 R c)
--               :*: M1
--                     S
--                     ('MetaSel
--                        'Nothing 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)
--                     (K1 R d)))
--         :*: ((M1
--                 S
--                 ('MetaSel
--                    'Nothing 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)
--                 (K1 R e)
--               :*: M1
--                     S
--                     ('MetaSel
--                        'Nothing 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)
--                     (K1 R f))
--              :*: (M1
--                     S
--                     ('MetaSel
--                        'Nothing 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)
--                     (K1 R g)
--                   :*: (M1
--                          S
--                          ('MetaSel
--                             'Nothing 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)
--                          (K1 R h)
--                        :*: M1
--                              S
--                              ('MetaSel
--                                 'Nothing 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)
--                              (K1 R i))))))

data ManyConstructors = B1 | C1 | D1 | E1 | F1 | G1 | H1 | I1 | J deriving (Generic)

-- >>>:kind! Rep ManyConstructors
-- Rep ManyConstructors :: * -> *
-- = M1
--     D
--     ('MetaData "ManyConstructors" "Try.Generics" "main" 'False)
--     (((M1 C ('MetaCons "B1" 'PrefixI 'False) U1
--        :+: M1 C ('MetaCons "C1" 'PrefixI 'False) U1)
--       :+: (M1 C ('MetaCons "D1" 'PrefixI 'False) U1
--            :+: M1 C ('MetaCons "E1" 'PrefixI 'False) U1))
--      :+: ((M1 C ('MetaCons "F1" 'PrefixI 'False) U1
--            :+: M1 C ('MetaCons "G1" 'PrefixI 'False) U1)
--           :+: (M1 C ('MetaCons "H1" 'PrefixI 'False) U1
--                :+: (M1 C ('MetaCons "I1" 'PrefixI 'False) U1
--                     :+: M1 C ('MetaCons "J" 'PrefixI 'False) U1))))

Defining datatype-generic functions

https://hackage.haskell.org/package/base-4.18.0.0/docs/GHC-Generics.html#g:10

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}

module Try.IO.RandomNumbers (main) where

import Control.Monad.Fix (fix)
import Data.Binary (decode, encode)
import Data.ByteString qualified as BS
import Data.ByteString.Builder (intDec, toLazyByteString)
import Data.ByteString.Char8 qualified as BSC
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Lazy.Char8 qualified as LBSC
import Data.Foldable (Foldable (..))
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.HashMap.Strict qualified as M
import GHC.IO.Handle.FD (withFile)
import GHC.IO.IOMode (IOMode (..))
import System.Random (newStdGen)
import System.Random.Stateful (Random (..))

nNumbers :: Int
nNumbers = 70 * 1024 * 1024

fname :: FilePath
fname = "tmp/file-1"

bounds :: (Int, Int)
bounds = (1, 10000)

-- | write generated numbers into a file
writeNumbers :: IO ()
writeNumbers = do
  print "generating numbers"
  g <- newStdGen
  let randomStream :: [Int] = randomRs bounds g
  LBS.writeFile fname $ LBSC.unwords (toLazyByteString . intDec <$> take nNumbers randomStream)

kb :: Int
kb = 1024

chunkSize :: Int
chunkSize = 16 * kb

type MyState = (M.HashMap Int Int, LBS.ByteString)

-- | count numbers while reading the file in fixed chunks
-- and inserting them into a map in one go
countNumbersChunks :: IO ()
countNumbersChunks = do
  print "counting numbers (chunks)"
  print . sum . fst
    =<< withFile
      fname
      ReadMode
      ( \h -> do
          fix
            ( \(ret :: MyState -> IO MyState) statePrev@(!quantities, unparsed) -> do
                chunk_ <- LBS.hGet h chunkSize
                let
                  newChunk = unparsed <> chunk_
                  stateNew =
                    foldl'
                      ( \(!qs, !unparsed_) (!y) ->
                          maybe
                            (qs, y)
                            (\(x_, _) -> (M.insertWith (+) x_ 1 qs, ""))
                            (LBSC.readInt y)
                      )
                      statePrev
                      (LBSC.words newChunk)

                (if LBS.null chunk_ then return else ret) stateNew
            )
            (M.empty, "")
      )

-- | count numbers using lazy bytestring's @readFile@
countNumbersReadFile :: IO ()
countNumbersReadFile = do
  print "counting numbers (readFile)"
  print
    . sum
    . M.fromListWith (+)
    . fmap (maybe undefined ((,1) . fst) . LBSC.readInt)
    . LBSC.words
    =<< LBS.readFile fname

main :: IO ()
main = do
  countNumbersChunks

Trying serialization

nums :: [Int]
nums = [1, 3, 4, 4, 5, 2, 5]

-- binary <= 0.8.9.1
-- binary isn't human-readable

s :: [Int]
s = decode . encode $ [1 :: Int, 2, 3]

-- >>> s
-- [1,2,3]

-- bytestring

tryConvertLBS' :: [Maybe (Int, LBSC.ByteString)]
tryConvertLBS' = LBSC.readInt <$> LBSC.words (LBSC.unwords (toLazyByteString . intDec <$> nums))

-- >>> tryConvertLBS'
-- [Just (1,""),Just (3,""),Just (4,""),Just (4,""),Just (5,""),Just (2,""),Just (5,"")]

{-# LANGUAGE ImplicitParams #-}

module Try.ImplicitParams.ImplicitParams where

data C

f :: Bool -> C
f = undefined

-- так задаем
x :: C
x = let ?a = True; ?b = False in y

-- так используем
y :: (?b :: Bool, ?a :: Bool) => C
y = f ?a

{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Try.Lens.MissingKey where

import Control.Lens
import Data.Map
import qualified Data.Map as Map
import GHC.Generics (Generic)

mp1 :: Map.Map String (Map.Map String Int)
mp1 = Map.fromList [("a", Map.fromList [("c", 3), ("d", 5)])]

t = mp1 ^? ix "a" . ix "d"

-- >>> t
-- Just 5

class Ixed m => PathIxed m where
  pat :: Index m -> Prism' ([Index m], Maybe m) (([Index m], Maybe (IxValue m)), m)
  pat' :: (PathIxed m, Applicative f, s ~ ([Index m], Maybe (IxValue m)), a ~ ([Index m], Maybe m)) => Index m -> (s -> f s) -> (a -> f a)
  pat' x = pat x . _1

instance Ord a => PathIxed (Map a b) where
  pat p = prism embed match
   where
    embed :: (([a], Maybe b), Map a b) -> ([a], Maybe (Map a b))
    embed ((path, v), parent) = (path <> [p], v >>= \v' -> pure (Map.insert p v' parent))

    match :: ([a], Maybe (Map a b)) -> Either ([a], Maybe (Map a b)) (([a], Maybe b), Map a b)
    match (path, m) =
      case m of
        Nothing -> Left (path <> [p], Nothing)
        Just m' ->
          case Map.lookup p m' of
            Nothing -> Left (path <> [p], Nothing)
            Just p' -> Right ((path <> [p], Just p'), m')

t1 = ([], Just mp1) ^? pat' "a" . pat' "c"

-- >>> t1
-- Just (["a","c"],Just 3)

t2 = matching' (pat' "c") ([], Just mp1)

-- >>> t2
-- Left (["c"],Nothing)

t3 = matching' (pat' "c" . pat' "d") ([], Just mp1)

-- >>> t3
-- Left (["c"],Nothing)

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Try.Lens.Node where

import Control.Lens (Iso, Iso', Plated, cosmos, filtered, has, ifiltered, indexing, iso, only, reversed, taking, traverseOf, traversed, (&), (<&>), (<.), (^.), (^..), (^@..))
import Control.Lens.Plated (Plated (plate))
import Data.Data (Data)
import Data.Generics.Labels ()
import GHC.Generics (Generic)

data Node f a = Node
  { nodeData :: a
  , nodeName :: String
  , nodeChildren :: [Node f a]
  }
  deriving stock (Data, Generic)

tree :: Node f Int
tree =
  Node
    { nodeData = 3
    , nodeName = "1"
    , nodeChildren =
        [ Node
            { nodeData = 4
            , nodeName = "2"
            , nodeChildren =
                [ Node{nodeData = 5, nodeName = "1", nodeChildren = []}
                ]
            }
        , Node
            { nodeData = 6
            , nodeName = "1"
            , nodeChildren =
                [ Node
                    { nodeData = 7
                    , nodeName = "2"
                    , nodeChildren =
                        [ Node{nodeData = 8, nodeName = "3", nodeChildren = []}
                        ]
                    }
                ]
            }
        ]
    }

changeTraversalOrderTo :: forall t2 t1 a. Iso' (Node t1 a) (Node t2 a)
changeTraversalOrderTo = iso change change
 where
  change Node{..} = Node{nodeChildren = nodeChildren ^.. traversed . changeTraversalOrderTo, ..}

ex :: forall f. Plated (Node f Int) => Node f Int -> [(Int, Int)]
ex tree = tree ^@.. changeTraversalOrderTo @f . indexing cosmos <. filtered (has (#nodeName . only "1")) . #nodeData

data InOrder

instance Plated (Node InOrder a) where
  plate f Node{..} = do
    nodeChildren <- traverse f nodeChildren
    pure Node{..}

-- >>> ex @InOrder tree
-- [(0,3),(2,5),(3,6)]

data WeirdOrder

instance (Num a, Ord a) => Plated (Node WeirdOrder a) where
  plate f Node{..} = do
    nodeChildren <- traverseOf (\a b -> (<>) <$> (traversed . ifiltered (\i v -> odd i && nodeData <= 4)) a b <*> traversed a b) f nodeChildren
    pure $ Node{..}

-- >>> ex @WeirdOrder tree
-- [(0,3),(1,6),(5,5),(6,6)]

module Try.Misc.Determinant where

import Data.Matrix (Matrix, detLU, matrix)

m1 :: Matrix Double
m1 = matrix 3 3 (\(a, b) -> fromIntegral (a ^ b))

-- >>> m1
-- ┌                ┐
-- │  1.0  1.0  1.0 │
-- │  2.0  4.0  8.0 │
-- │  3.0  9.0 27.0 │
-- └                ┘

det :: Double
det = detLU m1

-- >>> det
-- 12.0

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}

module Try.Monads.FunctionalDependencies where

import Data.Functor ((<&>))

-- Fundeps exercise - https://www.fpcomplete.com/haskell/tutorial/fundeps/#exercises

newtype PersonReader a = PersonReader {runPersonReader :: Person -> a}
  deriving (Functor, Applicative, Monad)

class Monad m => MonadReader env m | m -> env where
  ask :: m env

data Person = Person
  { nameP :: String
  , ageP :: Int
  }
  deriving (Show)

askAge :: MonadReader Person m => m Int
askAge = ask <&> ageP

askName :: MonadReader Person m => m String
askName = ask <&> nameP

greeting :: forall m. (Monad m, MonadReader Person m) => m String
greeting = do
  name <- askName
  age <- askAge
  pure $ name ++ " is " ++ show age ++ " years old"

instance MonadReader Person PersonReader where
  ask :: PersonReader Person
  ask = PersonReader id

greetingId :: String
greetingId = runPersonReader (greeting @PersonReader) Person{nameP = "ah", ageP = 3}

-- >>>greetingId
-- "ah is 3 years old"

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TupleSections #-}
{-# HLINT ignore "Use gets" #-}
{-# HLINT ignore "Use asks" #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

module Try.Monads.MonadBaseControl where

import Control.Monad.Base (MonadBase)
import Control.Monad.Reader (MonadReader (ask), ReaderT (runReaderT))
import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT (runStateT))
import Control.Monad.Trans.Writer
import Data.Functor ((<&>))

https://lexi-lambda.github.io/blog/2019/09/07/demystifying-monadbasecontrol/

The essence of MonadBaseControl

Capture the action’s input state and close over it.
Package up the action’s output state with its result and run it.
Restore the action’s output state into the enclosing transformer.
Return the action’s result.

class MonadBase b m => MonadBaseControl b m | m -> b where
  type InputState m
  type OutputState m
  captureInputState :: m (InputState m)

  -- run monad with an input state and return a result and the output state in another monad
  -- we have access to the result of the first monad
  closeOverInputState :: m a -> InputState m -> b (a, OutputState m)
  restoreOutputState :: OutputState m -> m ()

instance MonadBaseControl IO IO where
  type InputState IO = ()
  type OutputState IO = ()
  captureInputState = pure ()
  closeOverInputState m () = m <&> (,())
  restoreOutputState () = pure ()

instance MonadBaseControl b m => MonadBaseControl b (StateT s m) where
  type InputState (StateT s m) = (s, InputState m)
  type OutputState (StateT s m) = (s, OutputState m)
  captureInputState = (,) <$> get <*> lift captureInputState
  closeOverInputState m (s, ss) = do
    ((v, s'), ss') <- closeOverInputState (runStateT m s) ss
    pure (v, (s', ss'))
  restoreOutputState (s, ss) = lift (restoreOutputState ss) *> put s

instance MonadBaseControl b m => MonadBaseControl b (ReaderT r m) where
  type InputState (ReaderT r m) = (r, InputState m)
  type OutputState (ReaderT r m) = OutputState m
  captureInputState = (,) <$> ask <*> lift captureInputState
  closeOverInputState m (r, s) = closeOverInputState (runReaderT m r) s
  restoreOutputState s = lift (restoreOutputState s)

instance (MonadBaseControl b m, Monoid w) => MonadBaseControl b (WriterT w m) where
  type InputState (WriterT w m) = InputState m
  type OutputState (WriterT w m) = (w, OutputState m)
  captureInputState = lift captureInputState
  closeOverInputState m ss = do
    ((v, s'), ss') <- closeOverInputState (runWriterT m) ss
    pure (v, (s', ss'))
  restoreOutputState (s, ss) = lift (restoreOutputState ss) *> tell s

{-# LANGUAGE BlockArguments #-}
{-# HLINT ignore "Use newtype instead of data" #-}

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TupleSections #-}

{-# HLINT ignore "Use <$>" #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

module Try.Monads.Monads where

State

newtype State s a = State {runState :: s -> (a, s)}

instance Functor (State s) where
  fmap :: (a -> b) -> State s a -> State s b
  fmap f s = pure f <*> s

instance Applicative (State s) where
  pure :: a -> State s a
  pure x = State (x,)
  (<*>) :: State s (a -> b) -> State s a -> State s b
  f <*> x = do
    f1 <- f
    x1 <- x
    return $ f1 x1

instance Monad (State s) where
  return :: a -> State s a
  return = pure
  (>>=) :: State s a -> (a -> State s b) -> State s b
  (State f) >>= y = State $ \s ->
    let (a1, s1) = f s
        State x = y a1
        (a2, s2) = x s1
     in (a2, s2)

get :: State s s
get = State $ \s -> (s, s)

put :: s -> State s ()
put s = State $ const ((), s)

expr :: State s ()
expr = do
  t1 <- get
  put t1

expr1 :: ((), Int)
expr1 = flip runState 3 do
  t1 <- get
  put (t1 + 2)

-- >>>expr1
-- ((),5)

Cont

newtype Cont r a = Cont {runCont :: (a -> r) -> r} deriving (Functor)

instance Applicative (Cont r) where
  pure :: a -> Cont r a
  pure x = Cont ($ x)
  (<*>) :: Cont r (a -> b) -> Cont r a -> Cont r b
  (Cont f) <*> (Cont x) = Cont $ \y -> f $ \k -> x $ y . k

instance Monad (Cont r) where
  return :: a -> Cont r a
  return = pure
  (>>=) :: Cont r a -> (a -> Cont r b) -> Cont r b
  (Cont f) >>= x = Cont $ \b -> f $ \a -> runCont (x a) $ \t -> b t

ContT

data ContT r m a = ContT {runContT :: (a -> m r) -> m r} deriving (Functor)

instance Applicative (ContT r m) where
  pure :: a -> ContT r m a
  pure x = ContT ($ x)
  (<*>) :: ContT r m (a -> b) -> ContT r m a -> ContT r m b
  (ContT f) <*> (ContT x) = ContT $ \y -> f $ \k -> x $ y . k

instance Monad (ContT r m) where
  return :: a -> ContT r m a
  return = pure
  (>>=) :: ContT r m a -> (a -> ContT r m b) -> ContT r m b
  (ContT f) >>= x = ContT $ \b -> f $ \a -> runContT (x a) $ \t -> b t

module Try.Monoids.FizzBuzz where

import Control.Monad (guard)
import Data.Maybe (fromMaybe)

f :: [Integer] -> [String]
f =
  let (m ~> str) x = str <$ guard (x `mod` m == 0)
   in map (fromMaybe . show <*> 3 ~> "fizz" <> 5 ~> "buzz")

-- >>> f [1..100]
-- ["1","2","fizz","4","buzz","fizz","7","8","fizz","buzz","11","fizz","13","14","fizzbuzz","16","17","fizz","19","buzz","fizz","22","23","fizz","buzz","26","fizz","28","29","fizzbuzz","31","32","fizz","34","buzz","fizz","37","38","fizz","buzz","41","fizz","43","44","fizzbuzz","46","47","fizz","49","buzz","fizz","52","53","fizz","buzz","56","fizz","58","59","fizzbuzz","61","62","fizz","64","buzz","fizz","67","68","fizz","buzz","71","fizz","73","74","fizzbuzz","76","77","fizz","79","buzz","fizz","82","83","fizz","buzz","86","fizz","88","89","fizzbuzz","91","92","fizz","94","buzz","fizz","97","98","fizz","buzz"]

module Try.ParallelAndConcurrentHaskell.Exceptions where

import UnliftIO

Exceptions

Form a hierarchy

Catching

Some handlers

try :: Exception e => IO a -> IO (Either e a)
handle :: Exception e => (e -> IO a) -> IO a -> IO a
onException :: IO a -> IO b -> IO a

onException rethrows the exception. Example:

bracket before after thing =
  mask $ \restore -> do
    a <- before
    r <- restore (thing a) `onException` after a
    _ <- after a
    return r

catchJust, handleJust select an exception by a predicate.

Throwing
- throwIO :: Exception e => e -> IO a guarantees the ordering of exceptions
- throw :: Exception e => e -> a doesn't

Processing actions with possible exceptions

bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
finally :: IO a -> IO b -> IO a

Cancellation and Timeouts

Masking

mask :: ((IO a -> IO a) -> IO b) -> IO b

The mask operation defers the delivery of asynchronous exceptions for the duration of its argument.

Here, asynchronous exceptions can only be delivered inside the argument of restore - inside f a.

problem :: MVar a -> (a -> IO a) -> IO ()
problem m f = mask $ \restore -> do
  a <- takeMVar m
  r <- restore (f a) `catchAny` \e -> do putMVar m a; throwIO e
  putMVar m r

mask is applied to a function, which takes as its argument a function restore. The restore function can be used to restore the delivery of asynchronous exceptions to its present state during execution of the argument to mask. If we imagine shading the entire argument to mask except for the expression (f a), asynchronous exceptions cannot be raised in the shaded portions.

Interruptibility

An interruptible operation may receive an asynchronous exception only if it actually blocks. In the case of problem above, we know the MVar is definitely empty when we call putMVar, so putMVar cannot block, which means that it is not interruptible.

Get current masking state

getMaskingState :: IO MaskingState

data MaskingState
  = Unmasked
  | MaskedInterruptible
  | MaskedUninterruptible

The getMaskingState function returns one of the following construc‐ tors:

Unmasked - The current thread is not inside mask or uninterruptibleMask.
MaskedInterruptible - The current thread is inside mask.
MaskedUninterruptible - The current thread is inside uninterruptibleMask.

Multiple MVars

modifyMVar and company first takeMVar, then putMVar.

modifyTwo :: MVar a -> MVar b -> (a -> b -> IO (a, b)) -> IO ()
modifyTwo ma mb f =
  modifyMVar_ mb $ \b ->
    modifyMVar ma $ \a -> f a b

If this blocks in the inner modifyMVar and an exception is raised, then the outer modifyMVar_ will restore the contents of the MVar it took.

Bracket

bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket before after thing =
  mask $ \restore -> do
    a <- before
    r <- restore (thing a) `onException` after a
    _ <- after a
    return r

The IO actions passed in as before and after are performed inside mask. The bracket function guarantees that if before returns, after will be executed in the future. It is normal for before to contain a blocking operation; if an exception is raised while before is blocked, then no harm is done. But before should perform only one blocking oper‐ ation. An exception raised by a second blocking operation would not result in after being executed. If you need to perform two blocking operations, the right way is to nest calls to bracket, as we did with modifyMVar. Something else to watch out for here is using blocking operations in after. If you need to do this, then be aware that your blocking operation is interruptible and might receive an asynchronous exception.

Timeouts

See

catchJust
timeout
throwTo
- it's always interruptible

Catching asynchronous exceptions

If you need to handle asynchronous exceptions, it’s usually important for the exception handler to be inside a mask so that you don’t get interrupted by another asynchronous exception before you’ve finished dealing with the first one. For that rea‐ son, catch or handle might be more appropriate, because you can take advantage of the built-in mask.

Don't handle exceptions inside a handler.

mask and forkIO

Use async

{-# LANGUAGE ScopedTypeVariables #-}

module Try.ParallelAndConcurrentHaskell.MVar where

import Control.Concurrent ()
import Control.Exception (SomeException (SomeException), catch, mask, throw)
import qualified Data.Map as Map
import UnliftIO (MVar, atomically, modifyMVar, modifyMVar_, newEmptyMVar, newMVar, newTMVarIO, putMVar, takeMVar, takeTMVar)

MVar

MVar as a Container for Shared State

MVars are lazy.

name :: String
name = "name"

number :: String
number = "number"

book :: Map.Map String String
book = Map.empty

p1 :: IO ()
p1 = do
  m <- newMVar book
  putMVar m (Map.insert name number book)

This places in the MVar the unevaluated expression Map.insert name number book.

Benefit: can unlock state and dont wait for insert to complete. Drawback: consecutive inserts may create thunks

Solution - evaluate to WHNF

p2 :: IO ()
p2 = do
  m <- newMVar book
  putMVar m $! Map.insert name number book

Fairness

No thread can be blocked indefinitely on an MVar unless another thread holds that MVar indefinitely.

In other words, if a thread T is blocked in takeMVar and there are regular putMVar operations on the same MVar, it is guaranteed that at some point thread T’s takeMVar will return. In GHC, this guarantee is implemented by keeping blocked threads in a FIFO queue attached to the MVar, so eventually every thread in the queue will get to complete its operation as long as there are other threads performing regular putMVar operations (an equivalent guarantee applies to threads blocked in putMVar when there are regular takeMVars). Note that it is not enough to merely wake up the blocked thread because another thread might run first and take (respectively put) the MVar, causing the newly woken thread to go to the back of the queue again, which would invalidate the fairness guarantee. The implementation must therefore wake up the blocked thread and perform the blocked operation in a single atomic step, which is exactly what GHC does.

A consequence of the fairness implementation is that, when multiple threads are blocked in takeMVar and another thread does a putMVar, only one of the blocked threads becomes unblocked. This “single wakeup” property is a particularly important performance char‐ acteristic when a large number of threads are contending for a single MVar. As we shall see later, it is the fairness guarantee—together with the single wakeup property—that keeps MVars from being completely subsumed by software transactional memory.

Deadlocks

thread A did takeMVar a >> putMVar b, thread B did putMVar b >> takeMVar a
- Executes
  1. takeMVar a - A
  2. putMVar b - B
  3. putMVar b - A sleeps
  4. takeMVar a - B sleeps

Solution: Always first takeMVar, then putMVar.

Atomicity

If a thread does takeMVar, the MVar becomes empty, so no other thread may takeMVar. Then, that thread does putMVar. If the MVar modification was successful, the whole operation seems atomic to other threads.

From Control.Concurrent.MVar:

In particular, the "bigger" functions in this module (swapMVar, withMVar, modifyMVar_ and modifyMVar) are simply the composition of a takeMVar followed by a putMVar with exception safety. These have atomicity guarantees only if all other threads perform a takeMVar before a putMVar as well; otherwise, they may block.

Foreign calls

-- TODO

{-# LANGUAGE NumericUnderscores #-}

module Try.ParallelAndConcurrentHaskell.STM where

import UnliftIO
import UnliftIO.Concurrent

Software Transactional memory

MVar

There may be a situation when have to take 2 MVars and need to order taking.

Thread 1 takes the MVar for desktop a.
Thread 2 takes the MVar for desktop b.
Thread 1 tries to take the MVar for desktop b and blocks.
Thread 2 tries to take the MVar for desktop a and blocks.

Deadlock

STM

Can make transactions.

The current thread is blocked until one of the TVars that it is reading is written to, at which point the thread is unblocked again and the transaction is rerun.

retry :: STM a

The meaning of retry is simply “abandon the current transaction and run it again.”

p :: IO (Int, Int)
p = do
  ta <- newTMVarIO 2
  tb <- newTMVarIO 3
  atomically $ do
    a <- takeTMVar ta
    b <- takeTMVar tb
    return (a, b)

This example is difficult to program with MVar because taking a single MVar is a side effect that is visible to the rest of the program, and hence cannot be easily undone if the other MVar is empty. One way to implement it is with a third MVar acting as a lock to control access to the other two, but then of course all other clients have to be aware of the locking protocol.

Merging with STM

orElse :: STM a -> STM a -> STM a

Combine two blocking transactions such that one is performed but not both.

The operation orElse a b has the following behavior:

First, a is executed. If a returns a result, then the orElse call returns it and ends.
If a calls retry instead, a’s effects are discarded_ and b is executed instead.

Async exceptions

Exceptions just discard transactions.

Async

With async, the calling thread isn't blocked when running an async action.
We can check Async a for a result or block on it
withAsync :: IO a -> (a -> IO b) -> IO b - when the function a -> IO b returns, IO a is killed.
- There's no contradiction. We can't use the value stored in a without calling wait a. But this will make the computation IO b to suspend until IO a finishes or throws an exception.
```
exAsync = withAsync (threadDelay 3_000_000 >> print "ping") (\a -> wait a >> print "pong")
```
retry restarts a transaction and blocks the thread until one of the variables that were read changes its value
Broadcasting channel (e.g., TMChan)

{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# HLINT ignore "Avoid lambda using `infix`" #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

module Try.TemplateHaskell.ConstructorTags.Declare where

import Control.Lens (Iso', iso, (&), (<>~))
import Control.Monad
import Language.Haskell.TH

data HydraEvent
  = GetUTxOResponse Int
  | TxValid Int

p1 :: Q [Dec]
p1 =
  [d|
    data HydraEvent
      = GetUTxOResponse Int
      | TxValid Int
    |]

-- >>> runQ p1
-- [DataD [] HydraEvent_159 [] Nothing [NormalC GetUTxOResponse_160 [(Bang NoSourceUnpackedness NoSourceStrictness,ConT GHC.Types.Int)],NormalC TxValid_161 [(Bang NoSourceUnpackedness NoSourceStrictness,ConT GHC.Types.Int)]] []]

data HydraEventKind
  = GetUTxOResponseKind
  | TxValidKind
  deriving stock (Eq, Show)

p2 :: Q [Dec]
p2 =
  [d|
    data HydraEventKind
      = GetUTxOResponseKind
      | TxValidKind
      deriving stock (Eq, Show)
    |]

-- >>> runQ p2
-- [DataD [] HydraEventKind_156 [] Nothing [NormalC GetUTxOResponseKind_157 [],NormalC TxValidKind_158 []] [DerivClause (Just StockStrategy) [ConT GHC.Classes.Eq,ConT GHC.Show.Show]]]

nm :: Iso' Name String
nm = iso from to
 where
  from = nameBase
  to = mkName

deriveTags :: Name -> String -> [Name] -> Q [Dec]
deriveTags ty suff classes = do
  (TyConI tyCon) <- reify ty
  (tyName, cs) <- case tyCon of
    DataD _ n _ _ cs _ -> pure (n, cs)
    NewtypeD _ n _ _ cs _ -> pure (n, [cs])
    _ -> fail "deriveTags: only 'data' and 'newtype' are supported"
  cs' <-
    forM
      cs
      ( let mk n = pure $ NormalC (n & nm <>~ suff) []
         in \case
              NormalC n _ -> mk n
              RecC n _ -> mk n
              _ -> fail "deriveTags: constructor names must be NormalC or RecC (See https://hackage.haskell.org/package/template-haskell-2.20.0.0/docs/src/Language.Haskell.TH.Syntax.html#Con)"
      )
  let v = DataD [] (tyName & nm <>~ suff) [] Nothing cs' [DerivClause (Just StockStrategy) (ConT <$> classes)]
  pure [v]

getHydraEventKind :: HydraEvent -> HydraEventKind
getHydraEventKind event = case event of
  GetUTxOResponse{} -> GetUTxOResponseKind
  TxValid{} -> TxValidKind

p3 :: Q [Dec]
p3 =
  [d|
    getHydraEventKind :: HydraEvent -> HydraEventKind
    getHydraEventKind event = case event of
      GetUTxOResponse{} -> GetUTxOResponseKind
      TxValid{} -> TxValidKind
    |]

-- >>> runQ p3
-- [SigD getHydraEventKind_168 (AppT (AppT ArrowT (ConT Try.TemplateHaskell.Declare.HydraEvent)) (ConT Try.TemplateHaskell.Declare.HydraEventKind)),FunD getHydraEventKind_168 [Clause [VarP event_169] (NormalB (CaseE (VarE event_169) [Match (RecP Try.TemplateHaskell.Declare.GetUTxOResponse []) (NormalB (ConE Try.TemplateHaskell.Declare.GetUTxOResponseKind)) [],Match (RecP Try.TemplateHaskell.Declare.TxValid []) (NormalB (ConE Try.TemplateHaskell.Declare.TxValidKind)) []])) []]]

deriveMapping :: Name -> String -> String -> Q [Dec]
deriveMapping ty suff mappingName = do
  (TyConI tyCon) <- reify ty
  (tyName, cs) <- case tyCon of
    DataD _ n _ _ cs _ -> pure (n, cs)
    NewtypeD _ n _ _ cs _ -> pure (n, [cs])
    _ -> fail "deriveTags: only 'data' and 'newtype' are supported"
  let
    sig = SigD (mkName mappingName) (AppT (AppT ArrowT (ConT ty)) (ConT (tyName & nm <>~ suff)))
  event <- newName "event"
  matches <-
    forM
      cs
      ( let mk n = pure $ Match (RecP n []) (NormalB (ConE (n & nm <>~ suff))) []
         in \case
              NormalC n _ -> mk n
              RecC n _ -> mk n
              _ -> fail "deriveTags: constructor names must be NormalC or RecC (See https://hackage.haskell.org/package/template-haskell-2.20.0.0/docs/src/Language.Haskell.TH.Syntax.html#Con)"
      )
  let
    fun = FunD (mkName mappingName) [Clause [VarP event] (NormalB (CaseE (VarE event) matches)) []]
  pure [sig, fun]

{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# HLINT ignore "Avoid lambda using `infix`" #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

module Try.TemplateHaskell.ConstructorTags.Use where

import Try.TemplateHaskell.ConstructorTags.Declare (HydraEvent (..), deriveMapping, deriveTags)

$(deriveTags ''HydraEvent "Kind" [''Show, ''Eq])
$(deriveMapping ''HydraEvent "Kind" "getKind")

{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# HLINT ignore "Avoid lambda using `infix`" #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

module Try.TemplateHaskell.Typed.Declare where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax

myFunc :: Q Exp
myFunc = [|\x -> x + 1|]

add2 :: Q Exp
add2 = [|$myFunc . $myFunc|]

runAdd2 :: (Quasi m) => m Exp
runAdd2 = runQ add2

-- >>> runAdd2
-- InfixE (Just (LamE [VarP x_2] (InfixE (Just (VarE x_2)) (VarE GHC.Num.+) (Just (LitE (IntegerL 1)))))) (VarE GHC.Base..) (Just (LamE [VarP x_3] (InfixE (Just (VarE x_3)) (VarE GHC.Num.+) (Just (LitE (IntegerL 1))))))

myFuncTyped :: Code Q (Integer -> Integer)
myFuncTyped = [||\x -> x + 1||]

runMyFuncTyped :: (Quasi m) => m Exp
runMyFuncTyped = runQ $ unTypeCode myFuncTyped

-- >>> runMyFuncTyped
-- LamE [VarP x_5] (InfixE (Just (VarE x_5)) (VarE GHC.Num.+) (Just (LitE (IntegerL 1))))

add2Typed :: Code Q (Integer -> Integer)
add2Typed = [||$$myFuncTyped . $$myFuncTyped||]

runAdd2Typed :: (Quasi m) => m Exp
runAdd2Typed = runQ $ unTypeCode add2Typed

-- >>> runAdd2Typed
-- InfixE (Just (LamE [VarP x_162] (InfixE (Just (VarE x_162)) (VarE GHC.Num.+) (Just (LitE (IntegerL 1)))))) (VarE GHC.Base..) (Just (LamE [VarP x_163] (InfixE (Just (VarE x_163)) (VarE GHC.Num.+) (Just (LitE (IntegerL 1))))))

{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# HLINT ignore "Avoid lambda using `infix`" #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

module Try.TemplateHaskell.Typed.Use where

import Try.TemplateHaskell.Typed.Declare (runAdd2Typed)

p = $(runAdd2Typed) 2

-- >>> p
-- 4

module Try.Test.Theory where

Testing

Property-based testing

Hedgehog, quickcheck
- examples: lima

-HiD, Chapter 8* Test types:

unit tests -
property-based tests - checking property on a number of inputs
golden tests - check against a reference file contents (tasty-golden)

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Try.TypeClasses.Monoid where

import Control.Monad (guard)

Monoid, Semigroup

From https://medium.com/@stackdoesnotwork/magical-monoids-50da92b069f4

-- f <> g = \x -> f x <> g x

expr1 :: [Char]
expr1 = (take 3 <> const "oi" <> drop 4) "Monads are cool!"

-- >>>expr1
-- "Monoids are cool!"

Guards

deleteIfNegative :: (Num a, Ord a) => a -> Maybe a
deleteIfNegative x = guard (x >= 0) >> pure x

expr2 :: [Maybe Int]
expr2 = [deleteIfNegative 3, deleteIfNegative (-3)]

-- >>>expr2
-- [Just 3,Nothing]

pyth :: [(Integer, Integer, Integer)]
pyth = do
  z <- [1 ..]
  x <- [1 .. z]
  y <- [x .. z]
  guard (x ^ 2 + y ^ 2 == z ^ 2)
  return (x, y, z)

expr3 :: [(Integer, Integer, Integer)]
expr3 = take 5 pyth

-- >>>expr3
-- [(3,4,5),(6,8,10),(5,12,13),(9,12,15),(8,15,17)]

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}

module Try.TypeClasses.Theory where

Type classes

The part before the => is the context, while the part after the => is the head of the instance declaration. - src
```
instance (assertion1, ..., assertion) => class type1 ... typem where ...
```
How are type classes implemented in Haskell?
- All You Wanted to Know About Type Classes
  - What is a dictionary?
    - A data type with class functions as fields
  - How is it defined and passed into functions? - src
    - embed Superclass dictionary into Subclass dictionary
```
newtype BaseD a = BaseD {base :: a -> Bool}
data Sub1D a = Sub1D
  { super1 :: BaseD a
  , sub1 :: a -> Bool
  }
```
  - Passed automatically by the compiler
Why using constraints on a type variable within a data declaration isn't a good idea?
- They make code less flexible and disallow some instances - SO
- Can be achieved by using GADTs
What is coherence and why is it important to maintain it? What are the possible cases of coherence violation?
- A program is coherent if it has exactly one meaning — i.e., its semantics is unambiguously determined.
- Coherence is when multiple type derivations are possible - SO
- For each different derivation a different class instance can be used. This may lead to different behaviors
- FlexibleInstances and MultiParamTypeClasses introduce incoherence
- Need to maintain coherence to write a program whose type checking (static) doesn't change its runtime (dynamic) properties
Overlapping
- How does the instance selection process happen?
  - Find an instance with satisfying B of (instance A => C B where)
  - Find instance for A
- Is it possible to have overlapping instances?
  - instance C a and instance C Bool
- Does having overlapping instances violate coherence?
  - No
- Basics of Haskell instance selection - src
- Is it possible to have a compiled and working program with coherence violations?
  - Yes - src (see example above)
- How would you solve a problem of overlapping instances in various situations?
  - Make the most specific instance discoverable using the fine-grained per-instance pragmas
  - Rewrite
    - instance {-# OVERLAPPABLE #-} C a and instance C Bool
    - instance C a and instance {-# OVERLAPPING #-} C Bool
    - OVERLAPS = both
Orphans
- What are orphan instances? Why are they undesirable?
  - An orphan instance is a type class instance for class C and type T which is neither defined in the module where C is defined nor in the module where T is defined. - src
  - Type class instances are special in that they don't have a name and cannot be imported explicitly. This also means that they cannot be excluded explicitly. All instances defined in a module A are imported automatically when importing A, or importing any module that imports A, directly or indirectly.
  - Orphans may break the functionality planned by the library author
  - Orphans invalidate file fingerprints (hash of a file made by GHC to check later if a file has changed) and transitively - in modules that import them - src
- How to deliver orphans?
  - Expose type and instance only together by putting orphans into modules and re-exporting them - src
    - Cons:
      - a user has to use your instances
      - your lib uses more dependencies
  - Define instances in a separate package - src
    - cons: need to track these packages
- Does having orphan instances violate coherence?
  - When orphans violate coherence:
    - If you actually import both instances, your program will fail to compile.
    - If you do not directly import both, but rather use two modules which independently use the differing instances, you can end up with incoherent behaviour.
- What are the pros and cons of isolating orphans in special modules?
  - Pros: less often fingerprints invalidation
  - Cons: need to recompile the whole project on changes in that module - src
How the problem of orphans and overlapping is solved in other languages or by different overloading implementation techniques?
- Scala
  - An orphan instance in Scala means an instance that exists neither in the type's companion object nor the type class' companion object - src
  - Import packages with type and instance declaration separately
What are the problems of current typeclasses implementation?
- There's no formal proof that instance resolution is coherent
Is there a problem of structuring the hierarchy of standard typeclasses?
What is Final Tagless (FT) style? - src
- Example:
  - wimble :: (MonadReader Env m, MonadState State m) => m ()
- Can extend in two dimensions
  1. a new interpreter (change implementation of MonadReader)
  2. a new set of operations (add a constraint like MonadWriter)
- Application monad (AM) - a monad for organizing effectful application code
  - FT can define AM
- Tagged Initial - sum types are represented as (tag, payload). tag - for pattern-matching
- Tagless Initial - use GADTs to ban nonsense expressions, no tags
- Final Tagless - use overloaded functions

Functor laws:

fmap id = id

fmap (f . g)  ==  fmap f . fmap g

Foldable

class Foldable t where

When using folds, one can force the evaluation of an accumulator
- deepseq - YT
- BangPatterns with pattern matching on the element of an accumulator to force.
```
-- >>> foldl (\(!a1, !a2) x -> (a1 + x, a2 + x)) (0, 0) [1..9]
-- (45,45)
```
foldl' - fold a list from the left: f (f (f x a1) a2) ... and have accumulator in WHNF.
- May need to force the accumulator
foldr - calculate the full list and fold it from the right: f (f (f x a5) a4) ....
- Can terminate early if an operation is strict in the left argument (like &&) - SO
- Can cause stack overflow as it has to evaluate the whole list first - wiki
```
-- >>> foldr (&&) False (repeat False)
-- False
```
fold :: (Foldable t, Monoid m) => t m -> m
- folds a container with elements that have a Monoid instance
```
-- >>> fold [Just "a", Nothing, Just "c"]
-- Just "ac"
```
foldMap :: (Foldable t, Monoid m) => (a -> m) -> t a -> m - maps each element of a container to a Monoid and folds the container
```
-- >>> foldMap Just ["a", "b", "c"]
-- Just "abc"
```

Alternative and MonadPlus

Haskell wikibooks:

Alternative

Definition

class Applicative f => Alternative f where
  empty :: f a
  (<|>) :: f a -> f a -> f a

There's no instance for Either a

As it's an associative operation, it produces the same result for either fold

-- >>> foldr (<|>) empty [Just "a", Nothing, Just "c", Nothing, Just "e"]
-- Just "a"

-- >>> foldl' (<|>) empty [Just "a", Nothing, Just "c", Nothing, Just "e"]
-- Just "a"

Traversable

Haskell wikibooks:

class (Functor t, Foldable t) => Traversable t where
  traverse :: (Applicative f) => (a -> f b) -> t a -> f (t b)
  sequenceA :: (Applicative f) => t (f a) -> f (t a)

  -- These methods have default definitions.
  -- They are merely specialised versions of the other two.
  mapM :: (Monad m) => (a -> m b) -> t a -> m (t b)
  sequence :: (Monad m) => t (m a) -> m (t a)

Contravariant

Contravariant

Profunctor

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Try.TypeClasses.TypeClasses where

Problem

Make a function that converts a Foo to TFoo Foo and other types to TA a. Avoid TypeApplications if possible.

data Foo = Foo
data Bar = Bar

data FooOrA a = TFoo Foo | TA a

class Convert a b where
  toFooOrA :: a -> FooOrA b

instance Convert Foo a where
  toFooOrA = TFoo

instance (a ~ b) => Convert a b where
  toFooOrA = TA

s1 :: Integer
s1 = case toFooOrA @Int 42 of
  TFoo _ -> 1
  TA _ -> 2

-- >>>s
-- 1

s2 :: Integer
s2 = case toFooOrA Bar of
  TFoo _ -> 1
  TA _ -> 2

-- >>>s2
-- 2

{-# LANGUAGE QuasiQuotes #-}

module Try.TypeFamilies.StringInterpolate where

import Data.ByteString
import Data.String.Interpolate (i)
import Data.Text

string-interpolate

Implementation explanation feat. Type families, Tagged Classes

b :: Integer
b = 3

d :: Text
d = [i|comm|]

s :: ByteString
s = [i|A #{b} -c #{d}|]

-- >>> s
-- "A 3 -c comm"

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Try.TypeFamilies.TaggedClasses where

Tagged classes

tagged-aeson

Instance Chains

PureScript provides Instance Chains.

Here's how they can be rewritten using Tagged Classes

source - purescript-barlow-lens

import Data.Kind (Constraint)
import GHC.TypeLits (AppendSymbol, Symbol)

data Tag
  = WhenDot
  | WhenSpace
  | WhenSame
  | Else

type SelectTag :: Symbol -> Symbol -> Symbol -> Symbol -> Tag
type family SelectTag head tail out rest where
  SelectTag "." t "." t = WhenDot
  SelectTag " " t "" t = WhenSpace
  SelectTag h "" h "" = WhenSame
  SelectTag _ _ _ _ = Else

type ParsePercentageSymbol' :: Tag -> Symbol -> Symbol -> Symbol -> Symbol -> Constraint
class ParsePercentageSymbol' tag head tail out rest

instance ParsePercentageSymbol' WhenDot "." t "" t
instance ParsePercentageSymbol' WhenSpace " " t "" t
instance ParsePercentageSymbol' WhenSame h "" h ""
instance (ParsePercentageSymbol th tt tout trest, t ~ AppendSymbol th tt, out ~ AppendSymbol h tout) => ParsePercentageSymbol' Else h t out trest

type ParsePercentageSymbol :: Symbol -> Symbol -> Symbol -> Symbol -> Constraint
type ParsePercentageSymbol h t o r = ParsePercentageSymbol' (SelectTag h t o r) h t o r

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
{-# OPTIONS_GHC -Wno-missing-kind-signatures #-}
{-# OPTIONS_GHC -Wno-unused-type-patterns #-}

module Try.TypeFamilies.Theory where

import Data.Functor.Identity ( Identity )
import Data.Kind ( Type )

Type and Data Families

Haskell wiki (src):

The concept of a type family comes from type theory. An indexed type family in type theory is a partial function at the type level. Applying the function to parameters (called type indices) yields a type. Type families permit a program to compute what data constructors it will operate on, rather than having them fixed statically (as with simple type systems) or treated as opaque unknowns (as with parametrically polymorphic types).

Type families are to vanilla data types what type class methods are to regular functions. Vanilla polymorphic data types and functions have a single definition, which is used at all type instances. Classes and type families, on the other hand, have an interface definition and any number of instance definitions. A type family's interface definition declares its kind and its arity, or the number of type indices it takes. Instance definitions define the type family over some part of the domain.

Type Families: The Definitive Guide - src

Non-generative type can be reduced to other types:
- Pair a -> (a, a)
- Non-generative type constructors have arities assigned to them and must be used saturated.
Generative type constructor - can't be reduced to another type
- Maybe Bool ~ Maybe Bool and nothing else
- We set the kind via a standalone type .... Here, MaybeIf requires something of kind Bool for construction. Therefore, we supply a promoted True to it.
```
type MaybeIf :: Bool -> Type -> Type
type family MaybeIf b t where
  MaybeIf True t = Maybe t
  MaybeIf False t = Identity t
```

Use to implement operations on GADTs (e.g., concatenate lists)

type HList :: [Type] -> Type
data HList xs where
  HNil :: HList '[]
  (:&) :: x -> HList xs -> HList (x : xs)
infixr 5 :&

type Append :: [a] -> [a] -> [a]
type family Append xs ys where -- header
  Append '[] ys = ys -- clause 1
  Append (x : xs) ys = x : Append xs ys -- clause 2
happend :: HList xs -> HList ys -> HList (Append xs ys)
happend = undefined

Closed type families
- The clauses of a closed type family are ordered and matched from top to bottom
- Overlapping equations
```
type And :: Bool -> Bool -> Bool
type family And a b where
  And True True = True
  And _ _ = False
```

Open type families

Such families can be extended anywhere

The equations of an open type family are either:

Not overlapping, so get a combinatorial explosion in patterns:

type And' :: Bool -> Bool -> Bool
type family And' a b

type instance And' True True = True
type instance And' True False = False
type instance And' False True = False
type instance And' False False = False

Compatible:

Can make right sides equal and unify left sides via rewriting

type family G a b

type instance G a Bool = a -> Bool
type instance G Char b = Char -> b

-- ==>

type instance G Char Bool = Char -> Bool

Associated types

Almost the same as open type families

Can set default values

type family Unwrap x where
  Unwrap (f a) = a

class Container2 a where
  type Elem2 a

  -- default
  type Elem2 x = Int
  elements' :: a -> [Elem2 a]

Example from string-interpolate

Injectivity - get input types from output types
- Use TypeFamilyDependencies
```
type family Not x = r | r -> x where

-- >>> s @True
```

Data families

HaskellWiki

Compute new data types (type families compute the existing data types)

data family Vector a
newtype instance Vector () = VUnit Int
newtype instance Vector Int = VInts [Int]

Can associate with a class

class Vectorizable a where
  data Vector_ a
  vlength :: Vector_ a -> Int

newtype S = S {unS :: [Int]}
instance Vectorizable S where
  data Vector_ S = Vector_ {unVector_ :: S}
  vlength :: Vector_ S -> Int
  vlength = length . unS . unVector_

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-missing-kind-signatures #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
{-# OPTIONS_GHC -Wno-unused-type-patterns #-}

module Try.TypeFamilies.TypeFamilies where

import Data.Data (Proxy (Proxy), Typeable, typeRep)
import Data.Functor.Identity (Identity (Identity))
import Data.Kind (Type)

-- Type families

class Add a b where
  type SumTy a b
  plus :: a -> b -> SumTy a b

instance Add Integer Double where
  type SumTy Integer Double = Double
  plus :: Integer -> Double -> SumTy Integer Double
  plus x y = fromIntegral x + y

instance Add Double Integer where
  type SumTy Double Integer = Double
  plus :: Double -> Integer -> SumTy Double Integer
  plus x y = x + fromIntegral y

instance (Num a) => Add a a where
  type SumTy a a = a
  plus :: a -> a -> SumTy a a
  plus x y = x + y

checkAdd :: Double
checkAdd = plus (5 :: Integer) (6 :: Double)

-- >>> checkAdd
-- 11.0

-- Type families https://serokell.io/blog/type-families-haskell

-- kind signature
type Append :: forall a. [a] -> [a] -> [a]
type family Append xs ys where -- header
  Append '[] ys = ys -- clause 1
  Append (x : xs) ys = x : Append xs ys

type MaybeIf :: Bool -> Type -> Type
type family MaybeIf b t where
  MaybeIf 'True t = Maybe t
  MaybeIf 'False t = Identity t

data PlayerInfo b = MkPlayerInfo
  { name :: MaybeIf b String
  , score :: MaybeIf b Integer
  }

s1 :: Identity Int
s1 = Identity 3 :: MaybeIf False Int

s2 :: Maybe Int
s2 = Just 3 :: MaybeIf True Int

-- move type family parameter from header to body
type MaybeIf' :: Bool -> Type -> Type
type family MaybeIf' b where
  MaybeIf' True = Maybe
  MaybeIf' False = Identity

-- Open type families

type family F a
type instance F a = [a]
type instance F Char = String

-- Compatibility
-- - Their left-hand sides are apart (i.e. not overlapping)
-- - Their left-hand sides unify with a substitution, under which the right-hand sides are equal.

-- Like, we make right-hand sides equal, and then rewrite left-hand sides until we get the same expressions
type family G a b
type instance G a Bool = a -> Bool
type instance G Char b = Char -> b

-- a -> Bool ---> Char -> Bool => a = Char
-- Char -> b ---> Char -> Bool => b = Bool
-- =>
-- G a    Bool ---> G Char Bool
-- G Char b    ---> G Char Bool

type instance G Char Bool = Char -> Bool

-- Multiline ghci code >>> a = 3 >>> b = a >>> b + a 6

-- Associated types
-- Allows to switch from this
type family Elem a
class Container a where
  elements :: a -> [Elem a]

type instance Elem [a] = a
instance Container [a] where
  elements :: [a] -> [Elem [a]]
  elements = id

-- to this
class Container1 a where
  type Elem1 a
  elements1 :: a -> [Elem a]

instance Container1 [a] where
  type Elem1 [a] = a
  elements1 :: [a] -> [Elem [a]]
  elements1 = id

-- and get default values

type family Unwrap x where
  Unwrap (f a) = a

class Container2 a where
  type Elem2 a

  -- default
  type Elem2 x = Unwrap x
  elements' :: a -> [Elem2 a]

-- Checks during pattern matching
dedup :: (Eq a) => [a] -> [a]
dedup (x1 : x2 : xs) | x1 == x2 = dedup (x1 : xs)
dedup (y : xs) = y : dedup xs
dedup [] = []

-- Type family dependencies
-- injectivity

type family Not x = r | r -> x where
  Not True = False

s :: forall x. (Not x ~ True, Typeable x) => String
s = show (typeRep $ Proxy @x)

-- ?
-- >>>:set -XTypeFamilyDependencies
-- >>>s
-- Couldn't match type `Not x0_a1S7U[tau:1]' with 'True
--   arising from a use of `s'
-- The type variable `x0_a1S7U[tau:1]' is ambiguous
-- In the expression: s
-- In an equation for `it_a1S6U': it_a1S6U = s

-- Associated data type
class Vectorizable a where
  data Vector a
  vlength :: Vector a -> Int

newtype S = S {unS :: [Int]}
instance Vectorizable S where
  data Vector S = Vector {unVector :: S}
  vlength :: Vector S -> Int
  vlength = length . unS . unVector

-- Data family
data family SomeFamily a
newtype instance SomeFamily Int = SomeF Int

-- TODO deduplicate with Theory

Additional resources

Glassery
lens ipynb
operators
optics derivation
Plated - for recursive data structures
Optics are monoids - just cosmos!
- adjoin - a union of disjoint traversals
Putting Lenses to Work
Tree numbering - unsafePartsOf
package generic-lens
- Uses OverloadedLabels to generate lenses and prisms for instances of Generic.
- Allows to avoid TemplateHaskell and have more flexible order of expressions in a module.
- The disadvantage is runtime costs connected with the usage of generics.

Optics by example

Notes on Optics by example.

{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveFoldable #-}

module Book (main) where

import Control.Applicative (Applicative (..))
import Control.Lens
import Control.Lens.Unsound (adjoin, lensProduct)
import Control.Monad.Reader (ReaderT (runReaderT))
import Control.Monad.State ( MonadIO(liftIO), StateT, modify, runState, MonadState(get) )
import Control.Monad.Writer (Writer, WriterT, execWriter, tell)
import Data.Bitraversable (Bitraversable)
import Data.ByteString qualified as BS
import Data.Char (chr, isUpper, ord, toLower, toUpper)
import Data.Either.Validation ( Validation(..) )
import Data.Foldable (Foldable (..))
import Data.Foldable qualified as Foldable
import Data.Generics.Labels ()
import Data.List ( intercalate )
import Data.List qualified as L
import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty, toList)
import Data.Map (fromList)
import Data.Map qualified as M
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Monoid (Sum (..))
import Data.Ord (comparing)
import Data.Set qualified as S (Set, fromList)
import Data.Text qualified as T
import Data.Text.Lens (unpacked)
import Data.Tree (Tree (..))
import GHC.Word qualified
import Numeric.Lens (adding, multiplying, negated)
import Text.Read (readMaybe)
import Data.Kind (Type)
import qualified Data.Text as Text
import qualified Data.Map as Map

main :: IO ()
main = print "hello"

3. Lenses

A Lens must focus ONE thing inside a structure.
A Lens must never fail to get or set that focus.

3.1 Introduction to Lenses

Exercises - Optic Anatomy

Find: action, path, structure, focus

-- This will be evaluated by HLS
-- >>> view (_1 . _2) ((1, 2), 3)
-- 2

-- This will be evaluated by ghcid

-- $> print "Hello"

action: 'view'
path: (_1 . _2)
structure: ((1, 2), 3)
focus: 2

-- >>> set (_2 . _Left) "new" (False, Left "old")
-- (False,Left "new")

action: set
path: (_2 . _Left)
structure: (False, Left "old")
focus: "old"

-- >>> over (taking 2 worded . traversed) toUpper "testing one two three"
-- "TESTING ONE two three"

action: over
path: (taking 2 worded . traversed)
structure: "testing one two three"
focus: "testing one"

-- >>>foldOf (both . each) (["super", "cali"],["fragilistic", "expialidocious"])
-- "supercalifragilisticexpialidocious"

action: foldOf
path: (both . each)
structure: (["super", "cali"],["fragilistic", "expialidocious"])
focus: ["super", "cali", "fragilistic", "expilidocious"]

3.2 Lens Actions

-- >>>view _1 ('a', 'b')
-- 'a'

-- >>> set _1 'x' ('a', 'b')
-- ('x','b')

-- >>> over _1 (*100) (1, 2)
-- (100,2)

Exercises - Lens Actions

solution:

ex1 :: Lens' (Char, Int) Char
ex1 = undefined

Lens actions:
- get
- set
- modify

focus on c

-- >>>view _3 ('a','b','c')
-- 'c'

-- >>>s = over _2 (*10) (False, 2)
-- >>>:t s
-- s :: Num b => (Bool, b)
-- >>>s
-- (False,20)

3.3 Lenses and records

data Ship = Ship {_name :: String, _numCrew :: Int} deriving (Show)

name_ :: Lens' Ship String
name_ = lens getName setName
 where
  getName :: Ship -> String
  getName = _name
  setName :: Ship -> String -> Ship
  setName ship _name = ship{_name}

purplePearl :: Ship
purplePearl = Ship{_name = "Purple Pearl", _numCrew = 38}

apply lens

-- >>>view name_ purplePearl
-- "Purple Pearl"

-- >>>over name_ (const "Purple  Pearl") purplePearl
-- Ship {_name = "Purple  Pearl", _numCrew = 38}

makeLenses ''Ship

-- >>>:t name
-- name :: Lens' Ship String

Exercises - Records Part Two

Rewrite

data Spuzz
data Chumble
gazork :: Functor f => (Spuzz -> f Spuzz) -> Chumble -> f Chumble
gazork = undefined

gazork_ :: Lens' Spuzz Chumble
gazork_ = undefined

3.4 Limitations

Lens - An optic which always accesses exactly one focus.

Exercises

Can make both a getter and a setter

get1 :: (a, b, c) -> b
get1 (_, b, _) = b

set1 :: (a, b, c) -> b -> (a, b, c)
set1 (a, _, c) b_ = (a, b_, c)

Can't get from Nothing, so, can't have inMaybe :: Lens' (Maybe a) a not fail sometimes
```
get2 :: Maybe a -> a
get2 (Just a) = a
get2 _ = undefined
```
Similar situation with left :: Lens' (Either a b) a
No, a list may have < 2 elements
Yes, you always can set and get a value, and there'll be only one value focused
```
conditional :: Lens' (Bool, a, a) a
conditional = undefined
```

3.5 Lens Laws

Allow to reason about a lens' behavior.

You get back what you set (set-get)
- view myLens (set myLens newValue structure) == newValue
Setting back what you got doesn't do anything (get-set)
- set myLens (view myLens structure) structure == structure
Setting twice is the same as setting once (set-set)
- set myLens differentValue (set myLens value structure) == set myLens differentValue structure

Unlawful lenses

When using unlawful lenses in a library, should write a note.

lensProduct combines two lenses to get a new one

these lenses should be disjoint. Otherwise, how to set?

newtype Ex1 = Ex1 {_unEx1 :: String} deriving (Show, Eq)

makeLenses ''Ex1

alongsideEx1 :: Lens' Ex1 (Ex1, String)
alongsideEx1 = lensProduct id unEx1

ex3 :: Ex1
ex3 = Ex1 "c"

ex4 :: (Ex1, String)
ex4 = (Ex1 "a", "b")

-- ex5 :: Bool
ex5 :: (Ex1, String)
ex5 = view alongsideEx1 (set alongsideEx1 ex4 ex3)

We don't get back what we set:

-- >>>ex5
-- (Ex1 {_unEx1 = "b"},"b")

-- >>>ex4 == ex5
-- False

Exercises - Laws

break get-set

break2 :: Lens' Ex1 String
break2 = lens (const "1") (\_ _ -> Ex1 "2")

ex6 :: String
ex6 = view break2 ex3

-- >>>ex6
-- "1"

ex7 :: Ex1
ex7 = set break2 ex6 ex3

-- >>>ex7
-- Ex1 {_unEx1 = "2"}

get-set, set-set work, set-get fails

data Err
  = ReallyBadError {_msg :: String}
  | ExitCode {_code :: Int}
  deriving (Show, Eq)

msg :: Lens' Err String
msg = lens getMsg setMsg
 where
  getMsg (ReallyBadError message) = message
  -- Hrmm, I guess we just return ""?
  getMsg (ExitCode _) = ""
  setMsg (ReallyBadError _) newMessage = ReallyBadError newMessage
  -- Nowhere to set it, I guess we do nothing?
  setMsg (ExitCode n) _ = ExitCode n

err :: Err
err = ExitCode 3

msgTest :: Bool
msgTest =
  view msg (set msg "a" err) /= "a"
    && set msg (view msg err) err == err
    && set msg "a" (set msg "a" err) == set msg "a" err

-- >>>msgTest
-- True

fail get-set, pass other

msg1 :: Lens' Err String
msg1 = lens getMsg setMsg
 where
  getMsg (ReallyBadError message) = message
  -- Hrmm, I guess we just return ""?
  getMsg (ExitCode _) = ""
  setMsg (ReallyBadError _) newMessage = ReallyBadError newMessage
  -- Nowhere to set it, I guess we do nothing?
  setMsg (ExitCode _) x = ReallyBadError x

msg1Test :: Bool
msg1Test =
  set msg1 (view msg1 err) err /= err
    && set msg1 "a" (set msg1 "a" err) == set msg1 "a" err
    && view msg1 (set msg1 "a" err) == "a"

-- >>>msg1Test
-- True

like msg1

data Sink = A Int | B String deriving (Show, Eq)

sink :: Lens' Sink String
sink = lens getSink setSink
 where
  getSink (A x) = show x
  getSink (B x) = x
  setSink (A _) x = B x
  setSink (B _) x = B x

sinkEx :: Sink
sinkEx = A 4

sinkTest :: Bool
sinkTest =
  set sink (view sink sinkEx) sinkEx /= sinkEx
    && view sink (set sink "a" sinkEx) == "a"
    && set sink "a" (set sink "a" sinkEx) == set sink "a" sinkEx

-- >>>sinkTest
-- True

break all rules

newtype Break = Break String deriving (Show, Eq)

break_ :: Break
break_ = Break "hey"

breakAll :: Lens' Break String
breakAll = lens get_ set_
 where
  get_ (Break _) = "!"
  set_ (Break s) x = Break $ s ++ x

breakAllTest :: Bool
breakAllTest =
  set breakAll (view breakAll break_) break_ /= break_
    && view breakAll (set breakAll "a" break_) /= "a"
    && set breakAll "a" (set breakAll "a" break_) /= set breakAll "a" break_

-- >>>breakAllTest
-- True

builder

data Builder = Builder
  { _context :: [String]
  , _build :: [String] -> String
  }

instance Eq Builder where
  (==) :: Builder -> Builder -> Bool
  x == y = x._context == y._context

builderLens :: Lens' Builder String
builderLens = lens builderGet builderSet
 where
  builderGet (Builder{..}) = case _context of [] -> ""; s -> head s
  builderSet (Builder{..}) s = Builder{_context = case s of "" -> []; _ -> [s], ..}

builder1 :: Builder
builder1 = Builder{_context = [], _build = fold}

builderTest :: Bool
builderTest =
  set builderLens (view builderLens builder1) builder1 == builder1
    && view builderLens (set builderLens "a" builder1) == "a"
    && view builderLens (set builderLens "" builder1) == ""
    && set builderLens "a" (set builderLens "a" builder1) == set builderLens "a" builder1
    && set builderLens "" (set builderLens "" builder1) == set builderLens "" builder1

-- >>>builderTest
-- True

3.6 Virtual Fields

Export only lenses, not constructors. This is to make importing modules independent of a type's inner representation.

For a data type, we can make lenses that hide some computations on the existing type's fields and lenses.

data Temperature = Temperature
  { _location :: String
  , _celsius :: Float
  }
  deriving (Show)

makeLenses ''Temperature

celsiusToFahrenheit :: Float -> Float
celsiusToFahrenheit c = (c * (9 / 5)) + 32
fahrenheitToCelsius :: Float -> Float
fahrenheitToCelsius f = (f - 32) * (5 / 9)

fahrenheit :: Lens' Temperature Float
fahrenheit = lens getter setter
 where
  getter = celsiusToFahrenheit . view celsius
  setter temp_ f = set celsius (fahrenheitToCelsius f) temp_

temp :: Temperature
temp = Temperature "Berlin" 7.0

-- >>>over fahrenheit (+18) temp
-- Temperature {_location = "Berlin", _celsius = 17.0}

When changing a field's name in the original data type, we can separately export a lens for the old field. This lens is calculated based on the updated type's fields and lenses.

data Temperature_ = Temperature_
  { _location_ :: String
  , _kelvin_ :: Float
  }
  deriving (Show)

makeLenses ''Temperature_

celsius_ :: Lens' Temperature_ Float
celsius_ = lens getter setter
 where
  getter = subtract 273.15 . view kelvin_
  setter temp_ c = set kelvin_ (c + 273.15) temp_

Exercises - Virtual Fields

substitute lens

data User = User
  { _firstName :: String
  , _lastName :: String
  , _userEmail :: String
  }
  deriving (Show)

makeLenses ''User

username :: Lens' User String
username = lens getter setter
 where
  getter = view userEmail
  setter user_ s = set userEmail s user_

unlawful fullName lens

fullName :: Lens' User String
fullName = lens getter setter
 where
  getter user_ = view firstName user_ ++ " " ++ view lastName user_
  setter user_ f =
    let fname : (unwords -> lname) = words f
     in set firstName fname (set lastName lname user_)

user :: User
user = User "John" "Cena" "invisible@example.com"

-- >>>view fullName user
-- "John Cena"

-- >>>set fullName "Doctor of Thuganomics" user
-- User {_firstName = "Doctor", _lastName = "of Thuganomics", _email = "invisible@example.com"}

3.7 Data correction and maintaining invariants

We can provide some advanced logic in our setters and getters. E.g., saturate a number to a value between a pair of given values.

Exercises - Self-Correcting Lenses

and 2.

data ProducePrices = ProducePrices
  { _limePrice :: Float
  , _lemonPrice :: Float
  }
  deriving (Show)

limePrice :: Lens' ProducePrices Float
limePrice = lens getter setter
 where
  getter = _limePrice
  setter ProducePrices{..} p =
    ProducePrices
      { _limePrice = newLimePrice
      , _lemonPrice =
          if abs (_lemonPrice - newLimePrice) <= 0.5
            then _lemonPrice
            else max (newLimePrice + signum (_lemonPrice - newLimePrice) * 0.5) 0
      }
   where
    newLimePrice = max p 0

prices :: ProducePrices
prices = ProducePrices 1.50 1.48

-- >>>set limePrice 2 prices
-- ProducePrices {_limePrice = 2.0, _lemonPrice = 1.5}

-- >>>set limePrice 1.8 prices
-- ProducePrices {_limePrice = 1.8, _lemonPrice = 1.48}

-- >>> set limePrice 1.63 prices
-- ProducePrices {_limePrice = 1.63, _lemonPrice = 1.48}

-- >>>  set limePrice (-1.00) prices
-- ProducePrices {_limePrice = 0.0, _lemonPrice = 0.5}

4 Polymorphic Optics

type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t

s: structure before action
t: structure after action
a: focus before action
b: focus after action

We need polymorphic lenses whenever an action might want to change the type of the focus.

ex8 :: ([Char], Int)
ex8 = over _1 show (1 :: Int, 1)

-- >>>ex8
-- ("1",1)

data Promotion a = Promotion
  { _item :: a
  , _discountPercentage :: Double
  }
  deriving (Show)

4.2 When do we need polymorphic lenses

over :: Lens' s a -> (a -> a) -> s -> s

Changing type variables with polymorphic lenses

item :: Lens (a, b) (c, b) a c
item = lens getter setter
 where
  getter :: (a, b) -> a
  getter = fst
  setter :: (a, b) -> c -> (c, b)
  setter (_, b) c = (c, b)

Exercises - Polymorphic Lenses

Vorpal

data Vorpal a

vorpal :: Lens (Vorpal a) (Vorpal b) a b
vorpal = undefined

Polymorphic unlawful

data Preferences a = Preferences {_best :: a, _worst :: a} deriving (Show)

best :: Lens (Preferences a) (Preferences b) a b
best = lens getter setter
 where
  getter (Preferences a _) = a
  setter (Preferences _ _) c = Preferences{_best = c, _worst = c}

Result

data Result e = Result {_lineNumber :: Int, _result :: Either e String}

result :: Lens (Result a) (Result b) a b
result = undefined

Multiple

data Multi a b

multi :: Lens (Multi a b) (Multi c d) (a, b) (c, d)
multi = undefined

Predicate

newtype Predicate a = Predicate (a -> Bool)

predicate :: Lens (Predicate a) (Predicate b) (a -> Bool) (b -> Bool)
predicate = lens getter setter
 where
  getter (Predicate x) = x
  setter (Predicate _) = Predicate

How do Lens Types Compose?

We compose Lens' a b and Lens' b c.

Inside, they are b -> a and c -> b so that we can compose them like (b -> a) . (c -> b)

ex9 :: forall (a :: Type) (b :: Type) (c :: Type) (d :: Type) e f. (e -> f)
ex9 = (d . s) m
 where
  m :: a -> b
  m = undefined
  s :: (a -> b) -> (c -> d)
  s = undefined
  d :: (c -> d) -> (e -> f)
  d = undefined

Example

data Person
data Address
data StreetAddress

personAddressLens :: forall f. Functor f => (Address -> f Address) -> Person -> f Person
personAddressLens = undefined

personAddressLens_ :: Lens Person Person Address Address
personAddressLens_ = undefined

addressStreetLens :: forall f. Functor f => (StreetAddress -> f StreetAddress) -> Address -> f Address
addressStreetLens = undefined

addressStreetLens_ :: Lens Address Address StreetAddress StreetAddress
addressStreetLens_ = undefined

personStreetLens :: Functor f => (StreetAddress -> f StreetAddress) -> Person -> f Person
personStreetLens = personAddressLens . addressStreetLens

personStreet :: StreetAddress
personStreet = view personStreetLens (undefined :: Person)

Exercises - Lens Composition

Pairs

-- >>> view (_2 . _1 . _2) ("Ginerva", (("Galileo", "Waldo"), "Malfoy"))
-- "Waldo"

Domino

data Five
data Eight
data Two
data Three

fiveEightDomino :: Lens' Five Eight
fiveEightDomino = undefined
twoThreeDomino :: Lens' Two Three
twoThreeDomino = undefined
dominoTrain :: Lens' Five Three
dominoTrain = fiveEightDomino . mysteryDomino . twoThreeDomino

mysteryDomino :: Lens' Eight Two
mysteryDomino = undefined

Rewrite

data Armadillo
data Hedgehog
data Platypus
data BabySloth

g :: Functor f => (Armadillo -> f Hedgehog) -> (Platypus -> f BabySloth)
g = undefined

h :: Lens Platypus BabySloth Armadillo Hedgehog
h = undefined

Compose

data Gazork
data Trowlg
data Bandersnatch
data Yakka
data Zink
data Wattoom
data Grug
data Pubbawup
data Foob
data Mog
data Boojum
data Jabberwock
data Snark
data JubJub

snajubjumwock :: Lens Snark JubJub Boojum Jabberwock
snajubjumwock = undefined
boowockugwup :: Lens Boojum Jabberwock Grug Pubbawup
boowockugwup = undefined
gruggazinkoom :: Lens Grug Pubbawup Zink Wattoom
gruggazinkoom = undefined
zinkattumblezz :: Lens Zink Wattoom Chumble Spuzz
zinkattumblezz = undefined
spuzorktrowmble :: Lens Chumble Spuzz Gazork Trowlg
spuzorktrowmble = undefined
gazorlglesnatchka :: Lens Gazork Trowlg Bandersnatch Yakka
gazorlglesnatchka = undefined
banderyakoobog :: Lens Bandersnatch Yakka Foob Mog
banderyakoobog = undefined

ex10 :: (Foob -> [Mog]) -> Snark -> [JubJub]
ex10 = snajubjumwock @[] . boowockugwup . gruggazinkoom . zinkattumblezz . spuzorktrowmble . gazorlglesnatchka . banderyakoobog

5. Operators

Fixity - operator precedence

-- >>>:t _1 . _2 .~ 3
-- _1 . _2 .~ 3 :: (Field1 s t a1 b1, Field2 a1 b1 a2 b2, Num b2) => s -> t

is equivalent to

-- >>>:t (_1 . _2) .~ 3
-- (_1 . _2) .~ 3 :: (Field1 s t a1 b1, Field2 a1 b1 a2 b2, Num b2) => s -> t

We can use & to make a convenient-to-read chain

-- >>>((2,3),4) & (_1 . _2) .~ 5
-- ((2,5),4)

-- >>> :{
-- unknown command '{'
multiline :: Integer
multiline = 3

Or even

ex11 :: ((Integer, Integer), (Integer, Integer))
ex11 =
  ((2, 3), (4, 6))
    & (_1 . _2) .~ 5
    & (_2 . _1) .~ 5

-- >>>ex9
-- ((2,5),(5,6))

Optics operators - src

<| cons
|> snoc
^.. toListOf
^? preview/head
^?! UNSAFE preview/head
^@.. itoListOf
^@? SAFE head (with index)
^@?! UNSAFE head (with index)
^. view
^@. iview
<. a function composition (Indexed with non-indexed)
.> a function composition (non-indexed with Indexed)
<.> a composition of Indexed functions
%%~ modify target; extract functorial/applicative result
%%= modify target in state; return extra information
&~ used to chain lens operations
<&> a flipped version of <$>
?? used to flip argument order of composite functions
<%~ modify lens target; return result
<+~ increment lens target; return result
<-~ decrement lens target; return result
<*~ multiply lens target; return result
<//~ divide lens target; return result
<^~ raise lens target; return result
<^^~ raise lens target; return result
<__~ raise lens target; return result
<||~ logically-or lens target; return result
<&&~ logically-and lens target; return result
<<%~ modify lens target, return old value
<<.~ replace lens target, return old value
<<?~ replace lens target (with Just value), return old value
<<+~ increment lens target; return old value
<<-~ decrement lens target; return old value
<<*~ multiply lens target; return old value
<<//~ divide lens target; return old value
<<^~ raise lens target; return old value
<<^^~ raise lens target; return old value
<<__~ raise lens target; return old value
<||~ logically-or lens target; return old value
<&&~ logically-and lens target; return old value
<<<>~ modify lens target with (<>); return old value
<%= modify target in state; return result
<+= add to target in state; return result
<-= subtract from target in state; return result
<*= multiple the target in state; return result
<//= divide the target in state; return result
<^= raise lens target in state; return result
<^^= raise lens target in state; return result
<__= raise lens target in state; return result
<||= logically-or lens target in state; return result
<&&= logically-and lens target in state; return result
<<%= modify lens target in state; return old value
<<.= replace lens target in state; return old value
<<?= replace target (with Just value) in state, return old value
<<+= add to target in state; return old value
<<-= subtract from target in state; return old value
<<*= multiple the target in state; return old value
<<//= divide the target in state; return old value
<<^= raise lens target in state; return old value
<<^^= raise lens target in state; return old value
<<__= raise lens target in state; return old value
<<||= logically-or lens target in state; return old value
<<&&= logically-and lens target in state; return old value
<<<>= modify target with (<>) in state; return old value
<<~ run monadic action, set lens target
<<>~ (<>) onto the end of lens target; return result
<<>= (<>) onto the end of lens target in state; return result
<%@~ modify IndexedLens target; return intermediate result
<<%@~ modify IndexedLens target; return old value
%%@~ modify IndexedLens target; return supplementary result
%%@= modify IndexedLens target in state; return supplementary result
<%@= modify IndexedLens target in state; return intermediate result
<<%@= modify IndexedLens target in state; return old value
^# view (ALens version)
#~ set (ALens version)
#%~ over (ALens version)
#%%~ modify ALens target; extract functorial/applicative result
%%= modify target in state; return extra information
#= assign (ALens version)
#%= map over ALens target(s) in state
<#%~ modify ALens target; return result
<#%= modify ALens target in state; return result
#%%= modify ALens target in state; return extra information
<#~ set with pass-through (ALens version)
<#= set with pass-through in state (ALens version)
%~ over / modify target(s)
.~ set
?~ set to Just value
<.~ set with pass-through
<?~ set to Just value with pass-through
+~ increment target(s)
*~ multiply target(s)
-~ decrement target(s)
//~ divide target(s)
^~ raise target(s)
^~ raise target(s)
^^~ raise target(s)
__~ raise target(s)
||~ logically-or target(s)
&&~ logically-and target(s)
.= assign in state
%= map over target(s) in state
?= set target(s) to Just value in state
+= add to target(s) in state
*= multiply target(s) in state
-= decrement from target(s) in state
//= divide target(s) in state
^= raise target(s) in state
^= raise target(s) in state
^^= raise target(s) in state
__= raise target(s) in state
||= logically-or target(s) in state
&&= logically-and target(s) in state
<~ run monadic action, set target(s) in state
<.= set with pass-through in state
<?= set Just value with pass-through in state
<>~ modify target with (<>)
<>= modify target with (<>) in state
.@~ iset / set target(s) with index
.@= set target(s) in state with index
%@~ iover / modify target(s) with index
%@= modify target(s) in state with index
& a reverse application operator
# review
id focus the full structure

5.9 Exercises - Operators

Get to

data Gate = Gate {_open :: Bool, _oilTemp :: Float} deriving (Show)
makeLenses ''Gate
data Army = Army {_archers :: Int, _knights :: Int} deriving (Show)
makeLenses ''Army
data Kingdom = Kingdom {_name1 :: String, _army :: Army, _gate :: Gate} deriving (Show)
makeLenses ''Kingdom
duloc :: Kingdom
duloc = Kingdom{_name1 = "Duloc", _army = Army{_archers = 22, _knights = 14}, _gate = Gate{_open = True, _oilTemp = 10.0}}

goalA :: Kingdom
goalA = duloc & name1 <>~ ": a perfect place" & army . knights *~ 3 & gate . open &&~ False

-- >>>goalA
-- Kingdom {_name1 = "Duloc: a perfect place", _army = Army {_archers = 22, _knights = 42}, _gate = Gate {_open = False, _oilTemp = 10.0}}

goalB :: Kingdom
goalB = duloc & name1 <>~ "cinstein" & army . archers -~ 5 & army . knights +~ 12 & gate . oilTemp *~ 10

-- >>>goalB
-- Kingdom {_name1 = "Duloccinstein", _army = Army {_archers = 17, _knights = 26}, _gate = Gate {_open = True, _oilTemp = 100.0}}

goalB_ :: Kingdom
goalB_ = duloc & name1 <>~ "cinstein" & army %~ (\x -> x & archers -~ 5 & knights +~ 12) & gate . oilTemp *~ 10

-- >>>goalB_
-- Kingdom {_name1 = "Duloccinstein", _army = Army {_archers = 17, _knights = 26}, _gate = Gate {_open = True, _oilTemp = 100.0}}

goalC :: (String, Kingdom)
goalC = duloc & gate . oilTemp //~ 2 & name1 <>~ ": Home" & name1 <<%~ (<> "of the talking Donkeys")

-- >>>goalC
-- ("Duloc: Home",Kingdom {_name1 = "Duloc: Homeof the talking Donkeys", _army = Army {_archers = 22, _knights = 14}, _gate = Gate {_open = True, _oilTemp = 5.0}})

Enter code

ex12 :: (Bool, [Char])
ex12 = (False, "opossums") & _1 ||~ True

-- >>>ex10
-- (True,"opossums")

ex13 :: Integer
ex13 = 2 & id *~ 3

-- >>>ex11
-- 6

ex14 :: ((Bool, [Char]), Double)
ex14 =
  ((True, "Dudley"), 55.0)
    & (_1 . _2 <>~ " - the worst")
    & (_2 -~ 15)
    & (_2 //~ 2)
    & (_1 . _2 %~ map toUpper)
    & (_1 . _1 .~ False)

-- >>>ex12
-- ((False,"DUDLEY - THE WORST"),20.0)

&
(%~) :: Lens s t a b -> (a -> b) -> s -> t

6. Folds

have no laws!
focus on several elements
composition makes successive folds focus on the elements of previous focuses, forming a tree
the result of a composite fold is a Foldable of leaves of such a tree
combinators can work with a set of focuses (leaves) at a necessary level of such a tree

-- >>> [[1, 2, 3], [10, 20, 30], [100, 200, 300]] ^.. folded . taking 2 folded
-- [1,2,10,20,100,200]

6.1 Introduction to Folds

Folds can focus MANY things, Lenses must focus ONE thing
Folds can only get zero or more things, Lenses must always be able to get and set
Folds aren't polymorphic

Focusing all elements of a container

type Fold s a = forall m. Monoid m => Getting m s a
type Getting r s a = (a -> Const r a) -> s -> Const r s
newtype Const a (b :: k) = Const { getConst :: a }

s: structure
a: focus

Collapsing the Set

folded :: Foldable f => Fold (f a) a

ex15 :: [Integer]
ex15 = [Just 3, Nothing, Nothing] ^.. folded . _Just

-- >>>ex15
-- [3]

Using lenses as folds

We have

type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
type Fold s a = forall m. Monoid m => Getting m s a
type Getting r s a = (a -> Const r a) -> s -> Const r s

So, we can use a Lens' s a as a Fold s a

^.. first applies the folds, and returns them in a list

getPair2 :: Fold (a, b) b
getPair2 = _2

-- >>>(3,4) ^.. getPair2
-- [4]

Foundational fold combinators

both - Traverse both parts of a Bitraversable container with matching types
each - generalizes both for tuples

ex16 :: [Integer]
ex16 = (1, 2) ^.. both

-- >>>ex16
-- [1,2]

ex17 :: [Integer]
ex17 = (1, 2, 4, 5, 6) ^.. each

-- >>>ex17
-- [1,2,4,5,6]

ex18 :: [GHC.Word.Word8]
ex18 = ("Do or do not" :: BS.ByteString) ^.. each

Exercises - Simple Folds

beasts

beastSizes :: [(Int, String)]
beastSizes = [(3, "Sirens"), (882, "Kraken"), (92, "Ogopogo")]

-- >>> beastSizes ^.. folded
-- [(3,"Sirens"),(882,"Kraken"),(92,"Ogopogo")]

-- >>> beastSizes ^.. folded . folded
-- ["Sirens","Kraken","Ogopogo"]

-- >>> beastSizes ^.. folded . folded . folded
-- "SirensKrakenOgopogo"

-- >>> beastSizes ^.. folded . _2
-- ["Sirens","Kraken","Ogopogo"]

-- >>> toListOf (folded . folded) [[1, 2, 3], [4, 5, 6]]
-- [1,2,3,4,5,6]

ex19 :: [Char]
ex19 = toListOf (folded . folded) (M.fromList [("Jack" :: String, "Captain" :: String), ("Will", "First Mate")])

-- >>> ex19
-- "CaptainFirst Mate"

-- >>> ("Hello" :: String, "It's me") ^.. both . folded
-- "HelloIt's me"

-- >>> ("Why", "So", "Serious?") ^.. each
-- ["Why","So","Serious?"]

quotes :: [(T.Text, T.Text, T.Text)]
quotes = [("Why", "So", "Serious?"), ("This", "is", "SPARTA")]

ex20 :: [Char]
ex20 = quotes ^.. each . each . each

-- >>> ex20
-- "WhySoSerious?ThisisSPARTA"

Blank

-- >>>[1, 2, 3] ^.. folded
-- [1,2,3]

-- >>> ("Light", "Dark") ^.. _1
-- ["Light"]

-- >>> [("Light", "Dark"), ("Happy", "Sad")] ^.. each . each
-- ["Light","Dark","Happy","Sad"]

-- >>> [("Light", "Dark"), ("Happy", "Sad")] ^.. each . _1
-- ["Light","Happy"]

ex21 :: String
ex21 = ([("Light", "Dark" :: String), ("Happy", "Sad")] ^.. each . _2) ^.. each . each

-- >>> ex21
-- "DarkSad"

-- >>> ("Bond", "James", "Bond") ^.. each
-- ["Bond","James","Bond"]

6.2 Custom Folds

We should project the pieces of a structure into something Foldable. Then, we can construct a Fold.

folding :: Foldable f => (s -> f a) -> Fold s a

newtype Name = Name
  { getName :: String
  }
  deriving (Show)
data ShipCrew = ShipCrew
  { _shipName :: Name
  , _captain :: Name
  , _firstMate :: Name
  , _conscripts :: [Name]
  }
  deriving (Show)
makeLenses ''ShipCrew

myCrew :: ShipCrew
myCrew =
  ShipCrew
    { _shipName = Name "Purple Pearl"
    , _captain = Name "Grumpy Roger"
    , _firstMate = Name "Long-John Bronze"
    , _conscripts = [Name "One-eyed Jack", Name "Filthy Frank"]
    }

collectCrewMembers :: ShipCrew -> [Name]
collectCrewMembers sc = [sc ^. captain, sc ^. firstMate] ++ sc ^. conscripts

crewMembers :: Fold ShipCrew Name
crewMembers = folding collectCrewMembers

-- >>>myCrew ^.. crewMembers
-- [Name {getName = "Grumpy Roger"},Name {getName = "Long-John Bronze"},Name {getName = "One-eyed Jack"},Name {getName = "Filthy Frank"}]

Mapping over folds

to

converts a function into a Getter.
that's why, should never fail to get something from a structure.
Book:
```
to :: (s -> a) -> Fold s a
```
Real:

-- >>>:t to
-- to :: (Profunctor p, Contravariant f) => (s -> a) -> Optic' p f s a

class Profunctor (p :: Type -> Type -> Type) where
  dimap :: (a -> b) -> (c -> d) -> p b c -> p a d

Profunctors

Example

ex22 :: [Char]
ex22 = "Two-faced Tony" ^. to (take 2)

-- >>> ex22
-- "Tw"

Composition

-- >>> Name "Two-faced Tony" ^. to getName . to (fmap toUpper)
-- "TWO-FACED TONY"

-- >>> Name "Two-faced Tony" ^. to (fmap toUpper . getName)
-- "TWO-FACED TONY"

-- >>> myCrew ^.. crewMembers . to getName
-- ["Grumpy Roger","Long-John Bronze","One-eyed Jack","Filthy Frank"]

Combining multiple folds on the same structure

crewNames1 :: ShipCrew -> [Name]
crewNames1 sc = [captain, firstMate] ^.. folded . to (sc ^.) <> sc ^. conscripts

crewNames2 :: Fold ShipCrew Name
crewNames2 = folding (\s -> foldMap (s ^..) [captain, firstMate, conscripts . folded])

crewNames3 :: Fold ShipCrew Name
crewNames3 = folding (\s -> [captain, firstMate, conscripts . folded] ^.. folded . to (s ^..) . folded)

-- >>> myCrew ^.. crewNames2 . to getName
-- ["Grumpy Roger","Long-John Bronze","One-eyed Jack","Filthy Frank"]

Exercises - Custom Folds

blanks

ex23 :: [Char]
ex23 = ["Yer" :: String, "a", "wizard", "Harry"] ^.. folded . folded

-- >>> ex23
-- "YerawizardHarry"

-- >>> [[1, 2, 3], [4, 5, 6]] ^.. folded . folding (take 2)
-- [1,2,4,5]

-- >>> [[1, 2, 3], [4, 5, 6]] ^.. folded . to (take 2)
-- [[1,2],[4,5]]

-- >>> ["bob", "otto", "hannah"] ^.. folded . to reverse
-- ["bob","otto","hannah"]

-- >>> ("abc", "def") ^.. folding (\(a, b) -> [a, b]). to reverse . folded
-- "cbafed"

fold paths

-- >>> [1..5] ^.. folded . folding (\x -> [x * 100])
-- [100,200,300,400,500]

-- >>> (1, 2) ^.. folding (\(a,b) -> [a, b])
-- [1,2]

-- >>> [(1, "one"), (2, "two")] ^.. folded . folding (\(_,x) -> [x])
-- ["one","two"]

ex24 :: [Int]
ex24 = (Just 1, Just 2, Just 3) ^.. folding (\(a, b, c) -> [a, b, c]) . folded

-- >>> ex24
-- [1,2,3]

ex25 :: [Int]
ex25 = [Left 1, Right 2, Left 3] ^.. folded . folded

-- >>> ex25
-- [2]

ex26 :: [Int]
ex26 = [([1, 2], [3, 4]), ([5, 6], [7, 8])] ^.. folded . folding (uncurry (<>))

-- >>> ex26
-- [1,2,3,4,5,6,7,8]

-- >>> [1, 2, 3, 4] ^.. folded . to (\x -> (if odd x then Left else Right) x)
-- [Left 1,Right 2,Left 3,Right 4]

-- >>> [(1, (2, 3)), (4, (5, 6))] ^.. folded . folding (\(a, (b,c)) -> [a,b,c])
-- [1,2,3,4,5,6]

ex27 :: [Integer]
ex27 = [(Just 1, Left "one"), (Nothing, Right 2)] ^.. folded . folding (\(x, y) -> x ^.. folded <> y ^.. folded)

-- >>> ex27
-- [1,2]

ex28 :: [Either Integer String]
ex28 = [(1, "one"), (2, "two")] ^.. folded . folding (\(x, y) -> [Left x, Right y])

-- >>> ex28
-- [Left 1,Right "one",Left 2,Right "two"]

-- >>> S.fromList ["apricots", "apples"] ^.. folded . to reverse . folded
-- "selppastocirpa"

outside of the box

ex29 :: [Char]
ex29 = [(12, 45, 66), (91, 123, 87)] ^.. folded . folding (\(_, x, _) -> reverse (show x))

-- >>> ex29
-- "54321"

-- >>> [(1, "a"), (2, "b"), (3, "c"), (4, "d")] ^.. folded . folding (\(x,y) -> if odd x then [] else [y])
-- ["b","d"]

6.3 Fold Actions

Fold queries

Which focuses match this predicate?
What's the largest element in my structure
What's the result of running this side-effect on every focus?
What's the sum of these numeric focuses?
Does this fold focus any elements?
Does this specific value exist in my structure?

Writing queries with folds

There are folds for common functions like

minimumOf
sumOf

sumOf :: Num a => Getting (Endo (Endo a)) s a -> s -> a

Instead of Getting (Some type) s a, can put many optics, e.g., Fold s a.

elemOf :: Eq a => Fold s a -> a -> s -> Bool - does a fold contain an element?
anyOf :: Fold s a -> (a -> Bool) -> s -> Bool - does any focus match a predicate?
allOf :: Fold s a -> (a -> Bool) -> s -> Bool - do all focuses match a predicate?
findOf :: Fold s a -> (a -> Bool) -> s -> Maybe a - find the first elem that matches a predicate
has :: Fold s a -> s -> Bool - does my fold have any elements
hasn't :: Fold s a -> s -> Bool - or not?
lengthOf :: Fold s a -> s -> Int - how many focuses are there?
sumOf :: Num n => Fold s n -> s -> n - sum of focuses
productOf :: Num n => Fold s n -> s -> n - their product
firstOf :: Fold s a -> s -> Maybe a - get the first focus
preview :: Fold s a -> s -> Maybe a - like firstOf
(^?) :: s -> Fold s a -> Maybe a - like firstOf
worded :: Fold String String - like words
lastOf :: Fold s a -> s -> Maybe a - get the last focus
minimumOf :: Ord a => Fold s a -> s -> Maybe a - minimum
maximumOf :: Ord a => Fold s a -> s -> Maybe a - maximum
maximumByOf :: Fold s a -> (a -> a -> Ordering) -> s -> Maybe a - max element by a comparison func
folding :: Foldable f => (s -> f a) -> Fold s a - convert structure to a Foldable
foldrOf :: Fold s a -> (a -> r -> r) -> r -> s -> r - like foldr
foldlOf :: Fold s a -> (a -> r -> r) -> r -> s -> r - like foldl
foldMapOf :: Monoid r => Fold s a -> (a -> r) -> s -> r - like foldMap
foldByOf :: Fold s a -> (a -> a -> a) -> a -> s -> a - lets use a custom (<>) :: a -> a -> a
foldMapByOf :: Fold s a -> (r -> r -> r) -> r -> (a -> r) -> s -> r - same, but also lets map to a Monoid

data Actor = Actor
  { _actorName :: String
  , _birthYear :: Int
  }
  deriving (Show, Eq)
makeLenses ''Actor

data TVShow = TVShow
  { _title :: String
  , _numEpisodes :: Int
  , _numSeasons :: Int
  , _criticScore :: Double
  , _actors :: [Actor]
  }
  deriving (Show, Eq)
makeLenses ''TVShow

howIMetYourMother :: TVShow
howIMetYourMother =
  TVShow
    { _title = "How I Met Your Mother"
    , _numEpisodes = 208
    , _numSeasons = 9
    , _criticScore = 83
    , _actors =
        [ Actor "Josh Radnor" 1974
        , Actor "Cobie Smulders" 1982
        , Actor "Neil Patrick Harris" 1973
        , Actor "Alyson Hannigan" 1974
        , Actor "Jason Segel" 1980
        ]
    }
buffy :: TVShow
buffy =
  TVShow
    { _title = "Buffy the Vampire Slayer"
    , _numEpisodes = 144
    , _numSeasons = 7
    , _criticScore = 81
    , _actors =
        [ Actor "Sarah Michelle Gellar" 1977
        , Actor "Alyson Hannigan" 1974
        , Actor "Nicholas Brendon" 1971
        , Actor "David Boreanaz" 1969
        , Actor "Anthony Head" 1954
        ]
    }

tvShows :: [TVShow]
tvShows =
  [ howIMetYourMother
  , buffy
  ]

-- >>> sumOf (folded . numEpisodes) tvShows
-- 352

comparingOf :: Ord a => Getting a s a -> s -> s -> Ordering
comparingOf l = comparing (view l)

ex30 :: Maybe Actor
ex30 = maximumByOf (folded . actors . folded) (comparingOf birthYear) tvShows

-- >>> ex30
-- Just (Actor {_actorName = "Cobie Smulders", _birthYear = 1982})

Folding with effects

Effectful folding

traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f () - fold with effects

Similar to ordinary Foldable functions:

traverseOf_ :: Functor f => Fold s a -> (a -> f r) -> s -> f ()
forOf_ :: Functor f => Fold s a -> s -> (a -> f r) -> f ()

Uses just Functor (not Applicative) as Lens focuses a single element.

calcAge :: Actor -> Int
calcAge actor = 2030 - actor ^. birthYear

showActor :: Actor -> String
showActor actor = actor ^. actorName <> ": " <> show (calcAge actor)

-- $> traverseOf_ (folded . actors . folded . to showActor) putStrLn tvShows

-- >>> import Control.Monad.State
-- >>> execState (traverseOf_ (folded . actors . folded) (modify . const (+1)) tvShows) 0
-- 10

Combining fold results

Folds are all about collecting pieces of things and Monoids are all about combining things together. We can find many focuses within a structure, then combine the pieces together using a Monoid.

foldOf :: Getting a s a -> s -> a
foldMapOf :: Getting r s a -> (a -> r) -> s -> r

Implement an average fold

ageSummary :: Actor -> (Sum Int, Sum Int)
ageSummary actor = (Sum 1, Sum (calcAge actor))

ex31 :: Double
ex31 = fromIntegral age / fromIntegral n
 where
  sums = foldMapOf (folded . actors . folded) ageSummary tvShows
  n = getSum (fst sums)
  age = getSum (snd sums)

-- >>> ex31
-- 57.2

Using `view on folds`

Don't use view or ^. on folds. It works only if focuses are Monoids. Use foldOf

-- >>> Just (42 :: Int) ^. folded
-- No instance for (Monoid Int) arising from a use of `folded'
-- In the second argument of `(^.)', namely `folded'
-- In the expression: Just (42 :: Int) ^. folded
-- In an equation for `it_a2Cc0O':
--     it_a2Cc0O = Just (42 :: Int) ^. folded

Customizing monoidal folds

These functions allow customizing the (<>) operation on Monoids

folding :: Foldable f => (s -> f a) -> Fold s a
foldByOf :: Fold s a -> (a -> a -> a) -> a -> s -> a
foldMapByOf :: Fold s a -> (r -> r -> r) -> r -> (a -> r) -> s -> r
foldrOf :: Fold s a -> (a -> r -> r) -> r -> s -> r
foldlOf :: Fold s a -> (r -> a -> r) -> r -> s -> r

ex32 :: M.Map String Int
ex32 =
  foldMapByOf
    -- Focus each actor's name
    (folded . actors . folded . actorName)
    -- Combine duplicate keys with addition
    (M.unionWith (+))
    -- start with the empty Map
    mempty
    -- inject names into Maps with a count of 1
    (`M.singleton` 1)
    tvShows

-- >>> ex32
-- fromList [("Alyson Hannigan",2),("Anthony Head",1),("Cobie Smulders",1),("David Boreanaz",1),("Jason Segel",1),("Josh Radnor",1),("Neil Patrick Harris",1),("Nicholas Brendon",1),("Sarah Michelle Gellar",1)]

Exercises - Fold Actions

pick action

-- >>> has folded []
-- False

-- >>> foldOf both ("Yo", "Adrian!")
-- "YoAdrian!"

-- >>> elemOf each "phone" ("E.T.", "phone", "home")
-- True

-- >>> minimumOf folded [5, 7, 2, 3, 13, 17, 11]
-- Just 2

-- >>> maximumOf folded [5, 7, 2, 3, 13, 17, 11]
-- Just 17

-- >>> anyOf folded ((> 9) . length) ["Bulbasaur", "Charmander", "Squirtle"]
-- True

-- >>> findOf folded even [11, 22, 3, 5, 6]
-- Just 22

devise folds

ex33 :: Maybe String
ex33 = findOf folded (\x -> x == reverse x) ["umbrella", "olives", "racecar", "hammer"]

-- >>>ex33
-- Just "racecar"

-- >>>allOf each even (2,4,6)
-- True

ex34 :: Maybe (Int, String)
ex34 = maximumByOf folded (\x y -> compare (x ^. _1) (y ^. _1)) [(2 :: Int, "I'll" :: String), (3, "Be"), (1, "Back")]

-- >>> ex34
-- Just (3,"Be")

-- >>> sumOf each (1,2)
-- 3

bonus

isVowel :: Char -> Bool
isVowel x = x `elem` ("aouiey" :: String)

ex35 :: Maybe String
ex35 =
  maximumByOf
    worded
    (\x y -> let s = (length . filter isVowel) in compare (s x) (s y))
    ("Do or do not, there is no try." :: String)

-- >>> ex35
-- Just "there"

6.4 Higher Order Folds

There're optics combinators that alter other optics. They accept an optic and return a new one.

(with simplified types)

taking :: Int -> Fold s a -> Fold s a - like take
dropping :: Int -> Fold s a -> Fold s a - like drop
takingWhile :: (a -> Bool) -> Fold s a -> Fold s a - like takeWhile
droppingWhile :: (a -> Bool) -> Fold s a -> Fold s a - like dropWhile
backwards :: Fold s a -> Fold s a - reverse the order of focuses of a fold

Taking, Dropping

(real types are complex)

take N focuses

taking :: Int -> Fold s a -> Fold s a
dropping :: Int -> Fold s a -> Fold s a

-- >>>[3,5,4,6,7] ^.. taking 3 folded
-- [3,5,4]

-- >>>[3,5,4,6,7] ^.. dropping 3 folded
-- [6,7]

Since new folds branch on focuses, the next optics are applied on each branch separately.

-- >>> [[1, 2, 3], [10, 20, 30], [100, 200, 300]] ^.. folded . taking 2 folded
-- [1,2,10,20,100,200]

-- >>> ("Albus" :: String, "Dumbledore") ^.. both . taking 3 folded
-- "AlbDum"

We can move the combinator to operate on the necessary set of focuses, e.g., the final one.

-- No brackets; we're taking '3' from the results of 'both', then folding them
-- >>> ("Albus" :: String, "Dumbledore") ^.. taking 3 both . folded
-- "AlbusDumbledore"

-- >>> ("Albus" :: String, "Dumbledore") ^.. taking 3 (both . folded)
-- "Alb"

-- >>> ("Albus" :: String, "Dumbledore") ^.. dropping 2 (both . folded)
-- "busDumbledore"

Backwards

Reverses the order of a fold.

Book:

backwards :: Fold s a -> Fold s a

Real:

-- >>>:t backwards
-- backwards
--   :: (Profunctor p, Profunctor q) =>
--      Optical p q (Backwards f) s t a b -> Optical p q f s t a b

Examples:

-- >>> [1, 2, 3] ^.. backwards folded
-- [3,2,1]

takingWhile, droppingWhile

-- >>> [1..100] ^.. takingWhile (<10) folded
-- [1,2,3,4,5,6,7,8,9]

-- >>> [1..100] ^.. droppingWhile (<90) folded
-- [90,91,92,93,94,95,96,97,98,99,100]

Exercises - Higher Order Folds

blanks

-- >>> ("Here's looking at you, kid" :: String) ^.. dropping 7 folded
-- "looking at you, kid"

-- >>> ["My Precious" :: String, "Hakuna Matata", "No problemo"] ^.. folded . taking 1 .
-- "MHN"

-- >>> ["My Precious", "Hakuna Matata", "No problemo"] ^.. taking 1 (folded . worded)
-- ["My"]

-- >>> ["My Precious", "Hakuna Matata", "No problemo"] ^.. folded . taking 1 worded . folded
-- "MyHakunaNo"

-- >>> ["My Precious", "Hakuna Matata", "No problemo"] ^.. folded . taking 1 (folding words) . folded
-- "MyHakunaNo"

ex36 :: Integer
ex36 = sumOf (taking 2 each) (10, 50, 100)

-- >>> ex36
-- 60

-- >>> ("stressed", "guns", "evil") ^.. backwards each
-- ["evil","guns","stressed"]

-- >>> ("stressed", "guns", "evil") ^.. backwards each . to reverse
-- ["live","snug","desserts"]

-- >>> import Data.Char (isAlpha)
-- >>> "blink182 k9 blazeit420" ^.. folding (filter (\x -> not (isAlpha x || x == ' ')))
-- "1829420"

use higher-order folds

temperatureSample :: [Int]
temperatureSample = [-10, -5, 4, 3, 8, 6, -2, 3, -5, -7]

-- >>> length $ temperatureSample ^.. takingWhile (<= 0) folded
-- 2

-- >>> maximumOf (taking 4 folded) temperatureSample
-- Just 4

-- >>> temperatureSample ^? dropping 1 (droppingWhile (/= 4) folded)
-- Just 3

-- >>> length $ temperatureSample ^.. takingWhile (< 0) (backwards folded)
-- 2

-- >>> temperatureSample ^.. takingWhile (> 0) (droppingWhile (<= 0) folded)
-- [4,3,8,6]

trimmingWhile :: (a -> Bool) -> Fold s a -> Fold s a
trimmingWhile c f = backwards (droppingWhile c (backwards (droppingWhile c f)))

-- >>> temperatureSample ^.. trimmingWhile (< 0) folded
-- [4,3,8,6,-2,3]

6.5 Filtering folds

Filter focuses (like WHERE in SQL)
Can run a separate fold to calculate the filter condition
Can go deeper after filtering

Book:

filtered :: (s -> Bool) -> Fold s s - filter a fold
filteredBy :: Fold s a -> Fold s s or filteredBy :: Fold s a -> IndexedTraversal' a s s - filter by a condition represented as a fold

Real:

-- >>>:t filtered
-- filtered :: (Choice p, Applicative f) => (a -> Bool) -> Optic' p f a a

-- >>>:t filteredBy
-- filteredBy
--   :: (Indexable i p, Applicative f) =>
--      Getting (First i) a i -> p a (f a) -> a -> f a

Examples:

-- >>> [1, 2, 3, 4] ^.. folded . filtered even
-- [2,4]

-- >>> ["apple", "passionfruit", "orange", "pomegranate"] ^.. folded . filtered ((>6) . length)
-- ["passionfruit","pomegranate"]

-- A data structure to represent a single card
data Card = Card
  { _cardName :: String
  , _aura :: Aura
  , _holo :: Bool
  , _moves :: [Move]
  }
  deriving (Show, Eq)

-- Each card has an aura-type
data Aura
  = Wet
  | Hot
  | Spark
  | Leafy
  deriving (Show, Eq)

-- Cards have attack moves
data Move = Move
  { _moveName :: String
  , _movePower :: Int
  }
  deriving (Show, Eq)

makeLenses ''Card
makeLenses ''Move

deck :: [Card]
deck =
  [ Card "Skwortul" Wet False [Move "Squirt" 20]
  , Card "Scorchander" Hot False [Move "Scorch" 20]
  , Card "Seedasaur" Leafy False [Move "Allergize" 20]
  , Card "Kapichu" Spark False [Move "Poke" 10, Move "Zap" 30]
  , Card "Elecdude" Spark False [Move "Asplode" 50]
  , Card "Garydose" Wet True [Move "Gary's move" 40]
  , Card "Moisteon" Wet False [Move "Soggy" 3]
  , Card "Grasseon" Leafy False [Move "Leaf Cut" 30]
  , Card "Spicyeon" Hot False [Move "Capsaicisize" 40]
  , Card "Sparkeon" Spark True [Move "Shock" 40, Move "Battery" 50]
  ]

How many moves have an attack power above 30?

ex38 :: Int
ex38 =
  lengthOf
    ( folded
        . moves
        . folded
        . movePower
        . filtered (> 30)
    )
    deck

-- >>> ex38
-- 5

List all cards which have ANY move with an attack power greater than 40

ex39 :: [String]
ex39 =
  deck
    ^.. folded
      . filtered (anyOf (moves . folded . movePower) (> 40))
      . cardName

-- >>> ex39
-- ["Elecdude","Sparkeon"]

List all Spark Moves with a power greater than 30

-- ex40 :: [Move]
ex40 :: [String]
ex40 =
  deck
    ^.. folded
      . filtered (\x -> x ^. aura == Spark)
      . moves
      . folded
      . filtered (\x -> x ^. movePower > 30)
      . moveName

-- >>>ex40
-- ["Asplode","Shock","Battery"]

Other helpers

filteredBy :: Fold s a -> Fold s s - filter by a condition represented as a fold
only :: Eq a => a -> Prism' a () - return () iff input is equal to a reference value
nearly :: a -> (a -> Bool) -> Prism' a () - check condition. As it returns a prism, we have to supply the first argument for re-construction
```
-- >>> has (only "needle") "needle"
-- True
```

List all Spark Moves with a power greater than 30

ex41 :: [String]
ex41 =
  deck
    ^.. folded
      . filteredBy (aura . only Spark)
      . moves
      . folded
      . filteredBy (movePower . filtered (> 30))
      . moveName

-- >>> ex41
-- ["Asplode","Shock","Battery"]

ex42 :: Maybe String
ex42 =
  maximumByOf
    -- filter for holo cards
    (folded . filteredBy holo)
    -- compare them on number of moves
    (comparing (lengthOf moves))
    deck
    <&> (^. cardName)

-- >>> ex42
-- Just "Sparkeon"

Exercises - Filtering

List all the cards whose name starts with 'S'

ex43 :: [String]
ex43 = deck ^.. folded . filteredBy (cardName . taking 1 folded . only 'S') . cardName

-- >>> ex43
-- ["Skwortul","Scorchander","Seedasaur","Spicyeon","Sparkeon"]

What's the lowest attack power of all moves?

ex44 :: Maybe Int
ex44 = minimumOf (folded . moves . folded . movePower) deck

-- >>>ex44
-- Just 3

What's the name of the first card which has more than one move?

ex45 :: Maybe String
ex45 = findOf (folded . filtered (\x -> length (x ^. moves) > 1)) (const True) deck <&> (^. cardName)

-- >>>ex45
-- Just "Kapichu"

Are there any Hot cards with a move with more than 30 attack power?

ex46 :: Bool
ex46 =
  not . null $
    deck
      ^.. folded
        . filteredBy (aura . only Hot)
        . filteredBy (moves . folded . filteredBy (movePower . nearly 0 (> 30)))

-- >>>ex46
-- [Card {_cardName = "Spicyeon", _aura = Hot, _holo = False, _moves = [Move {_moveName = "Capsaicisize", _movePower = 40}]}]

List the names of all holographic cards with a Wet aura.

ex47 :: [String]
ex47 = deck ^.. folded . filtered (\x -> x ^. holo && x ^. aura == Wet) . cardName

-- >>>ex47
-- ["Garydose"]

What's the sum of all attack power for all moves belonging to non-Leafy cards?

ex48 :: Int
ex48 = sumOf (folded . filtered (\x -> x ^. aura /= Leafy) . moves . folded . movePower) deck

-- >>>ex48
-- 303

7. Traversals

Have multiple focuses. Can transform them.

7.1. Introduction to Traversals

Can get or set many focuses in-place.

rows - optics that we have
columns - how want to use that optics

alt

From Fold to Traversal

both :: Bitraversable r => Traversal (r a a) (r b b) a b

In case of tuples, both focuses both sides of a tuple.

Traversal s t a b:

s: structure before action
t: structure after action
a: focus before action
b: focus after action

Let's modify both elements of a tuple

ex49 :: (String, String)
ex49 = ("Bubbles", "Buttercup") & both %~ (++ "!")

-- >>> ex49
-- ("Bubbles!","Buttercup!")

Focuses may change type as long as the type of a structure remains valid. In case of each, we have to change types of all elements of a tuple.

-- >>> ("Bubbles", "Buttercup") & each %~ length
-- (7,9)

-- >>> [1, 2, 3, 4, 5] & dropping 3 traversed %~ show
-- No instance for (Num String) arising from the literal `1'
-- In the expression: 1
-- In the first argument of `(&)', namely `[1, 2, 3, 4, 5]'
-- In the expression: [1, 2, 3, 4, 5] & dropping 3 traversed %~ show

Some structures disallow changing the type.

-- >>> ("Houston we have a problem" :: T.Text) & each .~ (22 :: Int)
-- Couldn't match type `Int' with `Char' arising from a use of `each'
-- In the first argument of `(.~)', namely `each'
-- In the second argument of `(&)', namely `each .~ (22 :: Int)'
-- In the expression:
--   ("Houston we have a problem" :: Text) & each .~ (22 :: Int)

Can use some functions that we used for Folds, e.g., filtered.

-- Reverse only the long strings
ex50 :: (String, String)
ex50 =
  ("short", "really long")
    & both . filtered ((> 5) . length)
      %~ reverse

-- >>>ex50
-- ("short","gnol yllaer")

7.2 Traversal Combinators

Traversing each element of a container

Some optics are incompatible in types, e.g., folded and %~. That is, you can't modify focuses in a fold

-- >>> [1, 2, 3] & folded %~ (*10)
-- Could not deduce (Contravariant Identity)
--   arising from a use of `folded'
-- from the context: Num b_aNbRI[sk:1]
--   bound by the inferred type of
--              it_aNbPv :: Num b_aNbRI[sk:1] => [b_aNbRI[sk:1]]
--   at /home/eyjafjallajokull/Desktop/projects/optics-by-example/README.hs:2207:2-28
-- In the first argument of `(%~)', namely `folded'
-- In the second argument of `(&)', namely `folded %~ (* 10)'
-- In the expression: [1, 2, 3] & folded %~ (* 10)

That's why there is a specific function for traversing.

Book:

traversed :: Traversable f => Traversal (f a) (f b) a b

Real:

-- >>> :t traversed
-- traversed :: Traversable f => IndexedTraversal Int (f a) (f b) a b

class (Functor t, Foldable t) => Traversable t

If you compose a Traversal and a Fold, you get a Fold.

-- >>>[[3 :: Int, 4]] & traversed . folded %~ (*10)
-- No instance for (Contravariant Identity)
--   arising from a use of `folded'
-- In the second argument of `(.)', namely `folded'
-- In the first argument of `(%~)', namely `traversed . folded'
-- In the second argument of `(&)', namely
--   `traversed . folded %~ (* 10)'

-- >>>[[3 :: Int, 4]] ^.. traversed . folded
-- [3,4]

Compared to folded, traversed operates on less containers with more operations.

powerLevels :: M.Map String Integer
powerLevels =
  M.fromList
    [ ("Gohan", 710)
    , ("Goku", 9001)
    , ("Krillin", 5000)
    , ("Piccolo", 408)
    ]

-- operate on the values of a map
ex51 :: M.Map String String
ex51 =
  powerLevels
    & traversed %~ \n ->
      if n > 9000
        then "Over 9000"
        else show n

-- >>>ex51
-- fromList [("Gohan","710"),("Goku","Over 9000"),("Krillin","5000"),("Piccolo","408")]

More Combinators

Book:

worded :: Traversal' String String - focus on words
lined :: Traversal' String String - focus on lines

Real:

-- >>> :t worded
-- worded :: Applicative f => IndexedLensLike' Int f String String

-- >>> :t lined
-- lined :: Applicative f => IndexedLensLike' Int f String String

They're unlawful, because they wrongly reconstruct the results. E.g., like unwords . words, they substitute a single space for multiple spaces.

-- >>> "blue \n suede \n \n shoes" & worded %~ \(x:xs) -> toUpper x : xs
-- "Blue Suede Shoes"

Traversing multiple paths at once

Focus on all as from both structures in a tuple.

beside :: Traversal s t a b -> Traversal s' t' a b -> Traversal (s,s') (t,t') a b
beside :: Lens s t a b      -> Lens s' t' a b      -> Traversal (s,s') (t,t') a b
beside :: Fold s a          -> Fold s' a           -> Fold (s,s') a

-- >>> let dinos = ("T-Rex", (42, "Stegosaurus"))
-- >>>  dinos ^.. beside id _2
-- ["T-Rex","Stegosaurus"]

ex52 :: (String, [String])
ex52 =
  ("Cowabunga", ["let's", "order", "pizza"])
    -- Each half of the tuple has a different path to focus the characters
    & beside traversed (traversed . traversed)
      %~ toUpper

-- >>>ex52
-- ("COWABUNGA",["LET'S","ORDER","PIZZA"])

There are other Bitraversables like Either.

-- >>> Left (1, 2) & beside both traversed %~ negate
-- Left (-1,-2)

Focusing a specific traversal element

Focuses a single element with a given index. Can't change the type of that focus because it can't change the type of other focuses.

element :: Traversable f => Int -> Traversal' (f a) a

-- >>> [0, 1, 2, 3, 4] & element 2 *~ 100
-- [0,1,200,3,4]

Focus an element of a traversal or a fold

elementOf :: Traversal' s a -> Int -> Traversal' s a
elementOf :: Fold s a       -> Int -> Fold s a

-- >>> [[0, 1, 2], [3, 4], [5, 6, 7, 8]] & elementOf (traversed . traversed) 6 *~ 100
-- [[0,1,2],[3,4],[5,600,7,8]]

7.3 Traversal Composition

-- Add "Rich " to the names of people with more than $1000
ex53 :: ((String, Integer), (String, Integer), (String, Integer))
ex53 =
  (("Ritchie", 100000), ("Archie", 32), ("Reggie", 4350))
    & each
      . filtered ((> 1000) . snd)
      . _1
      %~ ("Rich " ++)

-- >>>ex53
-- (("Rich Ritchie",100000),("Archie",32),("Rich Reggie",4350))

Exercises - Simple Traversals

What type of optic do you get when you compose a traversal with a fold?

fold

-- >>> [[3 :: Int, 4]] ^.. traversed . folded
-- [3,4]

-- >>> [[3 :: Int, 4]] & traversed . folded .~ 2
-- No instance for (Contravariant Identity)
--   arising from a use of `folded'
-- In the second argument of `(.)', namely `folded'
-- In the first argument of `(.~)', namely `traversed . folded'
-- In the second argument of `(&)', namely `traversed . folded .~ 2'

Which of the optics we've learned can act as a traversal?
- lens and traversal
Which of the optics we've learned can act as a fold?
- lens, traversal, fold

-- >>>("Jurassic", "Park") & both .~ "N/A"
-- ("N/A","N/A")

-- >>> ("Jurassic" :: String, "Park") & both . traversed .~ 'x'
-- ("xxxxxxxx","xxxx")

-- >>>("Malcolm", ["Kaylee", "Inara", "Jayne"]) & beside id traversed %~ take 3
-- ("Mal",["Kay","Ina","Jay"])

-- >>>("Malcolm", ["Kaylee", "Inara", "Jayne"]) & _2 . elementOf traversed 1 .~ "River"
-- ("Malcolm",["Kaylee","River","Jayne"])

-- >>> ["Die Another Day", "Live and Let Die", "You Only Live Twice"] & traversed . elementOf worded 1 . traversed .~ 'x'
-- ["Die xxxxxxx Day","Live xxx Let Die","You xxxx Live Twice"]

-- >>>((1, 2), (3, 4)) & both . both +~ 1
-- ((2,3),(4,5))

-- >>>(1, (2, [3, 4])) & beside id (beside id traversed) +~ 1
-- (2,(3,[4,5]))

ex54 = ((True, "Strawberries" :: String), (False, "Blueberries"), (True, "Blackberries")) & each . filtered fst . _2 . taking 5 traversed %~ toUpper

-- >>> ex54
-- ((True,"STRAWberries"),(False,"Blueberries"),(True,"BLACKberries"))

ex55 = ((True, "Strawberries"), (False, "Blueberries"), (True, "Blackberries" :: String)) & each %~ snd

-- >>> ex55
-- ("Strawberries","Blueberries","Blackberries")

7.4 Traversal Actions

sequenceA :: (Traversable t, Applicative f) => t (f a) -> f (t a)

-- >>>sequenceA $ Just (Left "Whoops")
-- Left "Whoops"

-- >>>sequenceA $ Just (Right "Whoops")
-- Right (Just "Whoops")

-- >>> :t readMaybe
-- readMaybe :: Read a => String -> Maybe a

-- >>>traverse readMaybe ["1", "2", "3"] :: Maybe [Int]
-- Just [1,2,3]

-- >>>traverse readMaybe ["1", "snark", "3"] :: Maybe [Int]
-- Nothing

Traverse on Traversals

Can run traverse on arbitrary focuses!

-- >>>:t traverseOf
-- traverseOf :: LensLike f s t a b -> (a -> f b) -> s -> f t

-- >>> :t traverse
-- traverse :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b)

-- >>> :t traverseOf traversed
-- traverseOf traversed
--   :: (Traversable f1, Applicative f2) =>
--      (a -> f2 b) -> f1 a -> f2 (f1 b)

-- >>>traverseOf both readMaybe ("1", "2") :: Maybe (Int, Int)
-- Just (1,2)

-- >>> traverseOf both (\c -> [toLower c, toUpper c]) ('a', 'b')
-- [('a','b'),('a','B'),('A','b'),('A','B')]

-- >>> traverseOf (both . traversed) (\c -> [toLower c, toUpper c]) ("ab", "c")
-- [("ab","c"),("ab","C"),("aB","c"),("aB","C"),("Ab","c"),("Ab","C"),("AB","c"),("AB","C")]

validateEmail :: String -> Validation [String] String
validateEmail email
  | elem '@' email = Success email
  | otherwise =
      Failure ["missing '@': " <> email]

-- >>> traverseOf (both . traversed) validateEmail (["mike@tmnt.io", "raph@tmnt.io"], ["don@tmnt.io", "leo@tmnt.io"])
-- Success (["mike@tmnt.io","raph@tmnt.io"],["don@tmnt.io","leo@tmnt.io"])

-- >>> traverseOf (both . traversed) validateEmail (["mike@tmnt.io", "raph.io"], ["don@tmnt.io", "leo.io"])
-- Failure ["missing '@': raph.io","missing '@': leo.io"]

Other functions:

-- >>>:t forOf
-- forOf :: LensLike f s t a b -> s -> (a -> f b) -> f t

-- >>>:t sequenceAOf
-- sequenceAOf :: LensLike f s t (f b) b -> s -> f t

-- >>> sequenceAOf _1 (Just "Garfield", "Lasagna")
-- Just ("Garfield","Lasagna")

-- >>> sequenceAOf (both . traversed) ([Just "apples"], [Just "oranges"])
-- Just (["apples"],["oranges"])

Infix `traverseOf`

-- >>> (("1", "2") & both %%~ readMaybe) :: Maybe (Int, Int)
-- Just (1,2)

Use Traversals directly

Actual definitions:

traverseOf = id
(%%~) = id

So, we can (but should not!) use Traversals without traverseOf:

-- >>>both readMaybe ("1", "2") :: Maybe (Int, Int)
-- Just (1,2)

Exercises - Traversal Actions

-- >>> sequenceAOf _1 (Nothing, "Rosebud")
-- Nothing

-- >>> sequenceAOf (traversed . _1) [("ab" :: String,1),("cd",2)]
-- [[('a',1),('c',2)],[('a',1),('d',2)],[('b',1),('c',2)],[('b',1),('d',2)]]

ex56 :: (([Integer], (Integer, Integer)), Integer)
ex56 = runState result 0
 where
  result = traverseOf (beside traversed both) (\n -> modify (+ n) >> get) ([1, 1, 1], (1, 1))

-- >>>ex56
-- (([1,2,3],(4,5)),5)

ex57 :: [([Char], Bool)]
ex57 =
  ("ab" :: String, True)
    & (_1 . traversed)
      %%~ (\c -> [toLower c, toUpper c])

ex58 :: [[(Char, Bool)]]
ex58 =
  [('a', True), ('b', False)]
    & (traversed . _1)
      %%~ (\c -> [toLower c, toUpper c])

data UserWithAge = UserWithAge
  { _userName :: String
  , _userAge :: Int
  }
  deriving (Show)
makeLenses ''UserWithAge
data Account = Account
  { _accountId :: String
  , _userWithAge :: UserWithAge
  }
  deriving (Show)
makeLenses ''Account

validateAge :: Account -> Validation String Account
validateAge acc
  | age' <= 0 = Failure "Age is below 0"
  | age' >= 150 = Failure "Age is above 150"
  | otherwise = Success acc
 where
  age' = acc ^. userWithAge . userAge

7.5 Custom traversals

van Laarhoven optics are

type LensLike f s t a b = (a -> f b) -> (s -> f t)

plus constraints

type Lens s t a b = forall f. Functor f => (a -> f b) -> (s -> f t)
type Traversal s t a b = forall f. Applicative f => (a -> f b) -> (s -> f t)
type Fold s a = forall f. (Contravariant f, Applicative f) => (a -> f a) -> (s -> f s)

And LensLike is very similar to traverse signature:

traverse :: (Traversable g, Applicative f) => (a -> f b) -> (g a -> f (g b))
myTraversal :: myTraversal :: (Applicative f) => (a -> f b) -> (s -> f t)

Most optics are really just traverse wearing different pants.

Our first custom traversal

traversed for lists

-- values :: Traversal [a] [b] a b
values :: Applicative f => (a -> f b) -> [a] -> f [b]
values _ [] = pure []
values handler (a : as) = liftA2 (:) (handler a) (values handler as)

-- >>> ["one", "two", "three"] & values %~ length
-- [3,3,5]

Traversals with custom logic

Some bank software

data Transaction
  = Withdrawal {_amount :: Int}
  | Deposit {_amount :: Int}
  deriving (Show)
makeLenses ''Transaction

newtype BankAccount = BankAccount
  { _transactions :: [Transaction]
  }
  deriving (Show)
makeLenses ''BankAccount

aliceAccount :: BankAccount
aliceAccount = BankAccount [Deposit 100, Withdrawal 20, Withdrawal 10]

-- >>>aliceAccount ^.. transactions . traversed . amount
-- [100,20,10]

Case study: Transaction Traversal

Need a traversal which focuses on only the dollar amounts of deposits within a given account.

-- deposits :: Traversal' [Transaction] Int
-- deposits :: Traversal [Transaction] [Transaction] Int Int
deposits :: Applicative f => (Int -> f Int) -> [Transaction] -> f [Transaction]
deposits _ [] = pure []
deposits handler (Withdrawal amt : rest) = fmap (Withdrawal amt :) (deposits handler rest)
deposits handler (Deposit amt : rest) = liftA2 (:) (Deposit <$> handler amt) (deposits handler rest)

-- >>>[Deposit 10, Withdrawal 20, Deposit 30] & deposits *~ 10
-- [Deposit {_amount = 100},Withdrawal {_amount = 20},Deposit {_amount = 300}]

deposits' :: Traversal' [Transaction] Int
deposits' = traversed . filtered (\case Deposit _ -> True; _ -> False) . amount

Exercises - Custom traversals

custom traversal

-- amountT :: Traversal' Transaction Int
amountT :: Applicative f => (Int -> f Int) -> Transaction -> f Transaction
amountT f = \case Deposit am -> Deposit <$> f am; Withdrawal am -> Withdrawal <$> f am

custom both

both' :: Traversal (a, a) (b, b) a b
both' f (x, y) = liftA2 (,) (f x) (f y)

delta - Similar to change of coordinates via matrix pre- and post-multiplication

transactionDelta :: Traversal' Transaction Int
transactionDelta f = \case Deposit amt -> Deposit <$> f amt; Withdrawal amt -> Withdrawal . negate <$> f (negate amt)

-- >>> Deposit 10 ^? transactionDelta
-- Just 10

-- Withdrawal's delta is negative
-- >>> Withdrawal 10 ^? transactionDelta
-- Just (-10)
-- >>> Deposit 10 & transactionDelta .~ 15
-- Deposit {_amount = 15}
-- >>> Withdrawal 10 & transactionDelta .~ (-15)
-- Withdrawal {_amount = 15}
-- >>> Deposit 10 & transactionDelta +~ 5
-- Deposit {_amount = 15}
-- >>> Withdrawal 10 & transactionDelta +~ 5
-- Withdrawal {_amount = 5}

left' :: Traversal (Either a b) (Either a' b) a a'
left' f = \case Left e -> Left <$> f e; Right x -> pure $ Right x

beside' :: Traversal s t a b -> Traversal s' t' a b -> Traversal (s, s') (t, t') a b
beside' l r f (l1, r1) = liftA2 (,) (l f l1) (r f r1)

7.6 Traversal Laws

Law One: Respect Purity

Running the pure handler (which has no effects) using our traversal should be exactly the same as running pure on the original structure without using the traversal at all.

traverseOf myTraversal pure x == pure x

badTupleSnd :: Traversal (Int, a) (Int, b) a b
badTupleSnd handler (n, a) = (n + 1,) <$> handler a

-- >>> traverseOf badTupleSnd pure (10, "Yo")
-- (11,"Yo")

Law Two: Consistent Focuses

Running a traversal twice in a row with different handlers should be equivalent to running it once with the composition of those handlers.

x & myTraversal %~ f
  & myTraversal %~ g
==
x & myTraversal %~ (g . f)

The traversal should never change which elements it focuses due to alterations on those elements.

filtered breaks this law!

-- >>> 2 & filtered even %~ (+1) & filtered even %~ (*10)
-- 3

-- >>> 2 & filtered even %~ (*10) . (+1)
-- 30

Exercises - Traversal Laws

worded violates the Law Two

-- >>>("hit the road, jack" :: String) & worded %~ take 3 & worded %~ drop 2
-- "t e a c"

-- >>>("hit the road, jack" :: String) & worded %~ (take 3 . drop 2)
-- "t e ad, ck"

Break the Law One

myTraversal :: Traversal Int Int Int Int
myTraversal f _ = f 1

-- >>>(traverseOf myTraversal pure 6) :: Identity Int
-- Identity 1

-- >>>pure 6 :: Identity Int
-- Identity 6

Break the Law Two

ex60 :: Traversal' [Int] Int
ex60 = traversed . filtered even

-- >>> [1, 2, 3] & ex60 %~ (+ 1) & ex60 %~ (+ 2)
-- [1,3,3]

-- >>> [1, 2, 3] & ex60 %~ (+ 1) . (+ 2)
-- [1,5,3]

Check lawful

taking is lawful
beside is lawful
each is lawful
lined is unlawful

traversed is lawful

-- >>>("hit\nthe\nroad,\njack" :: String) & lined %~ take 3 & lined %~ drop 2
-- "t\ne\na\nc"

-- >>>("hit\nthe\nroad,\njack" :: String) & lined %~ (take 3 . drop 2)
-- "t\ne\nad,\nck"

update function can insert newlines

-- >>>("hit\nthe\nroad,\njack" :: String) & lined %~ (\(x:y:xs) -> (x:y:'\n':xs)) & lined %~ take 2
-- "hi\nt\nth\ne\nro\nad\nja\nck"

-- >>>("hit\nthe\nroad,\njack" :: String) & lined %~ (take 2 . \(x:y:xs) -> (x:y:'\n':xs))
-- "hi\nth\nro\nja"

7.7 Advanced manipulation

partsOf

Real:

-- >>>:t partsOf
-- partsOf :: Functor f => Traversing (->) f s t a a -> LensLike f s t [a] [a]

Book:

Make a lens whose focuses are focuses of a provided traversal
```
partsOf :: Traversal' s a -> Lens' s [a]
```

-- >>> [('a', 1 :: Int), ('b', 2), ('c', 3)] & partsOf (traversed . _2) .~ [4]
-- [('a',4),('b',2),('c',3)]

-- >>> [('a', 1 :: Int), ('b', 2), ('c', 3)] & partsOf (traversed . _2) .~ [4,5,6,7,8]
-- [('a',4),('b',5),('c',6)]

Cool example:

focus all characters in strings
concatenate, split into words, sort words, concatenate back
place on corresponding places

-- >>> ("how is a raven ", "like a ", "writing desk") & partsOf (each . traversed) %~ unwords . sort . words
-- ("a a desk how is"," like r","aven writing")

Placement matters

-- Collect 'each' tuple element into a list, then traverse that list
-- >>> ("abc", "def") ^.. partsOf each . traversed
-- ["abc","def"]

-- Collect each tuple element, then traverse those strings collecting each character into a list.
-- >>> (("abc", "def") ^.. partsOf (each . traversed)) :: [String]
-- ["abcdef"]

Can use other focuses for calculating each

ex61 :: [(Char, Double)]
ex61 =
  [('a', 1), ('b', 2), ('c', 3)]
    & partsOf (traversed . _2)
      %~ \xs -> (/ sum xs) <$> xs

-- >>>ex61
-- [('a',0.16666666666666666),('b',0.3333333333333333),('c',0.5)]

Polymorphic partsOf

We can change type of focuses if supply enough elements

unsafePartsOf :: Traversal s t a b -> Lens s t [a] [b]

-- >>>[('a', 1), ('b', 2), ('c', 3)] & unsafePartsOf (traversed . _1) .~ [True, False]
-- unsafePartsOf': not enough elements were supplied

ex62 :: [((Char, Maybe Char), Integer)]
ex62 =
  [('a', 1), ('b', 2), ('c', 3)]
    & unsafePartsOf (traversed . _1)
      %~ \xs -> zip xs ((Just <$> tail xs) ++ [Nothing])

-- >>>ex62
-- [(('a',Just 'b'),1),(('b',Just 'c'),2),(('c',Nothing),3)]

partsOf and other data structures

Replace each ID in a Tree with a User

userIds :: Tree UserId
lookupUsers :: [UserId] -> IO [User]
treeLookup :: Tree UserId -> IO (Tree User)
treeLookup = traverseOf (unsafePartsOf traversed) lookupUsers

Exercises - partsOf

-- >>> [1, 2, 3, 4] ^. partsOf (traversed . filtered even)
-- [2,4]

-- >>> ["Aardvark" :: String, "Bandicoot", "Capybara"] ^. traversed . partsOf (taking 3 traversed)
-- "AarBanCap"

ex63 :: [Int]
ex63 = ([1, 2], M.fromList [('a', 3), ('b', 4)]) ^. partsOf (beside traversed traversed)

-- >>> ex63
-- [1,2,3,4]

-- >>> [1, 2, 3, 4] & partsOf (traversed . filtered even) .~ [20, 40]
-- [1,20,3,40]

-- >>> ["Aardvark", "Bandicoot", "Capybara"] & partsOf (traversed . traversed) .~ "Kangaroo"
-- ["Kangaroo","Bandicoot","Capybara"]

-- >>> ["Aardvark", "Bandicoot", "Capybara"] & partsOf (traversed . traversed) .~ "Ant"
-- ["Antdvark","Bandicoot","Capybara"]

-- Modifying
-- Tip: Map values are traversed in order by KEY
-- >>> M.fromList [('a', 'a'), ('b', 'b'), ('c', 'c')] & partsOf traversed %~ \(x:xs) -> xs ++ [x]
-- fromList [('a','b'),('b','c'),('c','a')]

-- >>> ('a', 'b', 'c') & partsOf each %~ reverse
-- ('c','b','a')

-- >>> [1, 2, 3, 4, 5, 6] & partsOf (taking 3 traversed) %~ reverse
-- [3,2,1,4,5,6]

-- >>> ('a', 'b', 'c') & unsafePartsOf each %~ \xs -> fmap ((,) xs) xs
-- (("abc",'a'),("abc",'b'),("abc",'c'))

8. Indexable Structures

8.1 What's an "indexable" structure?

Indexable structures store values at named locations which can be identified by some index. That is, an index represents a specific location within a data structure where a value might be stored.

Data structures have different interfaces (lists, dicts)

8.2 Accessing and updating values with 'Ixed'

The Ixed Class

Unifies the interface to all data structures.

class Ixed m where
  ix :: Index m -> Traversal' m (IxValue m)

makes a Traversal because an Index at a specified location may be missing.

These are Type Families that calculate an index an a value types for a data structure.

type instance Index [a] = Int
type instance IxValue [a] = a

type instance Index (Map k a) = k
type instance IxValue (Map k a) = a

type instance Index Text = Int
type instance IxValue Text = Char

type instance Index ByteString = Int
type instance IxValue ByteString = Word8

Accessing and setting values with ix

Can't add or remove focuses.

Lists:

humanoids :: [String]
humanoids = ["Borg", "Cardassian", "Talaxian"]

-- >>> -- Get the value at index 1:
-- >>> humanoids & ix 1 .~ "Vulcan"
-- ["Borg","Vulcan","Talaxian"]
-- >>> -- There's no value at index 10 so the traversal doesn't focus anything
-- >>> humanoids & ix 10 .~ "Romulan"
-- ["Borg","Cardassian","Talaxian"]

Maps:

benders :: M.Map String String
benders = M.fromList [("Katara", "Water"), ("Toph", "Earth"), ("Zuko", "Fire")]

-- Get the value at key "Zuko"
-- >>> benders ^? ix "Zuko"
-- Just "Fire"

-- If there's no value at a key, the traversal returns zero elements
-- >>> benders ^? ix "Sokka"
-- Nothing

-- We can set the value at a key, but only if that key already exists
-- >>> benders & ix "Toph" .~ "Metal"
-- fromList [("Katara","Water"),("Toph","Metal"),("Zuko","Fire")]

-- Setting a non-existent element of a Map does NOT insert it.
-- >>> benders & ix "Iroh" .~ "Lightning"
-- fromList [("Katara","Water"),("Toph","Earth"),("Zuko","Fire")]

Indexed Structures

-- >>> :kind! forall a. Index [a]
-- forall a. Index [a] :: *
-- = Int

-- >>> :kind! forall a. IxValue [a]
-- forall a. IxValue [a] :: *
-- = a

Indexing monomorphic types

-- >>>("hello" :: T.Text) ^? ix 0
-- Just 'h'

-- We can edit a Word8 within a ByteString as though it's an integer.
-- >>> ("hello" :: BS.ByteString) & ix 0 +~ 2
-- "jello"

Cool example:

ex64 :: [T.Text]
ex64 = ("hello" :: T.Text) & ix 1 %%~ const ("aeiou" :: [Char])

Explanation:

type instance IxValue [a] = a
instance Ixed [a] where
  ix k f xs0 | k < 0     = pure xs0
             | otherwise = go xs0 k where
    go [] _ = pure []
    go (a:as) 0 = f a <&> (:as)
    go (a:as) i = (a:) <$> (go as $! i - 1)
  {-# INLINE ix #-}

So, we'll pre- and append the not-focused parts inside the Functorial context.

ex64' :: [String]
ex64' = ('h' :) <$> (const "aeiou" 'e' <&> (: "llo"))

-- >>>ex64'
-- ["hallo","hello","hillo","hollo","hullo"]

Indexing stranger structures

Numbers denote node children

tree :: Tree Int
tree = Node 1 [Node 2 [Node 4 []], Node 3 [Node 5 [], Node 6 []]]

-- >>> tree ^? ix [1, 1]
-- Just 6

-- >>> tree ^? ix [5, 6]
-- Nothing

Functions:

We can "set" or traverse individual results of a function! Here we overwrite the function's output at the input value "password" so it instead returns a new value.

-- >>> myPass = (reverse & ix "password" .~ "You found the secret!")
-- >>> "pass" & myPass
-- "ssap"
-- >>> "password" & myPass
-- "You found the secret!"

8.3 Inserting & Deleting with 'At'

Map-like structures

Can be used with structures that support inserts by an arbitrary index.

Map k v
Set k (~ Map k ()) Lists don't support that. E.g., can't insert 10th element without having 9th.

class At where
  at :: Index m -> Lens' m (Maybe (IxValue m))

ix :: Index m -> Traversal' m (IxValue m)
at :: Index m -> Lens' m (Maybe (IxValue m))

(?~) :: Traversal s t a (Maybe b) -> b -> s -> t

-- >>>benders & at "Iroh" ?~ "Lightning"
-- fromList [("Iroh","Lightning"),("Katara","Water"),("Toph","Earth"),("Zuko","Fire")]

sans :: At m => Index m -> m -> m
sans k = at k .~ Nothing

-- >>> sans "Katara" benders
-- fromList [("Toph","Earth"),("Zuko","Fire")]

ps :: [Int]
ps = foldl (\acc x -> acc <> check acc x) [2] [3 .. 100]
 where
  check (a : as) x
    | a * a > x = [x]
    | x `mod` a == 0 = []
    | otherwise = check as x
  check [] x = [x]

-- >>> ps
-- [2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97]

primes :: S.Set Int
primes = S.fromList (ps ^.. taking 5 traversed)

-- >>> primes & at 17 ?~ ()
-- fromList [2,3,5,7,11,17]

Exercises - Indexable Structuresm

fill in blanks

-- >>> ["Larry", "Curly", "Moe"] & ix 1 .~ "Wiggly"
-- ["Larry","Wiggly","Moe"]

heroesAndVillains :: M.Map String String
heroesAndVillains = M.fromList [("Superman", "Lex"), ("Batman", "Joker")]

-- >>> heroesAndVillains & at "Spiderman" .~ Just "Goblin"
-- fromList [("Batman","Joker"),("Spiderman","Goblin"),("Superman","Lex")]

-- >>> sans "Superman" heroesAndVillains
-- fromList [("Batman","Joker")]

-- >>> S.fromList ['a', 'e', 'i', 'o', 'u'] & at 'y' .~ Just () & at 'i' .~ Nothing
-- fromList "aeouy"

input -> output

input :: M.Map String Integer
input = M.fromList [("candy bars", 13), ("gum", 7), ("soda", 34)]

output :: M.Map String Integer
output = M.fromList [("candy bars", 13), ("ice cream", 5), ("soda", 37)]

-- >>> input & at "soda" %~ ((+ 3) <$>) & sans "gum" & at "ice cream" ?~ 5
-- fromList [("candy bars",13),("ice cream",5),("soda",37)]

-- TODO find 8.5 + and prisms and

10. Isos

isomorphism - a completely reversible transformation between two types or formats.
every iso MUST succeed for all inputs.

isos

Example: converting Text to String:

T.pack . T.unpack = id
T.unpack . T.pack = id

Construct an Iso:

iso :: (s -> a) -> (b -> t) -> Iso s t a b

packed :: Iso' String T.Text
packed = iso to' from'
 where
  to' :: String -> T.Text
  to' = T.pack
  from' :: T.Text -> String
  from' = T.unpack

-- >>> ("Ay, caramba!" :: String) ^. packed
-- "Ay, caramba!"

-- Use isos as prisms
-- >>> packed # ("Sufferin' Succotash" :: T.Text)
-- "Sufferin' Succotash"

10.3 Flipping isos with from

from :: Iso s t a b -> Iso b a t s
from :: Iso' s a -> Iso' a s

-- >>> ("Good grief" :: T.Text) ^. from packed
-- "Good grief"

Reversing again.

unpacked :: Iso' T.Text String
unpacked = from packed

10.4 Modification under isomorphism

Example: focus on Text (to use functions existing for Text), then convert back to a String.

-- >>> let str = "Idol on a pedestal" :: String
-- >>> over packed (T.replace "Idol" "Sand") str
-- "Sand on a pedestal"

-- Combining with other optics
-- >>> import Data.Char (toUpper)
-- >>> let txt = "Lorem ipsum" :: T.Text
-- >>> txt & from packed . traversed %~ toUpper
-- "LOREM IPSUM"

10.5 Varieties of isomorphisms

Isos for the same type

reversed :: Iso' [a] [a]
reversed = iso reverse reverse

involuted :: (a -> a) -> Iso' a a
involuted f = iso f f

reversed :: Iso' [a] [a]
reversed = involuted reverse

-- >>> "Blue suede shoes" & reversed . taking 1 worded . reversed .~ "gloves"
-- "Blue suede gloves"

Rearrange pairs

swapped :: Iso (s, s') (t, t') (a, a') (b, b')

swapped :: (Bifunctor p, Swapped p) => Iso (p a b) (p c d) (p b a) (p d c)

-- >>> ("Fall","Pride") ^. swapped
-- ("Pride","Fall")

-- >>> Right "Field" ^. swapped
-- Left "Field"

Isos for functions

flipped :: Iso' (a -> b -> c) (b -> a -> c)

-- >>> let (++?) = (++) ^. flipped
-- >>> "A" ++? "B"
-- "BA"

curried :: Iso' ((a, b) -> c) (a -> b -> c)
uncurried :: Iso' (a -> b -> c) ((a, b) -> c)

-- >>> let addTuple = (+) ^. uncurried
-- >>> addTuple (1, 2)
-- 3

Isos for numbers

-- >>> 100 ^. adding 50
-- 150

Composing isos

-- >>> import Numeric.Lens
-- >>> 30 & dividing 10 . multiplying 2 +~ 1
-- 35.0

-- 30 -> 30/10 = 3 -> 3 * 2 = 6 -> 6 + 1 = 7 -> 7 / 2 = 3.5 -> 3.5 * 10 = 35

Exercises - Intro to Isos

Choose the best optic:
- Focus a Celsius temperature in Fahrenheit - Iso - reversible
- Focus the last element of a list - Traversal - the element may be missing
- View a JSON object as its corresponding Haskell Record - Prism - may fail to parse
- Rotate the elements of a three-tuple one to the right - Iso - rotation is reversible
- Focus on the 'bits' of an Int as Bools - Traversal or Prism - multiple focuses
- Focusing an IntSet from a Set Int - Iso - reversible
Fill in the blank

-- >>> ("Beauty", "Age") ^. swapped
-- ("Age","Beauty")

-- >>> 50 ^. adding 10
-- 60

-- >>> 50 ^. from (adding 10)
-- 40

-- >>> 0 & multiplying 4 +~ 12
-- 3.0

-- >>> 0 & adding 10 . multiplying 2 .~ _
-- 2

-- Note: transpose flips the rows and columns of a nested list:
-- >>> import Data.List (transpose)
-- >>> transpose [[1, 2, 3], [10, 20, 30]]
-- [[1,10],[2,20],[3,30]]
-- >>> [[1, 2, 3], [10, 20, 30]] & involuted transpose %~ drop 1
-- [[2,3],[20,30]]

-- Extra hard: use `switchCase` somehow to make this statement work:
ex65 :: (Integer, String)
ex65 = (32, "Hi") & _2 . involuted (map switchCase) .~ ("hELLO" :: String)
 where
  switchCase c = if isUpper c then toLower c else toUpper c

-- >>> ex65
-- (32,"Hello")

Conversion

celsiusToF :: Double -> Double
celsiusToF c = (c * (9 / 5)) + 32

fToCelsius :: Double -> Double
fToCelsius f = (f - 32) * 5 / 9

fahrenheit' :: Iso' Double Double
fahrenheit' = iso fToCelsius celsiusToF

-- >>> 0 & fahrenheit' .~ 100
-- 212.0

10.6 Projecting Isos

We can lift Isos into other structures.

mapping :: (Functor f, Functor g) => Iso s t a b -> Iso (f s) (g t) (f a) (g b)

toYamlList :: [String] -> String
toYamlList xs = "- " <> intercalate "\n- " xs

shoppingList :: [T.Text]
shoppingList = ["Milk", "Eggs", "Flour"] :: [T.Text]

-- >>> shoppingList ^. mapping unpacked . to toYamlList
-- "- Milk\n- Eggs\n- Flour"

There's more:

contramapping :: Contravariant f => Iso s t a b -> Iso (f a) (f b) (f s) (f t)
bimapping :: (Bifunctor f, Bifunctor g) => Iso s t a b -> Iso s' t' a' b' -> Iso (f s s') (g t t') (f a a') (g b b')
dimapping :: (Profunctor p, Profunctor q) => Iso s t a b -> Iso s' t' a' b' -> Iso (p a s') (q b t') (p s a') (q t b')

textToYamlList :: [T.Text] -> T.Text
textToYamlList = (toYamlList :: [String] -> String) ^. dimapping (mapping unpacked :: Iso' [T.Text] [String]) (packed :: Iso' String T.Text)

-- much more readable
textToYamlList' :: [T.Text] -> T.Text
textToYamlList' = T.pack . toYamlList . fmap T.unpack

Exercises - Projected Isos

Fill in the blank

-- >>> ("Beauty", "Age") ^. mapping reversed . swapped
-- ("egA","Beauty")

-- >>> [True, False, True] ^. mapping (involuted not)
-- [False,True,False]

-- >>> [True, False, True] & mapping (involuted not) %~ filter id
-- [False]

-- >>> (show ^. mapping reversed) 1234
-- "4321"

Using enum :: Enum a => Iso' Int a implement the intNot.

intNot :: Int -> Int
intNot = not ^. dimapping enum (from enum)

-- >>> intNot 0
-- 1

-- >>> intNot 1
-- 0

-- >>> intNot 2
-- Prelude.Enum.Bool.toEnum: bad argument

intNot' :: Int -> Int
intNot' = fromEnum . not . toEnum @Bool

-- >>> intNot' 0
-- 1

-- >>> intNot' 1
-- 0

-- >>> intNot' 2
-- Prelude.Enum.Bool.toEnum: bad argument

10.7 Isos and newtypes

Coercing with isos

Coercible is derived for newtypes by the compiler
Can coerce between newtypes

coerced :: (Coercible s a, Coercible t b) => Iso s t a b

newtype Email = Email {_email :: String} deriving (Show)

-- >>> Email "hi\nu"
-- Email {_email = "hi\nu"}

-- >>> over coerced (reverse :: String -> String) (Email "joe@example.com") :: Email
-- Email {_email = "moc.elpmaxe@eoj"}

email :: Iso' Email String
email = coerced

ex66 :: String
ex66 = Email "joe@example.com" ^. email . reversed

Newtype wrapper isos

makeLenses derives isos

_Wrapped' :: Wrapped s => Iso' s (Unwrapped s)
_Unwrapped' :: Wrapped s => Iso' (Unwrapped s) s

map only between types and their newtype wrappers.
can be generated via makeWrapped

makeWrapped ''Email

ex67 :: Email
ex67 = Email "joe@example.com" & _Wrapped' @Email %~ reverse

-- >>> ex67
-- Email {_email = "moc.elpmaxe@eoj"}

10.8 Laws

Reversibility

myIso . from myIso == id
from myIso . myIso == id

-- >>> view (from reversed . reversed) ("Testing one two three")
-- "Testing one two three"

Exercises - Iso Laws

The following iso is unlawful; provide a counter example which shows that it breaks the law.

mapList :: Ord k => Iso' (M.Map k v) [(k, v)]
mapList = iso M.toList M.fromList

kvInts :: [(Int, Int)]
kvInts = [(2 :: Int, 1 :: Int), (1, 2)]

ex68 :: [(Int, Int)]
ex68 = kvInts ^. from mapList . mapList

-- >>> ex68
-- [(1,2),(2,1)]

-- >>> ex68 == kvInts
-- False

Is there a lawful implementation of the following iso? If so, implement it, if not, why not?

Yes, there is one.

nonEmptyList :: Iso [a] [b] (Maybe (NonEmpty a)) (Maybe (NonEmpty b))
nonEmptyList = iso nonEmpty (maybe [] Data.List.NonEmpty.toList)

-- >>> [] ^. nonEmptyList . from nonEmptyList
-- []

-- >>> Nothing ^. from nonEmptyList . nonEmptyList
-- Nothing

-- >>> [1] ^. nonEmptyList . from nonEmptyList
-- [1]

-- >>> (Just (1 :| [])) ^. from nonEmptyList . nonEmptyList
-- Just (1 :| [])

Is there a lawful implementation of an iso which 'sorts' a list of elements? If so, implement it, if not, why not?
```
sorted :: Ord a => Iso' [a] [a]
```
- There's no implementation for this iso because it loses the info about the initial element order.

What about the following iso which pairs each element with an Int which remembers its original position in the list. Is this a lawful iso? Why or why not? If not, try to find a counter-example.

sorted :: (Ord a) => Iso' [a] [(Int, a)]
sorted = iso to' from'
 where
  to' xs = L.sortOn snd $ zip [0 ..] xs
  from' xs = snd <$> L.sortOn fst xs

-- >>> [2, 1] ^. sorted . from sorted
-- [2,1]

-- >>> [(1, 1), (0, 2)] ^. from sorted . sorted
-- [(1,1),(0,2)]

11. Indexed Optics

11.1 What are indexed optics?

Let accumulate information about the current focus.

itraversed :: TraversableWithIndex i t => IndexedTraversal i (t a) (t b) a b

There are instances of TraversableWithIndex for most data structures. Like Ixed and At.

itoListOf :: IndexedGetting i (Endo [(i, a)]) s a -> s -> [(i, a)]
(^@..) :: s -> IndexedGetting i (Endo [(i, a)]) s a -> [(i, a)]

-- >>> itoListOf itraversed ["Summer", "Fall", "Winter", "Spring"]
-- [(0,"Summer"),(1,"Fall"),(2,"Winter"),(3,"Spring")]

Indices are added by actions. Indexed action accepts an indexed optic

actions

There are actions for: Lens, Traversal, Fold, Getter, Setter.

No actions for: Prisms, Isos.

Usually used for Folds or Traversals.

-- The index type of maps is the key,
-- so we can get a list of all elements and their key:
-- >>> let agenda = M.fromList [("Monday", "Shopping"), ("Tuesday", "Swimming")]
-- >>> agenda ^@.. itraversed
-- [("Monday","Shopping"),("Tuesday","Swimming")]

-- The index type of trees is a list of int's
-- which indicates their location in the tree
-- (See the section on indexed data structures)
-- >>> import Data.Tree
-- >>> let t = Node "top" [Node "left" [], Node "right" []]
-- >>> t ^@.. itraversed
-- [([],"top"),([0],"left"),([1],"right")]

11.2 Index Composition

Index of a path will be the index of the last indexed optic in the path.

agenda :: M.Map String [String]
agenda = M.fromList [("Monday", ["Shopping", "Yoga"]), ("Saturday", ["Brunch", "Food coma"])]

-- >>> agenda ^@.. itraversed . itraversed
-- [(0,"Shopping"),(1,"Yoga"),(0,"Brunch"),(1,"Food coma")]

(<.): Use the index of the optic to the left
(.>): Use the index of the optic to the right (This is how . already behaves)
(<.>): Combine the indices of both sides as a tuple

Use map key as an index

-- >>> agenda ^@.. itraversed <. itraversed
-- [("Monday","Shopping"),("Monday","Yoga"),("Saturday","Brunch"),("Saturday","Food coma")]

-- >>> agenda ^@.. itraversed <.> itraversed
-- [(("Monday",0),"Shopping"),(("Monday",1),"Yoga"),(("Saturday",0),"Brunch"),(("Saturday",1),"Food coma")]

Custom index composition

icompose Composition of Indexed functions with a user supplied function for combining indices.

icompose :: Indexable p c
         => (i -> j -> p)
         -> (Indexed i s t -> r)
         -> (Indexed j a b -> s -> t)
         -> c a b
         -> r

showDayAndNumber :: String -> Int -> String
showDayAndNumber a b = a <> ": " <> show b

-- >>> agenda ^@.. icompose showDayAndNumber itraversed itraversed
-- [("Monday: 0","Shopping"),("Monday: 1","Yoga"),("Saturday: 0","Brunch"),("Saturday: 1","Food coma")]

custom operator

(<symbols>) :: (Indexed <indexTypeA> s t -> r)
            -> (Indexed <indexTypeB> a b -> s -> t)
            -> (Indexed <combinedType> a b -> r)
(<symbols>) = icompose <combinationFunction>

(.++) :: (Indexed String s t -> r) -> (Indexed String a b -> s -> t) -> Indexed String a b -> r
(.++) = icompose (\a b -> a ++ ", " ++ b)

populationMap :: M.Map String (M.Map String Int)
populationMap =
  M.fromList
    [ ("Canada", M.fromList [("Ottawa", 994837), ("Toronto", 2930000)])
    , ("Germany", M.fromList [("Berlin", 3748000), ("Munich", 1456000)])
    ]

-- >>> populationMap ^@.. itraversed .++ itraversed
-- [("Canada, Ottawa",994837),("Canada, Toronto",2930000),("Germany, Berlin",3748000),("Germany, Munich",1456000)]

Exercises

-- >>> M.fromList [("streamResponse", False), ("useSSL", True)] ^@.. itraversed
-- [("streamResponse",False),("useSSL",True)]

-- >>> (M.fromList [('a', 1), ('b', 2)], M.fromList [('c', 3), ('d', 4)]) ^@.. both . itraversed
-- [('a',1),('b',2),('c',3),('d',4)]

ex69 :: [(Char, Bool)]
ex69 = M.fromList [('a', (True, 1)), ('b', (False, 2))] ^@.. itraversed <. _1

-- >>> ex69
-- [('a',True),('b',False)]

-- >>> [M.fromList [("Tulips", 5), ("Roses", 3)] , M.fromList [("Goldfish", 11), ("Frogs", 8)]] ^@.. itraversed <.> itraversed
-- [((0,"Roses"),3),((0,"Tulips"),5),((1,"Frogs"),8),((1,"Goldfish"),11)]

ex70 :: [Int]
ex70 = [10 :: Int, 20, 30] & itraversed %@~ (+)

-- >>> ex70
-- [10,21,32]

ex71 :: IO [String]
ex71 = itraverseOf itraversed (\i s -> pure (replicate i ' ' <> s)) ["one", "two", "three"]

-- >>> ex71
-- ["one"," two","  three"]

-- >>> itraverseOf itraversed (\n s -> pure (show n <> ": " <> s)) ["Go shopping", "Eat lunch", "Take a nap"]
-- ["0: Go shopping","1: Eat lunch","2: Take a nap"]

11.3 Filtering by index

indices :: (Indexable i p, Applicative f) => (i -> Bool) -> Optical' p (Indexed i) f a a

-- Get list elements with an 'even' list-index:
-- >>> ['a'..'z'] ^.. itraversed . indices even
-- "acegikmoqsuwy"

ratings :: M.Map String Integer
ratings =
  M.fromList
    [ ("Dark Knight", 94)
    , ("Dark Knight Rises", 87)
    , ("Death of Superman", 92)
    ]

-- >>> ratings ^.. itraversed . indices (has (prefixed "Dark"))
-- [94,87]

Target a single index

index :: (Indexable i p, Eq i, Applicative f) => i -> Optical' p (Indexed i) f a a

-- >>> ratings ^? itraversed . index "Death of Superman"
-- Just 92

Exercises

Exercises schedule

data

exercises :: M.Map String (M.Map String Int)
exercises =
  M.fromList
    [ ("Monday", M.fromList [("pushups", 10), ("crunches", 20)])
    , ("Wednesday", M.fromList [("pushups", 15), ("handstands", 3)])
    , ("Friday", M.fromList [("crunches", 25), ("handstands", 5)])
    ]

-- >>> exercises
-- fromList [("Friday",fromList [("crunches",25),("handstands",5)]),("Monday",fromList [("crunches",20),("pushups",10)]),("Wednesday",fromList [("handstands",3),("pushups",15)])]

Compute the total number of "crunches" you should do this week.

ex72 :: Int
ex72 = sumOf (traversed . itraversed . indices (has (only "crunches"))) exercises

-- >>> ex72
-- 45

Compute the number of reps you need to do across all exercise types on Wednesday.

ex73 :: Int
ex73 = sumOf (itraversed . indices (has (only "Wednesday")) . traversed) exercises

-- >>> ex73
-- 18

List out the number of pushups you need to do each day, you can use ix to help this time if you wish.
```
ex74 :: [Int]
ex74 = exercises ^.. traversed . at "pushups" . non 0

-- >>> ex74
-- [0,10,15]
```

Board

data

board :: [String]
board =
  [ "XOO"
  , ".XO"
  , "X.."
  ]

Generate a list of positions alongside their (row, column) coordinates.

ex75 :: [((Int, Int), Char)]
ex75 = board ^@.. itraversed <.> itraversed

-- >>> ex75
-- [((0,0),'X'),((0,1),'O'),((0,2),'O'),((1,0),'.'),((1,1),'X'),((1,2),'O'),((2,0),'X'),((2,1),'.'),((2,2),'.')]

Set the empty square at (1, 0) to an 'X'. HINT: When using the custom composition operators you'll often need to introduce parenthesis to get the right precedence.
```
ex76 :: [String]
ex76 = board & ix 1 . ix 0 .~ 'X'

-- >>> ex76
-- ["XOO","XXO","X.."]
```

Get the 2nd column as a list (e.g. "OX."). Try to do it using index instead of indices!

ex77 :: [Char]
ex77 = board ^.. itraversed . itraversed . index 1

-- >>> ex77
-- "OX."

Get the 3rd row as a list (e.g. "X.."). Try to do it using index instead of indices! HINT: The precedence for this one can be tricky too.
```
ex78 :: [String]
ex78 = board ^.. itraversed . index 2

-- >>> ex78
-- ["X.."]
```

11.4 Custom indexed optics

Tic-Tac-Toe

data Board a = Board a a a a a a a a a deriving (Show, Foldable)

data Position = I | II | III deriving (Show, Eq, Ord)

testBoard :: Board Char
testBoard = Board 'X' 'O' 'X' '.' 'X' 'O' '.' 'O' 'X'

Want to access positions in grid. Need to index.

ifolding :: (Foldable f, Indexable i p, Contravariant g, Applicative g) => (s -> f (i, a)) -> Over p g s t a b

slotsFold :: IndexedFold (Position, Position) (Board a) a
slotsFold =
  ifolding $ \board_ ->
    -- Use a list comprehension to get the list of all coordinate pairs
    -- in the correct order, then zip them with all the slots in our board
    zip
      [(x, y) | y <- [I, II, III], x <- [I, II, III]]
      (Foldable.toList board_)

-- >>> testBoard ^@.. slotsFold
-- [((I,I),'X'),((II,I),'O'),((III,I),'X'),((I,II),'.'),((II,II),'X'),((III,II),'O'),((I,III),'.'),((II,III),'O'),((III,III),'X')]

-- Filter indices where the Y coord is 'II'
-- >>> testBoard ^@.. slotsFold . indices ((== II) . snd)
-- [((I,II),'.'),((II,II),'X'),((III,II),'O')]

Custom IndexedTraversals

-- define a polymorphic indexed traversal with a tuple of positions as the index:
slotsTraversal :: IndexedTraversal (Position, Position) (Board a) (Board b) a b
slotsTraversal p (Board a1 b1 c1 a2 b2 c2 a3 b3 c3) =
  Board
    <$> indexed p (I, I) a1
    <*> indexed p (II, I) b1
    <*> indexed p (III, I) c1
    <*> indexed p (I, II) a2
    <*> indexed p (II, II) b2
    <*> indexed p (III, II) c2
    <*> indexed p (I, III) a3
    <*> indexed p (II, III) b3
    <*> indexed p (III, III) c3

-- >>> testBoard ^@.. slotsTraversal
-- [((I,I),'X'),((II,I),'O'),((III,I),'X'),((I,II),'.'),((II,II),'X'),((III,II),'O'),((I,III),'.'),((II,III),'O'),((III,III),'X')]

-- >>> testBoard & slotsTraversal . indices ((== II) . snd) .~ '?'
-- Board 'X' 'O' 'X' '?' '?' '?' '.' 'O' 'X'

printBoard :: Board Char -> String
printBoard = execWriter . itraverseOf slotsTraversal printSlot
 where
  printSlot (III, _) c = tell ([c] <> "\n") >> pure [c]
  printSlot (_, _) c = tell [c] >> pure [c]

-- >>> printBoard testBoard
-- "XOX\n.XO\n.OX\n"

type IndexedTraversal i s t a b = forall p f. (Indexable i p, Applicative f) => p a (f b) -> s -> f t

p is a Profunctor.

indexed p reduces it to a function

indexed :: Indexable i p => p a b -> i -> a -> b

There's also ilens:

ilens :: (s -> (i, a)) -> (s -> b -> t) -> IndexedLens i s t a b

Index helpers

Add numeric index alongside elements of an optic.

indexing :: Traversal s t a b -> IndexedTraversal Int s t a b

-- >>> ("hello" :: T.Text) ^@.. indexing each
-- [(0,'h'),(1,'e'),(2,'l'),(3,'l'),(4,'o')]

Re-map or edit the indexes of an optic

reindexed :: Indexable j p => (i -> j) -> (Indexed i a b -> r) -> p a b -> r

-- >>> ['a'..'c'] ^@.. itraversed
-- [(0,'a'),(1,'b'),(2,'c')]

-- >>> ['a'..'c'] ^@.. reindexed (*10) itraversed
-- [(0,'a'),(10,'b'),(20,'c')]

Set the index of the path to the current value. This is to bring the upper context to lower path sections. Useful for JSON.

selfIndex :: Indexable a p => p a fb -> a -> fb

-- >>> [("Betty", 37), ("Veronica", 12)] ^.. itraversed . selfIndex <. _2
-- [(("Betty",37),37),(("Veronica",12),12)]

Exercises - Custom Indexed Optics

Write an indexed Traversal

-- pair :: IndexedFold Bool (a, a) a
pair :: IndexedTraversal Bool (a, a) (b, b) a b
pair p (x, y) = (,) <$> indexed p False x <*> indexed p True y

-- >>> ('a', 'b') ^@.. pair
-- [(False,'a'),(True,'b')]

Use reindexed to provide an indexed list traversal which starts at 1 instead of 0.

oneIndexed

oneIndexed :: IndexedTraversal Int [a] [b] a b
oneIndexed = reindexed (+ 1) itraversed

-- >>> ['a'..'d'] ^@.. oneIndexed
-- [(1,'a'),(2,'b'),(3,'c'),(4,'d')]

Use reindexed to write a traversal indexed by the distance to the end of the list.

invertedIndex :: IndexedTraversal Int [a] [b] a b
invertedIndex p x = reindexed ((length x - 1) -) itraversed p x

-- >>> ['a'..'d'] ^@.. invertedIndex
-- [(3,'a'),(2,'b'),(1,'c'),(0,'d')]

Build the following combinators using only compositions of other optics.

chars :: IndexedTraversal Int T.Text T.Text Char Char
chars p x = T.pack <$> itraversed p (T.unpack x)

-- >>> ("banana" :: T.Text) ^@.. chars
-- [(0,'b'),(1,'a'),(2,'n'),(3,'a'),(4,'n'),(5,'a')]

-- charCoords :: IndexedTraversal (Int, Int) String String Char Char
-- charCoords p x = itraversed p (itraversed p (lines x))

chc :: [((Int, Int), Char)]
chc = "line\nby\nline" ^@.. indexing lined <.> itraversed

-- >>> chc
-- [((0,0),'l'),((0,1),'i'),((0,2),'n'),((0,3),'e'),((1,0),'b'),((1,1),'y'),((2,0),'l'),((2,1),'i'),((2,2),'n'),((2,3),'e')]

11.5 Index-preserving optics

Some optics forget the index. Can make existing optics index-preserving.

cloneIndexPreservingLens :: Lens s t a b -> IndexPreservingLens s t a b
cloneIndexPreservingTraversal :: Traversal s t a b -> IndexPreservingTraversal s t a b
cloneIndexPreservingSetter :: Setter s t a b -> IndexPreservingSetter s t a b

-- Now the index 'passes-through' `_1'` to the end.
-- >>> let _1' = cloneIndexPreservingLens _1
-- >>> [('a', True), ('b', False), ('c', True)] ^@.. itraversed . _1'
-- [(0,'a'),(1,'b'),(2,'c')]

Or, make lens index-preserving initially.

iplens :: (s -> a) -> (s -> b -> t) -> IndexPreservingLens s t a b

13. Optics and Monads

13.1 Reader Monad and View

view :: MonadReader s m => Getting a s a -> m a

s -> a is a valid MonadReader s m => m a where m ~ (->) s

instance Monad ((->) r) where
  return = const
  f >>= k = \r -> k (f r) r

type UserName = String
type Password = String
data Env = Env
  { _currentUser :: UserName
  , _users :: M.Map UserName Password
  }
  deriving (Show)

makeLenses ''Env

getUserPassword :: ReaderT Env IO (Maybe String)
getUserPassword = do
  userName_ <- view currentUser
  maybePassword <- preview (users . ix userName_)
  liftIO $ pure maybePassword

-- >>> flip runReaderT (Env "Hey" (M.fromList [("Hey", "password")])) getUserPassword
-- Just "password"

-- st :: String
st2 :: [Char]
st2 = ("optics by fun" :: String) & itraversed %@~ \i c -> chr (ord c + i)

-- >>> st2
-- "oqvlgx&i\129)p\128z"

st :: String
st = "oqvlgx&i\129)p\128z" & itraversed %@~ \i c -> chr (ord c - i)

-- >>> st
-- "optics by fun"

13.2 State Monad Combinators

till calculator for recording the sale of a couple beers

data Till = Till
  { _total :: Double
  , _sales :: [Double]
  , _taxRate :: Double
  }
  deriving (Show)

makeLenses ''Till

(.=) :: MonadState s m => Lens s s a b -> b -> m ()

saleCalculation :: StateT Till IO ()
saleCalculation = do
  total .= 0

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

module Extra where

import Control.Lens
import Control.Monad.State (execState, modify)
import Data.Generics.Labels ()
import Data.Map (fromList)
import Data.Map qualified as Map
import Data.Text qualified as Text
import Data.Traversable (for)

`non`

ex1 :: Map.Map Text.Text Int
ex1 = fromList [("WORLD", 456)]

ex2 :: Map.Map Text.Text Int
ex2 = ex1 & at "HELLO" . non 678 .~ 3

-- >>> x1
-- fromList [("HELLO",3),("WORLD",456)]

update at multiple indices

ex3 :: [Text.Text] -> Int -> Map.Map Text.Text Int -> Map.Map Text.Text Int
ex3 ks val = execState (traverse (\k -> modify (at k ?~ val)) ks)

ex4 :: Map.Map Text.Text Int
ex4 = Map.empty & ex3 ["a", "b", "c"] 4

-- >>> ex4
-- fromList [("a",4),("b",4),("c",4)]

ex5 :: Map.Map String Integer
ex5 = Map.empty &~ for ["b", "c", "d"] (\k -> at k ?= 10)

-- >>> ex5
-- fromList [("b",10),("c",10),("d",10)]

Chapter 2

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}

module Chapter02 where

import Control.Monad.Trans.Class (MonadTrans)
import GHC.TypeLits

2.3.2

-- >>>:kind! (1 + 17) - 3
-- (1 + 17) - 3 :: Natural
-- = 15

-- >>>:kind! (Div 128 8) ^ 2
-- (Div 128 8) ^ 2 :: Natural
-- = 256

2.3.3

2.3.3-i

-- >>>:kind! Show
-- Show :: * -> Constraint
-- = Show

2.3.3-ii

-- >>>:kind! Functor
-- Functor :: (* -> *) -> Constraint
-- = Functor

2.3.3-iv

-- >>>:kind! Monad
-- Monad :: (* -> *) -> Constraint
-- = Monad

2.3.3-v

-- >>>:kind! MonadTrans
-- MonadTrans :: ((* -> *) -> * -> *) -> Constraint
-- = MonadTrans

2.4.1

type family Not (x :: Bool) :: Bool where
  Not 'True = 'False
  Not 'False = 'True

type family Foo1 (x :: Bool) (y :: Bool) :: Bool
type family Bar1 x y :: Bool -> Bool -> Bool

-- >>>:kind Foo1
-- Foo1 :: Bool -> Bool -> Bool

-- >>>:kind Bar1
-- Bar1 :: * -> * -> Bool -> Bool -> Bool

Chapter 3

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Chapter03 where

Variance

newtype T1 a = T1 (Int -> a)
newtype T2 a = T2 (a -> Int)
newtype T3 a = T3 (a -> a)
newtype T4 a = T4 ((Int -> a) -> a)
newtype T5 a = T5 ((a -> Int) -> Int)

3-is

instance Functor T1 where
  fmap f (T1 g) = T1 $ f . g

instance Functor T5 where
  fmap f (T5 g) = T5 $ \b -> g (b . f)

Chapter 4

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Unused LANGUAGE pragma" #-}

module Chapter04 where

import Data.Typeable (Proxy (..), typeRep)

tr = typeRep (Proxy :: Proxy (Maybe Int))

-- >>> tr
-- Maybe Int

-- >>>:t fmap @Maybe
-- fmap @Maybe :: (a -> b) -> Maybe a -> Maybe b
-- >>>:t fmap @_ @Int @Bool
-- fmap @_ @Int @Bool :: Functor _ => (Int -> Bool) -> _ Int -> _ Bool

-- sugar for
-- p' :: forall a. a -> a
p' :: a -> a
p' = id

p :: forall a b c d. (Functor a, Functor b) => a c -> b c -> b c
p a b = b

-- >>>:t p
-- p :: (Functor a, Functor b) => a c -> b c -> b c
-- >>>:t p @_ @_
-- p @_ @_ :: (Functor _1, Functor _2) => _1 c -> _2 c -> _2 c

type family AlwaysUnit a where
  AlwaysUnit a = ()

p1 :: AlwaysUnit a -> a
p1 = undefined

Chapter 5

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-} 
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}


module Chapter05() where 


import Control.Monad.Trans.Class (MonadTrans)
import Data.Kind(Constraint, Type)

5.2 GADTs

data Expr a where
    LitInt :: Int -> Expr Int
    LitBool :: Bool -> Expr Bool
    Add :: Expr Int -> Expr Int -> Expr Int
    Not :: Expr Bool -> Expr Bool
    If :: Expr Bool -> Expr a -> Expr a -> Expr a

evalExpr :: Expr a -> a
evalExpr (LitInt i) = i
evalExpr (LitBool b) = b
evalExpr (Add x y) = evalExpr x + evalExpr y
evalExpr (Not x) = not $ evalExpr x
evalExpr (If b x y ) =
    if evalExpr b
    then evalExpr x
    else evalExpr y

ex1 :: Expr Int
ex1 =  If (LitBool False ) ( LitInt 1) (Add ( LitInt 5) (LitInt 13))

-- >>>evalExpr ex1
-- 18

5.3 Heterogeneous lists

data HList (ts :: [Type]) where
    HNil :: HList '[]
    (:#) :: t -> HList ts -> HList (t ': ts)
infixr 5 :#

-- >>>:t HNil
-- HNil :: HList '[]
-- >>>:t True :# HNil
-- True :# HNil :: HList '[Bool]

hHead :: HList (t:ts :: [Type]) -> t
hHead (x :# y) = x

p1 :: HList '[[Char], Bool, Integer, Bool]
p1 = "Hey" :# True :# 3 :# True :# HNil

-- >>>hHead p1
-- "Hey"

hLength :: HList ts -> Int
hLength HNil = 0
hLength (p :# ps) = 1 + hLength ps


-- >>>hLength p1
-- 4

showBool :: HList (t1 : Bool : ts) -> String
showBool (_ :# b :# _) = show b

instance Eq (HList '[]) where
    HNil == HNil = True

instance (Eq t, Eq (HList ts)) => Eq (HList (t ': ts)) where
    (a :# as) == (b :# bs) = a == b && as == bs

-- 5.3-i
instance Ord (HList '[]) where
    HNil <= HNil = True

instance (Ord t, Ord (HList ts)) => Ord (HList (t ': ts)) where
    (a :# as) <= (b :# bs) = a < b || a == b && as <= bs

p2 :: HList '[[Char], Bool, Integer, Bool]
p2 = "Hou" :# False :# 3 :# True :# HNil


-- >>>p1 <= p2
-- True

5.3-ii

newtype SepHList (ts :: [Type])= SepHList (HList ts)

instance Show (SepHList '[]) where
    show (SepHList HNil) = ""

instance (Show t, Show (SepHList ts)) => Show (SepHList (t:ts)) where
    show (SepHList as) =
        case as of
            a :# HNil -> show a 
            a :# as -> show a <> ", " <> show (SepHList as)

instance Show (HList '[]) where
    show HNil = ""

instance (Show t, Show (HList ts), Show (SepHList ts)) => Show (HList (t ': ts)) where
    show as = "[ " <> show (SepHList as) <> " ]"

-- >>>p2
-- [ "Hou", False, 3, True ]

type family AllEq (ts :: [Type]) :: Constraint where
    AllEq '[] = ()
    AllEq (t ': ts) = (Eq t, AllEq ts)

-- >>>:kind! AllEq '[Int, Bool]
-- AllEq '[Int, Bool] :: Constraint
-- = (Eq Int, (Eq Bool, () :: Constraint))

5.3 Heterogeneous lists

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Chapter05_1 () where

import Data.Kind (Constraint, Type)

data HList (ts :: [Type]) where
  HNil :: HList '[]
  (:#) :: t -> HList ts -> HList (t ': ts)
infixr 5 :#

type family All (c :: Type -> Constraint) (ts :: [Type]) :: Constraint where
  All c '[] = ()
  All c (t ': ts) = (c t, All c ts)

data HList' (ts :: [Type]) where
  HNil' :: HList' '[]
  (:#:) :: t -> HList' ts -> HList' (t ': ts)
infixr 5 :#:

instance (All Show ts) => Show (HList' ts) where
  show HNil' = ""
  show (a :#: HNil') = show a
  show (a :#: as) = show a <> ", " <> show as

f :: HList ts -> HList' ts
f hs = g hs HNil'
 where
  g :: HList ps -> HList' ps' -> HList' ps
  g HNil HNil' = HNil'
  g (a :# as) _ = a :#: g as HNil'
  g HNil _ = HNil'

instance (All Show ts) => Show (HList ts) where
  show ps = "[ " <> (show . f) ps <> "]"

p2 :: HList '[[Char], Bool, Integer, Bool]
p2 = "Hou" :# False :# 3 :# True :# HNil

-- >>>p2
-- [ "Hou", False, 3, True]

Chapter 6

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Chapter06 () where

import Data.Void (absurd)

6.2 Ranks

-- takes a function that accepts any possible a
applyToFive :: (forall a. a -> a) -> Int
applyToFive f = f 5

p :: Int -> (forall a. (a -> a))
p b = id

p1 :: (a -> b) -> (forall c. c -> a) -> b
p1 a b = (a . b) absurd

type A a = a

type B a r = (forall r. (a -> r) -> r)

6.4 The Continuation Monad

from :: A a -> B a r
from a b = b a

to :: B a r -> A a
to b = b id

(to . from) x =
    = to (from x)
    = (from x) id
    = (\b -> b x) id
    = id x
    = x

(from . to) x =
    = from (to x)
    = from (x id)
    = \b -> b (x id)
    = \b -> b ((\s -> s (a :: a)) id)
    = \b -> b (a :: a)

newtype Cont a = Cont {unCont :: forall r. (a -> r) -> r}

instance Functor Cont where
  fmap f (Cont a) = Cont $ \x -> a $ x . f

--   fmap f (Cont a) = Cont $ \x -> a $ \y -> x $ f y

instance Applicative Cont where
  pure a = Cont $ \x -> x a
  (Cont a) <*> (Cont b) = Cont $ \x -> a $ \y -> b (x . y)

instance Monad Cont where
  return = pure
  (Cont a) >>= f = Cont $ \x -> a (\y -> unCont (f y) x)

(Cont a) <*> (Cont b) = Cont $ \x -> a $ \y -> b $ \z -> x (y z)
(Cont a) <*> (Cont b) = Cont $ \x -> a $ \y -> b $ \z -> (x . y) z
\z -> x (y z) =
    x . y

withVersionNumber :: (Double -> r) -> r
withVersionNumber f = f 1.0

withTimestamp :: (Int -> r) -> r
withTimestamp f = f 1532083362

withOS :: (String -> r) -> r
withOS f = f "linux"

releaseStringCont :: String
releaseStringCont = flip unCont id $ do
  version <- Cont withVersionNumber
  date <- Cont withTimestamp
  os <- Cont withOS
  return $ os ++ "-" ++ show version ++ "-" ++ show date

newtype ContT r m a = ContT {unContT :: (a -> m r) -> m r}

instance (Functor m) => Functor (ContT r m) where
  fmap f (ContT a) = ContT $ \x -> a $ x . f

instance (Functor m) => Applicative (ContT r m) where
  pure x = ContT $ \y -> y x
  (ContT a) <*> (ContT b) = ContT $ \x -> a $ \y -> b (x . y)

Why use ContT

instance (Functor m) => Monad (ContT r m) where
  return = pure
  (ContT a) >>= f = ContT $ \x -> a (\y -> unContT (f y) x)

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}

module Chapter13 () where

import Data.Data (Proxy)
import GHC.Generics (Generic (..))

13 Generics

13.1 Generic Representations

All data types have a canonical representation as sums of products. They can be built from Eithers of pairs (,). E.g., for Maybe:

toCanonical :: Maybe a -> Either () a
toCanonical Nothing = Left ()
toCanonical (Just a) = Right a

fromCanonical :: Either () a -> Maybe a
fromCanonical (Left ()) = Nothing
fromCanonical (Right a) = Just a

-- >>> :kind! Rep Bool
-- Rep Bool :: * -> *
-- = M1
--     D
--     ('MetaData "Bool" "GHC.Types" "ghc-prim" 'False)
--     (M1 C ('MetaCons "False" 'PrefixI 'False) U1
--      :+: M1 C ('MetaCons "True" 'PrefixI 'False) U1)

13.2 Deriving Structural Polymorphism

Generically derive structural polymorphism:

Define a typeclass to act as a carrier .
Provide inductive instances of the class for the generic constructors.
Finally, write a helper function to map between the Rep and the desired type.

2.4 Type-Level functions

Type families must be saturated
- no currying

type family Map (x :: a -> b) (i :: [a]) :: [b] where
  Map f '[] = '[]
  Map f (x ': xs) = f x ': Map f xs

type family Or (x :: Bool) (y :: Bool) :: Bool where
  Or 'True y = 'True
  Or 'False y = y

-- >>>  :t undefined :: Proxy (Map (Or True) '[True, 'False, 'False])
-- The type family `Or' should have 2 arguments, but has been given 1
-- In an expression type signature:
--   Proxy (Map (Or True) '[True, 'False, 'False])
-- In the expression:
--     undefined :: Proxy (Map (Or True) '[True, 'False, 'False])

Chapter 1

module C_01_Handles (fileResource, getDataDir, greetingTxt) where

import Control.Exception (Exception (..))
import Control.Exception.Safe qualified as Ex
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Resource (ReleaseKey, ResourceT, allocate, runResourceT)
import Data.Functor ((<&>))
import GHC.IO.Handle (Handle)
import GHC.IO.IOMode (IOMode (..))
import Relude (print, putStrLn, show)
import System.Directory qualified as Dir
import System.FilePath ((</>))
import System.IO qualified as IO
import Prelude hiding (print, putStrLn, show)

0 Setup

getDataDir :: IO FilePath
getDataDir = do
  dir <- Dir.getXdgDirectory Dir.XdgData "sockets-and-pipes"
  Dir.createDirectoryIfMissing True dir
  return dir

1.2 Writing to a file

greetingTxt :: IO.FilePath
greetingTxt = "greeting.txt"

writeGreetingFile :: IO ()
writeGreetingFile = do
  dir <- getDataDir
  h <- IO.openFile (dir </> greetingTxt) WriteMode
  IO.putStrLn ("handle: " <> show h)
  IO.hPutStrLn h "hello"
  IO.hClose h
  IO.putStrLn dir

1.4 MonadIO

helloWorld :: (MonadIO m) => m ()
helloWorld = liftIO (IO.putStrLn "hello, world")

1.5 Exercises

Ex 1

writeGreetingSafe :: IO ()
writeGreetingSafe = runResourceT @IO do
  dir <- liftIO getDataDir
  (_releaseKey, h) <- fileResource (dir </> greetingTxt) WriteMode
  liftIO (IO.hPutStrLn h "hello")
  liftIO (IO.hPutStrLn h "world")

fileResource :: FilePath -> IOMode -> ResourceT IO (ReleaseKey, Handle)
fileResource p m =
  allocate
    (IO.openFile p m)
    IO.hClose

Ex 2

handlePrintTest :: IO ()
handlePrintTest = runResourceT do
  (_, p1) <- fileResource "hey" WriteMode
  liftIO $ print p1
  liftIO $ IO.hShow p1 >>= print

Ex 3

howManyHandles :: IO ()
howManyHandles = runResourceT @IO do
  hs <- openManyHandles
  liftIO $ putStrLn ("Opened " <> show (length hs) <> " handles")

openManyHandles :: ResourceT IO [Handle]
openManyHandles = do
  let openManyHandles_ xs =
        do
          x <- fileResourceMaybe
          case x of
            Just x' -> openManyHandles_ (x' : xs)
            Nothing -> return xs
  openManyHandles_ []

fileResourceMaybe :: ResourceT IO (Maybe Handle)
fileResourceMaybe = do
  dir <- liftIO getDataDir
  result <- Ex.tryIO (fileResource (dir </> "b") WriteMode <&> snd <&> Just)
  case result of
    Right x -> return x
    Left e -> do
      liftIO $ print (displayException e)
      return Nothing

main :: IO ()
main = howManyHandles

Chapter 2

module C_02_Chunks (repeatUntil) where

import C_01_Handles (fileResource, getDataDir, greetingTxt)
import Control.Monad ()
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Resource (runResourceT)
import Data.Char (isDigit)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import GHC.IO.Handle.FD (stdout)
import GHC.IO.IOMode (IOMode (WriteMode))
import Relude (IOMode (ReadMode))
import System.FilePath ((</>))
import System.IO qualified as IO

2.1 Packed characters

helloText :: IO ()
helloText = T.hPutStrLn stdout (T.pack "hello, world!")

helloTextFile :: IO ()
helloTextFile = runResourceT @IO do
  dir <- liftIO getDataDir
  (_, h) <- fileResource (dir </> greetingTxt) WriteMode
  liftIO do
    T.hPutStrLn h (T.pack "hello")
    T.hPutStrLn h (T.pack "world")

-- >>>helloTextFile

Text is strict. This crashes

p :: T.Text
p = T.take 10 (T.pack (cycle "abc"))

2.2 Reading from a file, one chunk at a time

printFileContentsUpperCase :: IO ()
printFileContentsUpperCase = runResourceT @IO do
  dir <- liftIO getDataDir
  (_, h) <- fileResource (dir </> greetingTxt) ReadMode
  liftIO $
    repeatUntilIO (T.hGetChunk h) T.null $
      \chunk -> T.putStr (T.toUpper chunk)

printCapitalizedText :: IO.Handle -> IO ()
printCapitalizedText h = continue
 where
  continue = do
    chunk <- T.hGetChunk h
    unless
      (T.null chunk)
      ( do
          T.putStr (T.toUpper chunk)
          continue
      )

repeatUntilIO ::
  IO chunk ->
  (chunk -> Bool) ->
  (chunk -> IO x) ->
  IO ()
repeatUntilIO getChunk isEnd f = continue
 where
  continue = do
    chunk <- getChunk
    unless
      (isEnd chunk)
      ( do
          _ <- f chunk
          continue
      )

Ex 4

digitsOnly :: Text -> Text
digitsOnly = T.filter isDigit

testDigitsOnly :: Text
testDigitsOnly = digitsOnly (T.pack "ab c123 def4")

testDigitsOnly "1234"

capitalizeLast :: Text -> Text
capitalizeLast t = T.init t <> T.toUpper (T.takeEnd 1 t)

capitalizeLast ","

capitalizeLast "a"

unParen :: Text -> Maybe Text
unParen t
  | T.length t < 2 = Nothing
  | pref == '(' && suff == ')' = Just body
  | otherwise = Nothing
 where
  pref = T.head t
  suff = T.last t
  body = T.init (T.tail t)

unParen "" Nothing

unParen "(a)" Just "a"

characterCount :: FilePath -> IO Int
characterCount fp = runResourceT @IO do
  dir <- liftIO getDataDir
  (_, h) <- fileResource (dir </> fp) ReadMode
  liftIO $ continue (T.hGetChunk h) T.null 0
 where
  continue :: IO Text -> (Text -> Bool) -> Int -> IO Int
  continue getChunk isEnd n = do
    chunk <- getChunk
    if isEnd chunk
      then return n
      else continue getChunk isEnd (n + T.length chunk)

characterCount "greeting.txt" 12

Ex 6

when :: (Monad m) => Bool -> m () -> m ()
when cond action = if cond then action else return ()

unless :: (Monad m) => Bool -> m () -> m ()
unless cond = when (not cond)

Ex 7

repeatUntil :: (Monad m) => m chunk -> (chunk -> Bool) -> (chunk -> m x) -> m ()
repeatUntil getChunk isEnd f = continue
 where
  continue = do
    chunk <- getChunk
    unless
      (isEnd chunk)
      ( do
          _ <- f chunk
          continue
      )

Chapter 3

module C_03_Bytes (binaryFileResource) where

import Data.Word (Word8)

import C_01_Handles (getDataDir, greetingTxt)
import C_02_Chunks (repeatUntil)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Resource (ReleaseKey, ResourceT, allocate, runResourceT)
import Data.ByteString as BS (ByteString, hGetSome, hPut, hPutStr, map, null, pack)
import Data.String (fromString)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.IO qualified as T
import GHC.IO.Handle.FD (stdout)
import Relude (Handle, IOMode (..), UnicodeException)
import System.FilePath ((</>))
import System.IO qualified as IO

3.1 Packed octets

exampleBytes :: [Word8]
exampleBytes = [104, 101, 108, 111] :: [Word8]

3.2 Copying a file

greeting2Txt :: FilePath
greeting2Txt = "greeting2.txt"

copyGreetingFile :: IO ()
copyGreetingFile = runResourceT @IO do
  dir <- liftIO getDataDir
  (_, h1) <- binaryFileResource (dir </> greetingTxt) ReadMode
  (_, h2) <- binaryFileResource (dir </> greeting2Txt) WriteMode
  liftIO $ repeatUntil (BS.hGetSome h1 1024) BS.null (BS.hPutStr h2)

binaryFileResource :: FilePath -> IOMode -> ResourceT IO (ReleaseKey, Handle)
binaryFileResource path mode = allocate (IO.openBinaryFile path mode) IO.hClose

3.5 Avoiding system defaults

helloHandle :: IO ()
helloHandle = IO.hPutStrLn IO.stdout "Hello, world!"

helloByteString :: IO ()
helloByteString = do
  IO.hSetBinaryMode stdout True
  BS.hPut stdout (BS.pack helloBytes)

helloBytes :: [Word8]
helloBytes =
  [ -- hello
    104
  , 101
  , 108
  , 111
  , -- ,
    32
  , -- world
    119
  , 111
  , 114
  , 108
  , 100
  , 33
  , -- /n
    10
  ]

-- >>>helloByteString

helloUtf8 :: IO ()
helloUtf8 = do
  IO.hSetBinaryMode stdout True
  BS.hPutStr stdout (T.encodeUtf8 (T.pack "hello, world!\n"))

-- >>>helloUtf8

3.6 Exercises

Ex 8

greet :: BS.ByteString -> IO ()
greet nameBS = case T.decodeUtf8' nameBS of
  Left _ -> putStrLn "Invalid byte string"
  Right nameText -> T.putStrLn (T.pack "Hello, " <> nameText)

p1 :: Either UnicodeException Text
p1 = T.decodeUtf8' (fromString "♫")

-- >>>p1
-- Right "k"

Ex 9

asciiUpper :: BS.ByteString -> BS.ByteString
asciiUpper = BS.map (\x -> if 97 <= x && x <= 122 then 65 + x - 97 else x)

p2 :: ByteString
p2 = asciiUpper (fromString "Hello!")

-- >>> p2
-- "HELLO!"

Chapter 4

module C_04_Sockets (openAndConnect, resolve) where

import C_02_Chunks (repeatUntil)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Resource (
  ReleaseKey,
  ResourceT,
  allocate,
  runResourceT,
 )
import Data.ByteString as BS (null, putStr)
import Data.Foldable (traverse_)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Network.Simple.TCP (Socket)
import Network.Socket (Family (..))
import Network.Socket qualified as S
import Network.Socket.ByteString qualified as S

4.1 Open up and connect

makeFriend :: S.SockAddr -> IO ()
makeFriend address = do
  s <- S.socket S.AF_INET S.Stream S.defaultProtocol
  S.connect s address
  S.sendAll s $
    T.encodeUtf8 $
      T.pack "Hello, will you be my friend?"
  repeatUntil (S.recv s 1024) BS.null BS.putStr

4.2 Extra details

sec :: Int -> Int
sec t = t * 1000

sec1 :: Int
sec1 = sec 1

makeFriendSafely :: S.SockAddr -> IO ()
makeFriendSafely address = runResourceT @IO do
  (_, s) <-
    allocate
      (S.socket S.AF_INET S.Stream S.defaultProtocol)
      S.close
  liftIO do
    S.setSocketOption s S.UserTimeout sec1
    S.connect s address
    S.sendAll s $
      T.encodeUtf8 $
        T.pack "Hello, will you be my friend?"
    repeatUntil (S.recv s 1024) BS.null BS.putStr
    S.gracefulClose s sec1

4.4 Address information

myHints :: S.AddrInfo
myHints = S.defaultHints{S.addrFamily = AF_INET6}

s1 :: IO ()
s1 = traverse_ print =<< S.getAddrInfo Nothing (Just "www.haskell.org") (Just "http")

s2 :: IO ()
s2 = traverse_ print =<< S.getAddrInfo (Just S.defaultHints{S.addrSocketType = S.Stream}) (Just "www.haskell.org") (Just "http")

findHaskellWebsite :: IO S.AddrInfo
findHaskellWebsite = do
  addrInfos <- S.getAddrInfo (Just S.defaultHints{S.addrSocketType = S.Stream}) (Just "www.haskell.org") (Just "http")
  case addrInfos of
    [] -> fail "getAddrInfo returned []"
    x : _ -> return x

makeFriendAddrInfo :: S.AddrInfo -> IO ()
makeFriendAddrInfo addressInfo = runResourceT @IO do
  (_, s) <- allocate (S.openSocket addressInfo) S.close
  liftIO do
    S.setSocketOption s S.UserTimeout sec1
    S.connect s (S.addrAddress addressInfo)
    S.sendAll s $
      T.encodeUtf8 $
        T.pack "Hello, will you be my friend?"
    repeatUntil (S.recv s 1024) BS.null BS.putStr
    S.gracefulClose s sec1

mkFriend :: IO ()
mkFriend = makeFriendSafely (S.SockAddrInet 80 (S.tupleToHostAddress (147, 75, 54, 133)))

-- >>>mkFriend

4.5 Exercises

Ex 10

openAndConnect :: S.AddrInfo -> ResourceT IO (ReleaseKey, Socket)
openAndConnect addressInfo = do
  (r, s) <- allocate (S.openSocket addressInfo) S.close
  liftIO do
    S.setSocketOption s S.UserTimeout 1000
    S.connect s (S.addrAddress addressInfo)
  return (r, s)

Ex 11

findGopherWebsite :: IO S.AddrInfo
findGopherWebsite = do
  addrInfos <- S.getAddrInfo (Just S.defaultHints{S.addrSocketType = S.Stream}) (Just "gopher.floodgap.com") (Just "gopher")
  case addrInfos of
    [] -> fail "getAddrInfo returned []"
    x : _ -> return x

Ex 12

resolve :: S.ServiceName -> S.HostName -> IO S.AddrInfo
resolve sname hname = do
  addrInfos <- S.getAddrInfo (Just S.defaultHints{S.addrSocketType = S.Stream}) (Just hname) (Just sname)
  case addrInfos of
    [] -> fail "getAddrInfo returned []"
    x : _ -> return x

Chapter 5

module C_05_HTTP (crlf, helloRequestString, helloResponseString) where

import ASCII (ASCII, fromCharList)
import ASCII qualified as A
import ASCII.Char qualified as A
import ASCII.Superset (FromString)
import C_04_Sockets (openAndConnect, resolve)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Resource (runResourceT)
import Data.ByteString qualified as BS
import Network.Simple.TCP (HostPreference (..))
import Network.Simple.TCP qualified as Net
import Relude (putBSLn)

5.3 ASCII strings

line :: BS.ByteString -> BS.ByteString
line x = x <> A.lift crlf

crlf :: (FromString superset) => ASCII superset
crlf = fromCharList [A.CarriageReturn, A.LineFeed]

text :: [BS.ByteString] -> BS.ByteString
text = foldMap line

helloRequestString :: BS.ByteString
helloRequestString =
  text
    [ [A.string|GET /hello.txt HTTP/1.1|]
    , [A.string|Host: www.example.com|]
    , [A.string|Accept-Language: en, mi|]
    , [A.string||]
    ]

5.4 HTTP responses

helloResponseString :: BS.ByteString
helloResponseString =
  text
    [ [A.string|HTTP/1.1 200 OK|]
    , [A.string|Content-Type: text/plain; charset=us-ascii|]
    , [A.string|Content-Length: 6|]
    , [A.string||]
    ]
    <> [A.string|Hello|]

5.5 Serving others

p :: (MonadIO m) => HostPreference -> Net.ServiceName -> ((Net.Socket, Net.SockAddr) -> IO ()) -> m a
p = Net.serve

ourFirstServer :: IO a
ourFirstServer = Net.serve @IO HostAny "8000" \(s, a) -> do
  putStrLn ("New connection from " <> show a)
  Net.send s helloResponseString

5.6 Exercises

Ex 13

repeatUntilNothing :: (Monad m) => m (Maybe chunk) -> (chunk -> m x) -> m ()
repeatUntilNothing getChunkMaybe f = continue
 where
  continue = do getChunkMaybe >>= maybe (return ()) (\x -> f x >> continue)

Ex 14

requestText :: BS.ByteString
requestText =
  text
    [ [A.string|GET / HTTP/1.1|]
    , [A.string|Host: haskell.org|]
    , [A.string|Connection: close|]
    ]

requestHaskellOrg :: IO ()
requestHaskellOrg = runResourceT @IO do
  addrInfo <- liftIO $ resolve "https" "haskell.org"
  (_, s) <- openAndConnect addrInfo
  Net.send s requestText
  repeatUntilNothing (Net.recv s 1024) (liftIO . putBSLn)

module C_06_HTTP_types (
  FieldName (..),
  FieldValue (..),
  HeaderField (..),
  HttpVersion (..),
  MessageBody (..),
  Method (..),
  ReasonPhrase (..),
  Request (..),
  RequestLine (..),
  RequestTarget (..),
  Response (..),
  StatusCode (..),
  StatusLine (..),
  helloRequest,
  helloResponse,
) where

import ASCII qualified as A
import ASCII.Decimal qualified as A (Digit (..))
import Data.ByteString qualified as BS
import Data.ByteString.Lazy (toChunks)
import Data.ByteString.Lazy qualified as LBS

data Request = Request RequestLine [HeaderField] (Maybe MessageBody)
data Response = Response StatusLine [HeaderField] (Maybe MessageBody)
data RequestLine = RequestLine Method RequestTarget HttpVersion
data StatusLine = StatusLine HttpVersion StatusCode ReasonPhrase
data StatusCode = StatusCode A.Digit A.Digit A.Digit
data HeaderField = HeaderField FieldName FieldValue
data HttpVersion = HttpVersion A.Digit A.Digit
newtype Method = Method BS.ByteString
newtype RequestTarget = RequestTarget BS.ByteString
newtype ReasonPhrase = ReasonPhrase BS.ByteString
newtype FieldName = FieldName BS.ByteString
newtype FieldValue = FieldValue BS.ByteString
newtype MessageBody = MessageBody LBS.ByteString

6.7 Exercises

Ex 16

helloRequest :: Request
helloRequest = Request start [host, lang] Nothing
 where
  start = RequestLine (Method [A.string|GET|]) (RequestTarget [A.string|/hello.txt|]) (HttpVersion A.Digit1 A.Digit1)
  host = HeaderField (FieldName [A.string|Host|]) (FieldValue [A.string|www.example.com|])
  lang = HeaderField (FieldName [A.string|Accept-Language|]) (FieldValue [A.string|en, mi|])

helloResponse :: Response
helloResponse = Response start [host, lang] (Just $ MessageBody [A.string|Hello|])
 where
  start = StatusLine (HttpVersion A.Digit1 A.Digit1) (StatusCode A.Digit2 A.Digit0 A.Digit0) (ReasonPhrase [A.string|OK|])
  host = HeaderField (FieldName [A.string|Content-Type|]) (FieldValue [A.string|text/plain; charset=us-ascii|])
  lang = HeaderField (FieldName [A.string|Content-Length|]) (FieldValue [A.string|6|])

Ex 17

inf :: LBS.ByteString
inf = [A.string|abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefgh|]

p :: [Int]
p = BS.length <$> toChunks inf

-- >>>p
-- [32,64,128,256,512,384]

-- >>>LBS.take 10 inf
-- "abcdefghij"

httpVersion :: HttpVersion
httpVersion = HttpVersion A.Digit1 A.Digit1

Chapter 7

module C_07_Encoding (
  encodeLineEnd,
  encodeStatusLine,
  encodeResponse,
  encodeRequestLine,
  repeatedlyEncode,
  encodeHeaderField,
  encodeMessageBody,
  optionallyEncode,
  encodeRequest,
) where

import ASCII (DigitStringSuperset (fromDigitList), fromCharList)
import ASCII qualified as A
import ASCII.Char qualified as AC
import C_01_Handles (getDataDir)
import C_05_HTTP (crlf, helloRequestString, helloResponseString)
import C_06_HTTP_types (
  FieldName (FieldName),
  FieldValue (FieldValue),
  HeaderField (HeaderField),
  HttpVersion (..),
  MessageBody (MessageBody),
  Method (Method),
  ReasonPhrase (ReasonPhrase),
  Request (Request),
  RequestLine (RequestLine),
  RequestTarget (RequestTarget),
  Response (Response),
  StatusCode (StatusCode),
  StatusLine (StatusLine),
  helloRequest,
  helloResponse,
 )
import Data.ByteString qualified as BS
import Data.ByteString.Builder qualified as BSB
import Data.Foldable (Foldable (..))
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Text.Lazy qualified as LT
import Data.Text.Lazy.Builder qualified as TB
import Data.Time qualified as Time
import System.FilePath ((</>))

7.1 String builders

sayHello :: T.Text -> T.Text
sayHello name = T.pack "Hello, " <> name <> T.pack "!"

-- >>>sayHello $ T.pack "Tim"
-- "Hello, Tim!"

sayHelloWithBuilder :: T.Text -> T.Text
sayHelloWithBuilder name =
  LT.toStrict $
    TB.toLazyText $
      TB.fromString "Hello" <> TB.fromText name <> TB.fromString "!"

7.2 Measuring time

time :: IO () -> IO ()
time action = do
  a <- Time.getCurrentTime
  action
  b <- Time.getCurrentTime
  print (Time.diffUTCTime b a)

concatWithStrict :: Int -> T.Text
concatWithStrict n = fold $ replicate n $ T.pack "a"

concatWithBuilder :: Int -> T.Text
concatWithBuilder n = LT.toStrict $ TB.toLazyText $ fold $ replicate n $ TB.fromString "a"

concatSpeedTest :: Int -> IO ()
concatSpeedTest n = do
  dir <- getDataDir
  time $ T.writeFile (dir </> "builder.txt") (concatWithBuilder n)
  time $ T.writeFile (dir </> "strict.txt") (concatWithStrict n)

-- >>>concatSpeedTest 10000

7.3 Request and response

encodeRequest :: Request -> BSB.Builder
encodeRequest (Request requestLine headerFields bodyMaybe) =
  encodeRequestLine requestLine
    <> repeatedlyEncode (\x -> encodeHeaderField x <> encodeLineEnd) headerFields
    <> encodeLineEnd
    <> optionallyEncode encodeMessageBody bodyMaybe

encodeResponse :: Response -> BSB.Builder
encodeResponse (Response statusLine headerFields bodyMaybe) =
  encodeStatusLine statusLine
    <> repeatedlyEncode (\x -> encodeHeaderField x <> encodeLineEnd) headerFields
    <> encodeLineEnd
    <> optionallyEncode encodeMessageBody bodyMaybe

encodeLineEnd :: BSB.Builder
encodeLineEnd = A.lift crlf

7.4 Higher-order encodings

optionallyEncode :: (a -> BSB.Builder) -> Maybe a -> BSB.Builder
optionallyEncode = foldMap

repeatedlyEncode :: (a -> BSB.Builder) -> [a] -> BSB.Builder
repeatedlyEncode = foldMap

7.5 The start line

encodeSpace :: BSB.Builder
encodeSpace = A.lift $ fromCharList [AC.Space]

encodeRequestLine :: RequestLine -> BSB.Builder
encodeRequestLine (RequestLine method requestTarget httpVersion) =
  encodeMethod method
    <> encodeSpace
    <> encodeRequestTarget requestTarget
    <> encodeSpace
    <> encodeHttpVersion httpVersion
    <> encodeLineEnd

encodeMethod :: Method -> BSB.Builder
encodeMethod (Method m) = BSB.byteString m

encodeRequestTarget :: RequestTarget -> BSB.Builder
encodeRequestTarget (RequestTarget rt) = BSB.byteString rt

encodeStatusLine :: StatusLine -> BSB.Builder
encodeStatusLine (StatusLine httpVersion statusCode reasonPhrase) =
  encodeHttpVersion httpVersion
    <> encodeSpace
    <> encodeStatusCode statusCode
    <> encodeSpace
    <> encodeReasonPhrase reasonPhrase
    <> encodeLineEnd

encodeStatusCode :: StatusCode -> BSB.Builder
encodeStatusCode (StatusCode c1 c2 c3) = A.lift $ fromDigitList [c1, c2, c3]

encodeReasonPhrase :: ReasonPhrase -> BSB.Builder
encodeReasonPhrase (ReasonPhrase s) = BSB.byteString s

encodeHttpVersion :: HttpVersion -> BSB.Builder
encodeHttpVersion (HttpVersion v1 v2) =
  BSB.byteString [A.string|HTTP/|]
    <> A.digitString v1
    <> A.lift (fromCharList [AC.FullStop])
    <> A.digitString v2

7.6 Exercises

encodeHeaderField :: HeaderField -> BSB.Builder
encodeHeaderField (HeaderField (FieldName x) (FieldValue y)) =
  BSB.byteString x
    <> A.lift (fromCharList [AC.Colon])
    <> encodeSpace
    <> BSB.byteString y

encodeMessageBody :: MessageBody -> BSB.Builder
encodeMessageBody (MessageBody s) = BSB.lazyByteString s

req :: BSB.Builder
req = encodeRequest helloRequest

-- >>>req
-- "GET /hello.txt HTTP/1.1\r\nHost: www.example.com\r\nAccept-Language: en, mi\r\n\r\n"

resp :: BSB.Builder
resp = encodeResponse helloResponse

-- >>>resp
-- "HTTP/1.1 200 OK\r\nHost: www.example.com\r\nAccept-Language: en, mi\r\n\r\nHello"

requestEqual :: Bool
requestEqual = BS.toStrict (BSB.toLazyByteString req) == helloRequestString

-- >>>reqEqual
-- True
-- >>>helloRequestString
-- "GET /hello.txt HTTP/1.1\r\nHost: www.example.com\r\nAccept-Language: en, mi\r\n\r\n"
-- >>>req
-- "GET /hello.txt HTTP/1.1\r\nHost: www.example.com\r\nAccept-Language: en, mi\r\n\r\n"

responseEqual :: Bool
responseEqual = BS.toStrict (BSB.toLazyByteString resp) == helloResponseString

-- >>>responseEqual
-- True
-- >>>helloResponseString
-- "HTTP/1.1 200 OK\r\nContent-Type: text/plain; charset=us-ascii\r\nContent-Length: 6\r\n\r\nHello"
-- >>>resp
-- "HTTP/1.1 200 OK\r\nContent-Type: text/plain; charset=us-ascii\r\nContent-Length: 6\r\n\r\nHello"

Chapter 8

module C_08_Responding (
  contentLength,
  contentType,
  status,
  ok,
  bodyLengthValue,
  contentLengthField,
  sendResponse,
) where

import ASCII qualified as A
import ASCII.Decimal qualified as A
import C_06_HTTP_types (
  FieldName (FieldName),
  FieldValue (FieldValue),
  HeaderField (HeaderField),
  HttpVersion (HttpVersion),
  MessageBody (MessageBody),
  ReasonPhrase (..),
  Response (Response),
  StatusCode (..),
  StatusLine (..),
 )
import C_07_Encoding (encodeLineEnd, encodeResponse, encodeStatusLine)
import Data.ByteString.Builder qualified as BSB
import Data.ByteString.Lazy qualified as LBS
import Data.Word (Word8)
import GHC.Natural (Natural)
import Network.Simple.TCP (HostPreference (HostAny), Socket, serve)
import Network.Simple.TCP qualified as Net

8.1 A measure of success

countHelloAscii :: Natural -> LBS.ByteString
countHelloAscii count =
  BSB.toLazyByteString $
    [A.string|Hello!|]
      <> encodeLineEnd
      <> [A.string|This page has |]
      <> case count of
        0 -> [A.string|never been viewed.|]
        1 -> [A.string|been viewed 1 time.|]
        _ ->
          [A.string|been viewed |]
            <> A.showIntegralDecimal count
            <> [A.string| times.|]

data Status = Status StatusCode ReasonPhrase

8.2 Response-building utilities

ok :: Status
ok =
  Status
    (StatusCode A.Digit2 A.Digit0 A.Digit0)
    (ReasonPhrase [A.string|OK|])

status :: Status -> StatusLine
status (Status statusCode reasonPhrase) = StatusLine http_1_1 statusCode reasonPhrase

http_1_1 :: HttpVersion
http_1_1 = HttpVersion A.Digit1 A.Digit1

encOk :: LBS.ByteString
encOk = BSB.toLazyByteString (encodeStatusLine (status ok))

-- >>>encOk
-- "HTTP/1.1 200 OK\r\n"

contentType :: FieldName
contentType = FieldName [A.string|Content-Type|]

contentLength :: FieldName
contentLength = FieldName [A.string|Content-Length|]

contentLengthField :: MessageBody -> HeaderField
contentLengthField body = HeaderField contentLength (bodyLengthValue body)

plainAscii :: FieldValue
plainAscii = FieldValue [A.string|text/plain; charset=us-ascii|]

asciiOk :: LBS.ByteString -> Response
asciiOk str = Response (status ok) [typ, len] (Just body)
 where
  typ = HeaderField contentType plainAscii
  len = HeaderField contentLength (bodyLengthValue body)
  body = MessageBody str

-- this is for Content-Length
bodyLengthValue :: MessageBody -> FieldValue
bodyLengthValue (MessageBody x) = FieldValue (A.showIntegralDecimal (LBS.length x))

8.3 Integers

8.4 Response transmission

sendResponse :: Socket -> Response -> IO ()
sendResponse s r =
  Net.sendLazy s $
    BSB.toLazyByteString (encodeResponse r)

stuckCountingServer :: IO a
stuckCountingServer = serve @IO HostAny "8000" \(s, _) -> do
  let count = 0
  sendResponse s (asciiOk (countHelloAscii count))

8.5 Exercises

Ex 21

-- curl http://localhost:8000 --dump-header -

Ex 22

mid :: Word8 -> Word8 -> Word8
mid x y = fromInteger (div (toInteger x + toInteger y) 2)

-- >>>mid 3 5
-- 4
-- >>>mid 220 250
-- 235

Chapter 9

module C_09_Content_types (textOk, countHelloText, countHelloHtml, htmlOk) where

import ASCII qualified as A
import C_06_HTTP_types (
  FieldValue (FieldValue),
  HeaderField (HeaderField),
  MessageBody (MessageBody),
  Request,
  Response (..),
 )
import C_07_Encoding (encodeRequest, encodeResponse)
import C_08_Responding (
  contentLengthField,
  contentType,
  ok,
  sendResponse,
  status,
 )
import Data.Aeson (KeyValue ((.=)), ToJSON (toJSON))
import Data.Aeson qualified as J
import Data.Aeson.Key qualified as J.Key
import Data.Aeson.KeyMap qualified as J.KeyMap
import Data.ByteString qualified as BS
import Data.ByteString.Builder qualified as BSB
import Data.ByteString.Lazy qualified as LBS
import Data.Int (Int64)
import Data.String (IsString (..))
import Data.Text qualified as T
import Data.Text.Lazy qualified as LT
import Data.Text.Lazy.Builder qualified as TL
import Data.Text.Lazy.Builder.Int qualified as TL
import Data.Text.Lazy.Encoding qualified as LT (encodeUtf8)
import GHC.Natural (Natural)
import Network.Simple.TCP (HostPreference (..), serve)
import Text.Blaze.Html (Html, toHtml)
import Text.Blaze.Html.Renderer.Utf8 qualified as BR
import Text.Blaze.Html5 as Html ()
import Text.Blaze.Html5 qualified as HTML

9.1 Some common types

plainUtf8 :: FieldValue
plainUtf8 = FieldValue [A.string|text/plain; charset=utf-8|]

htmlUtf8 :: FieldValue
htmlUtf8 = FieldValue [A.string|text/html; charset=utf-8|]

json :: FieldValue
json = FieldValue [A.string|application/json|]

9.2 UTF-8

countHelloText :: Natural -> LT.Text
countHelloText count =
  TL.toLazyText $
    TL.fromString "Hello! \9835\r\n"
      <> case count of
        0 -> TL.fromString "This page has never been viewed."
        1 -> TL.fromString "This page has never been viewed 1 time."
        _ -> TL.fromString "This page has been viewed " <> TL.decimal count <> TL.fromString " times."

helloNote :: LT.Text
helloNote = countHelloText 3

textOk :: LT.Text -> Response
textOk str = Response (status ok) [typ, len] (Just body)
 where
  typ = HeaderField contentType plainUtf8
  len = contentLengthField body
  -- should convert text to bytestring
  body = MessageBody (LT.encodeUtf8 str)

stuckCountingServerText :: IO a
stuckCountingServerText = serve @IO HostAny "8000" \(s, _) -> do
  let count = 0
  sendResponse s (textOk (countHelloText count))

9.3 HTML

countHelloHtml :: Natural -> Html
countHelloHtml count = HTML.docType <> htmlDocument
 where
  htmlDocument =
    HTML.html $
      documentMetadata <> documentBody
  documentMetadata = HTML.head titleHtml
  titleHtml = HTML.title (toHtml "My great web page")
  documentBody =
    HTML.body $
      greetingHtml <> HTML.hr <> hitCounterHtml
  greetingHtml = HTML.p (toHtml "Hello! \9835")
  hitCounterHtml = HTML.p $ case count of
    0 -> toHtml "This page has never been viewed."
    1 -> toHtml "This page has been viewed 1 time."
    _ ->
      toHtml "This page has been viewed "
        <> toHtml @Natural count
        <> toHtml " times."

renderHtml' :: Html -> LBS.ByteString
renderHtml' = BR.renderHtml

9.4 JSON

countHelloJSON1 :: Natural -> J.Value
countHelloJSON1 count = toJSON (J.KeyMap.fromList [greetingJson, hitsJson])
 where
  greetingJson = (J.Key.fromString "greeting", toJSON "Hello! \9835")
  hitsJson = (J.Key.fromString "hits", toJSON (J.KeyMap.fromList [numberJson, messageJson]))
  numberJson = (J.Key.fromString "count", toJSON count)
  messageJson = (J.Key.fromString "message", toJSON (countHelloText count))

ch :: J.Value
ch = countHelloJSON1 3

-- >>>ch
-- Object (fromList [("greeting",String "Hello! \9835"),("hits",Object (fromList [("count",Number 3.0),("message",String "Hello! \9835\r\nThis page has been viewed 3 times.")]))])

countHelloJSON :: Natural -> J.Value
countHelloJSON count =
  J.object
    [ fromString "greeting" .= fromString @T.Text "Hello! \9835"
    , fromString "hits"
        .= J.object
          [ fromString "count" .= count
          , fromString "message" .= countHelloText count
          ]
    ]

jsonOk :: J.Value -> Response
jsonOk str = Response (status ok) [typ, len] (Just body)
 where
  typ = HeaderField contentType json
  len = contentLengthField body
  body = MessageBody (J.encode str)

9.5 Exercises

htmlOk :: Html -> Response
htmlOk str = Response (status ok) [typ, len] (Just body)
 where
  typ = HeaderField contentType htmlUtf8
  len = contentLengthField body
  body = MessageBody (BR.renderHtml str)

stuckCountingServerHtml :: IO a
stuckCountingServerHtml = serve @IO HostAny "8000" \(s, _) -> do
  let count = 0
  sendResponse s (htmlOk (countHelloHtml count))

Ex 25

class Encode a where
  encode :: a -> BSB.Builder

instance Encode Request where
  encode :: Request -> BSB.Builder
  encode = encodeRequest

instance Encode Response where
  encode :: Response -> BSB.Builder
  encode = encodeResponse

instance Encode Integer where
  encode :: Integer -> BSB.Builder
  encode = BSB.integerDec

instance Encode Int64 where
  encode :: Int64 -> BSB.Builder
  encode = BSB.int64Dec

instance Encode T.Text where
  encode :: T.Text -> BSB.Builder
  encode = BSB.lazyByteString . LT.encodeUtf8 . LT.fromStrict

instance Encode LT.Text where
  encode :: LT.Text -> BSB.Builder
  encode = BSB.lazyByteString . LT.encodeUtf8

instance Encode BS.ByteString where
  encode :: BS.ByteString -> BSB.Builder
  encode = BSB.byteString

instance Encode LBS.ByteString where
  encode :: LBS.ByteString -> BSB.Builder
  encode = BSB.lazyByteString

instance Encode BSB.Builder where
  encode :: BSB.Builder -> BSB.Builder
  encode = id

Chapter 10

module C_10_Change () where

import C_08_Responding (sendResponse)
import C_09_Content_types (countHelloHtml, htmlOk, textOk)
import Control.Concurrent.Async as Async (replicateConcurrently_)
import Control.Concurrent.STM (
  TVar,
  atomically,
  modifyTVar',
  newTVar,
  readTVarIO,
  writeTVar,
 )
import Control.Concurrent.STM.TVar (newTVarIO, readTVar)
import Control.Monad (replicateM)
import Control.Monad.STM (STM)
import Data.Text.Lazy qualified as LT
import Data.Time as Time (diffUTCTime, getCurrentTime)
import GHC.Natural (Natural)
import Network.Simple.TCP (HostPreference (..), serve)
import Text.Blaze.Html5 as Html ()

10.1 STM

10.2 Increment

increment :: TVar Natural -> STM Natural
increment tvar = modifyTVar' tvar (+ 1) >> readTVar tvar

10.4 The counting server

countingServer :: IO ()
countingServer = do
  hitCounter <- newTVarIO (0 :: Natural)
  serve @IO HostAny "8000" \(s, _) -> do
    count <- atomically (increment hitCounter)
    sendResponse s (htmlOk (countHelloHtml count))

trySTM :: IO ()
trySTM = do
  x <- newTVarIO "Constantinopole"
  readTVarIO x >>= putStrLn
  atomically (writeTVar x "Istanbul")
  readTVarIO x >>= putStrLn

10.6 Exercises

Ex 26

incrementNotAtomic :: TVar Natural -> IO Natural
incrementNotAtomic t = do
  count <- readTVarIO t
  atomically $ writeTVar t (count + 1)
  readTVarIO t

testIncrement :: (TVar Natural -> IO a) -> IO Natural
testIncrement inc = do
  x <- atomically (newTVar @Natural 0)
  Async.replicateConcurrently_ 10 (replicateM 1000 (inc x))
  readTVarIO x

Ex 27

timingServer :: IO ()
timingServer = do
  lastTime <- newTVarIO Nothing
  serve @IO HostAny "8000" \(s, _) -> do
    prevTime <- readTVarIO lastTime
    curTime <- Time.getCurrentTime
    atomically $ writeTVar lastTime (Just curTime)
    sendResponse s $
      textOk $
        LT.pack $
          show (Time.diffUTCTime <$> Just curTime <*> prevTime)

11. Streaming

module C_11_Streaming () where

import C_01_Handles (getDataDir)
import C_03_Bytes (binaryFileResource)
import C_06_HTTP_types (MessageBody (MessageBody), Response (..))
import C_08_Responding (ok, sendResponse, status)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Resource (runResourceT)
import Data.ByteString.Lazy qualified as LBS
import GHC.IO.Handle (Handle)
import GHC.IO.IOMode (IOMode (..))
import Network.Simple.TCP (HostPreference (..), serve)
import System.FilePath ((</>))
import Text.Blaze.Html5 as Html ()

hContentsResponse :: Handle -> IO Response
hContentsResponse h = do
  fileContent <- liftIO (LBS.hGetContents h)
  let body = Just (MessageBody fileContent)
  return (Response (status ok) [] body)

fileStrict :: IO b
fileStrict = do
  dir <- getDataDir
  serve @IO HostAny "8000" \(s, _) -> runResourceT @IO do
    (_, h) <-
      binaryFileResource (dir </> "stream.txt") ReadMode
    r <- liftIO (hContentsResponse h)
    liftIO (sendResponse s r)

notes