{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BangPatterns #-}
module Database.ODBC.TH
( sql
, sqlFile
, partsParser
, Part(..)
) where
import Control.DeepSeq
import Data.Char
import Data.List (foldl1')
import Data.Monoid ((<>))
import Language.Haskell.TH (Q, Exp)
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Text.Parsec
import Text.Parsec.String
data Part
= SqlPart !String
| ParamName !String
deriving (Show, Eq)
partsParser :: Parser [Part]
partsParser = many1 (self <|> param <|> part)
where
self = try (SqlPart "$" <$ string "$$") <?> "escaped dollar $$"
param =
(char '$' *>
(ParamName <$>
(many1 (satisfy isAlphaNum)) <?> "variable name (alpha-numeric only)")) <?>
"parameter (e.g. $foo123)"
part = (SqlPart <$> many1 (satisfy (/= '$'))) <?> "SQL code"
sql :: QuasiQuoter
sql = QuasiQuoter { quoteExp = buildSqlQuery "<expression>"
, quotePat = ignored
, quoteType = ignored
, quoteDec = ignored
}
where
ignored :: x -> Q a
ignored _ = fail "sql quote can be used at the expression level only"
sqlFile :: FilePath -> Q Exp
sqlFile fp = do
!str <- fmap force (TH.runIO (readFile fp))
buildSqlQuery fp str
buildSqlQuery :: FilePath -> String -> Q Exp
buildSqlQuery fp input = do
case parse partsParser fp input of
Left err -> fail $ "Parse error in SQL: " <> show err
Right parts -> pure $ buildExp parts
buildExp :: [Part] -> Exp
buildExp = foldl1' go . fmap toExp
where
toExp (SqlPart s) = TH.LitE $ TH.StringL s
toExp (ParamName name) =
TH.AppE (TH.VarE $ TH.mkName "toSql") (TH.VarE $ TH.mkName name)
go a b = TH.UInfixE a (TH.VarE '(<>)) b