module Data.Lenses.Template (
nameDeriveLenses, deriveLenses
) where
import Language.Haskell.TH.Syntax
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)
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 <- liftM concat $ mapM (makeAccs params) 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 :: [Name] -> Con -> Q [Dec]
makeAccs params (RecC _ vars) =
liftM (concat . catMaybes) $ mapM (\ (name,_,ftype) -> makeAccFromName name params ftype) vars
makeAccs params (ForallC _ _ c) = makeAccs params c
makeAccs _ _ = return []
transformName :: Name -> Maybe Name
transformName (Name occ f) = do
n <- namer (occString occ)
return $ Name (mkOccName n) f
makeAccFromName :: Name -> [Name] -> Type -> Q (Maybe [Dec])
makeAccFromName name params ftype =
case transformName name of
Nothing -> return Nothing
Just n -> liftM Just $ makeAcc name params ftype n
#ifndef __HADDOCK__
makeAcc ::Name -> [Name] -> Type -> Name -> Q [Dec]
makeAcc name params ftype accName = do
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 (b:m:params) [AppT (AppT (ConT ''MonadState) appliedT) (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"
#endif