{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Database.Groundhog.Generic
(
createMigration,
executeMigration,
executeMigrationSilent,
executeMigrationUnsafe,
runMigration,
runMigrationSilent,
runMigrationUnsafe,
getQueries,
printMigration,
mergeMigrations,
primToPersistValue,
primFromPersistValue,
primToPurePersistValues,
primFromPurePersistValues,
primToSinglePersistValue,
primFromSinglePersistValue,
pureToPersistValue,
pureFromPersistValue,
singleToPersistValue,
singleFromPersistValue,
toSinglePersistValueUnique,
fromSinglePersistValueUnique,
toPersistValuesUnique,
fromPersistValuesUnique,
toSinglePersistValueAutoKey,
fromSinglePersistValueAutoKey,
failMessage,
failMessageNamed,
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)
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
getQueries ::
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 []
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
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
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
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
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
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
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
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 =>
m a ->
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 =>
m a ->
(a -> m b) ->
(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
{
PSFieldDef str -> str
psFieldName :: str,
PSFieldDef str -> Maybe str
psDbFieldName :: Maybe str,
PSFieldDef str -> Maybe str
psDbTypeName :: Maybe str,
PSFieldDef str -> Maybe str
psExprName :: Maybe str,
PSFieldDef str -> Maybe [PSFieldDef str]
psEmbeddedDef :: Maybe [PSFieldDef str],
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),
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
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