module Database.Relational.Query.Pure (
ProductConstructor (..),
ShowConstantTermsSQL (..)
) where
import Data.Monoid (mconcat)
import Data.Int (Int16, Int32, Int64)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import Text.Printf (PrintfArg, printf)
import Data.Time (FormatTime, Day, TimeOfDay, LocalTime, formatTime)
import System.Locale (defaultTimeLocale)
import Language.SQL.Keyword (Keyword (..), wordShow)
import Database.Record
(PersistableWidth, persistableWidth, PersistableRecordWidth)
import Database.Record.Persistable
(runPersistableRecordWidth)
class ProductConstructor r where
productConstructor :: r
instance ProductConstructor (a -> b -> (a, b)) where
productConstructor = (,)
intExprSQL :: (Show a, Integral a) => a -> String
intExprSQL = show
intTermsSQL :: (Show a, Integral a) => a -> [String]
intTermsSQL = (:[]) . intExprSQL
escapeStringToSqlExpr :: String -> String
escapeStringToSqlExpr = rec where
rec "" = ""
rec ('\'':cs) = '\'' : '\'' : rec cs
rec (c:cs) = c : rec cs
stringExprSQL :: String -> String
stringExprSQL = ('\'':) . (++ "'") . escapeStringToSqlExpr
stringTermsSQL :: String -> [String]
stringTermsSQL = (:[]) . stringExprSQL
class ShowConstantTermsSQL a where
showConstantTermsSQL :: a -> [String]
instance ShowConstantTermsSQL Int16 where
showConstantTermsSQL = intTermsSQL
instance ShowConstantTermsSQL Int32 where
showConstantTermsSQL = intTermsSQL
instance ShowConstantTermsSQL Int64 where
showConstantTermsSQL = intTermsSQL
instance ShowConstantTermsSQL String where
showConstantTermsSQL = stringTermsSQL
instance ShowConstantTermsSQL ByteString where
showConstantTermsSQL = stringTermsSQL . T.unpack . T.decodeUtf8
instance ShowConstantTermsSQL LB.ByteString where
showConstantTermsSQL = showConstantTermsSQL . mconcat . LB.toChunks
instance ShowConstantTermsSQL Text where
showConstantTermsSQL = stringTermsSQL . T.unpack
instance ShowConstantTermsSQL LT.Text where
showConstantTermsSQL = showConstantTermsSQL . LT.toStrict
instance ShowConstantTermsSQL Char where
showConstantTermsSQL = stringTermsSQL . (:"")
instance ShowConstantTermsSQL Bool where
showConstantTermsSQL = (:[]) . d where
d True = "(0=0)"
d False = "(0=1)"
floatTerms :: (PrintfArg a, Ord a, Num a)=> a -> [String]
floatTerms f = (:[]) $ printf fmt f where
fmt
| f >= 0 = "%f"
| otherwise = "(%f)"
instance ShowConstantTermsSQL Float where
showConstantTermsSQL = floatTerms
instance ShowConstantTermsSQL Double where
showConstantTermsSQL = floatTerms
constantTimeTerms :: FormatTime t => Keyword -> String -> t -> [String]
constantTimeTerms kw fmt t = [unwords [wordShow kw,
stringExprSQL $ formatTime defaultTimeLocale fmt t]]
instance ShowConstantTermsSQL Day where
showConstantTermsSQL = constantTimeTerms DATE "%Y-%m-%d"
instance ShowConstantTermsSQL TimeOfDay where
showConstantTermsSQL = constantTimeTerms TIME "%H:%M:%S"
instance ShowConstantTermsSQL LocalTime where
showConstantTermsSQL = constantTimeTerms TIMESTAMP "%Y-%m-%d %H:%M:%S"
showMaybeTerms :: ShowConstantTermsSQL a => PersistableRecordWidth a -> Maybe a -> [String]
showMaybeTerms wa = d where
d (Just a) = showConstantTermsSQL a
d Nothing = replicate (runPersistableRecordWidth wa) "NULL"
instance (PersistableWidth a, ShowConstantTermsSQL a)
=> ShowConstantTermsSQL (Maybe a) where
showConstantTermsSQL = showMaybeTerms persistableWidth
instance (ShowConstantTermsSQL a, ShowConstantTermsSQL b)
=> ShowConstantTermsSQL (a, b) where
showConstantTermsSQL (a, b) = showConstantTermsSQL a ++ showConstantTermsSQL b