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 (mkLabels1 True)
mkLabelsNoTypes :: [Name] -> Q [Dec]
mkLabelsNoTypes = liftM concat . mapM (mkLabels1 False)
mkLabels1 :: Bool -> Name -> Q [Dec]
mkLabels1 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 (mkLabel1 sigs n vars) ls')
mkLabel1 :: Bool -> Name -> [TyVarBndr] -> VarStrictType -> [Dec]
mkLabel1 sigs typeName binders (name, _, t) =
let
lensName = mkName $ case nameBase name of
('_' : c : rest) -> toLower c : rest
(f : rest) -> 'l' : toUpper f : rest
_ -> error "Invalid name"
source = foldl appTv (ConT typeName) binders
lensType = ForallT binders [] $ AppT (AppT (ConT $ mkName ":->") source) t
in (if sigs then [SigD lensName lensType] else []) ++ [functionBody lensName name]
appTv :: Type -> TyVarBndr -> Type
appTv t (PlainTV n) = AppT t (VarT n)
appTv _ v = error $ "Kinded type variable not supported: " ++ show v
functionBody :: Name -> Name -> Dec
functionBody lensName fieldName =
FunD lensName [
Clause [] (
NormalB (
AppE (AppE (VarE (mkName "lens")) (VarE fieldName))
(LamE [VarP (mkName "b"), VarP (mkName "a")]
(RecUpdE (VarE (mkName "a")) [(fieldName, VarE (mkName "b"))])
)
)
) [] ]