Traversals

Traversals.hs

{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}

module Traversals where

import Control.Applicative (Applicative(..))
import Data.Bool (Bool(True))
import Data.Char (toLower)
import Data.Either (Either(Left, Right))
import Data.Foldable (length)
import Data.Function (($), (.))
import Data.Functor (Functor(..), (<$>))
import Data.Int (Int)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Monoid (First(..), Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Traversable (Traversable(traverse))
import System.IO (IO, print)
import Text.Show (show)

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

_1 :: Lens (a, c) (b, c) a b
_1 a2fb (a, c) = (,c) <$> a2fb a

_2 :: Lens (c, a) (c, b) a b
_2 a2fb (c, a) = (c,) <$> a2fb a

newtype Identity a = Identity
  { runIdentity :: a
  }

instance Functor Identity where
  fmap :: (a -> b) -> Identity a -> Identity b
  fmap f (Identity a) = Identity (f a)

type Setter s t a b =
  (a -> Identity b) -> s -> Identity t

modify :: Setter s t a b -> (a -> b) -> s -> t
modify setting a2b = runIdentity . setting (Identity . a2b)

newtype Const a b = Const
  { getConst :: a
  }

instance Functor (Const c) where
  fmap :: (a -> b) -> Const c a -> Const c b
  fmap _ (Const c) = Const c

type Getter s a =
  (a -> Const a a) -> s -> Const a s

view :: Getter s a -> s -> a
view getting = getConst . getting Const

-- Cool, now, it's interesting to compare the similarities
-- between the type for Lens and the `traverse` function from
-- the Traversable type class:
--
-- ```
-- >>> :t traverse
-- traverse
--   :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b)
-- >>> :i Lens
-- type Lens s t a b =
--   forall (f :: * -> *). Functor f => (a -> f b) -> s -> f t
--         -- Defined at Traversals.hs:20:1
-- ```
--
-- Note that there's nothing stopping `t a -> f (t b)`
-- standing in for `s -> f t` (it's made a bit more confusing
-- by the `t`s in the two types being different). `s -> f t`
-- is a very permissive type.
--
-- What might happen if we try to _use_ `traverse` as a Lens?
--
-- ```
-- >>> modify traverse show [1, 2, 3]

-- <interactive>:1:8: error:
--     • Could not deduce (Applicative Identity)
--         arising from a use of ‘traverse’
--  more ...
-- ```
--
-- No problemo, an Applicative instance for Identity is pretty
-- straight forward:

instance Applicative Identity where
  pure = Identity
  Identity f <*> Identity a = Identity (f a)

-- Alright then:
--
-- ```
-- >>> modify traverse show [1, 2, 3]
-- ["1","2","3"]
-- ```
--
-- What about `view`ing using traverse?
--
-- ```
-- >>> view traverse ["1", "2", "3"]
-- <interactive>:1:6: error:
--    • No instance for (Applicative (Const String))
--         arising from a use of ‘traverse’
--  more ...
-- ```
--
-- Writing an Applicative instance for Const is a little less
-- straight forward. Let's go step by step.
--
-- As with the Functor instance we'll need to fix the first type
-- arg, let's call it `c` again:
--
-- ```
-- instance Applicative (Const c) where
-- ```
--
-- Now `pure`
--
-- ```
--   pure :: a -> Const c a
--   pure = undefined
-- ```
--
-- We need to produce a value of type `c`, but we can't, we
-- don't have one. Now, because `c` has nothing to do with
-- Applicative, we can technically assign it to whatever we
-- want. If we turn on FlexibleInstances we could even write
-- something like this:
--
-- ```
-- instance Applicative (Const ()) where
--   pure _ = Const ()
-- ```
--
-- In fact the whole instance is now pretty ... well:
--
-- ```
-- instance Applicative (Const ()) where
--   pure _ = Const ()
--   Const () <*> Const () = Const ()
-- ```
--
-- If we try to _use_ this instance for the examples above
-- we pretty quickly run into an issue.
--
-- ```
-- >>> :t view @[String] @String traverse
--
-- <interactive>:1:24: error:
--     • No instance for (Applicative (Const String))
--         arising from a use of ‘traverse’
-- ... more
-- >>> :t view @[()] @() traverse
-- view @[()] @() traverse :: [()] -> ()
-- ```
--
-- This will only ever work when `a` is `()`, it might be a
-- good idea to use a more general type than `()`, or any
-- concrete type really. Maybe ... we could use a _class_ of
-- types?
--
-- We need to a) make a value of this type out of thin air, and
-- b) perform some action on two values to produce one. There's
-- a type class which encapsulates types that behave this way
-- very well: Monoid.

instance Monoid c => Applicative (Const c) where
  pure _ = Const mempty
  Const a <*> Const b = Const (a <> b)

-- Does `traverse` work for viewing values now?
--
-- ```
-- >>> view traverse ["1", "2", "3"]
-- "123"
-- ```
--
-- Uh, in a way, sure. But only if `a` is a Monoid.
--
-- ```
-- >>> view traverse [1, 2, 3] :: Int
--
-- <interactive>:1:6: error:
--     • No instance for (Monoid Int) arising from a use of ‘traverse’
-- ... more
--
-- >>> import Data.Monoid (Sum(..))
-- >>> view traverse [Sum 1, Sum 2, Sum 3]
-- Sum {getSum = 6}
-- ```
--
-- What good is this? Well, for a start there are many very interesting
-- Traversable things, there are also many very interesting Monoids.
--
-- For example, First is a pretty interesting Monoid:
--
-- ```
-- >>> import Data.Monoid(First(..))
-- >>> import Data.Maybe (Maybe(Nothing, Just))
-- >>> import Data.Either (Either(Left, Right))
-- >>> view traverse (Right (First (Just 1)))
-- First {getFirst = Just 1}
-- >>> view traverse (Just (First (Just 1)))
-- First {getFirst = Just 1}
-- >>> view traverse [First (Just 1), First (Just 2)]
-- First {getFirst = Just 1}
-- >>> view traverse (Left "Boo") :: First Int
-- First {getFirst = Nothing}
-- >>> view traverse Nothing :: First Int
-- First {getFirst = Nothing}
-- >>> view traverse [] :: First Int
-- First {getFirst = Nothing}
-- ```
--
-- This suggests that there's a pretty handy function we could
-- write:
--
-- ```
-- preview :: Getter s a -> s -> Maybe a
-- preview getter = getFirst . getConst . getter (Const . First . Just)
-- ```
--
-- However if we try to compile that we get a type error pointing out
-- that the Getter type is too restrictive. We need something that allows
-- us to specify that the Const will contain something other than `a`:

type Getting r s a =
  (a -> Const r a) -> s -> Const r s

-- Now we can write preview:

preview :: Getting (First a) s a -> s -> Maybe a
preview getter = getFirst . getConst . getter (Const . First . Just)

-- It's fun to note that this can still be used with the above defined
-- Lenses:
--
-- ```
-- >>> preview _1 ("Y", "tho")
-- Just "Y"
-- ```
--

main :: IO ()
main = do
  print $ modify _1 (("It's " <>) . fmap toLower . show) (True, "Wow")
  -- ("It's true","Wow")
  print $ view _2 (True, "Wow")
  -- "Wow"
  print $ modify traverse length ["Hey", "that's", "weird"]
  -- [3,6,5]
  print $ view traverse ["Hey", "really", "weird"]
  -- "Heyreallyweird"
  print $ preview traverse (Right 2)
  -- Just 2
  print $ preview traverse (Left "Nope" :: Either String Int)
  -- Nothing
  print $ modify traverse length (Just "Hey")
  -- Just 3
  print $ preview traverse ["Not", "so", "weird"]
  -- Just "Not"