{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
module Database.DynamoDB.THLens where
import Control.Lens (over, _1)
import Control.Monad (forM_)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Writer.Lazy (WriterT, tell)
import Data.Function ((&))
import Data.List (isPrefixOf)
import Data.Monoid ((<>))
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Name (..), OccName (..))
createPolyLenses :: (String -> String) -> Name -> [Name] -> WriterT [Dec] Q ()
createPolyLenses translate table indexes = do
tblfields <- getFieldNames table id
fields <- tblfields & map fst
& filter ("_" `isPrefixOf`)
& map ((,) <$> translate <*> drop 1)
& mapM mkLensClass
mapM_ createClass fields
createInstances fields table
mapM_ (createInstances fields) indexes
where
mkLensClass (field, lens) = do
clsname <- lift $ newName (nameBase table ++ "_lens_" ++ field)
return (field, (mkName lens, clsname))
createClass (_, (lensname, clsname)) = do
a <- lift $ newName "a"
b <- lift $ newName "b"
f <- lift $ newName "f"
lift (pure $ ClassD [] clsname [PlainTV a,PlainTV b] [FunDep [a] [b]]
[SigD lensname (ForallT [PlainTV f] [AppT (ConT ''Functor) (VarT f)]
(AppT (AppT ArrowT (AppT (AppT ArrowT (VarT b))
(AppT (VarT f) (VarT b)))) (AppT (AppT ArrowT (VarT a))
(AppT (VarT f) (VarT a)))))]) >>= say
createInstances lensfields idx = do
tblfields <- getFieldNames idx id
forM_ tblfields $ \(fieldname, ftype) ->
whenJust (lookup (translate fieldname) lensfields) $ \(lensname, clsname) -> do
f <- lift $ newName "f"
t <- lift $ newName "t"
val <- lift $ newName "val"
let fieldSel = mkName fieldname
#if __GLASGOW_HASKELL__ >= 800
lift (pure $ InstanceD Nothing [] (AppT (AppT (ConT clsname) (ConT idx)) ftype)
[FunD lensname [Clause [VarP f,VarP t] (NormalB (InfixE (Just (LamE [VarP val]
(RecUpdE (VarE t) [(fieldSel,VarE val)]))) (VarE 'fmap)
(Just (AppE (VarE f) (AppE (VarE fieldSel) (VarE t)))))) []]])
#else
lift (pure $ InstanceD [] (AppT (AppT (ConT clsname) (ConT idx)) ftype)
[FunD lensname [Clause [VarP f,VarP t] (NormalB (InfixE (Just (LamE [VarP val]
(RecUpdE (VarE t) [(fieldSel,VarE val)]))) (VarE 'fmap)
(Just (AppE (VarE f) (AppE (VarE fieldSel) (VarE t)))))) []]])
#endif
>>= say
whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (Just a) f = f a
whenJust Nothing _ = return ()
say :: Monad m => t -> WriterT [t] m ()
say a = tell [a]
getFieldNames :: Name -> (String -> String) -> WriterT [Dec] Q [(String, Type)]
getFieldNames tbl translate = do
info <- lift $ reify tbl
case getRecords info of
Left err -> fail $ "Table " <> show tbl <> ": " <> err
Right lst -> return $ map (over _1 translate) lst
where
getRecords :: Info -> Either String [(String, Type)]
#if __GLASGOW_HASKELL__ >= 800
getRecords (TyConI (DataD _ _ _ _ [RecC _ vars] _)) = Right $ map (\(Name (OccName rname) _,_,typ) -> (rname, typ)) vars
#else
getRecords (TyConI (DataD _ _ _ [RecC _ vars] _)) = Right $ map (\(Name (OccName rname) _,_,typ) -> (rname, typ)) vars
#endif
getRecords _ = Left "not a record declaration with 1 constructor"