Experimenting with the Builder pattern in Control.Lens

LensBuilder.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Arrows #-}
 
{- Some ideas on the common Builder pattern from the OO world in the context of lenses -}
 
module Main where
 
import Control.Arrow
import Control.Lens
import Data.Default
import Data.Void
import qualified Data.Map as Map
import Control.Monad.State
 
{- Imagine you have a rich data structure with fields like this: -}
 
data ContactInfo = ContactInfo {
  _ciName :: String,
  _ciStreet :: String,
  _ciCity :: String,
  _ciProvince :: String,
  _ciPostalCode :: String
  } deriving (Eq, Show)
 
{- And you then do things like this: -}
 
{- Build a contact from some input; say, from a map: -}
 
contactMaker1 :: (Map.Map String String) -> Maybe ContactInfo
contactMaker1 m = do
  name'       <- Map.lookup "name" m
  street'     <- Map.lookup "street" m
  city'       <- Map.lookup "city" m
  province'   <- Map.lookup "state" m
  postalCode' <- Map.lookup "zip" m
  return $ ContactInfo street' name' city' province' postalCode'
 
{- But WAIT! That's wrong. street' and name' were used in the wrong order there.
   If only we had a way to match the name of the field to what we were pulling: -}
 
{- Lenses, especially makeFields, help us with that -}
makeFields ''ContactInfo
instance Default ContactInfo where
  def = ContactInfo def def def def def
 
{- So now we can do: -}
 
contactMaker2 :: (Map.Map String String) -> Maybe ContactInfo
contactMaker2 m = execStateT doIt def
  where
    getVal str = lift (Map.lookup str m)
    doIt :: StateT ContactInfo Maybe ()
    doIt = do name       <~ getVal "name"
              street     <~ getVal "street"
              city       <~ getVal "city"
              province   <~ getVal "state"
              postalCode <~ getVal "zip"
 
{- No more argument order issues! You can even swap stuff around: -}
 
contactMaker2' :: (Map.Map String String) -> Maybe ContactInfo
contactMaker2' m = execStateT doIt def
  where
    getVal str = lift (Map.lookup str m)
    doIt :: StateT ContactInfo Maybe ()
    doIt = do name       <~ getVal "name"
              city       <~ getVal "city"
              street     <~ getVal "street"
              province   <~ getVal "state"
              postalCode <~ getVal "zip"
 
{- And that's cool, but you can also do this, and have it compile: -}
 
contactMaker3 :: (Map.Map String String) -> Maybe ContactInfo
contactMaker3 m = execStateT doIt def
  where
    getVal str = lift (Map.lookup str m)
    doIt :: StateT ContactInfo Maybe ()
    doIt = do name       <~ getVal "name"
              street     <~ getVal "street"
              {- Missing field! -}
              province   <~ getVal "state"
              postalCode <~ getVal "zip"
 
{- So here's something to address that: it provides type-safety guarantees
   that you have all the fields, but provides nice order independence by
   connecting the fields to the values that fill them.
-}
 
{- imagine something like makeFields that autogenerated this, so in real code
   you wouldn't need to read this, you'd just see something like
   makeBuilder ''ContactInfo
   -}
data B'CI q = B'CI q
b'name :: Setter (B'CI (Void, a, b, c, d)) (B'CI (String, a, b, c, d)) Void String
b'name = sets (\m (B'CI q) -> B'CI ((_1 %~ m) q))
b'street :: Setter (B'CI (a, Void, b, c, d)) (B'CI (a, String, b, c, d)) Void String
b'street = sets (\m (B'CI q) -> B'CI ((_2 %~ m) q))
b'city :: Setter (B'CI (a, b, Void, c, d)) (B'CI (a, b, String, c, d)) Void String
b'city = sets (\m (B'CI q) -> B'CI ((_3 %~ m) q))
b'province :: Setter (B'CI (a, b, c, Void, d)) (B'CI (a, b, c, String, d)) Void String
b'province = sets (\m (B'CI q) -> B'CI ((_4 %~ m) q))
b'postalCode :: Setter (B'CI (a, b, c, d, Void)) (B'CI (a, b, c, d, String)) Void String
b'postalCode = sets (\m (B'CI q) -> B'CI ((_5 %~ m) q))
 
b'ContactInfo :: B'CI (String, String, String, String, String)
                 -> ContactInfo
b'ContactInfo (B'CI (a, b, c, d, e)) = ContactInfo a b c d e
 
emptyB'CI :: B'CI (Void, Void, Void, Void, Void)
emptyB'CI =  B'CI (undefined, undefined, undefined, undefined, undefined)
 
{- Now also imagine a Control.Lens.Arrow package with this in it: -}
 
(<~~) :: (Arrow ar) => ASetter s t a b -> ar s b -> ar s t
setter <~~ arrval = proc x -> do
                              bval <- arrval -< x
                              returnA -< x & setter .~ bval
  -- (arr (flip $ set setter) &&& arrval) >>> first (arr arr) >>> app
 
{- Now we can do this: -}
 
contactMaker4 :: (Map.Map String String) -> Maybe ContactInfo
contactMaker4 m = runKleisli doIt emptyB'CI
  where
    getVal str = Kleisli (const $ Map.lookup str m)
    doIt =     b'name       <~~ getVal "name"
           >>> b'province   <~~ getVal "state"
           >>> b'postalCode <~~ getVal "zip"
           >>> b'city       <~~ getVal "city"
           >>> b'street     <~~ getVal "street"
           >>> arr b'ContactInfo
 
{- And voila - order independence but with compile-time guarantees that
   I didn't forget one of the fields -}
 
{- Just to prove that it doesn't merely compile, actually works: -}
 
main :: IO ()
main = do let m = Map.fromList [("name", "Mary Sue"),
                                ("state", "DE"),
                                ("city", "Newark"),
                                ("street", "134 Lukas St."),
                                ("zip", "18765")]
          print (contactMaker4 m)

Note that (<~~) now exists as Control.Lens.Setter.assignA