ArcherAndDoctor.hs

#!/usr/bin/env stack
-- stack --resolver=lts-9.0 script --package=lens --package=template-haskell

{-# OPTIONS -Wall -Werror -ddump-splices #-}

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}

import           Control.Lens (Lens', (^.))

import           LensTHExtra (makeSimpleFields)

type Bow = String

data Doctor = Doctor { bow :: Bow }

data Archer = Archer { bow :: Bow }

class HasBow s a | s -> a where
    bow :: Lens' s a

makeSimpleFields ''Doctor
makeSimpleFields ''Archer

main :: IO ()
main = do
    let doctor = Doctor{bow = "🎀"}
    let archer = Archer{bow = "\127993"}

    let Doctor{bow = doctorBow} = doctor
    let Archer{bow = archerBow} = archer
    putStrLn doctorBow
    putStrLn archerBow

    putStrLn $ doctor ^. bow
    putStrLn $ archer ^. bow

LensTHExtra.hs

module LensTHExtra where

import           Control.Lens (Lens', iso, (%~), (.~), (^.), _head)
import           Control.Lens.Internal.FieldTH (makeFieldOptics)
import           Control.Lens.TH (DefName (MethodName), FieldNamer, LensRules,
                                  defaultFieldRules, lensField)
import           Data.Char (toUpper)
import           Data.Function ((&))
import           Data.Maybe (maybeToList)
import           Language.Haskell.TH (DecsQ, Name, mkName, nameBase)

makeSimpleFields :: Name -> DecsQ
makeSimpleFields = makeFieldOptics classNoPrefixFields

classNoPrefixFields :: LensRules
classNoPrefixFields = defaultFieldRules & lensField .~ classNoPrefixNamer

classNoPrefixNamer :: FieldNamer
classNoPrefixNamer _ _ field =
    [MethodName (mkName className) (mkName methodName)]
  where
    fieldUnprefixed = nameBase field
    className       = "Has" ++ (_head %~ toUpper) fieldUnprefixed
    methodName      = fieldUnprefixed