{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | This helper module is intended for use by the backend creators
module Database.Groundhog.Generic
  ( -- * Migration
    createMigration,
    executeMigration,
    executeMigrationSilent,
    executeMigrationUnsafe,
    runMigration,
    runMigrationSilent,
    runMigrationUnsafe,
    getQueries,
    printMigration,
    mergeMigrations,

    -- * Helper functions for defining *PersistValue instances
    primToPersistValue,
    primFromPersistValue,
    primToPurePersistValues,
    primFromPurePersistValues,
    primToSinglePersistValue,
    primFromSinglePersistValue,
    pureToPersistValue,
    pureFromPersistValue,
    singleToPersistValue,
    singleFromPersistValue,
    toSinglePersistValueUnique,
    fromSinglePersistValueUnique,
    toPersistValuesUnique,
    fromPersistValuesUnique,
    toSinglePersistValueAutoKey,
    fromSinglePersistValueAutoKey,
    failMessage,
    failMessageNamed,

    -- * Other
    bracket,
    finally,
    onException,
    PSFieldDef (..),
    applyDbTypeSettings,
    findOne,
    replaceOne,
    matchElements,
    haveSameElems,
    phantomDb,
    getDefaultAutoKeyType,
    getUniqueFields,
    isSimple,
    firstRow,
    streamToList,
    mapStream,
    joinStreams,
  )
where

import Control.Applicative ((<|>))
import qualified Control.Exception as E
import Control.Monad (forM_, unless)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Control (MonadBaseControl, control, restoreM)
import Control.Monad.Trans.Reader (ReaderT (..), ask, runReaderT)
import Control.Monad.Trans.State (StateT (..))
import Data.Acquire (with)
import Data.Acquire.Internal (Acquire (..), Allocated (..), ReleaseType (..))
import Data.Either (partitionEithers)
import Data.Function (on)
import Data.IORef
import Data.List (partition, sortBy)
import qualified Data.Map as Map
import Database.Groundhog.Core
import System.IO (hPutStrLn, stderr)

-- | Produce the migrations but not execute them. Fails when an unsafe migration occurs.
createMigration :: Monad m => Migration m -> m NamedMigrations
createMigration :: Migration m -> m NamedMigrations
createMigration Migration m
m = ((), NamedMigrations) -> NamedMigrations
forall a b. (a, b) -> b
snd (((), NamedMigrations) -> NamedMigrations)
-> m ((), NamedMigrations) -> m NamedMigrations
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Migration m -> NamedMigrations -> m ((), NamedMigrations)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Migration m
m NamedMigrations
forall k a. Map k a
Map.empty

-- | Returns either a list of errors in migration or a list of queries
getQueries ::
  -- | True - support unsafe queries
  Bool ->
  SingleMigration ->
  Either [String] [String]
getQueries :: Bool -> SingleMigration -> Either [String] [String]
getQueries Bool
_ (Left [String]
errs) = [String] -> Either [String] [String]
forall a b. a -> Either a b
Left [String]
errs
getQueries Bool
runUnsafe (Right [(Bool, Int, String)]
migs) =
  if Bool
runUnsafe Bool -> Bool -> Bool
|| [(Bool, Int, String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Bool, Int, String)]
unsafe
    then [String] -> Either [String] [String]
forall a b. b -> Either a b
Right ([String] -> Either [String] [String])
-> [String] -> Either [String] [String]
forall a b. (a -> b) -> a -> b
$ ((Bool, Int, String) -> String)
-> [(Bool, Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Bool
_, Int
_, String
query) -> String
query) [(Bool, Int, String)]
migs'
    else
      [String] -> Either [String] [String]
forall a b. a -> Either a b
Left ([String] -> Either [String] [String])
-> [String] -> Either [String] [String]
forall a b. (a -> b) -> a -> b
$
        [ String
"Database migration: manual intervention required.",
          String
"The following actions are considered unsafe:"
        ]
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((Bool, Int, String) -> String)
-> [(Bool, Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Bool
_, Int
_, String
query) -> String
query) [(Bool, Int, String)]
unsafe
  where
    migs' :: [(Bool, Int, String)]
migs' = ((Bool, Int, String) -> (Bool, Int, String) -> Ordering)
-> [(Bool, Int, String)] -> [(Bool, Int, String)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Bool, Int, String) -> Int)
-> (Bool, Int, String)
-> (Bool, Int, String)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` \(Bool
_, Int
i, String
_) -> Int
i) [(Bool, Int, String)]
migs
    unsafe :: [(Bool, Int, String)]
unsafe = ((Bool, Int, String) -> Bool)
-> [(Bool, Int, String)] -> [(Bool, Int, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Bool
isUnsafe, Int
_, String
_) -> Bool
isUnsafe) [(Bool, Int, String)]
migs'

executeMigration' :: (PersistBackend m, MonadIO m) => Bool -> Bool -> NamedMigrations -> m ()
executeMigration' :: Bool -> Bool -> NamedMigrations -> m ()
executeMigration' Bool
runUnsafe Bool
silent NamedMigrations
m = do
  let migs :: Either [String] [String]
migs = Bool -> SingleMigration -> Either [String] [String]
getQueries Bool
runUnsafe (SingleMigration -> Either [String] [String])
-> SingleMigration -> Either [String] [String]
forall a b. (a -> b) -> a -> b
$ [SingleMigration] -> SingleMigration
mergeMigrations ([SingleMigration] -> SingleMigration)
-> [SingleMigration] -> SingleMigration
forall a b. (a -> b) -> a -> b
$ NamedMigrations -> [SingleMigration]
forall k a. Map k a -> [a]
Map.elems NamedMigrations
m
  case Either [String] [String]
migs of
    Left [String]
errs -> String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
errs
    Right [String]
qs -> [String] -> (String -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
qs ((String -> m ()) -> m ()) -> (String -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \String
q -> do
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
silent (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Migrating: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
q
      Bool -> String -> [PersistValue] -> m ()
forall conn (m :: * -> *).
(PersistBackendConn conn, PersistBackend m, Conn m ~ conn) =>
Bool -> String -> [PersistValue] -> m ()
executeRaw Bool
False String
q []

-- | Execute the migrations with printing to stderr. Fails when an unsafe migration occurs.
executeMigration :: (PersistBackend m, MonadIO m) => NamedMigrations -> m ()
executeMigration :: NamedMigrations -> m ()
executeMigration = Bool -> Bool -> NamedMigrations -> m ()
forall (m :: * -> *).
(PersistBackend m, MonadIO m) =>
Bool -> Bool -> NamedMigrations -> m ()
executeMigration' Bool
False Bool
False

-- | Execute the migrations. Fails when an unsafe migration occurs.
executeMigrationSilent :: (PersistBackend m, MonadIO m) => NamedMigrations -> m ()
executeMigrationSilent :: NamedMigrations -> m ()
executeMigrationSilent = Bool -> Bool -> NamedMigrations -> m ()
forall (m :: * -> *).
(PersistBackend m, MonadIO m) =>
Bool -> Bool -> NamedMigrations -> m ()
executeMigration' Bool
False Bool
True

-- | Execute migrations. Executes the unsafe migrations without warnings and prints them to stderr
executeMigrationUnsafe :: (PersistBackend m, MonadIO m) => NamedMigrations -> m ()
executeMigrationUnsafe :: NamedMigrations -> m ()
executeMigrationUnsafe = Bool -> Bool -> NamedMigrations -> m ()
forall (m :: * -> *).
(PersistBackend m, MonadIO m) =>
Bool -> Bool -> NamedMigrations -> m ()
executeMigration' Bool
True Bool
False

-- | Pretty print the migrations
printMigration :: MonadIO m => NamedMigrations -> m ()
printMigration :: NamedMigrations -> m ()
printMigration NamedMigrations
migs = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
  [(String, SingleMigration)]
-> ((String, SingleMigration) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (NamedMigrations -> [(String, SingleMigration)]
forall k a. Map k a -> [(k, a)]
Map.assocs NamedMigrations
migs) (((String, SingleMigration) -> IO ()) -> IO ())
-> ((String, SingleMigration) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(String
k, SingleMigration
v) -> do
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Datatype " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
    case SingleMigration
v of
      Left [String]
errors -> (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"\tError:\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++)) [String]
errors
      Right [(Bool, Int, String)]
sqls -> do
        let showSql :: (Bool, b, String) -> String
showSql (Bool
isUnsafe, b
_, String
sql) = (if Bool
isUnsafe then String
"Unsafe:\t" else String
"Safe:\t") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sql
        ((Bool, Int, String) -> IO ()) -> [(Bool, Int, String)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn (String -> IO ())
-> ((Bool, Int, String) -> String) -> (Bool, Int, String) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> ((Bool, Int, String) -> String) -> (Bool, Int, String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, Int, String) -> String
forall b. (Bool, b, String) -> String
showSql) [(Bool, Int, String)]
sqls

-- | Creates migrations and executes them with printing to stderr. Fails when an unsafe migration occurs.
-- > runMigration m = createMigration m >>= executeMigration
runMigration :: (PersistBackend m, MonadIO m) => Migration m -> m ()
runMigration :: Migration m -> m ()
runMigration Migration m
m = Migration m -> m NamedMigrations
forall (m :: * -> *). Monad m => Migration m -> m NamedMigrations
createMigration Migration m
m m NamedMigrations -> (NamedMigrations -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NamedMigrations -> m ()
forall (m :: * -> *).
(PersistBackend m, MonadIO m) =>
NamedMigrations -> m ()
executeMigration

-- | Creates migrations and silently executes them. Fails when an unsafe migration occurs.
-- > runMigration m = createMigration m >>= executeMigrationSilent
runMigrationSilent :: (PersistBackend m, MonadIO m) => Migration m -> m ()
runMigrationSilent :: Migration m -> m ()
runMigrationSilent Migration m
m = Migration m -> m NamedMigrations
forall (m :: * -> *). Monad m => Migration m -> m NamedMigrations
createMigration Migration m
m m NamedMigrations -> (NamedMigrations -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NamedMigrations -> m ()
forall (m :: * -> *).
(PersistBackend m, MonadIO m) =>
NamedMigrations -> m ()
executeMigrationSilent

-- | Creates migrations and executes them with printing to stderr. Executes the unsafe migrations without warnings
-- > runMigrationUnsafe m = createMigration m >>= executeMigrationUnsafe
runMigrationUnsafe :: (PersistBackend m, MonadIO m) => Migration m -> m ()
runMigrationUnsafe :: Migration m -> m ()
runMigrationUnsafe Migration m
m = Migration m -> m NamedMigrations
forall (m :: * -> *). Monad m => Migration m -> m NamedMigrations
createMigration Migration m
m m NamedMigrations -> (NamedMigrations -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NamedMigrations -> m ()
forall (m :: * -> *).
(PersistBackend m, MonadIO m) =>
NamedMigrations -> m ()
executeMigrationUnsafe

-- | Joins the migrations. The result is either all error messages or all queries
mergeMigrations :: [SingleMigration] -> SingleMigration
mergeMigrations :: [SingleMigration] -> SingleMigration
mergeMigrations [SingleMigration]
ms = case [SingleMigration] -> ([[String]], [[(Bool, Int, String)]])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [SingleMigration]
ms of
  ([], [[(Bool, Int, String)]]
statements) -> [(Bool, Int, String)] -> SingleMigration
forall a b. b -> Either a b
Right ([(Bool, Int, String)] -> SingleMigration)
-> [(Bool, Int, String)] -> SingleMigration
forall a b. (a -> b) -> a -> b
$ [[(Bool, Int, String)]] -> [(Bool, Int, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Bool, Int, String)]]
statements
  ([[String]]
errors, [[(Bool, Int, String)]]
_) -> [String] -> SingleMigration
forall a b. a -> Either a b
Left ([String] -> SingleMigration) -> [String] -> SingleMigration
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
errors

failMessage :: PersistField a => a -> [PersistValue] -> String
failMessage :: a -> [PersistValue] -> String
failMessage a
a = String -> [PersistValue] -> String
failMessageNamed (a -> String
forall a. PersistField a => a -> String
persistName a
a)

failMessageNamed :: String -> [PersistValue] -> String
failMessageNamed :: String -> [PersistValue] -> String
failMessageNamed String
name [PersistValue]
xs = String
"Invalid list for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [PersistValue] -> String
forall a. Show a => a -> String
show [PersistValue]
xs

finally ::
  MonadBaseControl IO m =>
  -- | computation to run first
  m a ->
  -- | computation to run afterward (even if an exception was raised)
  m b ->
  m a
finally :: m a -> m b -> m a
finally m a
a m b
sequel = (RunInBase m IO -> IO (StM m a)) -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control ((RunInBase m IO -> IO (StM m a)) -> m a)
-> (RunInBase m IO -> IO (StM m a)) -> m a
forall a b. (a -> b) -> a -> b
$ \RunInBase m IO
runInIO ->
  IO (StM m a) -> IO (StM m b) -> IO (StM m a)
forall a b. IO a -> IO b -> IO a
E.finally
    (m a -> IO (StM m a)
RunInBase m IO
runInIO m a
a)
    (m b -> IO (StM m b)
RunInBase m IO
runInIO m b
sequel)

bracket ::
  MonadBaseControl IO m =>
  -- | computation to run first ("acquire resource")
  m a ->
  -- | computation to run last ("release resource")
  (a -> m b) ->
  -- | computation to run in-between
  (a -> m c) ->
  m c
bracket :: m a -> (a -> m b) -> (a -> m c) -> m c
bracket m a
before a -> m b
after a -> m c
thing = (RunInBase m IO -> IO (StM m c)) -> m c
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control ((RunInBase m IO -> IO (StM m c)) -> m c)
-> (RunInBase m IO -> IO (StM m c)) -> m c
forall a b. (a -> b) -> a -> b
$ \RunInBase m IO
runInIO ->
  IO (StM m a)
-> (StM m a -> IO (StM m b))
-> (StM m a -> IO (StM m c))
-> IO (StM m c)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (m a -> IO (StM m a)
RunInBase m IO
runInIO m a
before) (\StM m a
st -> m b -> IO (StM m b)
RunInBase m IO
runInIO (m b -> IO (StM m b)) -> m b -> IO (StM m b)
forall a b. (a -> b) -> a -> b
$ StM m a -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM m a
st m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m b
after) (\StM m a
st -> m c -> IO (StM m c)
RunInBase m IO
runInIO (m c -> IO (StM m c)) -> m c -> IO (StM m c)
forall a b. (a -> b) -> a -> b
$ StM m a -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM m a
st m a -> (a -> m c) -> m c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m c
thing)

onException ::
  MonadBaseControl IO m =>
  m a ->
  m b ->
  m a
onException :: m a -> m b -> m a
onException m a
io m b
what = (RunInBase m IO -> IO (StM m a)) -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control ((RunInBase m IO -> IO (StM m a)) -> m a)
-> (RunInBase m IO -> IO (StM m a)) -> m a
forall a b. (a -> b) -> a -> b
$ \RunInBase m IO
runInIO -> IO (StM m a) -> IO (StM m b) -> IO (StM m a)
forall a b. IO a -> IO b -> IO a
E.onException (m a -> IO (StM m a)
RunInBase m IO
runInIO m a
io) (m b -> IO (StM m b)
RunInBase m IO
runInIO m b
what)

data PSFieldDef str = PSFieldDef
  { -- | name in the record, bar
    PSFieldDef str -> str
psFieldName :: str,
    -- | column name, SQLbar
    PSFieldDef str -> Maybe str
psDbFieldName :: Maybe str,
    -- | column type, inet, NUMERIC(5, 2), VARCHAR(50), etc.
    PSFieldDef str -> Maybe str
psDbTypeName :: Maybe str,
    -- | name of constructor in the Field GADT, BarField
    PSFieldDef str -> Maybe str
psExprName :: Maybe str,
    PSFieldDef str -> Maybe [PSFieldDef str]
psEmbeddedDef :: Maybe [PSFieldDef str],
    -- | default value in the database
    PSFieldDef str -> Maybe str
psDefaultValue :: Maybe str,
    PSFieldDef str
-> Maybe
     (Maybe ((Maybe str, str), [str]), Maybe ReferenceActionType,
      Maybe ReferenceActionType)
psReferenceParent :: Maybe (Maybe ((Maybe str, str), [str]), Maybe ReferenceActionType, Maybe ReferenceActionType),
    -- | name of a pair of functions
    PSFieldDef str -> Maybe str
psFieldConverter :: Maybe str
  }
  deriving (PSFieldDef str -> PSFieldDef str -> Bool
(PSFieldDef str -> PSFieldDef str -> Bool)
-> (PSFieldDef str -> PSFieldDef str -> Bool)
-> Eq (PSFieldDef str)
forall str. Eq str => PSFieldDef str -> PSFieldDef str -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PSFieldDef str -> PSFieldDef str -> Bool
$c/= :: forall str. Eq str => PSFieldDef str -> PSFieldDef str -> Bool
== :: PSFieldDef str -> PSFieldDef str -> Bool
$c== :: forall str. Eq str => PSFieldDef str -> PSFieldDef str -> Bool
Eq, Int -> PSFieldDef str -> String -> String
[PSFieldDef str] -> String -> String
PSFieldDef str -> String
(Int -> PSFieldDef str -> String -> String)
-> (PSFieldDef str -> String)
-> ([PSFieldDef str] -> String -> String)
-> Show (PSFieldDef str)
forall str. Show str => Int -> PSFieldDef str -> String -> String
forall str. Show str => [PSFieldDef str] -> String -> String
forall str. Show str => PSFieldDef str -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [PSFieldDef str] -> String -> String
$cshowList :: forall str. Show str => [PSFieldDef str] -> String -> String
show :: PSFieldDef str -> String
$cshow :: forall str. Show str => PSFieldDef str -> String
showsPrec :: Int -> PSFieldDef str -> String -> String
$cshowsPrec :: forall str. Show str => Int -> PSFieldDef str -> String -> String
Show)

applyDbTypeSettings :: PSFieldDef String -> DbType -> DbType
applyDbTypeSettings :: PSFieldDef String -> DbType -> DbType
applyDbTypeSettings (PSFieldDef String
_ Maybe String
_ Maybe String
dbTypeName Maybe String
_ Maybe [PSFieldDef String]
Nothing Maybe String
def Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
psRef Maybe String
_) DbType
typ = case DbType
typ of
  DbTypePrimitive DbTypePrimitive
t Bool
nullable Maybe String
def' Maybe ParentTableReference
ref -> DbTypePrimitive
-> Bool -> Maybe String -> Maybe ParentTableReference -> DbType
DbTypePrimitive (DbTypePrimitive
-> (String -> DbTypePrimitive) -> Maybe String -> DbTypePrimitive
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DbTypePrimitive
t (\String
typeName -> OtherTypeDef' String -> DbTypePrimitive
forall str. OtherTypeDef' str -> DbTypePrimitive' str
DbOther (OtherTypeDef' String -> DbTypePrimitive)
-> OtherTypeDef' String -> DbTypePrimitive
forall a b. (a -> b) -> a -> b
$ [Either String DbTypePrimitive] -> OtherTypeDef' String
forall str.
[Either str (DbTypePrimitive' str)] -> OtherTypeDef' str
OtherTypeDef [String -> Either String DbTypePrimitive
forall a b. a -> Either a b
Left String
typeName]) Maybe String
dbTypeName) Bool
nullable (Maybe String
def Maybe String -> Maybe String -> Maybe String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
def') (Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
-> Maybe ParentTableReference -> Maybe ParentTableReference
applyReferencesSettings Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
psRef Maybe ParentTableReference
ref)
  DbEmbedded EmbeddedDef
emb Maybe ParentTableReference
ref -> EmbeddedDef -> Maybe ParentTableReference -> DbType
DbEmbedded EmbeddedDef
emb (Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
-> Maybe ParentTableReference -> Maybe ParentTableReference
applyReferencesSettings Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
psRef Maybe ParentTableReference
ref)
  DbType
t -> DbType
t
applyDbTypeSettings (PSFieldDef String
_ Maybe String
_ Maybe String
_ Maybe String
_ (Just [PSFieldDef String]
subs) Maybe String
_ Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
psRef Maybe String
_) DbType
typ =
  case DbType
typ of
    DbEmbedded (EmbeddedDef Bool
_ [(String, DbType)]
fields) Maybe ParentTableReference
ref -> EmbeddedDef -> Maybe ParentTableReference -> DbType
DbEmbedded ((Bool -> [(String, DbType)] -> EmbeddedDef)
-> (Bool, [(String, DbType)]) -> EmbeddedDef
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> [(String, DbType)] -> EmbeddedDef
forall str dbType.
Bool -> [(str, dbType)] -> EmbeddedDef' str dbType
EmbeddedDef ((Bool, [(String, DbType)]) -> EmbeddedDef)
-> (Bool, [(String, DbType)]) -> EmbeddedDef
forall a b. (a -> b) -> a -> b
$ [PSFieldDef String]
-> [(String, DbType)] -> (Bool, [(String, DbType)])
go [PSFieldDef String]
subs [(String, DbType)]
fields) (Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
-> Maybe ParentTableReference -> Maybe ParentTableReference
applyReferencesSettings Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
psRef Maybe ParentTableReference
ref)
    DbType
t -> String -> DbType
forall a. HasCallStack => String -> a
error (String -> DbType) -> String -> DbType
forall a b. (a -> b) -> a -> b
$ String
"applyDbTypeSettings: expected DbEmbedded, got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DbType -> String
forall a. Show a => a -> String
show DbType
t
  where
    go :: [PSFieldDef String]
-> [(String, DbType)] -> (Bool, [(String, DbType)])
go [] [(String, DbType)]
fs = (Bool
False, [(String, DbType)]
fs)
    go [PSFieldDef String]
st [] = String -> (Bool, [(String, DbType)])
forall a. HasCallStack => String -> a
error (String -> (Bool, [(String, DbType)]))
-> String -> (Bool, [(String, DbType)])
forall a b. (a -> b) -> a -> b
$ String
"applyDbTypeSettings: embedded datatype does not have expected fields: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [PSFieldDef String] -> String
forall a. Show a => a -> String
show [PSFieldDef String]
st
    go [PSFieldDef String]
st (field :: (String, DbType)
field@(String
fName, DbType
fType) : [(String, DbType)]
fs) = case (PSFieldDef String -> Bool)
-> [PSFieldDef String]
-> ([PSFieldDef String], [PSFieldDef String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
fName) (String -> Bool)
-> (PSFieldDef String -> String) -> PSFieldDef String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSFieldDef String -> String
forall str. PSFieldDef str -> str
psFieldName) [PSFieldDef String]
st of
      ([PSFieldDef String
fDef], [PSFieldDef String]
rest) -> (Bool, [(String, DbType)])
result
        where
          (Bool
flag, [(String, DbType)]
fields') = [PSFieldDef String]
-> [(String, DbType)] -> (Bool, [(String, DbType)])
go [PSFieldDef String]
rest [(String, DbType)]
fs
          result :: (Bool, [(String, DbType)])
result = case PSFieldDef String -> Maybe String
forall str. PSFieldDef str -> Maybe str
psDbFieldName PSFieldDef String
fDef of
            Maybe String
Nothing -> (Bool
flag, (String
fName, PSFieldDef String -> DbType -> DbType
applyDbTypeSettings PSFieldDef String
fDef DbType
fType) (String, DbType) -> [(String, DbType)] -> [(String, DbType)]
forall a. a -> [a] -> [a]
: [(String, DbType)]
fields')
            Just String
name' -> (Bool
True, (String
name', PSFieldDef String -> DbType -> DbType
applyDbTypeSettings PSFieldDef String
fDef DbType
fType) (String, DbType) -> [(String, DbType)] -> [(String, DbType)]
forall a. a -> [a] -> [a]
: [(String, DbType)]
fields')
      ([PSFieldDef String], [PSFieldDef String])
_ -> let (Bool
flag, [(String, DbType)]
fields') = [PSFieldDef String]
-> [(String, DbType)] -> (Bool, [(String, DbType)])
go [PSFieldDef String]
st [(String, DbType)]
fs in (Bool
flag, (String, DbType)
field (String, DbType) -> [(String, DbType)] -> [(String, DbType)]
forall a. a -> [a] -> [a]
: [(String, DbType)]
fields')

applyReferencesSettings :: Maybe (Maybe ((Maybe String, String), [String]), Maybe ReferenceActionType, Maybe ReferenceActionType) -> Maybe ParentTableReference -> Maybe ParentTableReference
applyReferencesSettings :: Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
-> Maybe ParentTableReference -> Maybe ParentTableReference
applyReferencesSettings Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
Nothing Maybe ParentTableReference
ref = Maybe ParentTableReference
ref
applyReferencesSettings (Just (Maybe ((Maybe String, String), [String])
parent, Maybe ReferenceActionType
onDel, Maybe ReferenceActionType
onUpd)) (Just (Either (EntityDef, Maybe String) ((Maybe String, String), [String])
parent', Maybe ReferenceActionType
onDel', Maybe ReferenceActionType
onUpd')) = ParentTableReference -> Maybe ParentTableReference
forall a. a -> Maybe a
Just (Either (EntityDef, Maybe String) ((Maybe String, String), [String])
-> (((Maybe String, String), [String])
    -> Either
         (EntityDef, Maybe String) ((Maybe String, String), [String]))
-> Maybe ((Maybe String, String), [String])
-> Either
     (EntityDef, Maybe String) ((Maybe String, String), [String])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Either (EntityDef, Maybe String) ((Maybe String, String), [String])
parent' ((Maybe String, String), [String])
-> Either
     (EntityDef, Maybe String) ((Maybe String, String), [String])
forall a b. b -> Either a b
Right Maybe ((Maybe String, String), [String])
parent, Maybe ReferenceActionType
onDel Maybe ReferenceActionType
-> Maybe ReferenceActionType -> Maybe ReferenceActionType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ReferenceActionType
onDel', Maybe ReferenceActionType
onUpd Maybe ReferenceActionType
-> Maybe ReferenceActionType -> Maybe ReferenceActionType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ReferenceActionType
onUpd')
applyReferencesSettings (Just (Just ((Maybe String, String), [String])
parent, Maybe ReferenceActionType
onDel, Maybe ReferenceActionType
onUpd)) Maybe ParentTableReference
Nothing = ParentTableReference -> Maybe ParentTableReference
forall a. a -> Maybe a
Just (((Maybe String, String), [String])
-> Either
     (EntityDef, Maybe String) ((Maybe String, String), [String])
forall a b. b -> Either a b
Right ((Maybe String, String), [String])
parent, Maybe ReferenceActionType
onDel, Maybe ReferenceActionType
onUpd)
applyReferencesSettings Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
_ Maybe ParentTableReference
Nothing = String -> Maybe ParentTableReference
forall a. HasCallStack => String -> a
error String
"applyReferencesSettings: expected type with reference, got Nothing"

primToPersistValue :: (PersistBackend m, PrimitivePersistField a) => a -> m ([PersistValue] -> [PersistValue])
primToPersistValue :: a -> m ([PersistValue] -> [PersistValue])
primToPersistValue a
a = ([PersistValue] -> [PersistValue])
-> m ([PersistValue] -> [PersistValue])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> PersistValue
forall a. PrimitivePersistField a => a -> PersistValue
toPrimitivePersistValue a
a PersistValue -> [PersistValue] -> [PersistValue]
forall a. a -> [a] -> [a]
:)

primFromPersistValue :: (PersistBackend m, PrimitivePersistField a) => [PersistValue] -> m (a, [PersistValue])
primFromPersistValue :: [PersistValue] -> m (a, [PersistValue])
primFromPersistValue (PersistValue
x : [PersistValue]
xs) = (a, [PersistValue]) -> m (a, [PersistValue])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PersistValue -> a
forall a. PrimitivePersistField a => PersistValue -> a
fromPrimitivePersistValue PersistValue
x, [PersistValue]
xs)
primFromPersistValue [PersistValue]
xs = (\a
a -> String -> m Any
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (a -> [PersistValue] -> String
forall a. PersistField a => a -> [PersistValue] -> String
failMessage a
a [PersistValue]
xs) m Any -> m (a, [PersistValue]) -> m (a, [PersistValue])
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (a, [PersistValue]) -> m (a, [PersistValue])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, [PersistValue]
xs)) a
forall a. HasCallStack => a
undefined

primToPurePersistValues :: PrimitivePersistField a => a -> ([PersistValue] -> [PersistValue])
primToPurePersistValues :: a -> [PersistValue] -> [PersistValue]
primToPurePersistValues a
a = (a -> PersistValue
forall a. PrimitivePersistField a => a -> PersistValue
toPrimitivePersistValue a
a PersistValue -> [PersistValue] -> [PersistValue]
forall a. a -> [a] -> [a]
:)

primFromPurePersistValues :: PrimitivePersistField a => [PersistValue] -> (a, [PersistValue])
primFromPurePersistValues :: [PersistValue] -> (a, [PersistValue])
primFromPurePersistValues (PersistValue
x : [PersistValue]
xs) = (PersistValue -> a
forall a. PrimitivePersistField a => PersistValue -> a
fromPrimitivePersistValue PersistValue
x, [PersistValue]
xs)
primFromPurePersistValues [PersistValue]
xs = (\a
a -> String -> (a, [PersistValue])
forall a. HasCallStack => String -> a
error (a -> [PersistValue] -> String
forall a. PersistField a => a -> [PersistValue] -> String
failMessage a
a [PersistValue]
xs) (a, [PersistValue]) -> (a, [PersistValue]) -> (a, [PersistValue])
forall a. a -> a -> a
`asTypeOf` (a
a, [PersistValue]
xs)) a
forall a. HasCallStack => a
undefined

primToSinglePersistValue :: (PersistBackend m, PrimitivePersistField a) => a -> m PersistValue
primToSinglePersistValue :: a -> m PersistValue
primToSinglePersistValue a
a = PersistValue -> m PersistValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> PersistValue
forall a. PrimitivePersistField a => a -> PersistValue
toPrimitivePersistValue a
a)

primFromSinglePersistValue :: (PersistBackend m, PrimitivePersistField a) => PersistValue -> m a
primFromSinglePersistValue :: PersistValue -> m a
primFromSinglePersistValue PersistValue
a = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PersistValue -> a
forall a. PrimitivePersistField a => PersistValue -> a
fromPrimitivePersistValue PersistValue
a)

pureToPersistValue :: (PersistBackend m, PurePersistField a) => a -> m ([PersistValue] -> [PersistValue])
pureToPersistValue :: a -> m ([PersistValue] -> [PersistValue])
pureToPersistValue a
a = ([PersistValue] -> [PersistValue])
-> m ([PersistValue] -> [PersistValue])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> [PersistValue] -> [PersistValue]
forall a.
PurePersistField a =>
a -> [PersistValue] -> [PersistValue]
toPurePersistValues a
a)

pureFromPersistValue :: (PersistBackend m, PurePersistField a) => [PersistValue] -> m (a, [PersistValue])
pureFromPersistValue :: [PersistValue] -> m (a, [PersistValue])
pureFromPersistValue [PersistValue]
xs = (a, [PersistValue]) -> m (a, [PersistValue])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PersistValue] -> (a, [PersistValue])
forall a.
PurePersistField a =>
[PersistValue] -> (a, [PersistValue])
fromPurePersistValues [PersistValue]
xs)

singleToPersistValue :: (PersistBackend m, SinglePersistField a) => a -> m ([PersistValue] -> [PersistValue])
singleToPersistValue :: a -> m ([PersistValue] -> [PersistValue])
singleToPersistValue a
a = a -> m PersistValue
forall a (m :: * -> *).
(SinglePersistField a, PersistBackend m) =>
a -> m PersistValue
toSinglePersistValue a
a m PersistValue
-> (PersistValue -> m ([PersistValue] -> [PersistValue]))
-> m ([PersistValue] -> [PersistValue])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PersistValue
x -> ([PersistValue] -> [PersistValue])
-> m ([PersistValue] -> [PersistValue])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PersistValue
x PersistValue -> [PersistValue] -> [PersistValue]
forall a. a -> [a] -> [a]
:)

singleFromPersistValue :: (PersistBackend m, SinglePersistField a) => [PersistValue] -> m (a, [PersistValue])
singleFromPersistValue :: [PersistValue] -> m (a, [PersistValue])
singleFromPersistValue (PersistValue
x : [PersistValue]
xs) = PersistValue -> m a
forall a (m :: * -> *).
(SinglePersistField a, PersistBackend m) =>
PersistValue -> m a
fromSinglePersistValue PersistValue
x m a -> (a -> m (a, [PersistValue])) -> m (a, [PersistValue])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> (a, [PersistValue]) -> m (a, [PersistValue])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, [PersistValue]
xs)
singleFromPersistValue [PersistValue]
xs = (\a
a -> String -> m Any
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (a -> [PersistValue] -> String
forall a. PersistField a => a -> [PersistValue] -> String
failMessage a
a [PersistValue]
xs) m Any -> m (a, [PersistValue]) -> m (a, [PersistValue])
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (a, [PersistValue]) -> m (a, [PersistValue])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, [PersistValue]
xs)) a
forall a. HasCallStack => a
undefined

toSinglePersistValueUnique ::
  forall m v u.
  (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)), PrimitivePersistField (Key v (Unique u))) =>
  u (UniqueMarker v) ->
  v ->
  m PersistValue
toSinglePersistValueUnique :: u (UniqueMarker v) -> v -> m PersistValue
toSinglePersistValueUnique u (UniqueMarker v)
u v
v = u (UniqueMarker v) -> v -> m (Either (AutoKey v) (AutoKey v))
forall conn v (u :: (* -> *) -> *) (m :: * -> *).
(PersistBackendConn conn, PersistEntity v,
 IsUniqueKey (Key v (Unique u)), PersistBackend m, Conn m ~ conn) =>
u (UniqueMarker v) -> v -> m (Either (AutoKey v) (AutoKey v))
insertBy u (UniqueMarker v)
u v
v m (Either (AutoKey v) (AutoKey v))
-> m PersistValue -> m PersistValue
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Key v (Unique u) -> m PersistValue
forall (m :: * -> *) a.
(PersistBackend m, PrimitivePersistField a) =>
a -> m PersistValue
primToSinglePersistValue (v -> Key v (Unique u)
forall uKey v u. (IsUniqueKey uKey, uKey ~ Key v u) => v -> uKey
extractUnique v
v :: Key v (Unique u))

fromSinglePersistValueUnique ::
  forall m v u.
  (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)), PrimitivePersistField (Key v (Unique u))) =>
  u (UniqueMarker v) ->
  PersistValue ->
  m v
fromSinglePersistValueUnique :: u (UniqueMarker v) -> PersistValue -> m v
fromSinglePersistValueUnique u (UniqueMarker v)
_ PersistValue
x = Key v (Unique u) -> m (Maybe v)
forall conn v (u :: (* -> *) -> *) (m :: * -> *).
(PersistBackendConn conn, PersistEntity v,
 IsUniqueKey (Key v (Unique u)), PersistBackend m, Conn m ~ conn) =>
Key v (Unique u) -> m (Maybe v)
getBy (PersistValue -> Key v (Unique u)
forall a. PrimitivePersistField a => PersistValue -> a
fromPrimitivePersistValue PersistValue
x :: Key v (Unique u)) m (Maybe v) -> (Maybe v -> m v) -> m v
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m v -> (v -> m v) -> Maybe v -> m v
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m v
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m v) -> String -> m v
forall a b. (a -> b) -> a -> b
$ String
"No data with id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PersistValue -> String
forall a. Show a => a -> String
show PersistValue
x) v -> m v
forall (f :: * -> *) a. Applicative f => a -> f a
pure

toPersistValuesUnique ::
  forall m v u.
  (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u))) =>
  u (UniqueMarker v) ->
  v ->
  m ([PersistValue] -> [PersistValue])
toPersistValuesUnique :: u (UniqueMarker v) -> v -> m ([PersistValue] -> [PersistValue])
toPersistValuesUnique u (UniqueMarker v)
u v
v = u (UniqueMarker v) -> v -> m (Either (AutoKey v) (AutoKey v))
forall conn v (u :: (* -> *) -> *) (m :: * -> *).
(PersistBackendConn conn, PersistEntity v,
 IsUniqueKey (Key v (Unique u)), PersistBackend m, Conn m ~ conn) =>
u (UniqueMarker v) -> v -> m (Either (AutoKey v) (AutoKey v))
insertBy u (UniqueMarker v)
u v
v m (Either (AutoKey v) (AutoKey v))
-> m ([PersistValue] -> [PersistValue])
-> m ([PersistValue] -> [PersistValue])
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Key v (Unique u) -> m ([PersistValue] -> [PersistValue])
forall a (m :: * -> *).
(PersistField a, PersistBackend m) =>
a -> m ([PersistValue] -> [PersistValue])
toPersistValues (v -> Key v (Unique u)
forall uKey v u. (IsUniqueKey uKey, uKey ~ Key v u) => v -> uKey
extractUnique v
v :: Key v (Unique u))

fromPersistValuesUnique ::
  forall m v u.
  (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u))) =>
  u (UniqueMarker v) ->
  [PersistValue] ->
  m (v, [PersistValue])
fromPersistValuesUnique :: u (UniqueMarker v) -> [PersistValue] -> m (v, [PersistValue])
fromPersistValuesUnique u (UniqueMarker v)
_ [PersistValue]
xs = [PersistValue] -> m (Key v (Unique u), [PersistValue])
forall a (m :: * -> *).
(PersistField a, PersistBackend m) =>
[PersistValue] -> m (a, [PersistValue])
fromPersistValues [PersistValue]
xs m (Key v (Unique u), [PersistValue])
-> ((Key v (Unique u), [PersistValue]) -> m (v, [PersistValue]))
-> m (v, [PersistValue])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Key v (Unique u)
k, [PersistValue]
xs') -> Key v (Unique u) -> m (Maybe v)
forall conn v (u :: (* -> *) -> *) (m :: * -> *).
(PersistBackendConn conn, PersistEntity v,
 IsUniqueKey (Key v (Unique u)), PersistBackend m, Conn m ~ conn) =>
Key v (Unique u) -> m (Maybe v)
getBy (Key v (Unique u)
k :: Key v (Unique u)) m (Maybe v)
-> (Maybe v -> m (v, [PersistValue])) -> m (v, [PersistValue])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (v, [PersistValue])
-> (v -> m (v, [PersistValue])) -> Maybe v -> m (v, [PersistValue])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m (v, [PersistValue])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (v, [PersistValue]))
-> String -> m (v, [PersistValue])
forall a b. (a -> b) -> a -> b
$ String
"No data with id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [PersistValue] -> String
forall a. Show a => a -> String
show [PersistValue]
xs) (\v
v -> (v, [PersistValue]) -> m (v, [PersistValue])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (v
v, [PersistValue]
xs'))

toSinglePersistValueAutoKey ::
  forall m v.
  (PersistBackend m, PersistEntity v, PrimitivePersistField (AutoKey v)) =>
  v ->
  m PersistValue
toSinglePersistValueAutoKey :: v -> m PersistValue
toSinglePersistValueAutoKey v
a = v -> m (Either (AutoKey v) (AutoKey v))
forall conn v (m :: * -> *).
(PersistBackendConn conn, PersistEntity v, PersistBackend m,
 Conn m ~ conn) =>
v -> m (Either (AutoKey v) (AutoKey v))
insertByAll v
a m (Either (AutoKey v) (AutoKey v))
-> (Either (AutoKey v) (AutoKey v) -> m PersistValue)
-> m PersistValue
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AutoKey v -> m PersistValue
forall (m :: * -> *) a.
(PersistBackend m, PrimitivePersistField a) =>
a -> m PersistValue
primToSinglePersistValue (AutoKey v -> m PersistValue)
-> (Either (AutoKey v) (AutoKey v) -> AutoKey v)
-> Either (AutoKey v) (AutoKey v)
-> m PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AutoKey v -> AutoKey v)
-> (AutoKey v -> AutoKey v)
-> Either (AutoKey v) (AutoKey v)
-> AutoKey v
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either AutoKey v -> AutoKey v
forall a. a -> a
id AutoKey v -> AutoKey v
forall a. a -> a
id

fromSinglePersistValueAutoKey ::
  forall m v.
  (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) =>
  PersistValue ->
  m v
fromSinglePersistValueAutoKey :: PersistValue -> m v
fromSinglePersistValueAutoKey PersistValue
x = Key v BackendSpecific -> m (Maybe v)
forall conn v (m :: * -> *).
(PersistBackendConn conn, PersistEntity v,
 PrimitivePersistField (Key v BackendSpecific), PersistBackend m,
 Conn m ~ conn) =>
Key v BackendSpecific -> m (Maybe v)
get (PersistValue -> Key v BackendSpecific
forall a. PrimitivePersistField a => PersistValue -> a
fromPrimitivePersistValue PersistValue
x :: Key v BackendSpecific) m (Maybe v) -> (Maybe v -> m v) -> m v
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m v -> (v -> m v) -> Maybe v -> m v
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m v
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m v) -> String -> m v
forall a b. (a -> b) -> a -> b
$ String
"No data with id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PersistValue -> String
forall a. Show a => a -> String
show PersistValue
x) v -> m v
forall (f :: * -> *) a. Applicative f => a -> f a
pure

replaceOne :: (Eq x, Show x) => String -> (a -> x) -> (b -> x) -> (a -> b -> b) -> a -> [b] -> [b]
replaceOne :: String -> (a -> x) -> (b -> x) -> (a -> b -> b) -> a -> [b] -> [b]
replaceOne String
what a -> x
getter1 b -> x
getter2 a -> b -> b
apply a
a [b]
bs = case (b -> Bool) -> [b] -> [b]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a -> x
getter1 a
a x -> x -> Bool
forall a. Eq a => a -> a -> Bool
==) (x -> Bool) -> (b -> x) -> b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> x
getter2) [b]
bs of
  [b
_] -> (b -> b) -> [b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (\b
b -> if a -> x
getter1 a
a x -> x -> Bool
forall a. Eq a => a -> a -> Bool
== b -> x
getter2 b
b then a -> b -> b
apply a
a b
b else b
b) [b]
bs
  [] -> String -> [b]
forall a. HasCallStack => String -> a
error (String -> [b]) -> String -> [b]
forall a b. (a -> b) -> a -> b
$ String
"Not found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
what String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ x -> String
forall a. Show a => a -> String
show (a -> x
getter1 a
a)
  [b]
_ -> String -> [b]
forall a. HasCallStack => String -> a
error (String -> [b]) -> String -> [b]
forall a b. (a -> b) -> a -> b
$ String
"Found more than one " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
what String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ x -> String
forall a. Show a => a -> String
show (a -> x
getter1 a
a)

findOne :: (Eq x, Show x) => String -> (a -> x) -> x -> [a] -> a
findOne :: String -> (a -> x) -> x -> [a] -> a
findOne String
what a -> x
getter x
x [a]
as = case (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter ((x
x x -> x -> Bool
forall a. Eq a => a -> a -> Bool
==) (x -> Bool) -> (a -> x) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> x
getter) [a]
as of
  [a
a] -> a
a
  [] -> String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Not found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
what String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ x -> String
forall a. Show a => a -> String
show x
x
  [a]
_ -> String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Found more than one " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
what String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ x -> String
forall a. Show a => a -> String
show x
x

-- | Returns only old elements, only new elements, and matched pairs (old, new).
-- The new ones exist only in datatype, the old are present only in DB, match is typically by name (the properties of the matched elements may differ).
matchElements :: Show a => (a -> b -> Bool) -> [a] -> [b] -> ([a], [b], [(a, b)])
matchElements :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [b], [(a, b)])
matchElements a -> b -> Bool
eq [a]
oldElems [b]
newElems = (b -> ([a], [b], [(a, b)]) -> ([a], [b], [(a, b)]))
-> ([a], [b], [(a, b)]) -> [b] -> ([a], [b], [(a, b)])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr b -> ([a], [b], [(a, b)]) -> ([a], [b], [(a, b)])
f ([a]
oldElems, [], []) [b]
newElems
  where
    f :: b -> ([a], [b], [(a, b)]) -> ([a], [b], [(a, b)])
f b
new ([a]
olds, [b]
news, [(a, b)]
matches) = case (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (a -> b -> Bool
`eq` b
new) [a]
olds of
      ([], [a]
rest) -> ([a]
rest, b
new b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
news, [(a, b)]
matches)
      ([a
old], [a]
rest) -> ([a]
rest, [b]
news, (a
old, b
new) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
matches)
      ([a]
xs, [a]
_) -> String -> ([a], [b], [(a, b)])
forall a. HasCallStack => String -> a
error (String -> ([a], [b], [(a, b)])) -> String -> ([a], [b], [(a, b)])
forall a b. (a -> b) -> a -> b
$ String
"matchElements: more than one element matched " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => a -> String
show [a]
xs

haveSameElems :: Show a => (a -> b -> Bool) -> [a] -> [b] -> Bool
haveSameElems :: (a -> b -> Bool) -> [a] -> [b] -> Bool
haveSameElems a -> b -> Bool
p [a]
xs [b]
ys = case (a -> b -> Bool) -> [a] -> [b] -> ([a], [b], [(a, b)])
forall a b.
Show a =>
(a -> b -> Bool) -> [a] -> [b] -> ([a], [b], [(a, b)])
matchElements a -> b -> Bool
p [a]
xs [b]
ys of
  ([], [], [(a, b)]
_) -> Bool
True
  ([a], [b], [(a, b)])
_ -> Bool
False

phantomDb :: PersistBackend m => m (proxy (Conn m))
phantomDb :: m (proxy (Conn m))
phantomDb = proxy (Conn m) -> m (proxy (Conn m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (proxy (Conn m) -> m (proxy (Conn m)))
-> proxy (Conn m) -> m (proxy (Conn m))
forall a b. (a -> b) -> a -> b
$ String -> proxy (Conn m)
forall a. HasCallStack => String -> a
error String
"phantomDb"

getDefaultAutoKeyType :: DbDescriptor db => proxy db -> DbTypePrimitive
getDefaultAutoKeyType :: proxy db -> DbTypePrimitive
getDefaultAutoKeyType proxy db
proxy = case proxy db -> AutoKeyType db -> DbType
forall a db (proxy :: * -> *).
(PersistField a, DbDescriptor db) =>
proxy db -> a -> DbType
dbType proxy db
proxy ((forall a. HasCallStack => a
forall (proxy :: * -> *) db. proxy db -> AutoKeyType db
undefined :: proxy db -> AutoKeyType db) proxy db
proxy) of
  DbTypePrimitive DbTypePrimitive
t Bool
_ Maybe String
_ Maybe ParentTableReference
_ -> DbTypePrimitive
t
  DbType
t -> String -> DbTypePrimitive
forall a. HasCallStack => String -> a
error (String -> DbTypePrimitive) -> String -> DbTypePrimitive
forall a b. (a -> b) -> a -> b
$ String
"getDefaultAutoKeyType: unexpected key type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DbType -> String
forall a. Show a => a -> String
show DbType
t

firstRow :: MonadIO m => RowStream a -> m (Maybe a)
firstRow :: RowStream a -> m (Maybe a)
firstRow RowStream a
s = IO (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> m (Maybe a)) -> IO (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ RowStream a -> (IO (Maybe a) -> IO (Maybe a)) -> IO (Maybe a)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with RowStream a
s IO (Maybe a) -> IO (Maybe a)
forall a. a -> a
id

streamToList :: MonadIO m => RowStream a -> m [a]
streamToList :: RowStream a -> m [a]
streamToList RowStream a
s = IO [a] -> m [a]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [a] -> m [a]) -> IO [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ RowStream a -> (IO (Maybe a) -> IO [a]) -> IO [a]
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with RowStream a
s IO (Maybe a) -> IO [a]
forall (m :: * -> *) a. Monad m => m (Maybe a) -> m [a]
go
  where
    go :: m (Maybe a) -> m [a]
go m (Maybe a)
next = m (Maybe a)
next m (Maybe a) -> (Maybe a -> m [a]) -> m [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m [a] -> (a -> m [a]) -> Maybe a -> m [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([a] -> m [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (\a
a -> ([a] -> [a]) -> m [a] -> m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) (m (Maybe a) -> m [a]
go m (Maybe a)
next))

mapStream :: PersistBackendConn conn => (a -> Action conn b) -> RowStream a -> Action conn (RowStream b)
mapStream :: (a -> Action conn b) -> RowStream a -> Action conn (RowStream b)
mapStream a -> Action conn b
f RowStream a
s = do
  conn
conn <- ReaderT conn IO conn
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let apply :: IO (Maybe a) -> IO (Maybe b)
apply IO (Maybe a)
next =
        IO (Maybe a)
next IO (Maybe a) -> (Maybe a -> IO (Maybe b)) -> IO (Maybe b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe a
Nothing -> Maybe b -> IO (Maybe b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe b
forall a. Maybe a
Nothing
          Just a
a' -> b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b) -> IO b -> IO (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action conn b -> conn -> IO b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> Action conn b
f a
a') conn
conn
  RowStream b -> Action conn (RowStream b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RowStream b -> Action conn (RowStream b))
-> RowStream b -> Action conn (RowStream b)
forall a b. (a -> b) -> a -> b
$ (IO (Maybe a) -> IO (Maybe b)) -> RowStream a -> RowStream b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IO (Maybe a) -> IO (Maybe b)
apply RowStream a
s

joinStreams :: [Action conn (RowStream a)] -> Action conn (RowStream a)
joinStreams :: [Action conn (RowStream a)] -> Action conn (RowStream a)
joinStreams [Action conn (RowStream a)]
streams = do
  conn
conn <- ReaderT conn IO conn
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IORef
  ((IO (Maybe a), ReleaseType -> IO ()), [Action conn (RowStream a)])
var <- IO
  (IORef
     ((IO (Maybe a), ReleaseType -> IO ()),
      [Action conn (RowStream a)]))
-> ReaderT
     conn
     IO
     (IORef
        ((IO (Maybe a), ReleaseType -> IO ()),
         [Action conn (RowStream a)]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (IORef
      ((IO (Maybe a), ReleaseType -> IO ()),
       [Action conn (RowStream a)]))
 -> ReaderT
      conn
      IO
      (IORef
         ((IO (Maybe a), ReleaseType -> IO ()),
          [Action conn (RowStream a)])))
-> IO
     (IORef
        ((IO (Maybe a), ReleaseType -> IO ()),
         [Action conn (RowStream a)]))
-> ReaderT
     conn
     IO
     (IORef
        ((IO (Maybe a), ReleaseType -> IO ()),
         [Action conn (RowStream a)]))
forall a b. (a -> b) -> a -> b
$ ((IO (Maybe a), ReleaseType -> IO ()), [Action conn (RowStream a)])
-> IO
     (IORef
        ((IO (Maybe a), ReleaseType -> IO ()),
         [Action conn (RowStream a)]))
forall a. a -> IO (IORef a)
newIORef ((Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing, IO () -> ReleaseType -> IO ()
forall a b. a -> b -> a
const (IO () -> ReleaseType -> IO ()) -> IO () -> ReleaseType -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()), [Action conn (RowStream a)]
streams)
  RowStream a -> Action conn (RowStream a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RowStream a -> Action conn (RowStream a))
-> RowStream a -> Action conn (RowStream a)
forall a b. (a -> b) -> a -> b
$
    ((forall b. IO b -> IO b) -> IO (Allocated (IO (Maybe a))))
-> RowStream a
forall a.
((forall b. IO b -> IO b) -> IO (Allocated a)) -> Acquire a
Acquire (((forall b. IO b -> IO b) -> IO (Allocated (IO (Maybe a))))
 -> RowStream a)
-> ((forall b. IO b -> IO b) -> IO (Allocated (IO (Maybe a))))
-> RowStream a
forall a b. (a -> b) -> a -> b
$ \forall b. IO b -> IO b
restore -> do
      let joinedNext :: IO (Maybe a)
joinedNext = do
            ((IO (Maybe a)
next, ReleaseType -> IO ()
close), [Action conn (RowStream a)]
queue) <- IORef
  ((IO (Maybe a), ReleaseType -> IO ()), [Action conn (RowStream a)])
-> IO
     ((IO (Maybe a), ReleaseType -> IO ()), [Action conn (RowStream a)])
forall a. IORef a -> IO a
readIORef IORef
  ((IO (Maybe a), ReleaseType -> IO ()), [Action conn (RowStream a)])
var
            Maybe a
val <- IO (Maybe a)
next
            case Maybe a
val of
              Maybe a
Nothing -> case [Action conn (RowStream a)]
queue of
                [] -> Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
                (Action conn (RowStream a)
makeStream : [Action conn (RowStream a)]
queue') -> do
                  ReleaseType -> IO ()
close ReleaseType
ReleaseNormal
                  Acquire (forall b. IO b -> IO b) -> IO (Allocated (IO (Maybe a)))
f <- Action conn (RowStream a) -> conn -> IO (RowStream a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Action conn (RowStream a)
makeStream conn
conn
                  Allocated IO (Maybe a)
next' ReleaseType -> IO ()
close' <- (forall b. IO b -> IO b) -> IO (Allocated (IO (Maybe a)))
f forall b. IO b -> IO b
restore
                  IORef
  ((IO (Maybe a), ReleaseType -> IO ()), [Action conn (RowStream a)])
-> ((IO (Maybe a), ReleaseType -> IO ()),
    [Action conn (RowStream a)])
-> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef
  ((IO (Maybe a), ReleaseType -> IO ()), [Action conn (RowStream a)])
var ((IO (Maybe a)
next', ReleaseType -> IO ()
close'), [Action conn (RowStream a)]
queue')
                  IO (Maybe a)
joinedNext
              Just a
a -> Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a
          joinedClose :: ReleaseType -> IO ()
joinedClose ReleaseType
typ = IORef
  ((IO (Maybe a), ReleaseType -> IO ()), [Action conn (RowStream a)])
-> IO
     ((IO (Maybe a), ReleaseType -> IO ()), [Action conn (RowStream a)])
forall a. IORef a -> IO a
readIORef IORef
  ((IO (Maybe a), ReleaseType -> IO ()), [Action conn (RowStream a)])
var IO
  ((IO (Maybe a), ReleaseType -> IO ()), [Action conn (RowStream a)])
-> (((IO (Maybe a), ReleaseType -> IO ()),
     [Action conn (RowStream a)])
    -> IO ())
-> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \((IO (Maybe a)
_, ReleaseType -> IO ()
close), [Action conn (RowStream a)]
_) -> ReleaseType -> IO ()
close ReleaseType
typ
      Allocated (IO (Maybe a)) -> IO (Allocated (IO (Maybe a)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Allocated (IO (Maybe a)) -> IO (Allocated (IO (Maybe a))))
-> Allocated (IO (Maybe a)) -> IO (Allocated (IO (Maybe a)))
forall a b. (a -> b) -> a -> b
$ IO (Maybe a) -> (ReleaseType -> IO ()) -> Allocated (IO (Maybe a))
forall a. a -> (ReleaseType -> IO ()) -> Allocated a
Allocated IO (Maybe a)
joinedNext ReleaseType -> IO ()
joinedClose

getUniqueFields :: UniqueDef' str (Either field str) -> [field]
getUniqueFields :: UniqueDef' str (Either field str) -> [field]
getUniqueFields (UniqueDef Maybe str
_ UniqueType
_ [Either field str]
uFields) = (Either field str -> field) -> [Either field str] -> [field]
forall a b. (a -> b) -> [a] -> [b]
map ((field -> field) -> (str -> field) -> Either field str -> field
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either field -> field
forall a. a -> a
id (String -> str -> field
forall a. HasCallStack => String -> a
error String
"A unique key may not contain expressions")) [Either field str]
uFields

isSimple :: [ConstructorDef] -> Bool
isSimple :: [ConstructorDef] -> Bool
isSimple [ConstructorDef
_] = Bool
True
isSimple [ConstructorDef]
_ = Bool
False