{-# 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 (LiteralSQL (..))
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 LiteralSQL ()
instance LiteralSQL Int8 where
showLiteral' = intTermsSQL
instance LiteralSQL Int16 where
showLiteral' = intTermsSQL
instance LiteralSQL Int32 where
showLiteral' = intTermsSQL
instance LiteralSQL Int64 where
showLiteral' = intTermsSQL
instance LiteralSQL Int where
showLiteral' = intTermsSQL
instance LiteralSQL String where
showLiteral' = stringTermsSQL
instance LiteralSQL ByteString where
showLiteral' = stringTermsSQL . T.unpack . T.decodeUtf8
instance LiteralSQL LB.ByteString where
showLiteral' = stringTermsSQL . LT.unpack . LT.decodeUtf8
instance LiteralSQL Text where
showLiteral' = stringTermsSQL . T.unpack
instance LiteralSQL LT.Text where
showLiteral' = stringTermsSQL . LT.unpack
instance LiteralSQL Char where
showLiteral' = stringTermsSQL . (:"")
instance LiteralSQL Bool where
showLiteral' = 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 LiteralSQL Float where
showLiteral' = floatTerms
instance LiteralSQL Double where
showLiteral' = floatTerms
constantTimeTerms :: FormatTime t => Keyword -> String -> t -> DList StringSQL
constantTimeTerms kw fmt t = pure $ kw <> stringExprSQL (formatTime defaultTimeLocale fmt t)
instance LiteralSQL Day where
showLiteral' = constantTimeTerms DATE "%Y-%m-%d"
instance LiteralSQL TimeOfDay where
showLiteral' = constantTimeTerms TIME "%H:%M:%S"
instance LiteralSQL LocalTime where
showLiteral' = constantTimeTerms TIMESTAMP "%Y-%m-%d %H:%M:%S"
instance LiteralSQL ZonedTime where
showLiteral' = constantTimeTerms TIMESTAMPTZ "%Y-%m-%d %H:%M:%S%z"
instance LiteralSQL UTCTime where
showLiteral' = constantTimeTerms TIMESTAMPTZ "%Y-%m-%d %H:%M:%S%z"
showMaybeTerms :: LiteralSQL a => PersistableRecordWidth a -> Maybe a -> DList StringSQL
showMaybeTerms wa = d where
d (Just a) = showLiteral' a
d Nothing = fromList . replicate (runPersistableRecordWidth wa) $ stringSQL "NULL"
instance (PersistableWidth a, LiteralSQL a)
=> LiteralSQL (Maybe a) where
showLiteral' = showMaybeTerms persistableWidth