{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
module Database.Relational.Pure () where
import Control.Applicative (pure)
import Data.Monoid ((<>))
import Data.Int (Int8, 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 qualified Data.Text.Lazy.Encoding as LT
import Text.Printf (PrintfArg, printf)
import Data.Time (FormatTime, Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, formatTime)
import Data.Time.Locale.Compat (defaultTimeLocale)
import Data.DList (DList, fromList)
import Language.SQL.Keyword (Keyword (..))
import Database.Record
(PersistableWidth, persistableWidth, PersistableRecordWidth)
import Database.Record.Persistable
(runPersistableRecordWidth)
import Database.Relational.Internal.String (StringSQL, stringSQL, boolSQL)
import Database.Relational.ProjectableClass (ShowConstantTermsSQL (..))
intTermsSQL :: (Show a, Integral a) => a -> DList StringSQL
intTermsSQL = pure . stringSQL . show
escapeStringToSqlExpr :: String -> String
escapeStringToSqlExpr = rec where
rec "" = ""
rec ('\'':cs) = '\'' : '\'' : rec cs
rec (c:cs) = c : rec cs
stringExprSQL :: String -> StringSQL
stringExprSQL = stringSQL . ('\'':) . (++ "'") . escapeStringToSqlExpr
stringTermsSQL :: String -> DList StringSQL
stringTermsSQL = pure . stringExprSQL
instance ShowConstantTermsSQL ()
instance ShowConstantTermsSQL Int8 where
showConstantTermsSQL' = intTermsSQL
instance ShowConstantTermsSQL Int16 where
showConstantTermsSQL' = intTermsSQL
instance ShowConstantTermsSQL Int32 where
showConstantTermsSQL' = intTermsSQL
instance ShowConstantTermsSQL Int64 where
showConstantTermsSQL' = intTermsSQL
instance ShowConstantTermsSQL Int 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' = stringTermsSQL . LT.unpack . LT.decodeUtf8
instance ShowConstantTermsSQL Text where
showConstantTermsSQL' = stringTermsSQL . T.unpack
instance ShowConstantTermsSQL LT.Text where
showConstantTermsSQL' = stringTermsSQL . LT.unpack
instance ShowConstantTermsSQL Char where
showConstantTermsSQL' = stringTermsSQL . (:"")
instance ShowConstantTermsSQL Bool where
showConstantTermsSQL' = pure . boolSQL
floatTerms :: (PrintfArg a, Ord a, Num a)=> a -> DList StringSQL
floatTerms f = pure . stringSQL $ 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 -> DList StringSQL
constantTimeTerms kw fmt t = pure $ 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"
instance ShowConstantTermsSQL ZonedTime where
showConstantTermsSQL' = constantTimeTerms TIMESTAMPTZ "%Y-%m-%d %H:%M:%S%z"
instance ShowConstantTermsSQL UTCTime where
showConstantTermsSQL' = constantTimeTerms TIMESTAMPTZ "%Y-%m-%d %H:%M:%S%z"
showMaybeTerms :: ShowConstantTermsSQL a => PersistableRecordWidth a -> Maybe a -> DList StringSQL
showMaybeTerms wa = d where
d (Just a) = showConstantTermsSQL' a
d Nothing = fromList . replicate (runPersistableRecordWidth wa) $ stringSQL "NULL"
instance (PersistableWidth a, ShowConstantTermsSQL a)
=> ShowConstantTermsSQL (Maybe a) where
showConstantTermsSQL' = showMaybeTerms persistableWidth