{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
module Database.Relational.Pure () where
import Control.Applicative (pure)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Word (Word8, Word16, Word32, Word64, Word)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Text.Printf (PrintfArg, printf)
import Data.Time (Day, TimeOfDay, LocalTime)
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)
import qualified Database.Relational.Internal.Literal as Lit
import Database.Relational.ProjectableClass (LiteralSQL (..))
instance LiteralSQL ()
instance LiteralSQL Int8 where
showLiteral' = pure . Lit.integral
instance LiteralSQL Int16 where
showLiteral' = pure . Lit.integral
instance LiteralSQL Int32 where
showLiteral' = pure . Lit.integral
instance LiteralSQL Int64 where
showLiteral' = pure . Lit.integral
instance LiteralSQL Int where
showLiteral' = pure . Lit.integral
instance LiteralSQL Word8 where
showLiteral' = pure . Lit.integral
instance LiteralSQL Word16 where
showLiteral' = pure . Lit.integral
instance LiteralSQL Word32 where
showLiteral' = pure . Lit.integral
instance LiteralSQL Word64 where
showLiteral' = pure . Lit.integral
instance LiteralSQL Word where
showLiteral' = pure . Lit.integral
instance LiteralSQL Integer where
showLiteral' = pure . Lit.integral
instance LiteralSQL String where
showLiteral' = pure . Lit.stringExpr
instance LiteralSQL Text where
showLiteral' = pure . Lit.stringExpr . T.unpack
instance LiteralSQL LT.Text where
showLiteral' = pure . Lit.stringExpr . LT.unpack
instance LiteralSQL Char where
showLiteral' = pure . Lit.stringExpr . (:"")
instance LiteralSQL Bool where
showLiteral' = pure . Lit.bool
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
instance LiteralSQL Day where
showLiteral' = pure . Lit.timestamp DATE "%Y-%m-%d"
instance LiteralSQL TimeOfDay where
showLiteral' = pure . Lit.timestamp TIME "%H:%M:%S"
instance LiteralSQL LocalTime where
showLiteral' = pure . Lit.timestamp TIMESTAMP "%Y-%m-%d %H:%M:%S"
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