module Derive(deriveBuildRec) where
import Common hiding (Q)
import Control.Monad
import Data.Binary
import Data.Binary.Get
import Data.ByteString.Lazy as DBL (ByteString)
import Data.Char (toLower)
import Data.Map.Strict (Map, lookup)
import Language.Haskell.TH
import Prelude hiding (lookup)
genNames :: Int -> Q [Name]
genNames n = replicateM n $ newName "x"
statements :: [Name] -> [(Name, Strict, Type)] -> Name -> [StmtQ]
statements names args r = fmap (\(n, (name, _, tpe)) -> do
bytesName <- newName "b"
bindS
(varP n)
(infixE
(Just (infixE (Just (appE (varE 'runGet) (sigE (varE 'get) (appT (conT ''Get) (pure tpe))))) (varE $ mkName ".") (Just (lamE [tupP [wildP,wildP,wildP, conP (mkName "CQL.Bytes") [varP bytesName]]] (varE bytesName)))))
(varE $ mkName "<$>")
(Just (appE (appE (varE 'lookup) (appE (conE 'CQLString) (litE (StringL (fmap toLower (nameBase name)))))) (varE r))))
) (names `zip` args)
rtrnStmt names conName = [noBindS (appE (varE $ mkName "return") (applyRec (appE (conE conName) (varE $ head names)) (tail names)) )]
applyRec = foldl (\ex nm -> appE ex (varE nm))
deriveBuildRec a = do
#if __GLASGOW_HASKELL__ >= 800
TyConI (DataD _ cName _ _ constructors _) <- reify a
#else
TyConI (DataD _ cName _ constructors _) <- reify a
#endif
case head constructors of
(RecC conName args) -> do
names <- genNames $ length args
rowName <- newName "r"
[d| instance BuildRec $(conT a) where
fromRow = $(lamE [varP rowName] (doE (statements names args rowName ++ rtrnStmt names conName))) |]
_ -> fail "deriveBuildRec: Only simple records supported, is the type you are deriving for, a record type?"