module Database.PostgreSQL.Query.TH.SqlExp
(
sqlExp
, Rope(..)
, ropeParser
, parseRope
, squashRope
, sqlQExp
, sqlExpEmbed
, sqlExpFile
) where
import Prelude hiding (takeWhile)
import Control.Applicative
import Control.Monad ( when )
import Data.Attoparsec.Combinator
import Data.Attoparsec.Text
import Data.Char ( isSpace )
import Data.FileEmbed ( bsToExp )
import Data.Maybe
import Data.Monoid
import Data.Text ( Text )
import Database.PostgreSQL.Query.SqlBuilder
#if MIN_VERSION_haskell_src_meta(0,8,0)
import Language.Haskell.Meta.Parse
#else
import Language.Haskell.Meta.Parse.Careful
#endif
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
sqlExp :: QuasiQuoter
sqlExp = QuasiQuoter
{ quoteExp = sqlQExp
, quotePat = error "sqlInt used in pattern"
, quoteType = error "sqlInt used in type"
, quoteDec = error "sqlInt used in declaration"
}
data Rope
= RLit Text
| RComment Text
| RSpaces Int
| RInt FieldOption Text
| RPaste Text
deriving (Ord, Eq, Show)
parseRope :: String -> [Rope]
parseRope s = either error id
$ parseOnly ropeParser
$ T.pack s
ropeParser :: Parser [Rope]
ropeParser = many1 $ choice
[ quoted
, iquoted
, RInt FieldMasked <$> someNested "#?{"
, RInt FieldDefault <$> someNested "#{"
, RPaste <$> someNested "^{"
, comment
, bcomment
, spaces
, (RLit . T.singleton) <$> anyChar
]
where
eofErf e p =
choice
[ endOfInput
*> (error $ "Unexpected end of input: " <> e)
, p
]
unquoteBraces = T.replace "\\}" "}"
someNested :: Text -> Parser Text
someNested prefix = do
_ <- string prefix
e <- many1 $ choice
[ string "\\}"
, T.singleton <$> notChar '}'
]
eofErf ("block " <> T.unpack prefix <> " not finished") $ do
_ <- char '}'
return $ unquoteBraces $ mconcat e
comment = do
b <- string "--"
c <- takeWhile (`notElem` ['\r', '\n'])
endOfLine <|> endOfInput
return $ RComment $ b <> c
spaces = (RSpaces . T.length) <$> takeWhile1 isSpace
bcomment :: Parser Rope
bcomment = RComment <$> go
where
go = do
b <- string "/*"
c <- many' $ choice
[ go
, justStar
, T.singleton <$> notChar '*'
]
eofErf "block comment not finished, maybe typo" $ do
e <- string "*/"
return $ b <> mconcat c <> e
justStar = do
_ <- char '*'
peekChar >>= \case
(Just '/') -> fail "no way"
_ -> return "*"
quoted = do
_ <- char '\''
ret <- many' $ choice
[ string "''"
, string "\\'"
, T.singleton <$> notChar '\''
]
eofErf "string literal not finished" $ do
_ <- char '\''
return $ RLit $ "'" <> mconcat ret <> "'"
iquoted = do
_ <- char '"'
ret <- many' $ choice
[ string "\"\""
, T.singleton <$> notChar '"'
]
eofErf "quoted identifier not finished" $ do
_ <- char '"'
return $ RLit $ "\"" <> mconcat ret <> "\""
buildBuilder :: Rope
-> Maybe (Q Exp)
buildBuilder (RLit t) = Just $ do
bs <- bsToExp $ T.encodeUtf8 t
[e| sqlBuilderFromByteString $(pure bs) |]
buildBuilder (RInt fo t) = Just $ do
when (T.null $ T.strip t) $ fail "empty interpolation string found"
let ex = either error id $ parseExp $ T.unpack t
[e| sqlBuilderFromField $(lift fo) $(pure ex) |]
buildBuilder (RPaste t) = Just $ do
when (T.null $ T.strip t) $ fail "empty paste string found"
let ex = either error id $ parseExp $ T.unpack t
[e| toSqlBuilder $(pure ex) |]
buildBuilder _ = Nothing
squashRope :: [Rope] -> [Rope]
squashRope = go . catMaybes . map cleanRope
where
cleanRope (RComment _) = Nothing
cleanRope (RSpaces _) = Just $ RLit " "
cleanRope x = Just x
go ((RLit a):(RLit b):xs) = go ((RLit $ a <> b):xs)
go (x:xs) = x:(go xs)
go [] = []
sqlQExp :: String
-> Q Exp
sqlQExp s = do
let rope = squashRope $ parseRope s
exps <- sequence
$ catMaybes
$ map buildBuilder rope
[e| ( mconcat $(pure $ ListE exps) ) |]
sqlExpEmbed :: String
-> Q Exp
sqlExpEmbed fpath = do
qAddDependentFile fpath
s <- runIO $ T.unpack . T.decodeUtf8 <$> B.readFile fpath
sqlQExp s
sqlExpFile :: String
-> Q Exp
sqlExpFile ptr = sqlExpEmbed $ "sql/" <> ptr <> ".sql"