module Data.Record.Label.TH
( mkLabels
, mkLabelsNoTypes
) where
import Control.Monad
import Data.Char
import Language.Haskell.TH.Syntax
mkLabels :: [Name] -> Q [Dec]
mkLabels = liftM concat . mapM (labels True)
mkLabelsNoTypes :: [Name] -> Q [Dec]
mkLabelsNoTypes = liftM concat . mapM (labels False)
labels :: Bool -> Name -> Q [Dec]
labels sigs n =
do i <- reify n
let
(cs',vars) =
case i of
TyConI (DataD _ _ vs cs _) -> (cs , vs)
TyConI (NewtypeD _ _ vs c _) -> ([c], vs)
_ -> ([], undefined)
ls' = [ l | RecC _ ls <- cs', l <- ls ]
return (concatMap (label sigs n vars) ls')
label :: Bool -> Name -> [TyVarBndr] -> VarStrictType -> [Dec]
label withType typeName binders (field, _, typ) =
if withType
then [signature, body]
else [body]
where
appTv w (PlainTV n) = AppT w (VarT n)
appTv _ v = error ("Kinded type variable not supported: " ++ show v)
name = mkName $
case nameBase field of
'_' : c : rest -> toLower c : rest
f : rest -> 'l' : toUpper f : rest
_ -> error "Invalid name"
source = foldl appTv (ConT typeName) binders
signature = SigD name (ForallT binders [] (ConT (mkName ":->") `AppT` source `AppT` typ))
body =
let getter = VarE field
setter = [VarP (mkName "b"), VarP (mkName "a")]
`LamE` RecUpdE (VarE (mkName "a")) [(field, VarE (mkName "b"))]
lens = VarE (mkName "lens") `AppE` getter `AppE` setter
in FunD name [ Clause [] (NormalB lens) [] ]