module Data.Record.Label.TH (mkLabels) where
import Control.Monad
import Data.Char
import Language.Haskell.TH.Syntax
mkLabels :: [Name] -> Q [Dec]
mkLabels = liftM concat . mapM mkLabels1
mkLabels1 :: Name -> Q [Dec]
mkLabels1 n = do
i <- reify n
let
cs' = case i of
TyConI (DataD _ _ _ cs _) -> cs
TyConI (NewtypeD _ _ _ c _) -> [c]
_ -> []
ls' = [ l | RecC _ ls <- cs', l <- ls ]
return (map mkLabel1 ls')
mkLabel1 :: VarStrictType -> Dec
mkLabel1 (name, _, _) =
let n = mkName $ case nameBase name of
('_' : c : rest) -> toLower c : rest
(f : rest) -> 'l' : toUpper f : rest
_ -> ""
in FunD n [Clause [] (NormalB (
AppE (AppE (VarE (mkName "label")) (VarE name))
(LamE [VarP (mkName "b"), VarP (mkName "a")]
(RecUpdE (VarE (mkName "a")) [(name, VarE (mkName "b"))]))
)) []]