{-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables, FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances, DefaultSignatures, DeriveGeneric #-}
-- | Types representable as columns in Selda's subset of SQL.
module Database.Selda.SqlType
  ( SqlType (..), SqlEnum (..)
  , Lit (..), UUID, UUID', RowID, ID, SqlValue (..), SqlTypeRep (..)
  , invalidRowId, isInvalidRowId, toRowId, fromRowId
  , fromId, toId, invalidId, isInvalidId, untyped
  , compLit, litType
  , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat
  , typedUuid, untypedUuid
  ) where
import Control.Applicative ((<|>))
import Control.Exception (Exception (..), throw)
import Data.ByteString (ByteString, empty)
import qualified Data.ByteString.Lazy as BSL
import Data.Int (Int32, Int64)
import Data.Maybe (fromJust)
import Data.Proxy ( Proxy(..) )
import Data.Text (Text, pack, unpack)
import qualified Data.Text.Lazy as LazyText
import Data.Time
    ( defaultTimeLocale,
      parseTimeM,
      Day(ModifiedJulianDay),
      UTCTime(UTCTime),
      ParseTime,
      TimeOfDay(TimeOfDay) )
import Data.Typeable ( Typeable )
import Data.UUID.Types (UUID, toString, fromByteString, nil)
import GHC.Generics (Generic)

-- | Format string used to represent date and time when
--   representing timestamps as text.
--   If at all possible, use 'SqlUTCTime' instead.
sqlDateTimeFormat :: String
sqlDateTimeFormat :: String
sqlDateTimeFormat = String
"%F %H:%M:%S%Q%z"

-- | Format string used to represent date when
--   representing dates as text.
--   If at all possible, use 'SqlDate' instead.
sqlDateFormat :: String
sqlDateFormat :: String
sqlDateFormat = String
"%F"

-- | Format string used to represent time of day when
--   representing time as text.
--   If at all possible, use 'SqlTime' instead.
sqlTimeFormat :: String
sqlTimeFormat :: String
sqlTimeFormat = String
"%H:%M:%S%Q%z"

-- | Representation of an SQL type.
data SqlTypeRep
  = TText
  | TRowID
  | TInt64
  | TInt32
  | TFloat
  | TBool
  | TDateTime
  | TDate
  | TTime
  | TBlob
  | TUUID
  | TJSON
    deriving (Int -> SqlTypeRep -> ShowS
[SqlTypeRep] -> ShowS
SqlTypeRep -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SqlTypeRep] -> ShowS
$cshowList :: [SqlTypeRep] -> ShowS
show :: SqlTypeRep -> String
$cshow :: SqlTypeRep -> String
showsPrec :: Int -> SqlTypeRep -> ShowS
$cshowsPrec :: Int -> SqlTypeRep -> ShowS
Show, SqlTypeRep -> SqlTypeRep -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SqlTypeRep -> SqlTypeRep -> Bool
$c/= :: SqlTypeRep -> SqlTypeRep -> Bool
== :: SqlTypeRep -> SqlTypeRep -> Bool
$c== :: SqlTypeRep -> SqlTypeRep -> Bool
Eq, Eq SqlTypeRep
SqlTypeRep -> SqlTypeRep -> Bool
SqlTypeRep -> SqlTypeRep -> Ordering
SqlTypeRep -> SqlTypeRep -> SqlTypeRep
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SqlTypeRep -> SqlTypeRep -> SqlTypeRep
$cmin :: SqlTypeRep -> SqlTypeRep -> SqlTypeRep
max :: SqlTypeRep -> SqlTypeRep -> SqlTypeRep
$cmax :: SqlTypeRep -> SqlTypeRep -> SqlTypeRep
>= :: SqlTypeRep -> SqlTypeRep -> Bool
$c>= :: SqlTypeRep -> SqlTypeRep -> Bool
> :: SqlTypeRep -> SqlTypeRep -> Bool
$c> :: SqlTypeRep -> SqlTypeRep -> Bool
<= :: SqlTypeRep -> SqlTypeRep -> Bool
$c<= :: SqlTypeRep -> SqlTypeRep -> Bool
< :: SqlTypeRep -> SqlTypeRep -> Bool
$c< :: SqlTypeRep -> SqlTypeRep -> Bool
compare :: SqlTypeRep -> SqlTypeRep -> Ordering
$ccompare :: SqlTypeRep -> SqlTypeRep -> Ordering
Ord)

-- | Any datatype representable in (Selda's subset of) SQL.
class Typeable a => SqlType a where
  -- | Create a literal of this type.
  mkLit :: a -> Lit a
  default mkLit :: (Typeable a, SqlEnum a) => a -> Lit a
  mkLit = forall a b. SqlTypeRep -> Lit a -> Lit b
LCustom SqlTypeRep
TText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Lit Text
LText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SqlEnum a => a -> Text
toText

  -- | The SQL representation for this type.
  sqlType :: Proxy a -> SqlTypeRep
  sqlType Proxy a
_ = forall a. Lit a -> SqlTypeRep
litType (forall a. SqlType a => Lit a
defaultValue :: Lit a)

  -- | Convert an SqlValue into this type.
  fromSql :: SqlValue -> a
  default fromSql :: (Typeable a, SqlEnum a) => SqlValue -> a
  fromSql = forall a. SqlEnum a => Text -> a
fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SqlType a => SqlValue -> a
fromSql

  -- | Default value when using 'def' at this type.
  defaultValue :: Lit a
  default defaultValue :: (Typeable a, SqlEnum a) => Lit a
  defaultValue = forall a. SqlType a => a -> Lit a
mkLit (forall a. Bounded a => a
minBound :: a)

-- | Any type that's bounded, enumerable and has a text representation, and
--   thus representable as a Selda enumerable.
--
--   While it would be more efficient to store enumerables as integers, this
--   makes hand-rolled SQL touching the values inscrutable, and will break if
--   the user a) derives Enum and b) changes the order of their constructors.
--   Long-term, this should be implemented in PostgreSQL as a proper enum
--   anyway, which mostly renders the performance argument moot.
class (Typeable a, Bounded a, Enum a) => SqlEnum a where
  toText :: a -> Text
  fromText :: Text -> a

instance {-# OVERLAPPABLE #-}
    (Typeable a, Bounded a, Enum a, Show a, Read a) => SqlEnum a where
  toText :: a -> Text
toText = String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
  fromText :: Text -> a
fromText = forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack

-- | An SQL literal.
data Lit a where
  LText     :: !Text       -> Lit Text
  LInt32    :: !Int32      -> Lit Int32
  LInt64    :: !Int64      -> Lit Int64
  LDouble   :: !Double     -> Lit Double
  LBool     :: !Bool       -> Lit Bool
  LDateTime :: !UTCTime    -> Lit UTCTime
  LDate     :: !Day        -> Lit Day
  LTime     :: !TimeOfDay  -> Lit TimeOfDay
  LJust     :: SqlType a => !(Lit a) -> Lit (Maybe a)
  LBlob     :: !ByteString -> Lit ByteString
  LNull     :: SqlType a => Lit (Maybe a)
  LCustom   :: SqlTypeRep  -> Lit a -> Lit b
  LUUID     :: !UUID       -> Lit UUID

-- | The SQL type representation for the given literal.
litType :: Lit a -> SqlTypeRep
litType :: forall a. Lit a -> SqlTypeRep
litType (LText{})     = SqlTypeRep
TText
litType (LInt32{})    = SqlTypeRep
TInt32
litType (LInt64{})    = SqlTypeRep
TInt64
litType (LDouble{})   = SqlTypeRep
TFloat
litType (LBool{})     = SqlTypeRep
TBool
litType (LDateTime{}) = SqlTypeRep
TDateTime
litType (LDate{})     = SqlTypeRep
TDate
litType (LTime{})     = SqlTypeRep
TTime
litType (LJust Lit a
x)     = forall a. Lit a -> SqlTypeRep
litType Lit a
x
litType (LBlob{})     = SqlTypeRep
TBlob
litType (x :: Lit a
x@Lit a
LNull)     = forall a. SqlType a => Proxy a -> SqlTypeRep
sqlType (forall a. Lit (Maybe a) -> Proxy a
proxyFor Lit a
x)
  where
    proxyFor :: Lit (Maybe a) -> Proxy a
    proxyFor :: forall a. Lit (Maybe a) -> Proxy a
proxyFor Lit (Maybe a)
_ = forall {k} (t :: k). Proxy t
Proxy
litType (LCustom SqlTypeRep
t Lit a
_) = SqlTypeRep
t
litType (LUUID{})     = SqlTypeRep
TUUID

instance Eq (Lit a) where
  Lit a
a == :: Lit a -> Lit a -> Bool
== Lit a
b = forall a b. Lit a -> Lit b -> Ordering
compLit Lit a
a Lit a
b forall a. Eq a => a -> a -> Bool
== Ordering
EQ

instance Ord (Lit a) where
  compare :: Lit a -> Lit a -> Ordering
compare = forall a b. Lit a -> Lit b -> Ordering
compLit

-- | Constructor tag for all literals. Used for Ord instance.
litConTag :: Lit a -> Int
litConTag :: forall a. Lit a -> Int
litConTag (LText{})     = Int
0
litConTag (LInt32{})    = Int
2
litConTag (LInt64{})    = Int
3
litConTag (LDouble{})   = Int
4
litConTag (LBool{})     = Int
5
litConTag (LDateTime{}) = Int
6
litConTag (LDate{})     = Int
7
litConTag (LTime{})     = Int
8
litConTag (LJust{})     = Int
9
litConTag (LBlob{})     = Int
10
litConTag (Lit a
LNull)       = Int
11
litConTag (LCustom{})   = Int
12
litConTag (LUUID{})     = Int
13

-- | Compare two literals of different type for equality.
compLit :: Lit a -> Lit b -> Ordering
compLit :: forall a b. Lit a -> Lit b -> Ordering
compLit (LText Text
x)     (LText Text
x')     = Text
x forall a. Ord a => a -> a -> Ordering
`compare` Text
x'
compLit (LInt32 Int32
x)    (LInt32 Int32
x')    = Int32
x forall a. Ord a => a -> a -> Ordering
`compare` Int32
x'
compLit (LInt64 Int64
x)    (LInt64 Int64
x')    = Int64
x forall a. Ord a => a -> a -> Ordering
`compare` Int64
x'
compLit (LDouble Double
x)   (LDouble Double
x')   = Double
x forall a. Ord a => a -> a -> Ordering
`compare` Double
x'
compLit (LBool Bool
x)     (LBool Bool
x')     = Bool
x forall a. Ord a => a -> a -> Ordering
`compare` Bool
x'
compLit (LDateTime UTCTime
x) (LDateTime UTCTime
x') = UTCTime
x forall a. Ord a => a -> a -> Ordering
`compare` UTCTime
x'
compLit (LDate Day
x)     (LDate Day
x')     = Day
x forall a. Ord a => a -> a -> Ordering
`compare` Day
x'
compLit (LTime TimeOfDay
x)     (LTime TimeOfDay
x')     = TimeOfDay
x forall a. Ord a => a -> a -> Ordering
`compare` TimeOfDay
x'
compLit (LBlob ByteString
x)     (LBlob ByteString
x')     = ByteString
x forall a. Ord a => a -> a -> Ordering
`compare` ByteString
x'
compLit (LJust Lit a
x)     (LJust Lit a
x')     = Lit a
x forall a b. Lit a -> Lit b -> Ordering
`compLit` Lit a
x'
compLit (LCustom SqlTypeRep
_ Lit a
x) (LCustom SqlTypeRep
_ Lit a
x') = Lit a
x forall a b. Lit a -> Lit b -> Ordering
`compLit` Lit a
x'
compLit (LUUID UUID
x)     (LUUID UUID
x')     = UUID
x forall a. Ord a => a -> a -> Ordering
`compare` UUID
x'
compLit Lit a
a             Lit b
b              = forall a. Lit a -> Int
litConTag Lit a
a forall a. Ord a => a -> a -> Ordering
`compare` forall a. Lit a -> Int
litConTag Lit b
b

-- | Some value that is representable in SQL.
data SqlValue where
  SqlInt32   :: !Int32      -> SqlValue
  SqlInt64   :: !Int64      -> SqlValue
  SqlFloat   :: !Double     -> SqlValue
  SqlString  :: !Text       -> SqlValue
  SqlBool    :: !Bool       -> SqlValue
  SqlBlob    :: !ByteString -> SqlValue
  SqlUTCTime :: !UTCTime    -> SqlValue
  SqlTime    :: !TimeOfDay  -> SqlValue
  SqlDate    :: !Day        -> SqlValue
  SqlNull    :: SqlValue

instance Show SqlValue where
  show :: SqlValue -> String
show (SqlInt32 Int32
n)   = String
"SqlInt32 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int32
n
  show (SqlInt64 Int64
n)   = String
"SqlInt64 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int64
n
  show (SqlFloat Double
f)   = String
"SqlFloat " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Double
f
  show (SqlString Text
s)  = String
"SqlString " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
s
  show (SqlBool Bool
b)    = String
"SqlBool " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Bool
b
  show (SqlBlob ByteString
b)    = String
"SqlBlob " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ByteString
b
  show (SqlUTCTime UTCTime
t) = String
"SqlUTCTime " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show UTCTime
t
  show (SqlTime TimeOfDay
t)    = String
"SqlTime " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TimeOfDay
t
  show (SqlDate Day
d)    = String
"SqlDate " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Day
d
  show (SqlValue
SqlNull)      = String
"SqlNull"

instance Show (Lit a) where
  show :: Lit a -> String
show (LText Text
s)     = forall a. Show a => a -> String
show Text
s
  show (LInt32 Int32
i)    = forall a. Show a => a -> String
show Int32
i
  show (LInt64 Int64
i)    = forall a. Show a => a -> String
show Int64
i
  show (LDouble Double
d)   = forall a. Show a => a -> String
show Double
d
  show (LBool Bool
b)     = forall a. Show a => a -> String
show Bool
b
  show (LDateTime UTCTime
s) = forall a. Show a => a -> String
show UTCTime
s
  show (LDate Day
s)     = forall a. Show a => a -> String
show Day
s
  show (LTime TimeOfDay
s)     = forall a. Show a => a -> String
show TimeOfDay
s
  show (LBlob ByteString
b)     = forall a. Show a => a -> String
show ByteString
b
  show (LJust Lit a
x)     = String
"Just " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Lit a
x
  show (Lit a
LNull)       = String
"Nothing"
  show (LCustom SqlTypeRep
_ Lit a
l) = forall a. Show a => a -> String
show Lit a
l
  show (LUUID UUID
u)     = UUID -> String
toString UUID
u

-- | A row identifier for some table.
--   This is the type of auto-incrementing primary keys.
newtype RowID = RowID Int64
  deriving (RowID -> RowID -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RowID -> RowID -> Bool
$c/= :: RowID -> RowID -> Bool
== :: RowID -> RowID -> Bool
$c== :: RowID -> RowID -> Bool
Eq, Eq RowID
RowID -> RowID -> Bool
RowID -> RowID -> Ordering
RowID -> RowID -> RowID
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RowID -> RowID -> RowID
$cmin :: RowID -> RowID -> RowID
max :: RowID -> RowID -> RowID
$cmax :: RowID -> RowID -> RowID
>= :: RowID -> RowID -> Bool
$c>= :: RowID -> RowID -> Bool
> :: RowID -> RowID -> Bool
$c> :: RowID -> RowID -> Bool
<= :: RowID -> RowID -> Bool
$c<= :: RowID -> RowID -> Bool
< :: RowID -> RowID -> Bool
$c< :: RowID -> RowID -> Bool
compare :: RowID -> RowID -> Ordering
$ccompare :: RowID -> RowID -> Ordering
Ord, Typeable, forall x. Rep RowID x -> RowID
forall x. RowID -> Rep RowID x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RowID x -> RowID
$cfrom :: forall x. RowID -> Rep RowID x
Generic)
instance Show RowID where
  show :: RowID -> String
show (RowID Int64
n) = forall a. Show a => a -> String
show Int64
n

-- | A row identifier which is guaranteed to not match any row in any table.
invalidRowId :: RowID
invalidRowId :: RowID
invalidRowId = Int64 -> RowID
RowID (-Int64
1)

-- | Is the given row identifier invalid? I.e. is it guaranteed to not match any
--   row in any table?
isInvalidRowId :: RowID -> Bool
isInvalidRowId :: RowID -> Bool
isInvalidRowId (RowID Int64
n) = Int64
n forall a. Ord a => a -> a -> Bool
< Int64
0

-- | Create a row identifier from an integer.
--   Use with caution, preferably only when reading user input.
toRowId :: Int64 -> RowID
toRowId :: Int64 -> RowID
toRowId = Int64 -> RowID
RowID

-- | Inspect a row identifier.
fromRowId :: RowID -> Int64
fromRowId :: RowID -> Int64
fromRowId (RowID Int64
n) = Int64
n

-- | A typed row identifier.
--   Generic tables should use this instead of 'RowID'.
--   Use 'untyped' to erase the type of a row identifier, and @cast@ from the
--   "Database.Selda.Unsafe" module if you for some reason need to add a type
--   to a row identifier.
newtype ID a = ID {forall a. ID a -> RowID
untyped :: RowID}
  deriving (ID a -> ID a -> Bool
forall a. ID a -> ID a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ID a -> ID a -> Bool
$c/= :: forall a. ID a -> ID a -> Bool
== :: ID a -> ID a -> Bool
$c== :: forall a. ID a -> ID a -> Bool
Eq, ID a -> ID a -> Bool
ID a -> ID a -> Ordering
ID a -> ID a -> ID a
forall a. Eq (ID a)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. ID a -> ID a -> Bool
forall a. ID a -> ID a -> Ordering
forall a. ID a -> ID a -> ID a
min :: ID a -> ID a -> ID a
$cmin :: forall a. ID a -> ID a -> ID a
max :: ID a -> ID a -> ID a
$cmax :: forall a. ID a -> ID a -> ID a
>= :: ID a -> ID a -> Bool
$c>= :: forall a. ID a -> ID a -> Bool
> :: ID a -> ID a -> Bool
$c> :: forall a. ID a -> ID a -> Bool
<= :: ID a -> ID a -> Bool
$c<= :: forall a. ID a -> ID a -> Bool
< :: ID a -> ID a -> Bool
$c< :: forall a. ID a -> ID a -> Bool
compare :: ID a -> ID a -> Ordering
$ccompare :: forall a. ID a -> ID a -> Ordering
Ord, Typeable, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ID a) x -> ID a
forall a x. ID a -> Rep (ID a) x
$cto :: forall a x. Rep (ID a) x -> ID a
$cfrom :: forall a x. ID a -> Rep (ID a) x
Generic)
instance Show (ID a) where
  show :: ID a -> String
show = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ID a -> RowID
untyped

-- | An UUID identifying a database row.
newtype UUID' a = UUID { forall a. UUID' a -> UUID
untypedUuid :: UUID }
  deriving (UUID' a -> UUID' a -> Bool
forall a. UUID' a -> UUID' a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UUID' a -> UUID' a -> Bool
$c/= :: forall a. UUID' a -> UUID' a -> Bool
== :: UUID' a -> UUID' a -> Bool
$c== :: forall a. UUID' a -> UUID' a -> Bool
Eq, UUID' a -> UUID' a -> Bool
UUID' a -> UUID' a -> Ordering
UUID' a -> UUID' a -> UUID' a
forall a. Eq (UUID' a)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. UUID' a -> UUID' a -> Bool
forall a. UUID' a -> UUID' a -> Ordering
forall a. UUID' a -> UUID' a -> UUID' a
min :: UUID' a -> UUID' a -> UUID' a
$cmin :: forall a. UUID' a -> UUID' a -> UUID' a
max :: UUID' a -> UUID' a -> UUID' a
$cmax :: forall a. UUID' a -> UUID' a -> UUID' a
>= :: UUID' a -> UUID' a -> Bool
$c>= :: forall a. UUID' a -> UUID' a -> Bool
> :: UUID' a -> UUID' a -> Bool
$c> :: forall a. UUID' a -> UUID' a -> Bool
<= :: UUID' a -> UUID' a -> Bool
$c<= :: forall a. UUID' a -> UUID' a -> Bool
< :: UUID' a -> UUID' a -> Bool
$c< :: forall a. UUID' a -> UUID' a -> Bool
compare :: UUID' a -> UUID' a -> Ordering
$ccompare :: forall a. UUID' a -> UUID' a -> Ordering
Ord, Typeable, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (UUID' a) x -> UUID' a
forall a x. UUID' a -> Rep (UUID' a) x
$cto :: forall a x. Rep (UUID' a) x -> UUID' a
$cfrom :: forall a x. UUID' a -> Rep (UUID' a) x
Generic)
instance Show (UUID' a) where
  show :: UUID' a -> String
show = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. UUID' a -> UUID
untypedUuid

-- | Convert an untyped UUID to a typed one.
--   Use sparingly, preferably only during deserialization.
typedUuid :: UUID -> UUID' a
typedUuid :: forall a. UUID -> UUID' a
typedUuid = forall a. UUID -> UUID' a
UUID

-- | Create a typed row identifier from an integer.
--   Use with caution, preferably only when reading user input.
toId :: Int64 -> ID a
toId :: forall a. Int64 -> ID a
toId = forall a. RowID -> ID a
ID forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> RowID
toRowId

-- | Create a typed row identifier from an integer.
--   Use with caution, preferably only when reading user input.
fromId :: ID a -> Int64
fromId :: forall a. ID a -> Int64
fromId (ID RowID
i) = RowID -> Int64
fromRowId RowID
i

-- | A typed row identifier which is guaranteed to not match any row in any
--   table.
invalidId :: ID a
invalidId :: forall a. ID a
invalidId = forall a. RowID -> ID a
ID RowID
invalidRowId

-- | Is the given typed row identifier invalid? I.e. is it guaranteed to not
--   match any row in any table?
isInvalidId :: ID a -> Bool
isInvalidId :: forall a. ID a -> Bool
isInvalidId = RowID -> Bool
isInvalidRowId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ID a -> RowID
untyped

fromSqlError :: String -> a
fromSqlError :: forall a. String -> a
fromSqlError = forall a e. Exception e => e -> a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FromSqlError
FromSqlError

newtype FromSqlError = FromSqlError String
instance Show FromSqlError where
  show :: FromSqlError -> String
show (FromSqlError String
e) = String
"[SELDA BUG] fromSql: " forall a. [a] -> [a] -> [a]
++ String
e
instance Exception FromSqlError

instance SqlType RowID where
  mkLit :: RowID -> Lit RowID
mkLit (RowID Int64
n) = forall a b. SqlTypeRep -> Lit a -> Lit b
LCustom SqlTypeRep
TRowID (Int64 -> Lit Int64
LInt64 Int64
n)
  sqlType :: Proxy RowID -> SqlTypeRep
sqlType Proxy RowID
_ = SqlTypeRep
TRowID
  fromSql :: SqlValue -> RowID
fromSql (SqlInt64 Int64
x) = Int64 -> RowID
RowID Int64
x
  fromSql SqlValue
v          = forall a. String -> a
fromSqlError forall a b. (a -> b) -> a -> b
$ String
"RowID column with non-int value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SqlValue
v
  defaultValue :: Lit RowID
defaultValue = forall a. SqlType a => a -> Lit a
mkLit RowID
invalidRowId

instance Typeable a => SqlType (ID a) where
  mkLit :: ID a -> Lit (ID a)
mkLit (ID RowID
n) = forall a b. SqlTypeRep -> Lit a -> Lit b
LCustom SqlTypeRep
TRowID (forall a. SqlType a => a -> Lit a
mkLit RowID
n)
  sqlType :: Proxy (ID a) -> SqlTypeRep
sqlType Proxy (ID a)
_ = SqlTypeRep
TRowID
  fromSql :: SqlValue -> ID a
fromSql = forall a. RowID -> ID a
ID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SqlType a => SqlValue -> a
fromSql
  defaultValue :: Lit (ID a)
defaultValue = forall a. SqlType a => a -> Lit a
mkLit (forall a. RowID -> ID a
ID RowID
invalidRowId)

instance SqlType Int where
  mkLit :: Int -> Lit Int
mkLit Int
n = forall a b. SqlTypeRep -> Lit a -> Lit b
LCustom SqlTypeRep
TInt64 (Int64 -> Lit Int64
LInt64 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
  sqlType :: Proxy Int -> SqlTypeRep
sqlType Proxy Int
_ = SqlTypeRep
TInt64
  fromSql :: SqlValue -> Int
fromSql (SqlInt64 Int64
x) = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
x
  fromSql SqlValue
v            = forall a. String -> a
fromSqlError forall a b. (a -> b) -> a -> b
$ String
"int column with non-int value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SqlValue
v
  defaultValue :: Lit Int
defaultValue = forall a. SqlType a => a -> Lit a
mkLit (Int
0 :: Int)

instance SqlType Int64 where
  mkLit :: Int64 -> Lit Int64
mkLit = Int64 -> Lit Int64
LInt64
  sqlType :: Proxy Int64 -> SqlTypeRep
sqlType Proxy Int64
_ = SqlTypeRep
TInt64
  fromSql :: SqlValue -> Int64
fromSql (SqlInt64 Int64
x) = Int64
x
  fromSql SqlValue
v          = forall a. String -> a
fromSqlError forall a b. (a -> b) -> a -> b
$ String
"int64 column with non-int value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SqlValue
v
  defaultValue :: Lit Int64
defaultValue = Int64 -> Lit Int64
LInt64 Int64
0

instance SqlType Int32 where
  mkLit :: Int32 -> Lit Int32
mkLit = Int32 -> Lit Int32
LInt32
  sqlType :: Proxy Int32 -> SqlTypeRep
sqlType Proxy Int32
_ = SqlTypeRep
TInt32
  fromSql :: SqlValue -> Int32
fromSql (SqlInt32 Int32
x) = Int32
x
  fromSql SqlValue
v          = forall a. String -> a
fromSqlError forall a b. (a -> b) -> a -> b
$ String
"int32 column with non-int value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SqlValue
v
  defaultValue :: Lit Int32
defaultValue = Int32 -> Lit Int32
LInt32 Int32
0

instance SqlType Double where
  mkLit :: Double -> Lit Double
mkLit = Double -> Lit Double
LDouble
  sqlType :: Proxy Double -> SqlTypeRep
sqlType Proxy Double
_ = SqlTypeRep
TFloat
  fromSql :: SqlValue -> Double
fromSql (SqlFloat Double
x) = Double
x
  fromSql SqlValue
v            = forall a. String -> a
fromSqlError forall a b. (a -> b) -> a -> b
$ String
"float column with non-float value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SqlValue
v
  defaultValue :: Lit Double
defaultValue = Double -> Lit Double
LDouble Double
0

instance SqlType Text where
  mkLit :: Text -> Lit Text
mkLit = Text -> Lit Text
LText
  sqlType :: Proxy Text -> SqlTypeRep
sqlType Proxy Text
_ = SqlTypeRep
TText
  fromSql :: SqlValue -> Text
fromSql (SqlString Text
x) = Text
x
  fromSql SqlValue
v             = forall a. String -> a
fromSqlError forall a b. (a -> b) -> a -> b
$ String
"text column with non-text value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SqlValue
v
  defaultValue :: Lit Text
defaultValue = Text -> Lit Text
LText Text
""

instance SqlType LazyText.Text where
  mkLit :: Text -> Lit Text
mkLit = forall a b. SqlTypeRep -> Lit a -> Lit b
LCustom SqlTypeRep
TText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Lit Text
LText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
LazyText.toChunks
  sqlType :: Proxy Text -> SqlTypeRep
sqlType Proxy Text
_ = SqlTypeRep
TText
  fromSql :: SqlValue -> Text
fromSql (SqlString Text
x) = [Text] -> Text
LazyText.fromChunks [Text
x]
  fromSql SqlValue
v             = forall a. String -> a
fromSqlError forall a b. (a -> b) -> a -> b
$ String
"lazy text column with non-text value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SqlValue
v
  defaultValue :: Lit Text
defaultValue = forall a. SqlType a => a -> Lit a
mkLit Text
""

instance SqlType Bool where
  mkLit :: Bool -> Lit Bool
mkLit = Bool -> Lit Bool
LBool
  sqlType :: Proxy Bool -> SqlTypeRep
sqlType Proxy Bool
_ = SqlTypeRep
TBool
  fromSql :: SqlValue -> Bool
fromSql (SqlBool Bool
x)  = Bool
x
  fromSql (SqlInt32 Int32
0) = Bool
False
  fromSql (SqlInt32 Int32
_) = Bool
True
  fromSql (SqlInt64 Int64
0) = Bool
False
  fromSql (SqlInt64 Int64
_) = Bool
True
  fromSql SqlValue
v            = forall a. String -> a
fromSqlError forall a b. (a -> b) -> a -> b
$ String
"bool column with non-bool value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SqlValue
v
  defaultValue :: Lit Bool
defaultValue = Bool -> Lit Bool
LBool Bool
False

instance SqlType UTCTime where
  mkLit :: UTCTime -> Lit UTCTime
mkLit = UTCTime -> Lit UTCTime
LDateTime
  sqlType :: Proxy UTCTime -> SqlTypeRep
sqlType Proxy UTCTime
_ = SqlTypeRep
TDateTime
  fromSql :: SqlValue -> UTCTime
fromSql (SqlUTCTime UTCTime
t) = UTCTime
t
  fromSql (SqlString Text
s) =
    case forall t. ParseTime t => String -> String -> Maybe t
withWeirdTimeZone String
sqlDateTimeFormat (Text -> String
unpack Text
s) of
      Just UTCTime
t -> UTCTime
t
      Maybe UTCTime
_      -> forall a. String -> a
fromSqlError forall a b. (a -> b) -> a -> b
$ String
"bad datetime string: " forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
s
  fromSql SqlValue
v = forall a. String -> a
fromSqlError forall a b. (a -> b) -> a -> b
$ String
"datetime column with non-datetime value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SqlValue
v
  defaultValue :: Lit UTCTime
defaultValue = UTCTime -> Lit UTCTime
LDateTime forall a b. (a -> b) -> a -> b
$ Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
40587) DiffTime
0

instance SqlType Day where
  mkLit :: Day -> Lit Day
mkLit = Day -> Lit Day
LDate
  sqlType :: Proxy Day -> SqlTypeRep
sqlType Proxy Day
_ = SqlTypeRep
TDate
  fromSql :: SqlValue -> Day
fromSql (SqlDate Day
d) = Day
d
  fromSql (SqlString Text
s) =
    case forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
sqlDateFormat (Text -> String
unpack Text
s) of
      Just Day
t -> Day
t
      Maybe Day
_      -> forall a. String -> a
fromSqlError forall a b. (a -> b) -> a -> b
$ String
"bad date string: " forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
s
  fromSql SqlValue
v = forall a. String -> a
fromSqlError forall a b. (a -> b) -> a -> b
$ String
"date column with non-date value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SqlValue
v
  defaultValue :: Lit Day
defaultValue = Day -> Lit Day
LDate forall a b. (a -> b) -> a -> b
$ Integer -> Day
ModifiedJulianDay Integer
40587

instance SqlType TimeOfDay where
  mkLit :: TimeOfDay -> Lit TimeOfDay
mkLit = TimeOfDay -> Lit TimeOfDay
LTime
  sqlType :: Proxy TimeOfDay -> SqlTypeRep
sqlType Proxy TimeOfDay
_ = SqlTypeRep
TTime
  fromSql :: SqlValue -> TimeOfDay
fromSql (SqlTime TimeOfDay
s) = TimeOfDay
s
  fromSql (SqlString Text
s) =
    case forall t. ParseTime t => String -> String -> Maybe t
withWeirdTimeZone String
sqlTimeFormat (Text -> String
unpack Text
s) of
      Just TimeOfDay
t -> TimeOfDay
t
      Maybe TimeOfDay
_      -> forall a. String -> a
fromSqlError forall a b. (a -> b) -> a -> b
$ String
"bad time string: " forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
s
  fromSql SqlValue
v = forall a. String -> a
fromSqlError forall a b. (a -> b) -> a -> b
$ String
"time column with non-time value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SqlValue
v
  defaultValue :: Lit TimeOfDay
defaultValue = TimeOfDay -> Lit TimeOfDay
LTime forall a b. (a -> b) -> a -> b
$ Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
0 Int
0 Pico
0

-- | Both PostgreSQL and SQLite to weird things with time zones.
--   Long term solution is to use proper binary types internally for
--   time values, so this is really just an interim solution.
withWeirdTimeZone :: ParseTime t => String -> String -> Maybe t
withWeirdTimeZone :: forall t. ParseTime t => String -> String -> Maybe t
withWeirdTimeZone String
fmt String
s =
  forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
fmt (String
sforall a. [a] -> [a] -> [a]
++String
"00")
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
fmt String
s
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
fmt (String
sforall a. [a] -> [a] -> [a]
++String
"+0000")

instance SqlType ByteString where
  mkLit :: ByteString -> Lit ByteString
mkLit = ByteString -> Lit ByteString
LBlob
  sqlType :: Proxy ByteString -> SqlTypeRep
sqlType Proxy ByteString
_ = SqlTypeRep
TBlob
  fromSql :: SqlValue -> ByteString
fromSql (SqlBlob ByteString
x) = ByteString
x
  fromSql SqlValue
v           = forall a. String -> a
fromSqlError forall a b. (a -> b) -> a -> b
$ String
"blob column with non-blob value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SqlValue
v
  defaultValue :: Lit ByteString
defaultValue = ByteString -> Lit ByteString
LBlob ByteString
empty

instance SqlType BSL.ByteString where
  mkLit :: ByteString -> Lit ByteString
mkLit = forall a b. SqlTypeRep -> Lit a -> Lit b
LCustom SqlTypeRep
TBlob forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Lit ByteString
LBlob forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict
  sqlType :: Proxy ByteString -> SqlTypeRep
sqlType Proxy ByteString
_ = SqlTypeRep
TBlob
  fromSql :: SqlValue -> ByteString
fromSql (SqlBlob ByteString
x) = ByteString -> ByteString
BSL.fromStrict ByteString
x
  fromSql SqlValue
v           = forall a. String -> a
fromSqlError forall a b. (a -> b) -> a -> b
$ String
"blob column with non-blob value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SqlValue
v
  defaultValue :: Lit ByteString
defaultValue = forall a b. SqlTypeRep -> Lit a -> Lit b
LCustom SqlTypeRep
TBlob (ByteString -> Lit ByteString
LBlob ByteString
empty)

-- | @defaultValue@ for UUIDs is the all-zero RFC4122 nil UUID.
instance SqlType UUID where
  mkLit :: UUID -> Lit UUID
mkLit = UUID -> Lit UUID
LUUID
  sqlType :: Proxy UUID -> SqlTypeRep
sqlType Proxy UUID
_ = SqlTypeRep
TUUID
  fromSql :: SqlValue -> UUID
fromSql (SqlBlob ByteString
x) = forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe UUID
fromByteString forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.fromStrict ByteString
x
  fromSql SqlValue
v           = forall a. String -> a
fromSqlError forall a b. (a -> b) -> a -> b
$ String
"UUID column with non-blob value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SqlValue
v
  defaultValue :: Lit UUID
defaultValue = UUID -> Lit UUID
LUUID UUID
nil

-- | @defaultValue@ for UUIDs is the all-zero RFC4122 nil UUID.
instance Typeable a => SqlType (UUID' a) where
  mkLit :: UUID' a -> Lit (UUID' a)
mkLit = forall a b. SqlTypeRep -> Lit a -> Lit b
LCustom SqlTypeRep
TUUID forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> Lit UUID
LUUID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. UUID' a -> UUID
untypedUuid
  sqlType :: Proxy (UUID' a) -> SqlTypeRep
sqlType Proxy (UUID' a)
_ = SqlTypeRep
TUUID
  fromSql :: SqlValue -> UUID' a
fromSql = forall a. UUID -> UUID' a
typedUuid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SqlType a => SqlValue -> a
fromSql
  defaultValue :: Lit (UUID' a)
defaultValue = forall a b. SqlTypeRep -> Lit a -> Lit b
LCustom SqlTypeRep
TUUID (UUID -> Lit UUID
LUUID UUID
nil)

instance SqlType a => SqlType (Maybe a) where
  mkLit :: Maybe a -> Lit (Maybe a)
mkLit (Just a
x) = forall a. SqlType a => Lit a -> Lit (Maybe a)
LJust forall a b. (a -> b) -> a -> b
$ forall a. SqlType a => a -> Lit a
mkLit a
x
  mkLit Maybe a
Nothing  = forall a. SqlType a => Lit (Maybe a)
LNull
  sqlType :: Proxy (Maybe a) -> SqlTypeRep
sqlType Proxy (Maybe a)
_ = forall a. SqlType a => Proxy a -> SqlTypeRep
sqlType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
  fromSql :: SqlValue -> Maybe a
fromSql (SqlValue
SqlNull) = forall a. Maybe a
Nothing
  fromSql SqlValue
x         = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. SqlType a => SqlValue -> a
fromSql SqlValue
x
  defaultValue :: Lit (Maybe a)
defaultValue = forall a. SqlType a => Lit (Maybe a)
LNull

instance SqlType Ordering