{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
------------------------------------------------------------------------------
-- |
-- Module:      Database.PostgreSQL.Simple.SqlQQ
-- Copyright:   (c) 2011-2012 Leon P Smith
-- License:     BSD3
-- Maintainer:  Leon P Smith <leon@melding-monads.com>
-- Stability:   experimental
--
------------------------------------------------------------------------------

module Database.PostgreSQL.Simple.SqlQQ (sql) where
import Database.PostgreSQL.Simple.Types (Query)
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Data.Char
import Data.String

-- | 'sql' is a quasiquoter that eases the syntactic burden
-- of writing big sql statements in Haskell source code.  For example:
--
-- > {-# LANGUAGE QuasiQuotes #-}
-- >
-- > query conn [sql| SELECT column_a, column_b
-- >                    FROM table1 NATURAL JOIN table2
-- >                   WHERE ? <= time AND time < ?
-- >                     AND name LIKE ?
-- >                   ORDER BY size DESC
-- >                   LIMIT 100                        |]
-- >            (beginTime,endTime,string)
--
-- This quasiquoter returns a literal string expression of type 'Query',
-- and attempts to minimize whitespace;  otherwise the above query would
-- consist of approximately half whitespace when sent to the database
-- backend.  It also recognizes and strips out standard sql comments "--".
--
-- The implementation of the whitespace reducer is currently incomplete.
-- Thus it can mess up your syntax in cases where whitespace should be
-- preserved as-is.  It does preserve whitespace inside standard SQL string
-- literals.  But it can get confused by the non-standard PostgreSQL string
-- literal syntax (which is the default setting in PostgreSQL 8 and below),
-- the extended escape string syntax,  quoted identifiers,  and other similar
-- constructs.
--
-- Of course, this caveat only applies to text written inside the SQL
-- quasiquoter; whitespace reduction is a compile-time computation and
-- thus will not touch the @string@ parameter above,  which is a run-time
-- value.
--
-- Also note that this will not work if the substring @|]@ is contained
-- in the query.

sql :: QuasiQuoter
sql :: QuasiQuoter
sql = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
    { quotePat :: String -> Q Pat
quotePat  = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in pattern context"
    , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in type context"
    , quoteExp :: String -> Q Exp
quoteExp  = String -> Q Exp
sqlExp
    , quoteDec :: String -> Q [Dec]
quoteDec  = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in declaration context"
    }

sqlExp :: String -> Q Exp
sqlExp :: String -> Q Exp
sqlExp = Q Exp -> Q Exp -> Q Exp
appE [| fromString :: String -> Query |] (Q Exp -> Q Exp) -> (String -> Q Exp) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q Exp
stringE (String -> Q Exp) -> (String -> String) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
minimizeSpace

minimizeSpace :: String -> String
minimizeSpace :: String -> String
minimizeSpace = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
reduceSpace
  where
    needsReduced :: String -> Bool
needsReduced []          = Bool
False
    needsReduced (Char
'-':Char
'-':String
_) = Bool
True
    needsReduced (Char
x:String
_)       = Char -> Bool
isSpace Char
x

    reduceSpace :: String -> String
reduceSpace String
xs =
        case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
xs of
          [] -> []
          (Char
'-':Char
'-':String
ys) -> String -> String
reduceSpace ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
ys)
          String
ys -> Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
insql String
ys

    insql :: String -> String
insql (Char
'\'':String
xs)            = Char
'\'' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
instring String
xs
    insql String
xs | String -> Bool
needsReduced String
xs = String -> String
reduceSpace String
xs
    insql (Char
x:String
xs)               = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
insql String
xs
    insql []                   = []

    instring :: String -> String
instring (Char
'\'':Char
'\'':String
xs) = Char
'\''Char -> String -> String
forall a. a -> [a] -> [a]
:Char
'\''Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
instring String
xs
    instring (Char
'\'':String
xs)      = Char
'\''Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
insql String
xs
    instring (Char
x:String
xs)         = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
instring String
xs
    instring []             = String -> String
forall a. HasCallStack => String -> a
error String
"Database.PostgreSQL.Simple.SqlQQ.sql: string literal not terminated"