{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances #-}

-- |
-- Module      : Database.Relational.Pure
-- Copyright   : 2013-2019 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module defines instances which lift from haskell pure values
-- to query internal record values.
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 (..))


-- | Constant SQL terms of '()'.
instance LiteralSQL ()

-- | Constant SQL terms of 'Int8'.
instance LiteralSQL Int8 where
  showLiteral' :: Int8 -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (Int8 -> StringSQL) -> Int8 -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> StringSQL
forall a. (Show a, Integral a) => a -> StringSQL
Lit.integral

-- | Constant SQL terms of 'Int16'.
instance LiteralSQL Int16 where
  showLiteral' :: Int16 -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (Int16 -> StringSQL) -> Int16 -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> StringSQL
forall a. (Show a, Integral a) => a -> StringSQL
Lit.integral

-- | Constant SQL terms of 'Int32'.
instance LiteralSQL Int32 where
  showLiteral' :: Int32 -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (Int32 -> StringSQL) -> Int32 -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> StringSQL
forall a. (Show a, Integral a) => a -> StringSQL
Lit.integral

-- | Constant SQL terms of 'Int64'.
instance LiteralSQL Int64 where
  showLiteral' :: Int64 -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (Int64 -> StringSQL) -> Int64 -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> StringSQL
forall a. (Show a, Integral a) => a -> StringSQL
Lit.integral

-- | Constant SQL terms of 'Int'.
--   Use this carefully, because this is architecture dependent size of integer type.
instance LiteralSQL Int where
  showLiteral' :: Int -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (Int -> StringSQL) -> Int -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> StringSQL
forall a. (Show a, Integral a) => a -> StringSQL
Lit.integral

-- | Constant SQL terms of 'Word8'.
instance LiteralSQL Word8 where
  showLiteral' :: Word8 -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (Word8 -> StringSQL) -> Word8 -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> StringSQL
forall a. (Show a, Integral a) => a -> StringSQL
Lit.integral

-- | Constant SQL terms of 'Word16'.
instance LiteralSQL Word16 where
  showLiteral' :: Word16 -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (Word16 -> StringSQL) -> Word16 -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> StringSQL
forall a. (Show a, Integral a) => a -> StringSQL
Lit.integral

-- | Constant SQL terms of 'Word32'.
instance LiteralSQL Word32 where
  showLiteral' :: Word32 -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (Word32 -> StringSQL) -> Word32 -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> StringSQL
forall a. (Show a, Integral a) => a -> StringSQL
Lit.integral

-- | Constant SQL terms of 'Word64'.
instance LiteralSQL Word64 where
  showLiteral' :: Word64 -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (Word64 -> StringSQL) -> Word64 -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> StringSQL
forall a. (Show a, Integral a) => a -> StringSQL
Lit.integral

-- | Constant SQL terms of 'Word'.
--   Use this carefully, because this is architecture dependent size of integer type.
instance LiteralSQL Word where
  showLiteral' :: Word -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (Word -> StringSQL) -> Word -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> StringSQL
forall a. (Show a, Integral a) => a -> StringSQL
Lit.integral

instance LiteralSQL Integer where
  showLiteral' :: Integer -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (Integer -> StringSQL) -> Integer -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> StringSQL
forall a. (Show a, Integral a) => a -> StringSQL
Lit.integral

-- | Constant SQL terms of 'String'.
instance LiteralSQL String where
  showLiteral' :: String -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (String -> StringSQL) -> String -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StringSQL
Lit.stringExpr

-- | Constant SQL terms of 'Text'.
instance LiteralSQL Text where
  showLiteral' :: Text -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (Text -> StringSQL) -> Text -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StringSQL
Lit.stringExpr (String -> StringSQL) -> (Text -> String) -> Text -> StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

-- | Constant SQL terms of 'LT.Text'.
instance LiteralSQL LT.Text where
  showLiteral' :: Text -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (Text -> StringSQL) -> Text -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StringSQL
Lit.stringExpr (String -> StringSQL) -> (Text -> String) -> Text -> StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
LT.unpack

-- | Constant SQL terms of 'Char'.
instance LiteralSQL Char where
  showLiteral' :: Char -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (Char -> StringSQL) -> Char -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StringSQL
Lit.stringExpr (String -> StringSQL) -> (Char -> String) -> Char -> StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> String
forall a. a -> [a] -> [a]
:String
"")

-- | Constant SQL terms of 'Bool'.
instance LiteralSQL Bool where
  showLiteral' :: Bool -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (Bool -> StringSQL) -> Bool -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> StringSQL
Lit.bool

floatTerms :: (PrintfArg a, Ord a, Num a)=> a -> DList StringSQL
floatTerms :: a -> DList StringSQL
floatTerms a
f = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (String -> StringSQL) -> String -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StringSQL
stringSQL (String -> DList StringSQL) -> String -> DList StringSQL
forall a b. (a -> b) -> a -> b
$ String -> a -> String
forall r. PrintfType r => String -> r
printf String
fmt a
f  where
  fmt :: String
fmt
    | a
f a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0    = String
"%f"
    | Bool
otherwise = String
"(%f)"

-- | Constant SQL terms of 'Float'. Caution for floating-point error rate.
instance LiteralSQL Float where
  showLiteral' :: Float -> DList StringSQL
showLiteral' = Float -> DList StringSQL
forall a. (PrintfArg a, Ord a, Num a) => a -> DList StringSQL
floatTerms

-- | Constant SQL terms of 'Double'. Caution for floating-point error rate.
instance LiteralSQL Double where
  showLiteral' :: Double -> DList StringSQL
showLiteral' = Double -> DList StringSQL
forall a. (PrintfArg a, Ord a, Num a) => a -> DList StringSQL
floatTerms

-- | Constant SQL terms of 'Day'.
instance LiteralSQL Day where
  showLiteral' :: Day -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (Day -> StringSQL) -> Day -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringSQL -> String -> Day -> StringSQL
forall t. FormatTime t => StringSQL -> String -> t -> StringSQL
Lit.timestamp StringSQL
DATE String
"%Y-%m-%d"

-- | Constant SQL terms of 'TimeOfDay'.
instance LiteralSQL TimeOfDay where
  showLiteral' :: TimeOfDay -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (TimeOfDay -> StringSQL) -> TimeOfDay -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringSQL -> String -> TimeOfDay -> StringSQL
forall t. FormatTime t => StringSQL -> String -> t -> StringSQL
Lit.timestamp StringSQL
TIME String
"%H:%M:%S"

-- | Constant SQL terms of 'LocalTime'.
instance LiteralSQL LocalTime where
  showLiteral' :: LocalTime -> DList StringSQL
showLiteral' = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL)
-> (LocalTime -> StringSQL) -> LocalTime -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringSQL -> String -> LocalTime -> StringSQL
forall t. FormatTime t => StringSQL -> String -> t -> StringSQL
Lit.timestamp StringSQL
TIMESTAMP String
"%Y-%m-%d %H:%M:%S"

showMaybeTerms :: LiteralSQL a => PersistableRecordWidth a -> Maybe a -> DList StringSQL
showMaybeTerms :: PersistableRecordWidth a -> Maybe a -> DList StringSQL
showMaybeTerms PersistableRecordWidth a
wa = Maybe a -> DList StringSQL
forall a. LiteralSQL a => Maybe a -> DList StringSQL
d  where
  d :: Maybe a -> DList StringSQL
d (Just a
a) = a -> DList StringSQL
forall a. LiteralSQL a => a -> DList StringSQL
showLiteral' a
a
  d Maybe a
Nothing  = [StringSQL] -> DList StringSQL
forall a. [a] -> DList a
fromList ([StringSQL] -> DList StringSQL)
-> (StringSQL -> [StringSQL]) -> StringSQL -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> StringSQL -> [StringSQL]
forall a. Int -> a -> [a]
replicate (PersistableRecordWidth a -> Int
forall a. PersistableRecordWidth a -> Int
runPersistableRecordWidth PersistableRecordWidth a
wa) (StringSQL -> DList StringSQL) -> StringSQL -> DList StringSQL
forall a b. (a -> b) -> a -> b
$ String -> StringSQL
stringSQL String
"NULL"

-- | Constant SQL terms of 'Maybe' type. Width inference is required.
instance (PersistableWidth a, LiteralSQL a)
         => LiteralSQL (Maybe a) where
  showLiteral' :: Maybe a -> DList StringSQL
showLiteral' = PersistableRecordWidth a -> Maybe a -> DList StringSQL
forall a.
LiteralSQL a =>
PersistableRecordWidth a -> Maybe a -> DList StringSQL
showMaybeTerms PersistableRecordWidth a
forall a. PersistableWidth a => PersistableRecordWidth a
persistableWidth