Generating Heist Splices using Generic programming

README

- This code demonstrates how to automatically derive Heist builder using a flat data structure.

- How to run (Tested on: ghc 7.10.3), assuming you have a stack environment setup with all the libraries: 
 - Load: stack exec ghci -- Main.hs -XTemplateHaskell -XOverloadedStrings 
 - Execute main - output below:
<API_root><login><user>JohnDoe</user><password>whatdoyouthink</password></login></API_root>

- How it works:
- This is modeled after deriveJSON of Aeson, but with few simplifications. We have this in Main.hs:
data AuthAPI = AuthAPI { _autha_uname :: String, _autha_pass :: Text} deriving (Show)
deriveHeistBuilder (Prelude.drop 7) ''AuthAPI

- The above code generates a typeclass for "HeistBuilder a" as defined in "Derive.hs". It will generate template parser as follows:
 1. Top level constructor name "AuthAPI" becomes lower-case and is used as top-level bind "authapi" in Heist splicing.
 2. Splices are generated to parse "uname" and "pass" (after dropping first 7 characters of function names as passed to deriveHeistBuilder). 
 3. So, resulting builder parses the following template (auth.tpl in the example):
 <API_root><authapi><login><user><uname/></user><password><pass/></password></login></authapi></API_root>

auth.tpl

<API_root><authapi><login><user><uname/></user><password><pass/></password></login></authapi></API_root>

Derive.hs

{-# LANGUAGE TemplateHaskell, OverloadedStrings, FlexibleInstances #-}
module Derive 
  (deriveHeistBuilder,
   HeistBuilder,
   buildSplice,
   genSpliceBuilder,
   genReqH)
where

import Language.Haskell.TH
import Control.Monad
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Either (runEitherT)
import Heist.Compiled as C
import Data.Char (toLower)
import Data.Map.Syntax 
import Data.Maybe (fromJust)
import Data.Text (pack, unpack, Text)
import Data.Text.Lazy (toStrict)
import Control.Monad.State.Strict (get, evalStateT, StateT, lift)
import Data.ByteString (ByteString)
import Data.ByteString.Builder.Internal (Builder)
import Blaze.ByteString.Builder (toByteString)
import Control.Lens
import Heist
import ToText

-- Get names of constructor fields and corresponding functions
-- transform the field names using rename function
listFields :: Name -> (String -> String) -> Q ([(String,[(String,Name)])])
listFields name rename = do
  -- A warning: with GHC 8, you'll have to add an extra “_” before “cons”
  TyConI (DataD _ _ _ cons _) <- reify name
  let showClause (RecC conName fields) = (map toLower $ nameBase conName, map (\(x,_,_) -> (rename . nameBase $ x,x)) fields)
  return $ map showClause cons

buildHeistSplice :: (String,Name) -> Stmt
buildHeistSplice (name,expr) = NoBindS (InfixE (Just (LitE (StringL name))) (VarE '(##)) (Just (InfixE (Just (InfixE (Just (VarE 'C.pureSplice)) (VarE '(.)) (Just (VarE 'C.textSplice)))) (VarE '($)) (Just (InfixE (Just (VarE 'ToText.toText)) (VarE '(.)) (Just (VarE expr)))))))  

buildHeistASTH :: [Stmt] -> Exp
buildHeistASTH stmts = InfixE (Just (AppE (VarE 'C.withSplices) (VarE 'C.runChildren))) (VarE '($)) (Just (DoE stmts))

--TODO - fix to handle all constructors instead of just one 
buildHeistAST :: (String,[(String,Name)]) -> Q Exp
buildHeistAST field = do
  let stmts = map buildHeistSplice $ snd field 
  return $ buildHeistASTH stmts

load :: MonadIO n => FilePath -> Splices (Splice n) -> IO (HeistState n)
load baseDir splices = do
    tmap <- runEitherT $ do
        let sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices
                        & scCompiledSplices .~ splices
                        & scTemplateLocations .~ [loadTemplates baseDir]
        initHeist $ emptyHeistConfig & hcNamespace .~ ""
                                     & hcErrorNotBound .~ False
                                     & hcSpliceConfig .~ sc
    either (error . Prelude.concat) return tmap

genReqH :: StateT a IO Builder -> a -> IO ByteString
genReqH runtime runtimeData = do
      return . toByteString =<< evalStateT runtime runtimeData

class HeistBuilder a where
  buildSplice :: C.Splice (StateT a IO)
  genSpliceBuilder :: FilePath -> ByteString -> IO (StateT a IO Builder)

-- Dummy declaration we use to grab splice AST for instance declaration
data T5_74323 = T5_74323

-- TH code to generate AST for HeistBuilder instance for type t
deriveHeistBuilderH :: (String,[(String,Name)]) -> Name -> Q [Dec]
deriveHeistBuilderH field t = do
  spliceH1 <- buildHeistAST field
  let topConsName = fst field -- Name of top-level constructor in lower-case - we pass it as top-level bind pattern
  d1 <- [d| instance HeistBuilder T5_74323 where buildSplice = buildSpliceH (lift get) where buildSpliceH = undefined |]
  d2 <- [d| instance HeistBuilder T5_74323 where genSpliceBuilder baseDir templName = do hs <- load baseDir ("auth" ## buildSplice); return $ fst . fromJust $ C.renderTemplate hs templName|]
  let [InstanceD [] (AppT heistBuildt (ConT _T1)) [ValD pat body [ValD buildH (NormalB bodyI) []]]] = d1
      [InstanceD _ (_) [FunD genBuildt [Clause clauseBody (NormalB (DoE [BindS pat1 (AppE exp1 _), NoBindS exp3])) []]]] = d2
      spliceH2 = (InfixE (Just (LitE (StringL topConsName))) (VarE '(##)) (Just (VarE 'buildSplice))) 
  return [InstanceD [] (AppT heistBuildt (ConT t)) [(ValD pat body [ValD buildH (NormalB spliceH1) []]),(FunD genBuildt [Clause clauseBody (NormalB (DoE [BindS pat1 (AppE exp1 spliceH2), NoBindS exp3])) []])]]

deriveHeistBuilder rename t = do
   fields <- listFields t rename
   if (Prelude.length fields /= 1) 
    then error "Heist Splice Generation derivation is supported only for single constructor"
    else deriveHeistBuilderH (head fields) t

Main.hs

{-# LANGUAGE TemplateHaskell #-}
module Main where
import Derive
import Data.Text (Text)

data AuthAPI = AuthAPI { _autha_uname :: String, _autha_pass :: Text} deriving (Show) 

deriveHeistBuilder (Prelude.drop 7) ''AuthAPI

main = do
  authBuilder <- genSpliceBuilder "." "auth"
  req <- genReqH (authBuilder) (AuthAPI { _autha_uname = "JohnDoe", _autha_pass = "whatdoyouthink"})
  print req

ToText.hs

{-# LANGUAGE FlexibleInstances #-}
module ToText 
where

import Data.List
import Data.Text (unpack, pack, Text)

class ToText a where
    toText :: (Show a) => a -> Text

instance {-# OVERLAPPING #-} ToText a  where
    toText = pack . show

instance {-# OVERLAPPING #-} ToText Char where
    toText c = pack [c]

instance {-# OVERLAPPING #-} ToText String where
    toText = pack

instance {-# OVERLAPPING #-} ToText Text where
    toText = id