{-# LANGUAGE TemplateHaskell,
CPP #-}
module Data.Lenses.Template (
nameDeriveLenses, deriveLenses
) where
import Language.Haskell.TH.Syntax
import Data.List (nub, )
import Data.Maybe (catMaybes, )
import Control.Monad.State
import Data.Lenses
deriveLenses :: Name -> Q [Dec]
deriveLenses n = nameDeriveLenses n stripUnderscore
stripUnderscore :: String -> Maybe String
stripUnderscore s = do
(stem,'_') <- viewR s
return stem
where
viewR :: [a] -> Maybe ([a], a)
viewR [] = Nothing
viewR xs = Just (init xs, last xs)
namedFields :: Con -> [VarStrictType]
namedFields (RecC _ fs) = fs
namedFields (ForallC _ _ c) = namedFields c
namedFields _ = []
nameDeriveLenses :: Name -> (String -> Maybe String) -> Q [Dec]
nameDeriveLenses t namer = do
info <- reify t
reified <- case info of
TyConI dec -> return dec
_ -> fail errmsg
(params, cons) <- case reified of
DataD _ _ params _ cons' _ -> return (params, cons')
NewtypeD _ _ params _ con' _ -> return (params, [con'])
_ -> fail errmsg
decs <- makeAccs params . nub $ concatMap namedFields cons
when (null decs) $ qReport False nodefmsg
return decs
where
errmsg = "Cannot derive accessors for name " ++ show t ++ " because"
++ "\n it is not a type declared with 'data' or 'newtype'"
++ "\n Did you remember to double-tick the type as in"
++ "\n $(deriveLenses ''TheType)?"
nodefmsg = "Warning: No accessors generated from the name " ++ show t
++ "\n If you are using deriveLenses rather than"
++ "\n nameDeriveLenses, remember accessors are"
++ "\n only generated for fields ending with an underscore"
makeAccs :: [TyVarBndr] -> [VarStrictType] -> Q [Dec]
makeAccs params vars =
liftM (concat . catMaybes) $ mapM (\ (name,_,ftype) -> makeAccFromName name params ftype) vars
transformName :: Name -> Maybe Name
transformName (Name occ f) = do
n <- namer (occString occ)
return $ Name (mkOccName n) f
makeAccFromName :: Name -> [TyVarBndr] -> Type -> Q (Maybe [Dec])
makeAccFromName name params ftype =
case transformName name of
Nothing -> return Nothing
Just n -> liftM Just $ makeAcc name params ftype n
makeAcc ::Name -> [TyVarBndr] -> Type -> Name -> Q [Dec]
makeAcc name params ftype accName = do
let params' = map (\x -> case x of (PlainTV n) -> n; (KindedTV n _) -> n) params
let appliedT = foldl AppT (ConT t) (map VarT params')
body <- [|
fromGetSet
( $( return $ VarE name ) )
( \x s ->
$( return $ RecUpdE (VarE 's) [(name, VarE 'x)] ) )
|]
return
[ SigD accName (ForallT (map PlainTV (b:m:params')) [ConT ''MonadState `AppT` appliedT `AppT` (VarT m)] (AppT (AppT ArrowT (AppT (AppT (AppT (ConT ''StateT) ftype) (VarT m)) (VarT b))) (AppT (VarT m) (VarT b))))
, ValD (VarP accName) (NormalB body) []
]
where
b = mkName "b"
m = mkName "m"