drf.hs

-- For automated generation of LabelOptic instances.
{-# LANGUAGE TemplateHaskell #-}

-- For duplicate names of record fields. To be replaced by NoFieldSelectors as
-- top level selector functions are not needed here.
{-# LANGUAGE DuplicateRecordFields #-}

-- For OverloadedLabels syntax.
{-# LANGUAGE OverloadedLabels #-}

-- For LabelOptic instances.
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

import Optics

----------------------------------------
-- Example from proposal

data Grade = A | B | C | D | E | F
data Quarter = Fall | Winter | Spring
data Status = Passed | Failed | Incomplete | Withdrawn

data Taken =
  Taken { year :: Int
        , term :: Quarter
        }

data Class =
  Class { hours :: Int
        , units :: Int
        , grade :: Grade
        , result :: Status
        , taken :: Taken
        }

makeFieldLabelsWith noPrefixFieldLabels ''Taken
makeFieldLabelsWith noPrefixFieldLabels ''Class

getResult :: Class -> Status
getResult c = c ^. #result -- get

setResult :: Class -> Status -> Class
setResult c r = c & #result .~ r -- update

setYearTaken :: Class -> Int -> Class
setYearTaken c y = c & #taken % #year .~ y -- nested update

addYears :: Class -> Int -> Class
addYears c n = c & #taken % #year %~ (+ n) -- update via op

squareUnits :: Class -> Class
squareUnits c = c & #units %~ (\x -> x * x) -- update via function

getResults :: [Class] -> [Status]
getResults = map (^. #result) -- section

getTerms :: [Class]  -> [Quarter]
getTerms = map (^. #taken % #term) -- nested section

----------------------------------------
-- Readme

data Company = Company {name :: String, owner :: Person}
data Person = Person {name :: String, age :: Int}

makeFieldLabelsWith noPrefixFieldLabels ''Company
makeFieldLabelsWith noPrefixFieldLabels ''Person

display :: Company -> String
display c = c ^. #name ++ " is run by " ++ c ^. #owner % #name

nameAfterOwner :: Company -> Company
nameAfterOwner c = c & #name .~ c ^. #owner % #name ++ "'s Company"

----------------------------------------
-- Problematic polymorphic updates

data Poly a = Poly { poly1 :: a, poly2 :: a }

makeFieldLabelsWith noPrefixFieldLabels ''Poly

-- Has to be written by hand, but in principle could be generated with TH.
instance (x ~ (a, a), y ~ (b, b)) => LabelOptic "poly1_poly2" A_Lens (Poly a) (Poly b) x y where
  labelOptic = lensVL $ \f (Poly p1 p2) ->
    (\(p1', p2') -> Poly { poly1 = p1', poly2 = p2' }) <$> f (p1, p2)

-- No polymorphic update is possible here
poly1Set :: a -> Poly a -> Poly a
poly1Set a poly = poly & #poly1 .~ a

-- But we can update both fields at the same time
polySet :: b -> b -> Poly a -> Poly b
polySet b1 b2 poly = poly & #poly1_poly2 .~ (b1, b2)

----------------------------------------
-- Different example, multiple field updates

data Human = Human
  { name :: String
  , age  :: Integer
  } deriving (Eq, Show)

data Animal = Animal
  { name :: String
  , age  :: Int
  } deriving (Eq, Show)

data AnimalType = Fish | Dog
  deriving (Eq, Show)

makeFieldLabelsWith noPrefixFieldLabels ''Human
makeFieldLabelsWith noPrefixFieldLabels ''Animal

human :: Human
human = Human "Bob" 20

human' :: Human
human' = human
  & #name .~ "Andy"
  & #age  .~ 27

animal :: Animal
animal = Animal "Goldie" 2

animal' :: Animal
animal' = animal
  & #name .~ "Sparky"
  & #age  .~ 3