{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.Schema (
    -- * Synopsis
    -- | Typed database tables and rows.

    -- * Database columns
      IsCol (..), SqlColType (..)
    , toColType
    , Primary (..)

    -- * Database rows and tables
    , Table (..), Col (..), (:.) (..)
    , IsRow (..)

    -- * SQL Queries
    , Query, callSql, runSql
    , createTable, selectAll, insertOne, repsertOne, updateOne, deleteAll, deleteOne

    -- * Testing
    , testPerson
    ) where

import Prelude

import Control.Monad.IO.Class
    ( MonadIO )
import Data.Proxy
    ( Proxy (..) )
import Data.Text
    ( Text )
import Database.Persist
    ( PersistField (..), PersistValue )
import Database.Persist.Sql
    ( PersistFieldSql (..), RawSql (..), SqlPersistT, SqlType (..) )
import GHC.TypeLits
    ( KnownSymbol, Symbol, symbolVal )

import qualified Data.Text as T
import qualified Database.Persist.Sql as Persist

{-------------------------------------------------------------------------------
    Types for database columns
-------------------------------------------------------------------------------}
-- | Primary key.
newtype Primary = Primary { Primary -> Int
getPrimary :: Int }
    deriving (Primary -> Primary -> Bool
(Primary -> Primary -> Bool)
-> (Primary -> Primary -> Bool) -> Eq Primary
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Primary -> Primary -> Bool
$c/= :: Primary -> Primary -> Bool
== :: Primary -> Primary -> Bool
$c== :: Primary -> Primary -> Bool
Eq,Eq Primary
Eq Primary
-> (Primary -> Primary -> Ordering)
-> (Primary -> Primary -> Bool)
-> (Primary -> Primary -> Bool)
-> (Primary -> Primary -> Bool)
-> (Primary -> Primary -> Bool)
-> (Primary -> Primary -> Primary)
-> (Primary -> Primary -> Primary)
-> Ord Primary
Primary -> Primary -> Bool
Primary -> Primary -> Ordering
Primary -> Primary -> Primary
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 :: Primary -> Primary -> Primary
$cmin :: Primary -> Primary -> Primary
max :: Primary -> Primary -> Primary
$cmax :: Primary -> Primary -> Primary
>= :: Primary -> Primary -> Bool
$c>= :: Primary -> Primary -> Bool
> :: Primary -> Primary -> Bool
$c> :: Primary -> Primary -> Bool
<= :: Primary -> Primary -> Bool
$c<= :: Primary -> Primary -> Bool
< :: Primary -> Primary -> Bool
$c< :: Primary -> Primary -> Bool
compare :: Primary -> Primary -> Ordering
$ccompare :: Primary -> Primary -> Ordering
$cp1Ord :: Eq Primary
Ord,Int -> Primary -> ShowS
[Primary] -> ShowS
Primary -> String
(Int -> Primary -> ShowS)
-> (Primary -> String) -> ([Primary] -> ShowS) -> Show Primary
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Primary] -> ShowS
$cshowList :: [Primary] -> ShowS
show :: Primary -> String
$cshow :: Primary -> String
showsPrec :: Int -> Primary -> ShowS
$cshowsPrec :: Int -> Primary -> ShowS
Show)

-- | SQL column types, including constraints.
-- Values of type 'SqlColType' represent SQL types such as
--
-- > INTEGER  PRIMARY KEY NOT NULL
-- > TEXT  NOT NULL
newtype SqlColType = SqlColType Text
    deriving (SqlColType -> SqlColType -> Bool
(SqlColType -> SqlColType -> Bool)
-> (SqlColType -> SqlColType -> Bool) -> Eq SqlColType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SqlColType -> SqlColType -> Bool
$c/= :: SqlColType -> SqlColType -> Bool
== :: SqlColType -> SqlColType -> Bool
$c== :: SqlColType -> SqlColType -> Bool
Eq,Eq SqlColType
Eq SqlColType
-> (SqlColType -> SqlColType -> Ordering)
-> (SqlColType -> SqlColType -> Bool)
-> (SqlColType -> SqlColType -> Bool)
-> (SqlColType -> SqlColType -> Bool)
-> (SqlColType -> SqlColType -> Bool)
-> (SqlColType -> SqlColType -> SqlColType)
-> (SqlColType -> SqlColType -> SqlColType)
-> Ord SqlColType
SqlColType -> SqlColType -> Bool
SqlColType -> SqlColType -> Ordering
SqlColType -> SqlColType -> SqlColType
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 :: SqlColType -> SqlColType -> SqlColType
$cmin :: SqlColType -> SqlColType -> SqlColType
max :: SqlColType -> SqlColType -> SqlColType
$cmax :: SqlColType -> SqlColType -> SqlColType
>= :: SqlColType -> SqlColType -> Bool
$c>= :: SqlColType -> SqlColType -> Bool
> :: SqlColType -> SqlColType -> Bool
$c> :: SqlColType -> SqlColType -> Bool
<= :: SqlColType -> SqlColType -> Bool
$c<= :: SqlColType -> SqlColType -> Bool
< :: SqlColType -> SqlColType -> Bool
$c< :: SqlColType -> SqlColType -> Bool
compare :: SqlColType -> SqlColType -> Ordering
$ccompare :: SqlColType -> SqlColType -> Ordering
$cp1Ord :: Eq SqlColType
Ord,Int -> SqlColType -> ShowS
[SqlColType] -> ShowS
SqlColType -> String
(Int -> SqlColType -> ShowS)
-> (SqlColType -> String)
-> ([SqlColType] -> ShowS)
-> Show SqlColType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SqlColType] -> ShowS
$cshowList :: [SqlColType] -> ShowS
show :: SqlColType -> String
$cshow :: SqlColType -> String
showsPrec :: Int -> SqlColType -> ShowS
$cshowsPrec :: Int -> SqlColType -> ShowS
Show)

-- | Helper for converting 'SqlType' into an SQL column type with constraints.
toColType :: Persist.SqlType -> SqlColType
toColType :: SqlType -> SqlColType
toColType SqlType
SqlString = Text -> SqlColType
SqlColType Text
"TEXT"
toColType SqlType
SqlInt32  = Text -> SqlColType
SqlColType Text
"INTEGER"
toColType SqlType
SqlInt64  = Text -> SqlColType
SqlColType Text
"INTEGER"
toColType SqlType
x = String -> SqlColType
forall a. HasCallStack => String -> a
error (String -> SqlColType) -> String -> SqlColType
forall a b. (a -> b) -> a -> b
$ String
"toColType: case not implemented: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SqlType -> String
forall a. Show a => a -> String
show SqlType
x

escapeSqlType :: SqlColType -> Text
escapeSqlType :: SqlColType -> Text
escapeSqlType (SqlColType Text
x) = Text
x

-- | Class of columns that can be stored in database tables.
class PersistField a => IsCol a where
    getSqlType :: Proxy a -> SqlColType

instance {-# OVERLAPPABLE #-} (PersistField a, PersistFieldSql a) => IsCol a where
    getSqlType :: Proxy a -> SqlColType
getSqlType = SqlType -> SqlColType
toColType (SqlType -> SqlColType)
-> (Proxy a -> SqlType) -> Proxy a -> SqlColType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> SqlType
forall a. PersistFieldSql a => Proxy a -> SqlType
sqlType

instance PersistField Primary where
    toPersistValue :: Primary -> PersistValue
toPersistValue = Int -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (Int -> PersistValue)
-> (Primary -> Int) -> Primary -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Primary -> Int
getPrimary
    fromPersistValue :: PersistValue -> Either Text Primary
fromPersistValue = (Int -> Primary) -> Either Text Int -> Either Text Primary
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Primary
Primary (Either Text Int -> Either Text Primary)
-> (PersistValue -> Either Text Int)
-> PersistValue
-> Either Text Primary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistValue -> Either Text Int
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue

instance IsCol Primary where
    getSqlType :: Proxy Primary -> SqlColType
getSqlType Proxy Primary
_ = Text -> SqlColType
SqlColType Text
"INTEGER NOT NULL PRIMARY KEY"

instance IsCol Int where
    getSqlType :: Proxy Int -> SqlColType
getSqlType Proxy Int
_ = Text -> SqlColType
SqlColType Text
"INTEGER NOT NULL"

instance IsCol (Maybe Int) where
    getSqlType :: Proxy (Maybe Int) -> SqlColType
getSqlType Proxy (Maybe Int)
_ = Text -> SqlColType
SqlColType Text
"INTEGER"

{-------------------------------------------------------------------------------
    Types for database tables and rows
-------------------------------------------------------------------------------}
-- | Infix notation for a pair of types.
data a :. b = a :. b
    deriving ((a :. b) -> (a :. b) -> Bool
((a :. b) -> (a :. b) -> Bool)
-> ((a :. b) -> (a :. b) -> Bool) -> Eq (a :. b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. (Eq a, Eq b) => (a :. b) -> (a :. b) -> Bool
/= :: (a :. b) -> (a :. b) -> Bool
$c/= :: forall a b. (Eq a, Eq b) => (a :. b) -> (a :. b) -> Bool
== :: (a :. b) -> (a :. b) -> Bool
$c== :: forall a b. (Eq a, Eq b) => (a :. b) -> (a :. b) -> Bool
Eq,Eq (a :. b)
Eq (a :. b)
-> ((a :. b) -> (a :. b) -> Ordering)
-> ((a :. b) -> (a :. b) -> Bool)
-> ((a :. b) -> (a :. b) -> Bool)
-> ((a :. b) -> (a :. b) -> Bool)
-> ((a :. b) -> (a :. b) -> Bool)
-> ((a :. b) -> (a :. b) -> a :. b)
-> ((a :. b) -> (a :. b) -> a :. b)
-> Ord (a :. b)
(a :. b) -> (a :. b) -> Bool
(a :. b) -> (a :. b) -> Ordering
(a :. b) -> (a :. b) -> a :. b
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 b. (Ord a, Ord b) => Eq (a :. b)
forall a b. (Ord a, Ord b) => (a :. b) -> (a :. b) -> Bool
forall a b. (Ord a, Ord b) => (a :. b) -> (a :. b) -> Ordering
forall a b. (Ord a, Ord b) => (a :. b) -> (a :. b) -> a :. b
min :: (a :. b) -> (a :. b) -> a :. b
$cmin :: forall a b. (Ord a, Ord b) => (a :. b) -> (a :. b) -> a :. b
max :: (a :. b) -> (a :. b) -> a :. b
$cmax :: forall a b. (Ord a, Ord b) => (a :. b) -> (a :. b) -> a :. b
>= :: (a :. b) -> (a :. b) -> Bool
$c>= :: forall a b. (Ord a, Ord b) => (a :. b) -> (a :. b) -> Bool
> :: (a :. b) -> (a :. b) -> Bool
$c> :: forall a b. (Ord a, Ord b) => (a :. b) -> (a :. b) -> Bool
<= :: (a :. b) -> (a :. b) -> Bool
$c<= :: forall a b. (Ord a, Ord b) => (a :. b) -> (a :. b) -> Bool
< :: (a :. b) -> (a :. b) -> Bool
$c< :: forall a b. (Ord a, Ord b) => (a :. b) -> (a :. b) -> Bool
compare :: (a :. b) -> (a :. b) -> Ordering
$ccompare :: forall a b. (Ord a, Ord b) => (a :. b) -> (a :. b) -> Ordering
$cp1Ord :: forall a b. (Ord a, Ord b) => Eq (a :. b)
Ord,Int -> (a :. b) -> ShowS
[a :. b] -> ShowS
(a :. b) -> String
(Int -> (a :. b) -> ShowS)
-> ((a :. b) -> String) -> ([a :. b] -> ShowS) -> Show (a :. b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> (a :. b) -> ShowS
forall a b. (Show a, Show b) => [a :. b] -> ShowS
forall a b. (Show a, Show b) => (a :. b) -> String
showList :: [a :. b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [a :. b] -> ShowS
show :: (a :. b) -> String
$cshow :: forall a b. (Show a, Show b) => (a :. b) -> String
showsPrec :: Int -> (a :. b) -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> (a :. b) -> ShowS
Show,ReadPrec [a :. b]
ReadPrec (a :. b)
Int -> ReadS (a :. b)
ReadS [a :. b]
(Int -> ReadS (a :. b))
-> ReadS [a :. b]
-> ReadPrec (a :. b)
-> ReadPrec [a :. b]
-> Read (a :. b)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall a b. (Read a, Read b) => ReadPrec [a :. b]
forall a b. (Read a, Read b) => ReadPrec (a :. b)
forall a b. (Read a, Read b) => Int -> ReadS (a :. b)
forall a b. (Read a, Read b) => ReadS [a :. b]
readListPrec :: ReadPrec [a :. b]
$creadListPrec :: forall a b. (Read a, Read b) => ReadPrec [a :. b]
readPrec :: ReadPrec (a :. b)
$creadPrec :: forall a b. (Read a, Read b) => ReadPrec (a :. b)
readList :: ReadS [a :. b]
$creadList :: forall a b. (Read a, Read b) => ReadS [a :. b]
readsPrec :: Int -> ReadS (a :. b)
$creadsPrec :: forall a b. (Read a, Read b) => Int -> ReadS (a :. b)
Read)
infixl 3 :.

-- | Named database column.
newtype Col (name :: Symbol) a = Col a
    deriving (Col name a -> Col name a -> Bool
(Col name a -> Col name a -> Bool)
-> (Col name a -> Col name a -> Bool) -> Eq (Col name a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (name :: Symbol) a. Eq a => Col name a -> Col name a -> Bool
/= :: Col name a -> Col name a -> Bool
$c/= :: forall (name :: Symbol) a. Eq a => Col name a -> Col name a -> Bool
== :: Col name a -> Col name a -> Bool
$c== :: forall (name :: Symbol) a. Eq a => Col name a -> Col name a -> Bool
Eq,Eq (Col name a)
Eq (Col name a)
-> (Col name a -> Col name a -> Ordering)
-> (Col name a -> Col name a -> Bool)
-> (Col name a -> Col name a -> Bool)
-> (Col name a -> Col name a -> Bool)
-> (Col name a -> Col name a -> Bool)
-> (Col name a -> Col name a -> Col name a)
-> (Col name a -> Col name a -> Col name a)
-> Ord (Col name a)
Col name a -> Col name a -> Bool
Col name a -> Col name a -> Ordering
Col name a -> Col name a -> Col name 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 (name :: Symbol) a. Ord a => Eq (Col name a)
forall (name :: Symbol) a.
Ord a =>
Col name a -> Col name a -> Bool
forall (name :: Symbol) a.
Ord a =>
Col name a -> Col name a -> Ordering
forall (name :: Symbol) a.
Ord a =>
Col name a -> Col name a -> Col name a
min :: Col name a -> Col name a -> Col name a
$cmin :: forall (name :: Symbol) a.
Ord a =>
Col name a -> Col name a -> Col name a
max :: Col name a -> Col name a -> Col name a
$cmax :: forall (name :: Symbol) a.
Ord a =>
Col name a -> Col name a -> Col name a
>= :: Col name a -> Col name a -> Bool
$c>= :: forall (name :: Symbol) a.
Ord a =>
Col name a -> Col name a -> Bool
> :: Col name a -> Col name a -> Bool
$c> :: forall (name :: Symbol) a.
Ord a =>
Col name a -> Col name a -> Bool
<= :: Col name a -> Col name a -> Bool
$c<= :: forall (name :: Symbol) a.
Ord a =>
Col name a -> Col name a -> Bool
< :: Col name a -> Col name a -> Bool
$c< :: forall (name :: Symbol) a.
Ord a =>
Col name a -> Col name a -> Bool
compare :: Col name a -> Col name a -> Ordering
$ccompare :: forall (name :: Symbol) a.
Ord a =>
Col name a -> Col name a -> Ordering
$cp1Ord :: forall (name :: Symbol) a. Ord a => Eq (Col name a)
Ord,Int -> Col name a -> ShowS
[Col name a] -> ShowS
Col name a -> String
(Int -> Col name a -> ShowS)
-> (Col name a -> String)
-> ([Col name a] -> ShowS)
-> Show (Col name a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (name :: Symbol) a. Show a => Int -> Col name a -> ShowS
forall (name :: Symbol) a. Show a => [Col name a] -> ShowS
forall (name :: Symbol) a. Show a => Col name a -> String
showList :: [Col name a] -> ShowS
$cshowList :: forall (name :: Symbol) a. Show a => [Col name a] -> ShowS
show :: Col name a -> String
$cshow :: forall (name :: Symbol) a. Show a => Col name a -> String
showsPrec :: Int -> Col name a -> ShowS
$cshowsPrec :: forall (name :: Symbol) a. Show a => Int -> Col name a -> ShowS
Show)

-- | Named database table.
data Table (name :: Symbol) = Table
    deriving (Table name -> Table name -> Bool
(Table name -> Table name -> Bool)
-> (Table name -> Table name -> Bool) -> Eq (Table name)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (name :: Symbol). Table name -> Table name -> Bool
/= :: Table name -> Table name -> Bool
$c/= :: forall (name :: Symbol). Table name -> Table name -> Bool
== :: Table name -> Table name -> Bool
$c== :: forall (name :: Symbol). Table name -> Table name -> Bool
Eq,Eq (Table name)
Eq (Table name)
-> (Table name -> Table name -> Ordering)
-> (Table name -> Table name -> Bool)
-> (Table name -> Table name -> Bool)
-> (Table name -> Table name -> Bool)
-> (Table name -> Table name -> Bool)
-> (Table name -> Table name -> Table name)
-> (Table name -> Table name -> Table name)
-> Ord (Table name)
Table name -> Table name -> Bool
Table name -> Table name -> Ordering
Table name -> Table name -> Table name
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 (name :: Symbol). Eq (Table name)
forall (name :: Symbol). Table name -> Table name -> Bool
forall (name :: Symbol). Table name -> Table name -> Ordering
forall (name :: Symbol). Table name -> Table name -> Table name
min :: Table name -> Table name -> Table name
$cmin :: forall (name :: Symbol). Table name -> Table name -> Table name
max :: Table name -> Table name -> Table name
$cmax :: forall (name :: Symbol). Table name -> Table name -> Table name
>= :: Table name -> Table name -> Bool
$c>= :: forall (name :: Symbol). Table name -> Table name -> Bool
> :: Table name -> Table name -> Bool
$c> :: forall (name :: Symbol). Table name -> Table name -> Bool
<= :: Table name -> Table name -> Bool
$c<= :: forall (name :: Symbol). Table name -> Table name -> Bool
< :: Table name -> Table name -> Bool
$c< :: forall (name :: Symbol). Table name -> Table name -> Bool
compare :: Table name -> Table name -> Ordering
$ccompare :: forall (name :: Symbol). Table name -> Table name -> Ordering
$cp1Ord :: forall (name :: Symbol). Eq (Table name)
Ord,Int -> Table name -> ShowS
[Table name] -> ShowS
Table name -> String
(Int -> Table name -> ShowS)
-> (Table name -> String)
-> ([Table name] -> ShowS)
-> Show (Table name)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (name :: Symbol). Int -> Table name -> ShowS
forall (name :: Symbol). [Table name] -> ShowS
forall (name :: Symbol). Table name -> String
showList :: [Table name] -> ShowS
$cshowList :: forall (name :: Symbol). [Table name] -> ShowS
show :: Table name -> String
$cshow :: forall (name :: Symbol). Table name -> String
showsPrec :: Int -> Table name -> ShowS
$cshowsPrec :: forall (name :: Symbol). Int -> Table name -> ShowS
Show)

-- | Class of row types that can be stored in database tables.
-- Instances of this class are essentially lists of columns.
-- Example:
--
-- > type PersonRow = Table "person" :. Col "name" Text :. Col "age" Int
class IsRow row where
    getTableName :: Proxy row -> Text
    getColNames :: Proxy row -> [Text]
    getSqlTypes :: Proxy row -> [SqlColType]

    toSqlValues   :: row -> [PersistValue]
    fromSqlValues :: [PersistValue] -> Either Text row

instance KnownSymbol name => IsRow (Table name) where
    getTableName :: Proxy (Table name) -> Text
getTableName Proxy (Table name)
_ = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy :: Proxy name)
    getColNames :: Proxy (Table name) -> [Text]
getColNames  Proxy (Table name)
_ = []
    getSqlTypes :: Proxy (Table name) -> [SqlColType]
getSqlTypes  Proxy (Table name)
_ = []

    toSqlValues :: Table name -> [PersistValue]
toSqlValues  Table name
_ = []
    fromSqlValues :: [PersistValue] -> Either Text (Table name)
fromSqlValues [] = Table name -> Either Text (Table name)
forall a b. b -> Either a b
Right Table name
forall (name :: Symbol). Table name
Table
    fromSqlValues [PersistValue]
_  = Text -> Either Text (Table name)
forall a b. a -> Either a b
Left Text
"Table should contain zero rows"

-- FIXME: O(n^2) when getting the values!
instance (IsRow row, KnownSymbol name, IsCol a)
    => IsRow (row :. Col name a)
  where
    getTableName :: Proxy (row :. Col name a) -> Text
getTableName Proxy (row :. Col name a)
_ = Proxy row -> Text
forall row. IsRow row => Proxy row -> Text
getTableName (Proxy row
forall k (t :: k). Proxy t
Proxy :: Proxy row)
    getColNames :: Proxy (row :. Col name a) -> [Text]
getColNames  Proxy (row :. Col name a)
_ = Proxy row -> [Text]
forall row. IsRow row => Proxy row -> [Text]
getColNames (Proxy row
forall k (t :: k). Proxy t
Proxy :: Proxy row)
        [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy :: Proxy name)]
    getSqlTypes :: Proxy (row :. Col name a) -> [SqlColType]
getSqlTypes  Proxy (row :. Col name a)
_ = Proxy row -> [SqlColType]
forall row. IsRow row => Proxy row -> [SqlColType]
getSqlTypes (Proxy row
forall k (t :: k). Proxy t
Proxy :: Proxy row)
        [SqlColType] -> [SqlColType] -> [SqlColType]
forall a. [a] -> [a] -> [a]
++ [Proxy a -> SqlColType
forall a. IsCol a => Proxy a -> SqlColType
getSqlType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)]

    toSqlValues :: (row :. Col name a) -> [PersistValue]
toSqlValues (row
cs :. Col a
a) = row -> [PersistValue]
forall row. IsRow row => row -> [PersistValue]
toSqlValues row
cs [PersistValue] -> [PersistValue] -> [PersistValue]
forall a. [a] -> [a] -> [a]
++ [a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue a
a]

    fromSqlValues :: [PersistValue] -> Either Text (row :. Col name a)
fromSqlValues [PersistValue]
xs = case [PersistValue]
xs of
        [] -> Text -> Either Text (row :. Col name a)
forall a b. a -> Either a b
Left (Text -> Either Text (row :. Col name a))
-> Text -> Either Text (row :. Col name a)
forall a b. (a -> b) -> a -> b
$ Text
"Expected column " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
colname
        [PersistValue]
_  -> case [PersistValue] -> Either Text row
forall row. IsRow row => [PersistValue] -> Either Text row
fromSqlValues ([PersistValue] -> [PersistValue]
forall a. [a] -> [a]
init [PersistValue]
xs) of
            Left Text
e   -> Text -> Either Text (row :. Col name a)
forall a b. a -> Either a b
Left Text
e
            Right row
cs -> case PersistValue -> Either Text a
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue ([PersistValue] -> PersistValue
forall a. [a] -> a
last [PersistValue]
xs) of
                Left Text
e  -> Text -> Either Text (row :. Col name a)
forall a b. a -> Either a b
Left (Text -> Either Text (row :. Col name a))
-> Text -> Either Text (row :. Col name a)
forall a b. (a -> b) -> a -> b
$ Text
"Column " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
colname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e
                Right a
c -> (row :. Col name a) -> Either Text (row :. Col name a)
forall a b. b -> Either a b
Right ((row :. Col name a) -> Either Text (row :. Col name a))
-> (row :. Col name a) -> Either Text (row :. Col name a)
forall a b. (a -> b) -> a -> b
$ row
cs row -> Col name a -> row :. Col name a
forall a b. a -> b -> a :. b
:. a -> Col name a
forall (name :: Symbol) a. a -> Col name a
Col a
c
      where
        colname :: Text
colname = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy :: Proxy name)

{-------------------------------------------------------------------------------
    Types test
-------------------------------------------------------------------------------}
type PersonRow = Table "person"
    :. Col "name" Text :. Col "birth" Int :. Col "id" Primary

testPerson :: PersonRow
testPerson :: PersonRow
testPerson = Table "person"
forall (name :: Symbol). Table name
Table Table "person"
-> Col "name" Text -> Table "person" :. Col "name" Text
forall a b. a -> b -> a :. b
:. Text -> Col "name" Text
forall (name :: Symbol) a. a -> Col name a
Col Text
"Ada Lovelace" (Table "person" :. Col "name" Text)
-> Col "birth" Int
-> (Table "person" :. Col "name" Text) :. Col "birth" Int
forall a b. a -> b -> a :. b
:. Int -> Col "birth" Int
forall (name :: Symbol) a. a -> Col name a
Col Int
1815 ((Table "person" :. Col "name" Text) :. Col "birth" Int)
-> Col "id" Primary -> PersonRow
forall a b. a -> b -> a :. b
:. Primary -> Col "id" Primary
forall (name :: Symbol) a. a -> Col name a
Col (Int -> Primary
Primary Int
0)

{-------------------------------------------------------------------------------
    Connect with Persistent
-------------------------------------------------------------------------------}
newtype Wrap a = Wrap { Wrap a -> a
unWrap :: a }

instance IsRow row => RawSql (Wrap row) where
    rawSqlCols :: (Text -> Text) -> Wrap row -> (Int, [Text])
rawSqlCols Text -> Text
_ Wrap row
_ = ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
n, [])
      where n :: [Text]
n = Proxy row -> [Text]
forall row. IsRow row => Proxy row -> [Text]
getColNames (Proxy row
forall k (t :: k). Proxy t
Proxy :: Proxy row)
    rawSqlColCountReason :: Wrap row -> String
rawSqlColCountReason Wrap row
_ = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
        Text
"Table " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Proxy row -> Text
forall row. IsRow row => Proxy row -> Text
getTableName Proxy row
proxy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has columns "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
mkTuple (Proxy row -> [Text]
forall row. IsRow row => Proxy row -> [Text]
getColNames Proxy row
proxy)
      where proxy :: Proxy row
proxy = Proxy row
forall k (t :: k). Proxy t
Proxy :: Proxy row
    rawSqlProcessRow :: [PersistValue] -> Either Text (Wrap row)
rawSqlProcessRow = (row -> Wrap row) -> Either Text row -> Either Text (Wrap row)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap row -> Wrap row
forall a. a -> Wrap a
Wrap (Either Text row -> Either Text (Wrap row))
-> ([PersistValue] -> Either Text row)
-> [PersistValue]
-> Either Text (Wrap row)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PersistValue] -> Either Text row
forall row. IsRow row => [PersistValue] -> Either Text row
fromSqlValues

-- | Run an SQL query and return a list of rows as result.
callSql :: (MonadIO m, IsRow row)
    => Query row
    -> SqlPersistT m [row]
callSql :: Query row -> SqlPersistT m [row]
callSql Query{Text
stmt :: forall row. Query row -> Text
stmt :: Text
stmt,[PersistValue]
params :: forall row. Query row -> [PersistValue]
params :: [PersistValue]
params} = (Wrap row -> row) -> [Wrap row] -> [row]
forall a b. (a -> b) -> [a] -> [b]
map Wrap row -> row
forall a. Wrap a -> a
unWrap ([Wrap row] -> [row])
-> ReaderT SqlBackend m [Wrap row] -> SqlPersistT m [row]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> [PersistValue] -> ReaderT SqlBackend m [Wrap row]
forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
Persist.rawSql Text
stmt [PersistValue]
params

-- | Execute an SQL query, but do not return any results
runSql :: MonadIO m => Query () -> SqlPersistT m ()
runSql :: Query () -> SqlPersistT m ()
runSql Query{Text
stmt :: Text
stmt :: forall row. Query row -> Text
stmt,[PersistValue]
params :: [PersistValue]
params :: forall row. Query row -> [PersistValue]
params} = Text -> [PersistValue] -> SqlPersistT m ()
forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m ()
Persist.rawExecute Text
stmt [PersistValue]
params

{-------------------------------------------------------------------------------
    SQL queries
-------------------------------------------------------------------------------}
-- | An SQL query that returns a list of values of type @row@.
data Query row = Query
    { Query row -> Text
stmt :: Text
    -- ^ SQL statement containing placeholders \"?\" which are
    -- replaced by the parameters
    , Query row -> [PersistValue]
params :: [PersistValue]
    -- ^ Parameters to insert into the SQL statement.
    } deriving (Query row -> Query row -> Bool
(Query row -> Query row -> Bool)
-> (Query row -> Query row -> Bool) -> Eq (Query row)
forall row. Query row -> Query row -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Query row -> Query row -> Bool
$c/= :: forall row. Query row -> Query row -> Bool
== :: Query row -> Query row -> Bool
$c== :: forall row. Query row -> Query row -> Bool
Eq, Int -> Query row -> ShowS
[Query row] -> ShowS
Query row -> String
(Int -> Query row -> ShowS)
-> (Query row -> String)
-> ([Query row] -> ShowS)
-> Show (Query row)
forall row. Int -> Query row -> ShowS
forall row. [Query row] -> ShowS
forall row. Query row -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Query row] -> ShowS
$cshowList :: forall row. [Query row] -> ShowS
show :: Query row -> String
$cshow :: forall row. Query row -> String
showsPrec :: Int -> Query row -> ShowS
$cshowsPrec :: forall row. Int -> Query row -> ShowS
Show)

-- | Escape a column or table name.
--
-- FIXME: Use a newtype for more type safety.
-- 'Query' used to be this newtype, but that has changed
-- due to the 'params' field.
escape :: Text -> Text
escape :: Text -> Text
escape Text
s = Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""

-- | Helper for making a syntactically correct SQL tuple.
mkTuple :: [Text] -> Text
mkTuple :: [Text] -> Text
mkTuple [Text]
xs = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
xs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | Create a database table that can store the given rows.
createTable :: IsRow row => Proxy row -> Query ()
createTable :: Proxy row -> Query ()
createTable Proxy row
proxy = Query :: forall row. Text -> [PersistValue] -> Query row
Query
    { stmt :: Text
stmt =
        Text
"CREATE TABLE IF NOT EXISTS " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
table
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
mkTuple [Text]
cols Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";"
    , params :: [PersistValue]
params = []
    }
  where
    table :: Text
table = Text -> Text
escape (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Proxy row -> Text
forall row. IsRow row => Proxy row -> Text
getTableName Proxy row
proxy
    cols :: [Text]
cols  = (Text -> SqlColType -> Text) -> [Text] -> [SqlColType] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Text
name SqlColType
typ -> Text -> Text
escape Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SqlColType -> Text
escapeSqlType SqlColType
typ)
        (Proxy row -> [Text]
forall row. IsRow row => Proxy row -> [Text]
getColNames Proxy row
proxy) (Proxy row -> [SqlColType]
forall row. IsRow row => Proxy row -> [SqlColType]
getSqlTypes Proxy row
proxy)

-- | Select all rows from the table.
selectAll :: forall row. IsRow row => Query row
selectAll :: Query row
selectAll = Query :: forall row. Text -> [PersistValue] -> Query row
Query
    { stmt :: Text
stmt = Text
"SELECT " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"," [Text]
cols Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";"
    , params :: [PersistValue]
params = []
    }
  where
    proxy :: Proxy row
proxy = Proxy row
forall k (t :: k). Proxy t
Proxy :: Proxy row
    table :: Text
table = Text -> Text
escape (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Proxy row -> Text
forall row. IsRow row => Proxy row -> Text
getTableName Proxy row
proxy
    cols :: [Text]
cols  = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
escape ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Proxy row -> [Text]
forall row. IsRow row => Proxy row -> [Text]
getColNames Proxy row
proxy

-- | Insert a single row into the corresponding table.
insertOne :: forall row. IsRow row => row -> Query ()
insertOne :: row -> Query ()
insertOne row
row = Query :: forall row. Text -> [PersistValue] -> Query row
Query
    { stmt :: Text
stmt =
        Text
"INSERT INTO " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
mkTuple [Text]
cols
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" VALUES " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
mkTuple (Text
"?" Text -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Text]
cols) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";"
    , params :: [PersistValue]
params = row -> [PersistValue]
forall row. IsRow row => row -> [PersistValue]
toSqlValues row
row
    }
  where
    proxy :: Proxy row
proxy = Proxy row
forall k (t :: k). Proxy t
Proxy :: Proxy row
    table :: Text
table = Text -> Text
escape (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Proxy row -> Text
forall row. IsRow row => Proxy row -> Text
getTableName Proxy row
proxy
    cols :: [Text]
cols  = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
escape ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Proxy row -> [Text]
forall row. IsRow row => Proxy row -> [Text]
getColNames Proxy row
proxy

-- | Replace or insert a single row with a primary key into a database.
--
-- FIXME: It would be nicer if the "id" column was the first column
-- instead of the last column in the table.
repsertOne :: forall row. IsRow row
    => (row :. Col "id" Primary) -> Query ()
repsertOne :: (row :. Col "id" Primary) -> Query ()
repsertOne row :. Col "id" Primary
row = Query :: forall row. Text -> [PersistValue] -> Query row
Query
    { stmt :: Text
stmt =
        Text
"INSERT OR REPLACE INTO " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
mkTuple [Text]
cols
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" VALUES " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
mkTuple (Text
"?" Text -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Text]
cols) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";"
    , params :: [PersistValue]
params = (row :. Col "id" Primary) -> [PersistValue]
forall row. IsRow row => row -> [PersistValue]
toSqlValues row :. Col "id" Primary
row
    }
  where
    proxy :: Proxy (row :. Col "id" Primary)
proxy = Proxy (row :. Col "id" Primary)
forall k (t :: k). Proxy t
Proxy :: Proxy (row :. Col "id" Primary)
    table :: Text
table = Text -> Text
escape (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Proxy (row :. Col "id" Primary) -> Text
forall row. IsRow row => Proxy row -> Text
getTableName Proxy (row :. Col "id" Primary)
proxy
    cols :: [Text]
cols  = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
escape ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Proxy (row :. Col "id" Primary) -> [Text]
forall row. IsRow row => Proxy row -> [Text]
getColNames Proxy (row :. Col "id" Primary)
proxy

-- | Update one row with a given \"id\" column in a database table.
updateOne :: forall row. IsRow row
    => (row :. Col "id" Primary) -> Query ()
updateOne :: (row :. Col "id" Primary) -> Query ()
updateOne row :. Col "id" Primary
row= Query :: forall row. Text -> [PersistValue] -> Query row
Query
    { stmt :: Text
stmt = Text
"UPDATE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" SET " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sets Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE \"id\"=?;"
    , params :: [PersistValue]
params = (row :. Col "id" Primary) -> [PersistValue]
forall row. IsRow row => row -> [PersistValue]
toSqlValues row :. Col "id" Primary
row
    }
  where
    proxy :: Proxy row
proxy = Proxy row
forall k (t :: k). Proxy t
Proxy :: Proxy row
    table :: Text
table = Text -> Text
escape (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Proxy row -> Text
forall row. IsRow row => Proxy row -> Text
getTableName Proxy row
proxy
    cols :: [Text]
cols  = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
escape ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Proxy row -> [Text]
forall row. IsRow row => Proxy row -> [Text]
getColNames Proxy row
proxy
    sets :: Text
sets  = Text -> [Text] -> Text
T.intercalate Text
", " [Text
col Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=?" | Text
col <- [Text]
cols]

-- | Delete one row with a given \"id\" column in a database table.
deleteOne :: forall row. IsRow row => Proxy row -> Col "id" Primary -> Query ()
deleteOne :: Proxy row -> Col "id" Primary -> Query ()
deleteOne Proxy row
proxy (Col Primary
key) = Query :: forall row. Text -> [PersistValue] -> Query row
Query
    { stmt :: Text
stmt = Text
"DELETE FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE \"id\"=?;"
    , params :: [PersistValue]
params = [Primary -> PersistValue
forall a. PersistField a => a -> PersistValue
Persist.toPersistValue Primary
key]
    }
  where
    table :: Text
table = Text -> Text
escape (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Proxy row -> Text
forall row. IsRow row => Proxy row -> Text
getTableName Proxy row
proxy

-- | Delete all rows in a database table
deleteAll :: forall row. IsRow row => Proxy row -> Query ()
deleteAll :: Proxy row -> Query ()
deleteAll Proxy row
proxy = Query :: forall row. Text -> [PersistValue] -> Query row
Query
    { stmt :: Text
stmt = Text
"DELETE FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
table
    , params :: [PersistValue]
params = []
    }
  where
    table :: Text
table = Text -> Text
escape (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Proxy row -> Text
forall row. IsRow row => Proxy row -> Text
getTableName Proxy row
proxy