{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

-- | This @Internal@ module may have breaking changes that will not be reflected
-- in major version bumps. Please use "Database.Persist.Quasi" instead. If you
-- need something in this module, please file an issue on GitHub.
--
-- @since 2.13.0.0
module Database.Persist.Quasi.Internal
    ( parse
    , PersistSettings (..)
    , upperCaseSettings
    , lowerCaseSettings
    , Token (..)
    , SourceLoc (..)
    , sourceLocFromTHLoc
    , parseFieldType
    , takeColsEx
    , CumulativeParseResult
    , renderErrors
    , parserWarningMessage

      -- * UnboundEntityDef
    , UnboundEntityDef (..)
    , getUnboundEntityNameHS
    , unbindEntityDef
    , getUnboundFieldDefs
    , UnboundForeignDef (..)
    , getSqlNameOr
    , UnboundFieldDef (..)
    , UnboundCompositeDef (..)
    , UnboundIdDef (..)
    , unbindFieldDef
    , isUnboundFieldNullable
    , unboundIdDefToFieldDef
    , PrimarySpec (..)
    , mkAutoIdField'
    , UnboundForeignFieldList (..)
    , ForeignFieldReference (..)
    , mkKeyConType
    , isHaskellUnboundField
    , FieldTypeLit (..)
    ) where

import Prelude hiding (lines)

import Control.Applicative (Alternative ((<|>)))
import Control.Monad
import Data.Char (isDigit, isLower, isSpace, isUpper, toLower)
import Data.Foldable (toList)
import Data.List (find, foldl')
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NEL
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Monoid (mappend)
import Data.Text (Text)
import qualified Data.Text as T
import Database.Persist.EntityDef.Internal
import Database.Persist.Quasi.PersistSettings
import Database.Persist.Quasi.PersistSettings.Internal ( psToFKName
                                                       , psToDBName
                                                       , psIdName
                                                       , psStrictFields
                                                       )
import Database.Persist.Quasi.Internal.ModelParser
import Database.Persist.Types
import Database.Persist.Types.Base
import Language.Haskell.TH.Syntax (Lift, Loc (..))
import qualified Text.Read as R

data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving (Int -> ParseState a -> ShowS
[ParseState a] -> ShowS
ParseState a -> [Char]
(Int -> ParseState a -> ShowS)
-> (ParseState a -> [Char])
-> ([ParseState a] -> ShowS)
-> Show (ParseState a)
forall a. Show a => Int -> ParseState a -> ShowS
forall a. Show a => [ParseState a] -> ShowS
forall a. Show a => ParseState a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> ParseState a -> ShowS
showsPrec :: Int -> ParseState a -> ShowS
$cshow :: forall a. Show a => ParseState a -> [Char]
show :: ParseState a -> [Char]
$cshowList :: forall a. Show a => [ParseState a] -> ShowS
showList :: [ParseState a] -> ShowS
Show)

parseFieldType :: Text -> Either String FieldType
parseFieldType :: Text -> Either [Char] FieldType
parseFieldType Text
t0 =
    case Text -> ParseState FieldType
parseApplyFT Text
t0 of
        PSSuccess FieldType
ft Text
t'
            | (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isSpace Text
t' -> FieldType -> Either [Char] FieldType
forall a b. b -> Either a b
Right FieldType
ft
        PSFail [Char]
err -> [Char] -> Either [Char] FieldType
forall a b. a -> Either a b
Left ([Char] -> Either [Char] FieldType)
-> [Char] -> Either [Char] FieldType
forall a b. (a -> b) -> a -> b
$ [Char]
"PSFail " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
err
        ParseState FieldType
other -> [Char] -> Either [Char] FieldType
forall a b. a -> Either a b
Left ([Char] -> Either [Char] FieldType)
-> [Char] -> Either [Char] FieldType
forall a b. (a -> b) -> a -> b
$ ParseState FieldType -> [Char]
forall a. Show a => a -> [Char]
show ParseState FieldType
other
  where
    parseApplyFT :: Text -> ParseState FieldType
    parseApplyFT :: Text -> ParseState FieldType
parseApplyFT Text
t =
        case ([FieldType] -> [FieldType]) -> Text -> ParseState [FieldType]
forall a. ([FieldType] -> a) -> Text -> ParseState a
goMany [FieldType] -> [FieldType]
forall a. a -> a
id Text
t of
            PSSuccess (FieldType
ft : [FieldType]
fts) Text
t' -> FieldType -> Text -> ParseState FieldType
forall a. a -> Text -> ParseState a
PSSuccess ((FieldType -> FieldType -> FieldType)
-> FieldType -> [FieldType] -> FieldType
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' FieldType -> FieldType -> FieldType
FTApp FieldType
ft [FieldType]
fts) Text
t'
            PSSuccess [] Text
_ -> [Char] -> ParseState FieldType
forall a. [Char] -> ParseState a
PSFail [Char]
"empty"
            PSFail [Char]
err -> [Char] -> ParseState FieldType
forall a. [Char] -> ParseState a
PSFail [Char]
err
            ParseState [FieldType]
PSDone -> ParseState FieldType
forall a. ParseState a
PSDone

    parseEnclosed
        :: Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType
    parseEnclosed :: Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType
parseEnclosed Char
end FieldType -> FieldType
ftMod Text
t =
        let
            (Text
a, Text
b) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
end) Text
t
         in
            case Text -> ParseState FieldType
parseApplyFT Text
a of
                PSSuccess FieldType
ft Text
t' -> case ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
t', Text -> Maybe (Char, Text)
T.uncons Text
b) of
                    (Text
"", Just (Char
c, Text
t'')) | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
end -> FieldType -> Text -> ParseState FieldType
forall a. a -> Text -> ParseState a
PSSuccess (FieldType -> FieldType
ftMod FieldType
ft) (Text
t'' Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`Data.Monoid.mappend` Text
t')
                    (Text
x, Maybe (Char, Text)
y) -> [Char] -> ParseState FieldType
forall a. [Char] -> ParseState a
PSFail ([Char] -> ParseState FieldType) -> [Char] -> ParseState FieldType
forall a b. (a -> b) -> a -> b
$ (Text, Text, Maybe (Char, Text)) -> [Char]
forall a. Show a => a -> [Char]
show (Text
b, Text
x, Maybe (Char, Text)
y)
                ParseState FieldType
x -> [Char] -> ParseState FieldType
forall a. [Char] -> ParseState a
PSFail ([Char] -> ParseState FieldType) -> [Char] -> ParseState FieldType
forall a b. (a -> b) -> a -> b
$ ParseState FieldType -> [Char]
forall a. Show a => a -> [Char]
show ParseState FieldType
x

    parse1 :: Text -> ParseState FieldType
    parse1 :: Text -> ParseState FieldType
parse1 Text
t = ParseState FieldType
-> Maybe (ParseState FieldType) -> ParseState FieldType
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> ParseState FieldType
forall a. [Char] -> ParseState a
PSFail (Text -> [Char]
forall a. Show a => a -> [Char]
show Text
t)) (Maybe (ParseState FieldType) -> ParseState FieldType)
-> Maybe (ParseState FieldType) -> ParseState FieldType
forall a b. (a -> b) -> a -> b
$ do
        case Text -> Maybe (Char, Text)
T.uncons Text
t of
            Maybe (Char, Text)
Nothing -> ParseState FieldType -> Maybe (ParseState FieldType)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParseState FieldType
forall a. ParseState a
PSDone
            Just (Char
x, Text
xs) ->
                Char -> Text -> Maybe (ParseState FieldType)
parseSpace Char
x Text
xs
                    Maybe (ParseState FieldType)
-> Maybe (ParseState FieldType) -> Maybe (ParseState FieldType)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Text -> Maybe (ParseState FieldType)
forall {m :: * -> *}.
(Monad m, Alternative m) =>
Char -> Text -> m (ParseState FieldType)
parseParenEnclosed Char
x Text
xs
                    Maybe (ParseState FieldType)
-> Maybe (ParseState FieldType) -> Maybe (ParseState FieldType)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Text -> Maybe (ParseState FieldType)
forall {m :: * -> *}.
(Monad m, Alternative m) =>
Char -> Text -> m (ParseState FieldType)
parseList Char
x Text
xs
                    Maybe (ParseState FieldType)
-> Maybe (ParseState FieldType) -> Maybe (ParseState FieldType)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Text -> Maybe (ParseState FieldType)
parseNumericLit Char
x Text
xs
                    Maybe (ParseState FieldType)
-> Maybe (ParseState FieldType) -> Maybe (ParseState FieldType)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Text -> Maybe (ParseState FieldType)
parseTextLit Char
x Text
xs
                    Maybe (ParseState FieldType)
-> Maybe (ParseState FieldType) -> Maybe (ParseState FieldType)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Text -> Maybe (ParseState FieldType)
forall {m :: * -> *}.
(Monad m, Alternative m) =>
Char -> Text -> m (ParseState FieldType)
parseTypeCon Char
x Text
xs

    parseSpace :: Char -> Text -> Maybe (ParseState FieldType)
    parseSpace :: Char -> Text -> Maybe (ParseState FieldType)
parseSpace Char
c Text
t = do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char -> Bool
isSpace Char
c)
        ParseState FieldType -> Maybe (ParseState FieldType)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseState FieldType -> Maybe (ParseState FieldType))
-> ParseState FieldType -> Maybe (ParseState FieldType)
forall a b. (a -> b) -> a -> b
$ Text -> ParseState FieldType
parse1 ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
t)

    parseParenEnclosed :: Char -> Text -> m (ParseState FieldType)
parseParenEnclosed Char
c Text
t = do
        Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(')
        ParseState FieldType -> m (ParseState FieldType)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseState FieldType -> m (ParseState FieldType))
-> ParseState FieldType -> m (ParseState FieldType)
forall a b. (a -> b) -> a -> b
$ Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType
parseEnclosed Char
')' FieldType -> FieldType
forall a. a -> a
id Text
t

    parseList :: Char -> Text -> m (ParseState FieldType)
parseList Char
c Text
t = do
        Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'[')
        ParseState FieldType -> m (ParseState FieldType)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseState FieldType -> m (ParseState FieldType))
-> ParseState FieldType -> m (ParseState FieldType)
forall a b. (a -> b) -> a -> b
$ Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType
parseEnclosed Char
']' FieldType -> FieldType
FTList Text
t

    parseTextLit :: Char -> Text -> Maybe (ParseState FieldType)
    parseTextLit :: Char -> Text -> Maybe (ParseState FieldType)
parseTextLit Char
c Text
t = do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"')
        let
            (Text
a, Text
b) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"') Text
t
            lit :: FieldType
lit = FieldTypeLit -> FieldType
FTLit (Text -> FieldTypeLit
TextTypeLit Text
a)
        ParseState FieldType -> Maybe (ParseState FieldType)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseState FieldType -> Maybe (ParseState FieldType))
-> ParseState FieldType -> Maybe (ParseState FieldType)
forall a b. (a -> b) -> a -> b
$ FieldType -> Text -> ParseState FieldType
forall a. a -> Text -> ParseState a
PSSuccess FieldType
lit (Int -> Text -> Text
T.drop Int
1 Text
b)

    parseNumericLit :: Char -> Text -> Maybe (ParseState FieldType)
    parseNumericLit :: Char -> Text -> Maybe (ParseState FieldType)
parseNumericLit Char
c Text
t = do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isDigit Text
t)
        let
            (Text
a, Text
b) = Text -> (Text, Text)
breakAtNextSpace Text
t
        FieldType
lit <- FieldTypeLit -> FieldType
FTLit (FieldTypeLit -> FieldType)
-> (Integer -> FieldTypeLit) -> Integer -> FieldType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> FieldTypeLit
IntTypeLit (Integer -> FieldType) -> Maybe Integer -> Maybe FieldType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Integer
forall a. Read a => Text -> Maybe a
readMaybe (Char -> Text -> Text
T.cons Char
c Text
a)
        ParseState FieldType -> Maybe (ParseState FieldType)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseState FieldType -> Maybe (ParseState FieldType))
-> ParseState FieldType -> Maybe (ParseState FieldType)
forall a b. (a -> b) -> a -> b
$ FieldType -> Text -> ParseState FieldType
forall a. a -> Text -> ParseState a
PSSuccess FieldType
lit Text
b

    parseTypeCon :: Char -> Text -> m (ParseState FieldType)
parseTypeCon Char
c Text
t = do
        Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'')
        let
            (Text
a, Text
b) = Text -> (Text, Text)
breakAtNextSpace Text
t
        ParseState FieldType -> m (ParseState FieldType)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseState FieldType -> m (ParseState FieldType))
-> ParseState FieldType -> m (ParseState FieldType)
forall a b. (a -> b) -> a -> b
$ FieldType -> Text -> ParseState FieldType
forall a. a -> Text -> ParseState a
PSSuccess (Char -> Text -> FieldType
parseFieldTypePiece Char
c Text
a) Text
b

    goMany :: ([FieldType] -> a) -> Text -> ParseState a
    goMany :: forall a. ([FieldType] -> a) -> Text -> ParseState a
goMany [FieldType] -> a
front Text
t =
        case Text -> ParseState FieldType
parse1 Text
t of
            PSSuccess FieldType
x Text
t' -> ([FieldType] -> a) -> Text -> ParseState a
forall a. ([FieldType] -> a) -> Text -> ParseState a
goMany ([FieldType] -> a
front ([FieldType] -> a)
-> ([FieldType] -> [FieldType]) -> [FieldType] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldType
x FieldType -> [FieldType] -> [FieldType]
forall a. a -> [a] -> [a]
:)) Text
t'
            PSFail [Char]
err -> [Char] -> ParseState a
forall a. [Char] -> ParseState a
PSFail [Char]
err
            ParseState FieldType
PSDone -> a -> Text -> ParseState a
forall a. a -> Text -> ParseState a
PSSuccess ([FieldType] -> a
front []) Text
t

breakAtNextSpace :: Text -> (Text, Text)
breakAtNextSpace :: Text -> (Text, Text)
breakAtNextSpace =
    (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isSpace

parseFieldTypePiece :: Char -> Text -> FieldType
parseFieldTypePiece :: Char -> Text -> FieldType
parseFieldTypePiece Char
fstChar Text
rest =
    case Char
fstChar of
        Char
'\'' ->
            Text -> FieldType
FTTypePromoted Text
rest
        Char
_ ->
            let
                t :: Text
t = Char -> Text -> Text
T.cons Char
fstChar Text
rest
             in
                case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd Text
"." Text
t of
                    (Text
_, Text
"") -> Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing Text
t
                    (Text
"", Text
_) -> Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing Text
t
                    (Text
a, Text
b) -> Maybe Text -> Text -> FieldType
FTTypeCon (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text
Text -> Text
T.init Text
a) Text
b

sourceLocFromTHLoc :: Loc -> SourceLoc
sourceLocFromTHLoc :: Loc -> SourceLoc
sourceLocFromTHLoc Loc{loc_filename :: Loc -> [Char]
loc_filename = [Char]
filename, loc_start :: Loc -> CharPos
loc_start = CharPos
start} =
    SourceLoc
        { locFile :: Text
locFile = [Char] -> Text
T.pack [Char]
filename
        , locStartLine :: Int
locStartLine = CharPos -> Int
forall a b. (a, b) -> a
fst CharPos
start
        , locStartCol :: Int
locStartCol = CharPos -> Int
forall a b. (a, b) -> b
snd CharPos
start
        }

-- | Parses a quasi-quoted syntax into a list of entity definitions.
parse
  :: PersistSettings
  -> [(Maybe SourceLoc, Text)]
  -> CumulativeParseResult [UnboundEntityDef]
parse :: PersistSettings
-> [(Maybe SourceLoc, Text)]
-> CumulativeParseResult [UnboundEntityDef]
parse PersistSettings
ps [(Maybe SourceLoc, Text)]
chunks = [ParseResult [UnboundEntityDef]]
-> CumulativeParseResult [UnboundEntityDef]
forall a. Monoid a => [ParseResult a] -> CumulativeParseResult a
toCumulativeParseResult ([ParseResult [UnboundEntityDef]]
 -> CumulativeParseResult [UnboundEntityDef])
-> [ParseResult [UnboundEntityDef]]
-> CumulativeParseResult [UnboundEntityDef]
forall a b. (a -> b) -> a -> b
$ ((Maybe SourceLoc, Text) -> ParseResult [UnboundEntityDef])
-> [(Maybe SourceLoc, Text)] -> [ParseResult [UnboundEntityDef]]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe SourceLoc, Text) -> ParseResult [UnboundEntityDef]
parseChunk [(Maybe SourceLoc, Text)]
chunks
  where
    parseChunk :: (Maybe SourceLoc, Text) -> ParseResult [UnboundEntityDef]
    parseChunk :: (Maybe SourceLoc, Text) -> ParseResult [UnboundEntityDef]
parseChunk (Maybe SourceLoc
mSourceLoc, Text
source) =
      (([ParsedEntityDef] -> [UnboundEntityDef])
-> Either (ParseErrorBundle [Char] Void) [ParsedEntityDef]
-> Either (ParseErrorBundle [Char] Void) [UnboundEntityDef]
forall a b.
(a -> b)
-> Either (ParseErrorBundle [Char] Void) a
-> Either (ParseErrorBundle [Char] Void) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([ParsedEntityDef] -> [UnboundEntityDef])
 -> Either (ParseErrorBundle [Char] Void) [ParsedEntityDef]
 -> Either (ParseErrorBundle [Char] Void) [UnboundEntityDef])
-> ((ParsedEntityDef -> UnboundEntityDef)
    -> [ParsedEntityDef] -> [UnboundEntityDef])
-> (ParsedEntityDef -> UnboundEntityDef)
-> Either (ParseErrorBundle [Char] Void) [ParsedEntityDef]
-> Either (ParseErrorBundle [Char] Void) [UnboundEntityDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParsedEntityDef -> UnboundEntityDef)
-> [ParsedEntityDef] -> [UnboundEntityDef]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (PersistSettings -> ParsedEntityDef -> UnboundEntityDef
mkUnboundEntityDef PersistSettings
ps) (Either (ParseErrorBundle [Char] Void) [ParsedEntityDef]
 -> Either (ParseErrorBundle [Char] Void) [UnboundEntityDef])
-> (Set ParserWarning,
    Either (ParseErrorBundle [Char] Void) [ParsedEntityDef])
-> ParseResult [UnboundEntityDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistSettings
-> Maybe SourceLoc
-> Text
-> (Set ParserWarning,
    Either (ParseErrorBundle [Char] Void) [ParsedEntityDef])
parseSource PersistSettings
ps Maybe SourceLoc
mSourceLoc Text
source

entityNamesFromParsedDef
    :: PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB)
entityNamesFromParsedDef :: PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB)
entityNamesFromParsedDef PersistSettings
ps ParsedEntityDef
parsedEntDef = (EntityNameHS
entNameHS, EntityNameDB
entNameDB)
  where
    entNameHS :: EntityNameHS
entNameHS =
        ParsedEntityDef -> EntityNameHS
parsedEntityDefEntityName ParsedEntityDef
parsedEntDef

    entNameDB :: EntityNameDB
entNameDB =
        Text -> EntityNameDB
EntityNameDB (Text -> EntityNameDB) -> Text -> EntityNameDB
forall a b. (a -> b) -> a -> b
$
            PersistSettings -> Text -> [Text] -> Text
getDbName
                PersistSettings
ps
                (EntityNameHS -> Text
unEntityNameHS EntityNameHS
entNameHS)
                (ParsedEntityDef -> [Text]
parsedEntityDefEntityAttributes ParsedEntityDef
parsedEntDef)

-- | This type represents an @Id@ declaration in the QuasiQuoted syntax.
--
-- > Id
--
-- This uses the implied settings, and is equivalent to omitting the @Id@
-- statement entirely.
--
-- > Id Text
--
-- This will set the field type of the ID to be 'Text'.
--
-- > Id Text sql=foo_id
--
-- This will set the field type of the Id to be 'Text' and the SQL DB name to be @foo_id@.
--
-- > Id FooId
--
-- This results in a shared primary key - the @FooId@ refers to a @Foo@ table.
--
-- > Id FooId OnDelete Cascade
--
-- You can set a cascade behavior on an ID column.
--
-- @since 2.13.0.0
data UnboundIdDef = UnboundIdDef
    { UnboundIdDef -> EntityNameHS
unboundIdEntityName :: EntityNameHS
    , UnboundIdDef -> FieldNameDB
unboundIdDBName :: !FieldNameDB
    , UnboundIdDef -> [FieldAttr]
unboundIdAttrs :: [FieldAttr]
    , UnboundIdDef -> FieldCascade
unboundIdCascade :: FieldCascade
    , UnboundIdDef -> Maybe FieldType
unboundIdType :: Maybe FieldType
    }
    deriving (UnboundIdDef -> UnboundIdDef -> Bool
(UnboundIdDef -> UnboundIdDef -> Bool)
-> (UnboundIdDef -> UnboundIdDef -> Bool) -> Eq UnboundIdDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnboundIdDef -> UnboundIdDef -> Bool
== :: UnboundIdDef -> UnboundIdDef -> Bool
$c/= :: UnboundIdDef -> UnboundIdDef -> Bool
/= :: UnboundIdDef -> UnboundIdDef -> Bool
Eq, Eq UnboundIdDef
Eq UnboundIdDef =>
(UnboundIdDef -> UnboundIdDef -> Ordering)
-> (UnboundIdDef -> UnboundIdDef -> Bool)
-> (UnboundIdDef -> UnboundIdDef -> Bool)
-> (UnboundIdDef -> UnboundIdDef -> Bool)
-> (UnboundIdDef -> UnboundIdDef -> Bool)
-> (UnboundIdDef -> UnboundIdDef -> UnboundIdDef)
-> (UnboundIdDef -> UnboundIdDef -> UnboundIdDef)
-> Ord UnboundIdDef
UnboundIdDef -> UnboundIdDef -> Bool
UnboundIdDef -> UnboundIdDef -> Ordering
UnboundIdDef -> UnboundIdDef -> UnboundIdDef
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: UnboundIdDef -> UnboundIdDef -> Ordering
compare :: UnboundIdDef -> UnboundIdDef -> Ordering
$c< :: UnboundIdDef -> UnboundIdDef -> Bool
< :: UnboundIdDef -> UnboundIdDef -> Bool
$c<= :: UnboundIdDef -> UnboundIdDef -> Bool
<= :: UnboundIdDef -> UnboundIdDef -> Bool
$c> :: UnboundIdDef -> UnboundIdDef -> Bool
> :: UnboundIdDef -> UnboundIdDef -> Bool
$c>= :: UnboundIdDef -> UnboundIdDef -> Bool
>= :: UnboundIdDef -> UnboundIdDef -> Bool
$cmax :: UnboundIdDef -> UnboundIdDef -> UnboundIdDef
max :: UnboundIdDef -> UnboundIdDef -> UnboundIdDef
$cmin :: UnboundIdDef -> UnboundIdDef -> UnboundIdDef
min :: UnboundIdDef -> UnboundIdDef -> UnboundIdDef
Ord, Int -> UnboundIdDef -> ShowS
[UnboundIdDef] -> ShowS
UnboundIdDef -> [Char]
(Int -> UnboundIdDef -> ShowS)
-> (UnboundIdDef -> [Char])
-> ([UnboundIdDef] -> ShowS)
-> Show UnboundIdDef
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnboundIdDef -> ShowS
showsPrec :: Int -> UnboundIdDef -> ShowS
$cshow :: UnboundIdDef -> [Char]
show :: UnboundIdDef -> [Char]
$cshowList :: [UnboundIdDef] -> ShowS
showList :: [UnboundIdDef] -> ShowS
Show, (forall (m :: * -> *). Quote m => UnboundIdDef -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    UnboundIdDef -> Code m UnboundIdDef)
-> Lift UnboundIdDef
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => UnboundIdDef -> m Exp
forall (m :: * -> *).
Quote m =>
UnboundIdDef -> Code m UnboundIdDef
$clift :: forall (m :: * -> *). Quote m => UnboundIdDef -> m Exp
lift :: forall (m :: * -> *). Quote m => UnboundIdDef -> m Exp
$cliftTyped :: forall (m :: * -> *).
Quote m =>
UnboundIdDef -> Code m UnboundIdDef
liftTyped :: forall (m :: * -> *).
Quote m =>
UnboundIdDef -> Code m UnboundIdDef
Lift)

-- | An 'EntityDef' produced by the QuasiQuoter. It contains information that
-- the QuasiQuoter is capable of knowing about the entities. It is inherently
-- unfinished, though - there are many other @Unbound@ datatypes that also
-- contain partial information.
--
-- The 'unboundEntityDef' is not complete or reliable - to know which fields are
-- safe to use, consult the parsing code.
--
-- This type was completely internal until 2.13.0.0, when it was exposed as part
-- of the "Database.Persist.Quasi.Internal" module.
--
-- TODO: refactor this so we can expose it for consumers.
--
-- @since 2.13.0.0
data UnboundEntityDef
    = UnboundEntityDef
    { UnboundEntityDef -> [UnboundForeignDef]
unboundForeignDefs :: [UnboundForeignDef]
    -- ^ A list of foreign definitions on the parsed entity.
    --
    -- @since 2.13.0.0
    , UnboundEntityDef -> PrimarySpec
unboundPrimarySpec :: PrimarySpec
    -- ^ The specification for the primary key of the unbound entity.
    --
    -- @since 2.13.0.0
    , UnboundEntityDef -> EntityDef
unboundEntityDef :: EntityDef
    -- ^ The incomplete and partial 'EntityDef' that we're defining. We re-use
    -- the type here to prevent duplication, but several of the fields are unset
    -- and left to defaults.
    --
    -- @since 2.13.0.0
    , UnboundEntityDef -> [UnboundFieldDef]
unboundEntityFields :: [UnboundFieldDef]
    -- ^ The list of fields for the entity. We're not capable of knowing
    -- information like "is this a reference?" or "what's the underlying type of
    -- the field?" yet, so we defer those to the Template Haskell execution.
    --
    -- @since 2.13.0.0
    , UnboundEntityDef -> Maybe SourceSpan
unboundEntityDefSpan :: Maybe SourceSpan
    -- ^ The source code span of this entity in the models file.
    --
    -- @since 2.15.0.0
    }
    deriving (UnboundEntityDef -> UnboundEntityDef -> Bool
(UnboundEntityDef -> UnboundEntityDef -> Bool)
-> (UnboundEntityDef -> UnboundEntityDef -> Bool)
-> Eq UnboundEntityDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnboundEntityDef -> UnboundEntityDef -> Bool
== :: UnboundEntityDef -> UnboundEntityDef -> Bool
$c/= :: UnboundEntityDef -> UnboundEntityDef -> Bool
/= :: UnboundEntityDef -> UnboundEntityDef -> Bool
Eq, Eq UnboundEntityDef
Eq UnboundEntityDef =>
(UnboundEntityDef -> UnboundEntityDef -> Ordering)
-> (UnboundEntityDef -> UnboundEntityDef -> Bool)
-> (UnboundEntityDef -> UnboundEntityDef -> Bool)
-> (UnboundEntityDef -> UnboundEntityDef -> Bool)
-> (UnboundEntityDef -> UnboundEntityDef -> Bool)
-> (UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef)
-> (UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef)
-> Ord UnboundEntityDef
UnboundEntityDef -> UnboundEntityDef -> Bool
UnboundEntityDef -> UnboundEntityDef -> Ordering
UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: UnboundEntityDef -> UnboundEntityDef -> Ordering
compare :: UnboundEntityDef -> UnboundEntityDef -> Ordering
$c< :: UnboundEntityDef -> UnboundEntityDef -> Bool
< :: UnboundEntityDef -> UnboundEntityDef -> Bool
$c<= :: UnboundEntityDef -> UnboundEntityDef -> Bool
<= :: UnboundEntityDef -> UnboundEntityDef -> Bool
$c> :: UnboundEntityDef -> UnboundEntityDef -> Bool
> :: UnboundEntityDef -> UnboundEntityDef -> Bool
$c>= :: UnboundEntityDef -> UnboundEntityDef -> Bool
>= :: UnboundEntityDef -> UnboundEntityDef -> Bool
$cmax :: UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef
max :: UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef
$cmin :: UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef
min :: UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef
Ord, Int -> UnboundEntityDef -> ShowS
[UnboundEntityDef] -> ShowS
UnboundEntityDef -> [Char]
(Int -> UnboundEntityDef -> ShowS)
-> (UnboundEntityDef -> [Char])
-> ([UnboundEntityDef] -> ShowS)
-> Show UnboundEntityDef
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnboundEntityDef -> ShowS
showsPrec :: Int -> UnboundEntityDef -> ShowS
$cshow :: UnboundEntityDef -> [Char]
show :: UnboundEntityDef -> [Char]
$cshowList :: [UnboundEntityDef] -> ShowS
showList :: [UnboundEntityDef] -> ShowS
Show, (forall (m :: * -> *). Quote m => UnboundEntityDef -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    UnboundEntityDef -> Code m UnboundEntityDef)
-> Lift UnboundEntityDef
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => UnboundEntityDef -> m Exp
forall (m :: * -> *).
Quote m =>
UnboundEntityDef -> Code m UnboundEntityDef
$clift :: forall (m :: * -> *). Quote m => UnboundEntityDef -> m Exp
lift :: forall (m :: * -> *). Quote m => UnboundEntityDef -> m Exp
$cliftTyped :: forall (m :: * -> *).
Quote m =>
UnboundEntityDef -> Code m UnboundEntityDef
liftTyped :: forall (m :: * -> *).
Quote m =>
UnboundEntityDef -> Code m UnboundEntityDef
Lift)

-- | Convert an 'EntityDef' into an 'UnboundEntityDef'. This "forgets"
-- information about the 'EntityDef', but it is all kept present on the
-- 'unboundEntityDef' field if necessary.
--
-- @since 2.13.0.0
unbindEntityDef :: EntityDef -> UnboundEntityDef
unbindEntityDef :: EntityDef -> UnboundEntityDef
unbindEntityDef EntityDef
ed =
    UnboundEntityDef
        { unboundForeignDefs :: [UnboundForeignDef]
unboundForeignDefs =
            (ForeignDef -> UnboundForeignDef)
-> [ForeignDef] -> [UnboundForeignDef]
forall a b. (a -> b) -> [a] -> [b]
map ForeignDef -> UnboundForeignDef
unbindForeignDef (EntityDef -> [ForeignDef]
entityForeigns EntityDef
ed)
        , unboundPrimarySpec :: PrimarySpec
unboundPrimarySpec =
            case EntityDef -> EntityIdDef
entityId EntityDef
ed of
                EntityIdField FieldDef
fd ->
                    UnboundIdDef -> PrimarySpec
SurrogateKey (EntityNameHS -> FieldDef -> UnboundIdDef
unbindIdDef (EntityDef -> EntityNameHS
entityHaskell EntityDef
ed) FieldDef
fd)
                EntityIdNaturalKey CompositeDef
cd ->
                    UnboundCompositeDef -> PrimarySpec
NaturalKey (CompositeDef -> UnboundCompositeDef
unbindCompositeDef CompositeDef
cd)
        , unboundEntityDef :: EntityDef
unboundEntityDef =
            EntityDef
ed
        , unboundEntityFields :: [UnboundFieldDef]
unboundEntityFields =
            (FieldDef -> UnboundFieldDef) -> [FieldDef] -> [UnboundFieldDef]
forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> UnboundFieldDef
unbindFieldDef (EntityDef -> [FieldDef]
entityFields EntityDef
ed)
        , unboundEntityDefSpan :: Maybe SourceSpan
unboundEntityDefSpan = EntityDef -> Maybe SourceSpan
entitySpan EntityDef
ed
        }

-- | Returns the @['UnboundFieldDef']@ for an 'UnboundEntityDef'. This returns
-- all fields defined on the entity.
--
-- @since 2.13.0.0
getUnboundFieldDefs :: UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs :: UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs = UnboundEntityDef -> [UnboundFieldDef]
unboundEntityFields

-- | This function forgets information about the 'CompositeDef' so that it can
-- be remembered through Template Haskell.
--
-- @since 2.13.0.0
unbindCompositeDef :: CompositeDef -> UnboundCompositeDef
unbindCompositeDef :: CompositeDef -> UnboundCompositeDef
unbindCompositeDef CompositeDef
cd =
    UnboundCompositeDef
        { unboundCompositeCols :: NonEmpty FieldNameHS
unboundCompositeCols =
            (FieldDef -> FieldNameHS)
-> NonEmpty FieldDef -> NonEmpty FieldNameHS
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldDef -> FieldNameHS
fieldHaskell (CompositeDef -> NonEmpty FieldDef
compositeFields CompositeDef
cd)
        , unboundCompositeAttrs :: [Text]
unboundCompositeAttrs =
            CompositeDef -> [Text]
compositeAttrs CompositeDef
cd
        }

-- | A representation of a database column, with everything that can be known at
-- parse time.
--
-- @since 2.13.0.0
data UnboundFieldDef
    = UnboundFieldDef
    { UnboundFieldDef -> FieldNameHS
unboundFieldNameHS :: FieldNameHS
    -- ^  The Haskell name of the field. This is parsed directly from the
    -- definition, and is used to generate the Haskell record field and the
    -- 'EntityField' definition.
    --
    -- @since 2.13.0.0
    , UnboundFieldDef -> FieldNameDB
unboundFieldNameDB :: FieldNameDB
    -- ^ The database name of the field. By default, this is determined by the
    -- 'PersistSettings' record at parse time. You can customize this with
    -- a @sql=@ attribute:
    --
    -- @
    --     name Text  sql=foo_name
    -- @
    --
    -- @since 2.13.0.0
    , UnboundFieldDef -> [FieldAttr]
unboundFieldAttrs :: [FieldAttr]
    -- ^ The attributes present on the field. For rules on parsing and utility,
    -- see the comments on the datatype.
    --
    -- @since 2.13.0.0
    , UnboundFieldDef -> Bool
unboundFieldStrict :: Bool
    -- ^ Whether or not the field should be strict in the generated Haskell
    -- code.
    --
    -- @since 2.13.0.0
    , UnboundFieldDef -> FieldType
unboundFieldType :: FieldType
    -- ^ The type of the field, as far as is known at parse time.
    --
    -- The TemplateHaskell code will reconstruct a 'Type' out of this, but the
    -- names will be imported as-is.
    --
    -- @since 2.13.0.0
    , UnboundFieldDef -> FieldCascade
unboundFieldCascade :: FieldCascade
    -- ^ We parse if there's a 'FieldCascade' on the field. If the field is not
    -- a reference, this information is ignored.
    --
    -- @
    -- Post
    --    user UserId OnDeleteCascade
    -- @
    --
    -- @since 2.13.0.0
    , UnboundFieldDef -> Maybe Text
unboundFieldGenerated :: Maybe Text
    -- ^ Contains an expression to generate the column. If this is present, then
    -- the column will not be written to the database, but generated by the
    -- expression every time.
    --
    -- @
    -- Item
    --     subtotal Int
    --     taxRate  Rational
    --     total    Int      generated="subtotal * tax_rate"
    -- @
    --
    -- @since 2.13.0.0
    , UnboundFieldDef -> Maybe Text
unboundFieldComments :: Maybe Text
    -- ^ Any comments present on the field. Documentation comments use
    -- a Haskell-like syntax, and must be present before the field in question.
    --
    -- @
    -- Post
    --     -- | This is the blog post title.
    --     title Text
    --     -- | You can have multi-line comments.
    --     -- | But each line must have the pipe character.
    --     author UserId
    -- @
    --
    -- @since 2.13.0.0
    }
    deriving (UnboundFieldDef -> UnboundFieldDef -> Bool
(UnboundFieldDef -> UnboundFieldDef -> Bool)
-> (UnboundFieldDef -> UnboundFieldDef -> Bool)
-> Eq UnboundFieldDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnboundFieldDef -> UnboundFieldDef -> Bool
== :: UnboundFieldDef -> UnboundFieldDef -> Bool
$c/= :: UnboundFieldDef -> UnboundFieldDef -> Bool
/= :: UnboundFieldDef -> UnboundFieldDef -> Bool
Eq, Eq UnboundFieldDef
Eq UnboundFieldDef =>
(UnboundFieldDef -> UnboundFieldDef -> Ordering)
-> (UnboundFieldDef -> UnboundFieldDef -> Bool)
-> (UnboundFieldDef -> UnboundFieldDef -> Bool)
-> (UnboundFieldDef -> UnboundFieldDef -> Bool)
-> (UnboundFieldDef -> UnboundFieldDef -> Bool)
-> (UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef)
-> (UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef)
-> Ord UnboundFieldDef
UnboundFieldDef -> UnboundFieldDef -> Bool
UnboundFieldDef -> UnboundFieldDef -> Ordering
UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: UnboundFieldDef -> UnboundFieldDef -> Ordering
compare :: UnboundFieldDef -> UnboundFieldDef -> Ordering
$c< :: UnboundFieldDef -> UnboundFieldDef -> Bool
< :: UnboundFieldDef -> UnboundFieldDef -> Bool
$c<= :: UnboundFieldDef -> UnboundFieldDef -> Bool
<= :: UnboundFieldDef -> UnboundFieldDef -> Bool
$c> :: UnboundFieldDef -> UnboundFieldDef -> Bool
> :: UnboundFieldDef -> UnboundFieldDef -> Bool
$c>= :: UnboundFieldDef -> UnboundFieldDef -> Bool
>= :: UnboundFieldDef -> UnboundFieldDef -> Bool
$cmax :: UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef
max :: UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef
$cmin :: UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef
min :: UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef
Ord, Int -> UnboundFieldDef -> ShowS
[UnboundFieldDef] -> ShowS
UnboundFieldDef -> [Char]
(Int -> UnboundFieldDef -> ShowS)
-> (UnboundFieldDef -> [Char])
-> ([UnboundFieldDef] -> ShowS)
-> Show UnboundFieldDef
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnboundFieldDef -> ShowS
showsPrec :: Int -> UnboundFieldDef -> ShowS
$cshow :: UnboundFieldDef -> [Char]
show :: UnboundFieldDef -> [Char]
$cshowList :: [UnboundFieldDef] -> ShowS
showList :: [UnboundFieldDef] -> ShowS
Show, (forall (m :: * -> *). Quote m => UnboundFieldDef -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    UnboundFieldDef -> Code m UnboundFieldDef)
-> Lift UnboundFieldDef
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => UnboundFieldDef -> m Exp
forall (m :: * -> *).
Quote m =>
UnboundFieldDef -> Code m UnboundFieldDef
$clift :: forall (m :: * -> *). Quote m => UnboundFieldDef -> m Exp
lift :: forall (m :: * -> *). Quote m => UnboundFieldDef -> m Exp
$cliftTyped :: forall (m :: * -> *).
Quote m =>
UnboundFieldDef -> Code m UnboundFieldDef
liftTyped :: forall (m :: * -> *).
Quote m =>
UnboundFieldDef -> Code m UnboundFieldDef
Lift)

-- | Forget innformation about a 'FieldDef' so it can beused as an
-- 'UnboundFieldDef'.
--
-- @since 2.13.0.0
unbindFieldDef :: FieldDef -> UnboundFieldDef
unbindFieldDef :: FieldDef -> UnboundFieldDef
unbindFieldDef FieldDef
fd =
    UnboundFieldDef
        { unboundFieldNameHS :: FieldNameHS
unboundFieldNameHS =
            FieldDef -> FieldNameHS
fieldHaskell FieldDef
fd
        , unboundFieldNameDB :: FieldNameDB
unboundFieldNameDB =
            FieldDef -> FieldNameDB
fieldDB FieldDef
fd
        , unboundFieldAttrs :: [FieldAttr]
unboundFieldAttrs =
            FieldDef -> [FieldAttr]
fieldAttrs FieldDef
fd
        , unboundFieldType :: FieldType
unboundFieldType =
            FieldDef -> FieldType
fieldType FieldDef
fd
        , unboundFieldStrict :: Bool
unboundFieldStrict =
            FieldDef -> Bool
fieldStrict FieldDef
fd
        , unboundFieldCascade :: FieldCascade
unboundFieldCascade =
            FieldDef -> FieldCascade
fieldCascade FieldDef
fd
        , unboundFieldComments :: Maybe Text
unboundFieldComments =
            FieldDef -> Maybe Text
fieldComments FieldDef
fd
        , unboundFieldGenerated :: Maybe Text
unboundFieldGenerated =
            FieldDef -> Maybe Text
fieldGenerated FieldDef
fd
        }

isUnboundFieldNullable :: UnboundFieldDef -> IsNullable
isUnboundFieldNullable :: UnboundFieldDef -> IsNullable
isUnboundFieldNullable =
    [FieldAttr] -> IsNullable
fieldAttrsContainsNullable ([FieldAttr] -> IsNullable)
-> (UnboundFieldDef -> [FieldAttr])
-> UnboundFieldDef
-> IsNullable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> [FieldAttr]
unboundFieldAttrs

-- | The specification for how an entity's primary key should be formed.
--
-- Persistent requires that every table have a primary key. By default, an
-- implied ID is assigned, based on the 'mpsImplicitIdDef' field on
-- 'MkPersistSettings'. Because we can't access that type at parse-time, we
-- defer that decision until later.
--
-- @since 2.13.0.0
data PrimarySpec
    = -- | A 'NaturalKey' contains columns that are defined on the datatype
      -- itself. This is defined using the @Primary@ keyword and given a non-empty
      -- list of columns.
      --
      -- @
      -- User
      --     name    Text
      --     email   Text
      --
      --     Primary name email
      -- @
      --
      -- A natural key may also contain only a single column. A natural key with
      -- multiple columns is called a 'composite key'.
      --
      -- @since 2.13.0.0
      NaturalKey UnboundCompositeDef
    | -- | A surrogate key is not part of the domain model for a database table.
      -- You can specify a custom surro
      --
      -- You can specify a custom surrogate key using the @Id@ syntax.
      --
      -- @
      -- User
      --     Id    Text
      --     name  Text
      -- @
      --
      -- Note that you must provide a @default=@ expression when using this in
      -- order to use 'insert' or related functions. The 'insertKey' function can
      -- be used instead, as it allows you to specify a key directly. Fixing this
      -- issue is tracked in #1247 on GitHub.
      --
      -- @since 2.13.0.0
      SurrogateKey UnboundIdDef
    | -- | The default key for the entity using the settings in
      -- 'MkPersistSettings'.
      --
      -- This is implicit - a table without an @Id@ or @Primary@ declaration will
      -- have a 'DefaultKey'.
      --
      -- @since 2.13.0.0
      DefaultKey FieldNameDB
    deriving (PrimarySpec -> PrimarySpec -> Bool
(PrimarySpec -> PrimarySpec -> Bool)
-> (PrimarySpec -> PrimarySpec -> Bool) -> Eq PrimarySpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PrimarySpec -> PrimarySpec -> Bool
== :: PrimarySpec -> PrimarySpec -> Bool
$c/= :: PrimarySpec -> PrimarySpec -> Bool
/= :: PrimarySpec -> PrimarySpec -> Bool
Eq, Eq PrimarySpec
Eq PrimarySpec =>
(PrimarySpec -> PrimarySpec -> Ordering)
-> (PrimarySpec -> PrimarySpec -> Bool)
-> (PrimarySpec -> PrimarySpec -> Bool)
-> (PrimarySpec -> PrimarySpec -> Bool)
-> (PrimarySpec -> PrimarySpec -> Bool)
-> (PrimarySpec -> PrimarySpec -> PrimarySpec)
-> (PrimarySpec -> PrimarySpec -> PrimarySpec)
-> Ord PrimarySpec
PrimarySpec -> PrimarySpec -> Bool
PrimarySpec -> PrimarySpec -> Ordering
PrimarySpec -> PrimarySpec -> PrimarySpec
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PrimarySpec -> PrimarySpec -> Ordering
compare :: PrimarySpec -> PrimarySpec -> Ordering
$c< :: PrimarySpec -> PrimarySpec -> Bool
< :: PrimarySpec -> PrimarySpec -> Bool
$c<= :: PrimarySpec -> PrimarySpec -> Bool
<= :: PrimarySpec -> PrimarySpec -> Bool
$c> :: PrimarySpec -> PrimarySpec -> Bool
> :: PrimarySpec -> PrimarySpec -> Bool
$c>= :: PrimarySpec -> PrimarySpec -> Bool
>= :: PrimarySpec -> PrimarySpec -> Bool
$cmax :: PrimarySpec -> PrimarySpec -> PrimarySpec
max :: PrimarySpec -> PrimarySpec -> PrimarySpec
$cmin :: PrimarySpec -> PrimarySpec -> PrimarySpec
min :: PrimarySpec -> PrimarySpec -> PrimarySpec
Ord, Int -> PrimarySpec -> ShowS
[PrimarySpec] -> ShowS
PrimarySpec -> [Char]
(Int -> PrimarySpec -> ShowS)
-> (PrimarySpec -> [Char])
-> ([PrimarySpec] -> ShowS)
-> Show PrimarySpec
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PrimarySpec -> ShowS
showsPrec :: Int -> PrimarySpec -> ShowS
$cshow :: PrimarySpec -> [Char]
show :: PrimarySpec -> [Char]
$cshowList :: [PrimarySpec] -> ShowS
showList :: [PrimarySpec] -> ShowS
Show, (forall (m :: * -> *). Quote m => PrimarySpec -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    PrimarySpec -> Code m PrimarySpec)
-> Lift PrimarySpec
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => PrimarySpec -> m Exp
forall (m :: * -> *). Quote m => PrimarySpec -> Code m PrimarySpec
$clift :: forall (m :: * -> *). Quote m => PrimarySpec -> m Exp
lift :: forall (m :: * -> *). Quote m => PrimarySpec -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => PrimarySpec -> Code m PrimarySpec
liftTyped :: forall (m :: * -> *). Quote m => PrimarySpec -> Code m PrimarySpec
Lift)

-- | Construct an entity definition.
mkUnboundEntityDef
    :: PersistSettings
    -> ParsedEntityDef
    -- ^ parsed entity definition
    -> UnboundEntityDef
mkUnboundEntityDef :: PersistSettings -> ParsedEntityDef -> UnboundEntityDef
mkUnboundEntityDef PersistSettings
ps ParsedEntityDef
parsedEntDef =
    UnboundEntityDef
        { unboundForeignDefs :: [UnboundForeignDef]
unboundForeignDefs =
            EntityConstraintDefs -> [UnboundForeignDef]
entityConstraintDefsForeignsList EntityConstraintDefs
entityConstraintDefs
        , unboundPrimarySpec :: PrimarySpec
unboundPrimarySpec =
            case (Maybe UnboundIdDef
idField, Maybe UnboundCompositeDef
primaryComposite) of
                (Just{}, Just{}) ->
                    [Char] -> PrimarySpec
forall a. HasCallStack => [Char] -> a
error [Char]
"Specified both an ID field and a Primary field"
                (Just UnboundIdDef
a, Maybe UnboundCompositeDef
Nothing) ->
                    if UnboundIdDef -> Maybe FieldType
unboundIdType UnboundIdDef
a Maybe FieldType -> Maybe FieldType -> Bool
forall a. Eq a => a -> a -> Bool
== FieldType -> Maybe FieldType
forall a. a -> Maybe a
Just (EntityNameHS -> FieldType
mkKeyConType (UnboundIdDef -> EntityNameHS
unboundIdEntityName UnboundIdDef
a))
                        then
                            FieldNameDB -> PrimarySpec
DefaultKey (Text -> FieldNameDB
FieldNameDB (Text -> FieldNameDB) -> Text -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text
psIdName PersistSettings
ps)
                        else
                            UnboundIdDef -> PrimarySpec
SurrogateKey UnboundIdDef
a
                (Maybe UnboundIdDef
Nothing, Just UnboundCompositeDef
a) ->
                    UnboundCompositeDef -> PrimarySpec
NaturalKey UnboundCompositeDef
a
                (Maybe UnboundIdDef
Nothing, Maybe UnboundCompositeDef
Nothing) ->
                    FieldNameDB -> PrimarySpec
DefaultKey (Text -> FieldNameDB
FieldNameDB (Text -> FieldNameDB) -> Text -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text
psIdName PersistSettings
ps)
        , unboundEntityFields :: [UnboundFieldDef]
unboundEntityFields =
            [UnboundFieldDef]
cols
        , unboundEntityDefSpan :: Maybe SourceSpan
unboundEntityDefSpan = ParsedEntityDef -> Maybe SourceSpan
parsedEntityDefSpan ParsedEntityDef
parsedEntDef
        , unboundEntityDef :: EntityDef
unboundEntityDef =
            EntityDef
                { entityHaskell :: EntityNameHS
entityHaskell = EntityNameHS
entNameHS
                , entityDB :: EntityNameDB
entityDB = EntityNameDB
entNameDB
                , -- idField is the user-specified Id
                  -- otherwise useAutoIdField
                  -- but, adjust it if the user specified a Primary
                  entityId :: EntityIdDef
entityId =
                    FieldDef -> EntityIdDef
EntityIdField (FieldDef -> EntityIdDef) -> FieldDef -> EntityIdDef
forall a b. (a -> b) -> a -> b
$
                        FieldDef
-> (UnboundIdDef -> FieldDef) -> Maybe UnboundIdDef -> FieldDef
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FieldDef
autoIdField (FieldNameDB -> EntityNameHS -> UnboundIdDef -> FieldDef
unboundIdDefToFieldDef (PersistSettings -> FieldNameDB
defaultIdName PersistSettings
ps) EntityNameHS
entNameHS) Maybe UnboundIdDef
idField
                , entityAttrs :: [Text]
entityAttrs =
                    ParsedEntityDef -> [Text]
parsedEntityDefEntityAttributes ParsedEntityDef
parsedEntDef
                , entityFields :: [FieldDef]
entityFields =
                    []
                , entityUniques :: [UniqueDef]
entityUniques = EntityConstraintDefs -> [UniqueDef]
entityConstraintDefsUniquesList EntityConstraintDefs
entityConstraintDefs
                , entityForeigns :: [ForeignDef]
entityForeigns = []
                , entityDerives :: [Text]
entityDerives = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ ([Text] -> Maybe [Text]) -> [[Text]] -> [[Text]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Text] -> Maybe [Text]
takeDerives [[Text]]
textAttribs
                , entityExtra :: Map Text [[Text]]
entityExtra = ParsedEntityDef -> Map Text [[Text]]
parsedEntityDefExtras ParsedEntityDef
parsedEntDef
                , entitySum :: Bool
entitySum = ParsedEntityDef -> Bool
parsedEntityDefIsSum ParsedEntityDef
parsedEntDef
                , entityComments :: Maybe Text
entityComments =
                    case ParsedEntityDef -> [Text]
parsedEntityDefComments ParsedEntityDef
parsedEntDef of
                        [] -> Maybe Text
forall a. Maybe a
Nothing
                        [Text]
comments -> Text -> Maybe Text
forall a. a -> Maybe a
Just ([Text] -> Text
T.unlines [Text]
comments)
                , entitySpan :: Maybe SourceSpan
entitySpan = ParsedEntityDef -> Maybe SourceSpan
parsedEntityDefSpan ParsedEntityDef
parsedEntDef
                }
        }
  where
    (EntityNameHS
entNameHS, EntityNameDB
entNameDB) =
        PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB)
entityNamesFromParsedDef PersistSettings
ps ParsedEntityDef
parsedEntDef

    attribs :: [([Token], Maybe Text)]
attribs =
        ParsedEntityDef -> [([Token], Maybe Text)]
parsedEntityDefFieldAttributes ParsedEntityDef
parsedEntDef

    cols :: [UnboundFieldDef]
    cols :: [UnboundFieldDef]
cols = (([Token], Maybe Text) -> [UnboundFieldDef])
-> [([Token], Maybe Text)] -> [UnboundFieldDef]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe UnboundFieldDef -> [UnboundFieldDef]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe UnboundFieldDef -> [UnboundFieldDef])
-> (([Token], Maybe Text) -> Maybe UnboundFieldDef)
-> ([Token], Maybe Text)
-> [UnboundFieldDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistSettings -> ([Token], Maybe Text) -> Maybe UnboundFieldDef
commentedField PersistSettings
ps) [([Token], Maybe Text)]
attribs

    textAttribs :: [[Text]]
    textAttribs :: [[Text]]
textAttribs = (Token -> Text) -> [Token] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Token -> Text
tokenContent ([Token] -> [Text])
-> (([Token], Maybe Text) -> [Token])
-> ([Token], Maybe Text)
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Token], Maybe Text) -> [Token]
forall a b. (a, b) -> a
fst (([Token], Maybe Text) -> [Text])
-> [([Token], Maybe Text)] -> [[Text]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([Token], Maybe Text)]
attribs

    entityConstraintDefs :: EntityConstraintDefs
entityConstraintDefs =
        ([Text] -> EntityConstraintDefs)
-> [[Text]] -> EntityConstraintDefs
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
            (EntityConstraintDefs
-> (NonEmpty Text -> EntityConstraintDefs)
-> Maybe (NonEmpty Text)
-> EntityConstraintDefs
forall b a. b -> (a -> b) -> Maybe a -> b
maybe EntityConstraintDefs
forall a. Monoid a => a
mempty (PersistSettings
-> EntityNameHS
-> [UnboundFieldDef]
-> NonEmpty Text
-> EntityConstraintDefs
takeConstraint PersistSettings
ps EntityNameHS
entNameHS [UnboundFieldDef]
cols) (Maybe (NonEmpty Text) -> EntityConstraintDefs)
-> ([Text] -> Maybe (NonEmpty Text))
-> [Text]
-> EntityConstraintDefs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty)
            [[Text]]
textAttribs

    idField :: Maybe UnboundIdDef
idField =
        case EntityConstraintDefs -> SetOnceAtMost UnboundIdDef
entityConstraintDefsIdField EntityConstraintDefs
entityConstraintDefs of
            SetOnceAtMost UnboundIdDef
SetMoreThanOnce -> [Char] -> Maybe UnboundIdDef
forall a. HasCallStack => [Char] -> a
error [Char]
"expected only one Id declaration per entity"
            SetOnce UnboundIdDef
a -> UnboundIdDef -> Maybe UnboundIdDef
forall a. a -> Maybe a
Just UnboundIdDef
a
            SetOnceAtMost UnboundIdDef
NotSet -> Maybe UnboundIdDef
forall a. Maybe a
Nothing

    primaryComposite :: Maybe UnboundCompositeDef
primaryComposite =
        case EntityConstraintDefs -> SetOnceAtMost UnboundCompositeDef
entityConstraintDefsPrimaryComposite EntityConstraintDefs
entityConstraintDefs of
            SetOnceAtMost UnboundCompositeDef
SetMoreThanOnce -> [Char] -> Maybe UnboundCompositeDef
forall a. HasCallStack => [Char] -> a
error [Char]
"expected only one Primary declaration per entity"
            SetOnce UnboundCompositeDef
a -> UnboundCompositeDef -> Maybe UnboundCompositeDef
forall a. a -> Maybe a
Just UnboundCompositeDef
a
            SetOnceAtMost UnboundCompositeDef
NotSet -> Maybe UnboundCompositeDef
forall a. Maybe a
Nothing

    commentedField
        :: PersistSettings
        -> ([Token], Maybe Text)
        -> Maybe UnboundFieldDef
    commentedField :: PersistSettings -> ([Token], Maybe Text) -> Maybe UnboundFieldDef
commentedField PersistSettings
s ([Token]
tokens, Maybe Text
mCommentText) = do
        UnboundFieldDef
unb <- PersistSettings -> [Text] -> Maybe UnboundFieldDef
takeColsEx PersistSettings
s (Token -> Text
tokenContent (Token -> Text) -> [Token] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token]
tokens)
        UnboundFieldDef -> Maybe UnboundFieldDef
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnboundFieldDef -> Maybe UnboundFieldDef)
-> UnboundFieldDef -> Maybe UnboundFieldDef
forall a b. (a -> b) -> a -> b
$ UnboundFieldDef
unb{unboundFieldComments = mCommentText}

    autoIdField :: FieldDef
    autoIdField :: FieldDef
autoIdField =
        PersistSettings -> EntityNameHS -> SqlType -> FieldDef
mkAutoIdField PersistSettings
ps EntityNameHS
entNameHS SqlType
idSqlType

    idSqlType :: SqlType
    idSqlType :: SqlType
idSqlType =
        SqlType
-> (UnboundCompositeDef -> SqlType)
-> Maybe UnboundCompositeDef
-> SqlType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SqlType
SqlInt64 (SqlType -> UnboundCompositeDef -> SqlType
forall a b. a -> b -> a
const (SqlType -> UnboundCompositeDef -> SqlType)
-> SqlType -> UnboundCompositeDef -> SqlType
forall a b. (a -> b) -> a -> b
$ Text -> SqlType
SqlOther Text
"Primary Key") Maybe UnboundCompositeDef
primaryComposite

defaultIdName :: PersistSettings -> FieldNameDB
defaultIdName :: PersistSettings -> FieldNameDB
defaultIdName = Text -> FieldNameDB
FieldNameDB (Text -> FieldNameDB)
-> (PersistSettings -> Text) -> PersistSettings -> FieldNameDB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistSettings -> Text
psIdName

-- | Convert an 'UnboundIdDef' into a 'FieldDef' suitable for use in the
-- 'EntityIdField' constructor.
--
-- @since 2.13.0.0
unboundIdDefToFieldDef
    :: FieldNameDB
    -> EntityNameHS
    -> UnboundIdDef
    -> FieldDef
unboundIdDefToFieldDef :: FieldNameDB -> EntityNameHS -> UnboundIdDef -> FieldDef
unboundIdDefToFieldDef FieldNameDB
dbField EntityNameHS
entNameHS UnboundIdDef
uid =
    FieldDef
        { fieldHaskell :: FieldNameHS
fieldHaskell =
            Text -> FieldNameHS
FieldNameHS Text
"Id"
        , fieldDB :: FieldNameDB
fieldDB =
            FieldNameDB -> [FieldAttr] -> FieldNameDB
getSqlNameOr FieldNameDB
dbField (UnboundIdDef -> [FieldAttr]
unboundIdAttrs UnboundIdDef
uid)
        , fieldType :: FieldType
fieldType =
            FieldType -> Maybe FieldType -> FieldType
forall a. a -> Maybe a -> a
fromMaybe (EntityNameHS -> FieldType
mkKeyConType EntityNameHS
entNameHS) (Maybe FieldType -> FieldType) -> Maybe FieldType -> FieldType
forall a b. (a -> b) -> a -> b
$ UnboundIdDef -> Maybe FieldType
unboundIdType UnboundIdDef
uid
        , fieldSqlType :: SqlType
fieldSqlType =
            Text -> SqlType
SqlOther Text
"SqlType unset for Id"
        , fieldStrict :: Bool
fieldStrict =
            Bool
False
        , fieldReference :: ReferenceDef
fieldReference =
            EntityNameHS -> ReferenceDef
ForeignRef EntityNameHS
entNameHS
        , fieldAttrs :: [FieldAttr]
fieldAttrs =
            UnboundIdDef -> [FieldAttr]
unboundIdAttrs UnboundIdDef
uid
        , fieldComments :: Maybe Text
fieldComments =
            Maybe Text
forall a. Maybe a
Nothing
        , fieldCascade :: FieldCascade
fieldCascade = UnboundIdDef -> FieldCascade
unboundIdCascade UnboundIdDef
uid
        , fieldGenerated :: Maybe Text
fieldGenerated = Maybe Text
forall a. Maybe a
Nothing
        , fieldIsImplicitIdColumn :: Bool
fieldIsImplicitIdColumn = Bool
True
        }

-- | Convert an 'EntityNameHS' into 'FieldType' that will get parsed into the ID
-- type for the entity.
--
-- @
-- >>> mkKeyConType (EntityNameHS "Hello)
-- FTTypeCon Nothing "HelloId"
-- @
--
-- @since 2.13.0.0
mkKeyConType :: EntityNameHS -> FieldType
mkKeyConType :: EntityNameHS -> FieldType
mkKeyConType EntityNameHS
entNameHs =
    Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing (EntityNameHS -> Text
keyConName EntityNameHS
entNameHs)

-- | Assuming that the provided 'FieldDef' is an ID field, this converts it into
-- an 'UnboundIdDef'.
--
-- @since 2.13.0.0
unbindIdDef :: EntityNameHS -> FieldDef -> UnboundIdDef
unbindIdDef :: EntityNameHS -> FieldDef -> UnboundIdDef
unbindIdDef EntityNameHS
entityName FieldDef
fd =
    UnboundIdDef
        { unboundIdEntityName :: EntityNameHS
unboundIdEntityName =
            EntityNameHS
entityName
        , unboundIdDBName :: FieldNameDB
unboundIdDBName =
            FieldDef -> FieldNameDB
fieldDB FieldDef
fd
        , unboundIdAttrs :: [FieldAttr]
unboundIdAttrs =
            FieldDef -> [FieldAttr]
fieldAttrs FieldDef
fd
        , unboundIdCascade :: FieldCascade
unboundIdCascade =
            FieldDef -> FieldCascade
fieldCascade FieldDef
fd
        , unboundIdType :: Maybe FieldType
unboundIdType =
            FieldType -> Maybe FieldType
forall a. a -> Maybe a
Just (FieldType -> Maybe FieldType) -> FieldType -> Maybe FieldType
forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldType
fieldType FieldDef
fd
        }

mkAutoIdField :: PersistSettings -> EntityNameHS -> SqlType -> FieldDef
mkAutoIdField :: PersistSettings -> EntityNameHS -> SqlType -> FieldDef
mkAutoIdField PersistSettings
ps =
    FieldNameDB -> EntityNameHS -> SqlType -> FieldDef
mkAutoIdField' (Text -> FieldNameDB
FieldNameDB (Text -> FieldNameDB) -> Text -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text
psIdName PersistSettings
ps)

mkAutoIdField' :: FieldNameDB -> EntityNameHS -> SqlType -> FieldDef
mkAutoIdField' :: FieldNameDB -> EntityNameHS -> SqlType -> FieldDef
mkAutoIdField' FieldNameDB
dbName EntityNameHS
entName SqlType
idSqlType =
    FieldDef
        { fieldHaskell :: FieldNameHS
fieldHaskell = Text -> FieldNameHS
FieldNameHS Text
"Id"
        , fieldDB :: FieldNameDB
fieldDB = FieldNameDB
dbName
        , fieldType :: FieldType
fieldType = Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing (Text -> FieldType) -> Text -> FieldType
forall a b. (a -> b) -> a -> b
$ EntityNameHS -> Text
keyConName EntityNameHS
entName
        , fieldSqlType :: SqlType
fieldSqlType = SqlType
idSqlType
        , fieldReference :: ReferenceDef
fieldReference = ReferenceDef
NoReference
        , fieldAttrs :: [FieldAttr]
fieldAttrs = []
        , fieldStrict :: Bool
fieldStrict = Bool
True
        , fieldComments :: Maybe Text
fieldComments = Maybe Text
forall a. Maybe a
Nothing
        , fieldCascade :: FieldCascade
fieldCascade = FieldCascade
noCascade
        , fieldGenerated :: Maybe Text
fieldGenerated = Maybe Text
forall a. Maybe a
Nothing
        , fieldIsImplicitIdColumn :: Bool
fieldIsImplicitIdColumn = Bool
True
        }

keyConName :: EntityNameHS -> Text
keyConName :: EntityNameHS -> Text
keyConName EntityNameHS
entName = EntityNameHS -> Text
unEntityNameHS EntityNameHS
entName Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
"Id"

isCapitalizedText :: Text -> Bool
isCapitalizedText :: Text -> Bool
isCapitalizedText Text
t =
    Bool -> Bool
not (Text -> Bool
T.null Text
t) Bool -> Bool -> Bool
&& Char -> Bool
isUpper (HasCallStack => Text -> Char
Text -> Char
T.head Text
t)

takeColsEx :: PersistSettings -> [Text] -> Maybe UnboundFieldDef
takeColsEx :: PersistSettings -> [Text] -> Maybe UnboundFieldDef
takeColsEx =
    (Text -> [Char] -> Maybe UnboundFieldDef)
-> PersistSettings -> [Text] -> Maybe UnboundFieldDef
takeCols
        (\Text
ft [Char]
perr -> [Char] -> Maybe UnboundFieldDef
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maybe UnboundFieldDef)
-> [Char] -> Maybe UnboundFieldDef
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid field type " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
ft [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
perr)

takeCols
    :: (Text -> String -> Maybe UnboundFieldDef)
    -> PersistSettings
    -> [Text]
    -> Maybe UnboundFieldDef
takeCols :: (Text -> [Char] -> Maybe UnboundFieldDef)
-> PersistSettings -> [Text] -> Maybe UnboundFieldDef
takeCols Text -> [Char] -> Maybe UnboundFieldDef
_ PersistSettings
_ (Text
"deriving" : [Text]
_) = Maybe UnboundFieldDef
forall a. Maybe a
Nothing
takeCols Text -> [Char] -> Maybe UnboundFieldDef
onErr PersistSettings
ps (Text
n' : Text
typ : [Text]
rest')
    | Bool -> Bool
not (Text -> Bool
T.null Text
n) Bool -> Bool -> Bool
&& Char -> Bool
isLower (HasCallStack => Text -> Char
Text -> Char
T.head Text
n) =
        case Text -> Either [Char] FieldType
parseFieldType Text
typ of
            Left [Char]
err -> Text -> [Char] -> Maybe UnboundFieldDef
onErr Text
typ [Char]
err
            Right FieldType
ft ->
                UnboundFieldDef -> Maybe UnboundFieldDef
forall a. a -> Maybe a
Just
                    UnboundFieldDef
                        { unboundFieldNameHS :: FieldNameHS
unboundFieldNameHS =
                            Text -> FieldNameHS
FieldNameHS Text
n
                        , unboundFieldNameDB :: FieldNameDB
unboundFieldNameDB =
                            PersistSettings -> Text -> [FieldAttr] -> FieldNameDB
getDbName' PersistSettings
ps Text
n [FieldAttr]
fieldAttrs_
                        , unboundFieldType :: FieldType
unboundFieldType =
                            FieldType
ft
                        , unboundFieldAttrs :: [FieldAttr]
unboundFieldAttrs =
                            [FieldAttr]
fieldAttrs_
                        , unboundFieldStrict :: Bool
unboundFieldStrict =
                            Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (PersistSettings -> Bool
psStrictFields PersistSettings
ps) Maybe Bool
mstrict
                        , unboundFieldComments :: Maybe Text
unboundFieldComments =
                            Maybe Text
forall a. Maybe a
Nothing
                        , unboundFieldCascade :: FieldCascade
unboundFieldCascade =
                            FieldCascade
cascade_
                        , unboundFieldGenerated :: Maybe Text
unboundFieldGenerated =
                            Maybe Text
generated_
                        }
  where
    fieldAttrs_ :: [FieldAttr]
fieldAttrs_ = [Text] -> [FieldAttr]
parseFieldAttrs [Text]
attrs_
    generated_ :: Maybe Text
generated_ = [Text] -> Maybe Text
parseGenerated [Text]
attrs_
    (FieldCascade
cascade_, [Text]
attrs_) = [Text] -> (FieldCascade, [Text])
parseCascade [Text]
rest'
    (Maybe Bool
mstrict, Text
n)
        | Just Text
x <- Text -> Text -> Maybe Text
T.stripPrefix Text
"!" Text
n' = (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True, Text
x)
        | Just Text
x <- Text -> Text -> Maybe Text
T.stripPrefix Text
"~" Text
n' = (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False, Text
x)
        | Bool
otherwise = (Maybe Bool
forall a. Maybe a
Nothing, Text
n')
takeCols Text -> [Char] -> Maybe UnboundFieldDef
_ PersistSettings
_ [Text]
_ = Maybe UnboundFieldDef
forall a. Maybe a
Nothing

parseGenerated :: [Text] -> Maybe Text
parseGenerated :: [Text] -> Maybe Text
parseGenerated = (Maybe Text -> Text -> Maybe Text)
-> Maybe Text -> [Text] -> Maybe Text
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Maybe Text
acc Text
x -> Maybe Text
acc Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Text -> Maybe Text
T.stripPrefix Text
"generated=" Text
x) Maybe Text
forall a. Maybe a
Nothing

getDbName :: PersistSettings -> Text -> [Text] -> Text
getDbName :: PersistSettings -> Text -> [Text] -> Text
getDbName PersistSettings
ps Text
n =
    Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (PersistSettings -> Text -> Text
psToDBName PersistSettings
ps Text
n) (Maybe Text -> Text) -> ([Text] -> Maybe Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text)
-> ([Text] -> [Text]) -> [Text] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe Text) -> [Text] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text -> Text -> Maybe Text
T.stripPrefix Text
"sql=")

getDbName' :: PersistSettings -> Text -> [FieldAttr] -> FieldNameDB
getDbName' :: PersistSettings -> Text -> [FieldAttr] -> FieldNameDB
getDbName' PersistSettings
ps Text
n =
    FieldNameDB -> [FieldAttr] -> FieldNameDB
getSqlNameOr (Text -> FieldNameDB
FieldNameDB (Text -> FieldNameDB) -> Text -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> Text
psToDBName PersistSettings
ps Text
n)

getSqlNameOr
    :: FieldNameDB
    -> [FieldAttr]
    -> FieldNameDB
getSqlNameOr :: FieldNameDB -> [FieldAttr] -> FieldNameDB
getSqlNameOr FieldNameDB
def =
    FieldNameDB -> (Text -> FieldNameDB) -> Maybe Text -> FieldNameDB
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FieldNameDB
def Text -> FieldNameDB
FieldNameDB (Maybe Text -> FieldNameDB)
-> ([FieldAttr] -> Maybe Text) -> [FieldAttr] -> FieldNameDB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FieldAttr] -> Maybe Text
findAttrSql
  where
    findAttrSql :: [FieldAttr] -> Maybe Text
findAttrSql =
        [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text)
-> ([FieldAttr] -> [Text]) -> [FieldAttr] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldAttr -> Maybe Text) -> [FieldAttr] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FieldAttr -> Maybe Text
isAttrSql
    isAttrSql :: FieldAttr -> Maybe Text
isAttrSql FieldAttr
attr =
        case FieldAttr
attr of
            FieldAttrSql Text
t ->
                Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
            FieldAttr
_ ->
                Maybe Text
forall a. Maybe a
Nothing

data SetOnceAtMost a
    = NotSet
    | SetOnce a
    | SetMoreThanOnce

instance Semigroup (SetOnceAtMost a) where
    SetOnceAtMost a
a <> :: SetOnceAtMost a -> SetOnceAtMost a -> SetOnceAtMost a
<> SetOnceAtMost a
b =
        case (SetOnceAtMost a
a, SetOnceAtMost a
b) of
            (SetOnceAtMost a
_, SetOnceAtMost a
NotSet) -> SetOnceAtMost a
a
            (SetOnceAtMost a
NotSet, SetOnceAtMost a
_) -> SetOnceAtMost a
b
            (SetOnce a
_, SetOnce a
_) -> SetOnceAtMost a
forall a. SetOnceAtMost a
SetMoreThanOnce
            (SetOnceAtMost a, SetOnceAtMost a)
_ -> SetOnceAtMost a
a

instance Monoid (SetOnceAtMost a) where
    mempty :: SetOnceAtMost a
mempty =
        SetOnceAtMost a
forall a. SetOnceAtMost a
NotSet

data EntityConstraintDefs = EntityConstraintDefs
    { EntityConstraintDefs -> SetOnceAtMost UnboundIdDef
entityConstraintDefsIdField :: SetOnceAtMost UnboundIdDef
    , EntityConstraintDefs -> SetOnceAtMost UnboundCompositeDef
entityConstraintDefsPrimaryComposite :: SetOnceAtMost UnboundCompositeDef
    , EntityConstraintDefs -> Maybe (NonEmpty UniqueDef)
entityConstraintDefsUniques :: Maybe (NonEmpty UniqueDef)
    , EntityConstraintDefs -> Maybe (NonEmpty UnboundForeignDef)
entityConstraintDefsForeigns :: Maybe (NonEmpty UnboundForeignDef)
    }

instance Semigroup EntityConstraintDefs where
    EntityConstraintDefs
a <> :: EntityConstraintDefs
-> EntityConstraintDefs -> EntityConstraintDefs
<> EntityConstraintDefs
b =
        EntityConstraintDefs
            { entityConstraintDefsIdField :: SetOnceAtMost UnboundIdDef
entityConstraintDefsIdField =
                EntityConstraintDefs -> SetOnceAtMost UnboundIdDef
entityConstraintDefsIdField EntityConstraintDefs
a SetOnceAtMost UnboundIdDef
-> SetOnceAtMost UnboundIdDef -> SetOnceAtMost UnboundIdDef
forall a. Semigroup a => a -> a -> a
<> EntityConstraintDefs -> SetOnceAtMost UnboundIdDef
entityConstraintDefsIdField EntityConstraintDefs
b
            , entityConstraintDefsPrimaryComposite :: SetOnceAtMost UnboundCompositeDef
entityConstraintDefsPrimaryComposite =
                EntityConstraintDefs -> SetOnceAtMost UnboundCompositeDef
entityConstraintDefsPrimaryComposite EntityConstraintDefs
a SetOnceAtMost UnboundCompositeDef
-> SetOnceAtMost UnboundCompositeDef
-> SetOnceAtMost UnboundCompositeDef
forall a. Semigroup a => a -> a -> a
<> EntityConstraintDefs -> SetOnceAtMost UnboundCompositeDef
entityConstraintDefsPrimaryComposite EntityConstraintDefs
b
            , entityConstraintDefsUniques :: Maybe (NonEmpty UniqueDef)
entityConstraintDefsUniques =
                EntityConstraintDefs -> Maybe (NonEmpty UniqueDef)
entityConstraintDefsUniques EntityConstraintDefs
a Maybe (NonEmpty UniqueDef)
-> Maybe (NonEmpty UniqueDef) -> Maybe (NonEmpty UniqueDef)
forall a. Semigroup a => a -> a -> a
<> EntityConstraintDefs -> Maybe (NonEmpty UniqueDef)
entityConstraintDefsUniques EntityConstraintDefs
b
            , entityConstraintDefsForeigns :: Maybe (NonEmpty UnboundForeignDef)
entityConstraintDefsForeigns =
                EntityConstraintDefs -> Maybe (NonEmpty UnboundForeignDef)
entityConstraintDefsForeigns EntityConstraintDefs
a Maybe (NonEmpty UnboundForeignDef)
-> Maybe (NonEmpty UnboundForeignDef)
-> Maybe (NonEmpty UnboundForeignDef)
forall a. Semigroup a => a -> a -> a
<> EntityConstraintDefs -> Maybe (NonEmpty UnboundForeignDef)
entityConstraintDefsForeigns EntityConstraintDefs
b
            }

instance Monoid EntityConstraintDefs where
    mempty :: EntityConstraintDefs
mempty =
        SetOnceAtMost UnboundIdDef
-> SetOnceAtMost UnboundCompositeDef
-> Maybe (NonEmpty UniqueDef)
-> Maybe (NonEmpty UnboundForeignDef)
-> EntityConstraintDefs
EntityConstraintDefs SetOnceAtMost UnboundIdDef
forall a. Monoid a => a
mempty SetOnceAtMost UnboundCompositeDef
forall a. Monoid a => a
mempty Maybe (NonEmpty UniqueDef)
forall a. Maybe a
Nothing Maybe (NonEmpty UnboundForeignDef)
forall a. Maybe a
Nothing

entityConstraintDefsUniquesList :: EntityConstraintDefs -> [UniqueDef]
entityConstraintDefsUniquesList :: EntityConstraintDefs -> [UniqueDef]
entityConstraintDefsUniquesList = (NonEmpty UniqueDef -> [UniqueDef])
-> Maybe (NonEmpty UniqueDef) -> [UniqueDef]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NonEmpty UniqueDef -> [UniqueDef]
forall a. NonEmpty a -> [a]
NEL.toList (Maybe (NonEmpty UniqueDef) -> [UniqueDef])
-> (EntityConstraintDefs -> Maybe (NonEmpty UniqueDef))
-> EntityConstraintDefs
-> [UniqueDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityConstraintDefs -> Maybe (NonEmpty UniqueDef)
entityConstraintDefsUniques

entityConstraintDefsForeignsList :: EntityConstraintDefs -> [UnboundForeignDef]
entityConstraintDefsForeignsList :: EntityConstraintDefs -> [UnboundForeignDef]
entityConstraintDefsForeignsList = (NonEmpty UnboundForeignDef -> [UnboundForeignDef])
-> Maybe (NonEmpty UnboundForeignDef) -> [UnboundForeignDef]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NonEmpty UnboundForeignDef -> [UnboundForeignDef]
forall a. NonEmpty a -> [a]
NEL.toList (Maybe (NonEmpty UnboundForeignDef) -> [UnboundForeignDef])
-> (EntityConstraintDefs -> Maybe (NonEmpty UnboundForeignDef))
-> EntityConstraintDefs
-> [UnboundForeignDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityConstraintDefs -> Maybe (NonEmpty UnboundForeignDef)
entityConstraintDefsForeigns

takeConstraint
    :: PersistSettings
    -> EntityNameHS
    -> [UnboundFieldDef]
    -> NonEmpty Text
    -> EntityConstraintDefs
takeConstraint :: PersistSettings
-> EntityNameHS
-> [UnboundFieldDef]
-> NonEmpty Text
-> EntityConstraintDefs
takeConstraint PersistSettings
ps EntityNameHS
entityName [UnboundFieldDef]
defs (Text
n :| [Text]
rest) =
    case Text
n of
        Text
"Unique" ->
            EntityConstraintDefs
forall a. Monoid a => a
mempty
                { entityConstraintDefsUniques =
                    pure <$> takeUniq ps (unEntityNameHS entityName) defs rest
                }
        Text
"Foreign" ->
            EntityConstraintDefs
forall a. Monoid a => a
mempty
                { entityConstraintDefsForeigns =
                    Just $ pure (takeForeign ps entityName rest)
                }
        Text
"Primary" ->
            let
                unboundComposite :: UnboundCompositeDef
unboundComposite =
                    [FieldNameHS] -> [Text] -> UnboundCompositeDef
takeComposite (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS (UnboundFieldDef -> FieldNameHS)
-> [UnboundFieldDef] -> [FieldNameHS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UnboundFieldDef]
defs) [Text]
rest
             in
                EntityConstraintDefs
forall a. Monoid a => a
mempty
                    { entityConstraintDefsPrimaryComposite =
                        SetOnce unboundComposite
                    , entityConstraintDefsUniques =
                        Just $ pure $ compositeToUniqueDef entityName defs unboundComposite
                    }
        Text
"Id" ->
            EntityConstraintDefs
forall a. Monoid a => a
mempty
                { entityConstraintDefsIdField =
                    SetOnce (takeId ps entityName rest)
                }
        Text
_
            | Text -> Bool
isCapitalizedText Text
n ->
                EntityConstraintDefs
forall a. Monoid a => a
mempty
                    { entityConstraintDefsUniques =
                        pure <$> takeUniq ps "" defs (n : rest)
                    }
        Text
_ ->
            EntityConstraintDefs
forall a. Monoid a => a
mempty

-- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName.
-- need to re-work takeCols function
takeId :: PersistSettings -> EntityNameHS -> [Text] -> UnboundIdDef
takeId :: PersistSettings -> EntityNameHS -> [Text] -> UnboundIdDef
takeId PersistSettings
ps EntityNameHS
entityName [Text]
texts =
    UnboundIdDef
        { unboundIdDBName :: FieldNameDB
unboundIdDBName =
            Text -> FieldNameDB
FieldNameDB (Text -> FieldNameDB) -> Text -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text
psIdName PersistSettings
ps
        , unboundIdEntityName :: EntityNameHS
unboundIdEntityName =
            EntityNameHS
entityName
        , unboundIdCascade :: FieldCascade
unboundIdCascade =
            FieldCascade
cascade_
        , unboundIdAttrs :: [FieldAttr]
unboundIdAttrs =
            [Text] -> [FieldAttr]
parseFieldAttrs [Text]
attrs_
        , unboundIdType :: Maybe FieldType
unboundIdType =
            Maybe FieldType
typ
        }
  where
    typ :: Maybe FieldType
typ =
        case [Text]
texts of
            [] ->
                Maybe FieldType
forall a. Maybe a
Nothing
            (Text
t : [Text]
_) ->
                case Text -> Either [Char] FieldType
parseFieldType Text
t of
                    Left [Char]
_ ->
                        Maybe FieldType
forall a. Maybe a
Nothing
                    Right FieldType
ft ->
                        FieldType -> Maybe FieldType
forall a. a -> Maybe a
Just FieldType
ft
    (FieldCascade
cascade_, [Text]
attrs_) = [Text] -> (FieldCascade, [Text])
parseCascade [Text]
texts

-- | A definition for a composite primary key.
--
-- @since.2.13.0.0
data UnboundCompositeDef = UnboundCompositeDef
    { UnboundCompositeDef -> NonEmpty FieldNameHS
unboundCompositeCols :: NonEmpty FieldNameHS
    -- ^ The field names for the primary key.
    --
    -- @since 2.13.0.0
    , UnboundCompositeDef -> [Text]
unboundCompositeAttrs :: [Attr]
    -- ^ A list of attributes defined on the primary key. This is anything that
    -- occurs after a @!@ character.
    --
    -- @since 2.13.0.0
    }
    deriving (UnboundCompositeDef -> UnboundCompositeDef -> Bool
(UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> (UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> Eq UnboundCompositeDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
== :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
$c/= :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
/= :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
Eq, Eq UnboundCompositeDef
Eq UnboundCompositeDef =>
(UnboundCompositeDef -> UnboundCompositeDef -> Ordering)
-> (UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> (UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> (UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> (UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> (UnboundCompositeDef
    -> UnboundCompositeDef -> UnboundCompositeDef)
-> (UnboundCompositeDef
    -> UnboundCompositeDef -> UnboundCompositeDef)
-> Ord UnboundCompositeDef
UnboundCompositeDef -> UnboundCompositeDef -> Bool
UnboundCompositeDef -> UnboundCompositeDef -> Ordering
UnboundCompositeDef -> UnboundCompositeDef -> UnboundCompositeDef
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: UnboundCompositeDef -> UnboundCompositeDef -> Ordering
compare :: UnboundCompositeDef -> UnboundCompositeDef -> Ordering
$c< :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
< :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
$c<= :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
<= :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
$c> :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
> :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
$c>= :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
>= :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
$cmax :: UnboundCompositeDef -> UnboundCompositeDef -> UnboundCompositeDef
max :: UnboundCompositeDef -> UnboundCompositeDef -> UnboundCompositeDef
$cmin :: UnboundCompositeDef -> UnboundCompositeDef -> UnboundCompositeDef
min :: UnboundCompositeDef -> UnboundCompositeDef -> UnboundCompositeDef
Ord, Int -> UnboundCompositeDef -> ShowS
[UnboundCompositeDef] -> ShowS
UnboundCompositeDef -> [Char]
(Int -> UnboundCompositeDef -> ShowS)
-> (UnboundCompositeDef -> [Char])
-> ([UnboundCompositeDef] -> ShowS)
-> Show UnboundCompositeDef
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnboundCompositeDef -> ShowS
showsPrec :: Int -> UnboundCompositeDef -> ShowS
$cshow :: UnboundCompositeDef -> [Char]
show :: UnboundCompositeDef -> [Char]
$cshowList :: [UnboundCompositeDef] -> ShowS
showList :: [UnboundCompositeDef] -> ShowS
Show, (forall (m :: * -> *). Quote m => UnboundCompositeDef -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    UnboundCompositeDef -> Code m UnboundCompositeDef)
-> Lift UnboundCompositeDef
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => UnboundCompositeDef -> m Exp
forall (m :: * -> *).
Quote m =>
UnboundCompositeDef -> Code m UnboundCompositeDef
$clift :: forall (m :: * -> *). Quote m => UnboundCompositeDef -> m Exp
lift :: forall (m :: * -> *). Quote m => UnboundCompositeDef -> m Exp
$cliftTyped :: forall (m :: * -> *).
Quote m =>
UnboundCompositeDef -> Code m UnboundCompositeDef
liftTyped :: forall (m :: * -> *).
Quote m =>
UnboundCompositeDef -> Code m UnboundCompositeDef
Lift)

compositeToUniqueDef
    :: EntityNameHS -> [UnboundFieldDef] -> UnboundCompositeDef -> UniqueDef
compositeToUniqueDef :: EntityNameHS
-> [UnboundFieldDef] -> UnboundCompositeDef -> UniqueDef
compositeToUniqueDef EntityNameHS
entityName [UnboundFieldDef]
fields UnboundCompositeDef{[Text]
NonEmpty FieldNameHS
unboundCompositeCols :: UnboundCompositeDef -> NonEmpty FieldNameHS
unboundCompositeAttrs :: UnboundCompositeDef -> [Text]
unboundCompositeCols :: NonEmpty FieldNameHS
unboundCompositeAttrs :: [Text]
..} =
    UniqueDef
        { uniqueHaskell :: ConstraintNameHS
uniqueHaskell =
            Text -> ConstraintNameHS
ConstraintNameHS (EntityNameHS -> Text
unEntityNameHS EntityNameHS
entityName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"PrimaryKey")
        , uniqueDBName :: ConstraintNameDB
uniqueDBName =
            Text -> ConstraintNameDB
ConstraintNameDB Text
"primary_key"
        , uniqueFields :: NonEmpty (FieldNameHS, FieldNameDB)
uniqueFields =
            (FieldNameHS -> (FieldNameHS, FieldNameDB))
-> NonEmpty FieldNameHS -> NonEmpty (FieldNameHS, FieldNameDB)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FieldNameHS
hsName -> (FieldNameHS
hsName, FieldNameHS -> FieldNameDB
getDbNameFor FieldNameHS
hsName)) NonEmpty FieldNameHS
unboundCompositeCols
        , uniqueAttrs :: [Text]
uniqueAttrs =
            [Text]
unboundCompositeAttrs
        }
  where
    getDbNameFor :: FieldNameHS -> FieldNameDB
getDbNameFor FieldNameHS
hsName =
        case (UnboundFieldDef -> Maybe FieldNameDB)
-> [UnboundFieldDef] -> [FieldNameDB]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (FieldNameHS -> UnboundFieldDef -> Maybe FieldNameDB
forall {m :: * -> *}.
(Monad m, Alternative m) =>
FieldNameHS -> UnboundFieldDef -> m FieldNameDB
matchHsName FieldNameHS
hsName) [UnboundFieldDef]
fields of
            [] ->
                [Char] -> FieldNameDB
forall a. HasCallStack => [Char] -> a
error [Char]
"Unable to find `hsName` in fields"
            (FieldNameDB
a : [FieldNameDB]
_) ->
                FieldNameDB
a
    matchHsName :: FieldNameHS -> UnboundFieldDef -> m FieldNameDB
matchHsName FieldNameHS
hsName UnboundFieldDef{Bool
[FieldAttr]
Maybe Text
FieldNameHS
FieldNameDB
FieldCascade
FieldType
unboundFieldNameHS :: UnboundFieldDef -> FieldNameHS
unboundFieldNameDB :: UnboundFieldDef -> FieldNameDB
unboundFieldAttrs :: UnboundFieldDef -> [FieldAttr]
unboundFieldStrict :: UnboundFieldDef -> Bool
unboundFieldType :: UnboundFieldDef -> FieldType
unboundFieldCascade :: UnboundFieldDef -> FieldCascade
unboundFieldGenerated :: UnboundFieldDef -> Maybe Text
unboundFieldComments :: UnboundFieldDef -> Maybe Text
unboundFieldNameHS :: FieldNameHS
unboundFieldNameDB :: FieldNameDB
unboundFieldAttrs :: [FieldAttr]
unboundFieldStrict :: Bool
unboundFieldType :: FieldType
unboundFieldCascade :: FieldCascade
unboundFieldGenerated :: Maybe Text
unboundFieldComments :: Maybe Text
..} = do
        Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ FieldNameHS
unboundFieldNameHS FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== FieldNameHS
hsName
        FieldNameDB -> m FieldNameDB
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldNameDB
unboundFieldNameDB

takeComposite
    :: [FieldNameHS]
    -> [Text]
    -> UnboundCompositeDef
takeComposite :: [FieldNameHS] -> [Text] -> UnboundCompositeDef
takeComposite [FieldNameHS]
fields [Text]
pkcols =
    UnboundCompositeDef
        { unboundCompositeCols :: NonEmpty FieldNameHS
unboundCompositeCols =
            (Text -> FieldNameHS) -> NonEmpty Text -> NonEmpty FieldNameHS
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([FieldNameHS] -> Text -> FieldNameHS
getDef [FieldNameHS]
fields) NonEmpty Text
neCols
        , unboundCompositeAttrs :: [Text]
unboundCompositeAttrs =
            [Text]
attrs
        }
  where
    neCols :: NonEmpty Text
neCols =
        case [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [Text]
cols of
            Maybe (NonEmpty Text)
Nothing ->
                [Char] -> NonEmpty Text
forall a. HasCallStack => [Char] -> a
error [Char]
"No fields provided for primary key"
            Just NonEmpty Text
xs ->
                NonEmpty Text
xs
    ([Text]
cols, [Text]
attrs) = (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text
"!" Text -> Text -> Bool
`T.isPrefixOf`) [Text]
pkcols
    getDef :: [FieldNameHS] -> Text -> FieldNameHS
getDef [] Text
t = [Char] -> FieldNameHS
forall a. HasCallStack => [Char] -> a
error ([Char] -> FieldNameHS) -> [Char] -> FieldNameHS
forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown column in primary key constraint: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
t
    getDef (FieldNameHS
d : [FieldNameHS]
ds) Text
t
        | FieldNameHS
d FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> FieldNameHS
FieldNameHS Text
t =
            -- TODO: check for nullability in later step
            -- if nullable (fieldAttrs d) /= NotNullable
            --     then error $ "primary key column cannot be nullable: " ++ show t ++ show fields
            FieldNameHS
d
        | Bool
otherwise =
            [FieldNameHS] -> Text -> FieldNameHS
getDef [FieldNameHS]
ds Text
t

-- Unique UppercaseConstraintName list of lowercasefields terminated
-- by ! or sql= such that a unique constraint can look like:
-- `UniqueTestNull fieldA fieldB sql=ConstraintNameInDatabase !force`
-- Here using sql= sets the name of the constraint.
takeUniq
    :: PersistSettings
    -> Text
    -> [UnboundFieldDef]
    -> [Text]
    -> Maybe UniqueDef
takeUniq :: PersistSettings
-> Text -> [UnboundFieldDef] -> [Text] -> Maybe UniqueDef
takeUniq PersistSettings
ps Text
tableName [UnboundFieldDef]
defs (Text
n : [Text]
rest)
    | Text -> Bool
isCapitalizedText Text
n = do
        NonEmpty Text
fields <- Maybe (NonEmpty Text)
mfields
        UniqueDef -> Maybe UniqueDef
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            UniqueDef
                { uniqueHaskell :: ConstraintNameHS
uniqueHaskell =
                    Text -> ConstraintNameHS
ConstraintNameHS Text
n
                , uniqueDBName :: ConstraintNameDB
uniqueDBName =
                    ConstraintNameDB
dbName
                , uniqueFields :: NonEmpty (FieldNameHS, FieldNameDB)
uniqueFields =
                    (Text -> (FieldNameHS, FieldNameDB))
-> NonEmpty Text -> NonEmpty (FieldNameHS, FieldNameDB)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
a -> (Text -> FieldNameHS
FieldNameHS Text
a, [UnboundFieldDef] -> Text -> FieldNameDB
getDBName [UnboundFieldDef]
defs Text
a)) NonEmpty Text
fields
                , uniqueAttrs :: [Text]
uniqueAttrs =
                    [Text]
attrs
                }
  where
    isAttr :: Text -> Bool
isAttr Text
a =
        Text
"!" Text -> Text -> Bool
`T.isPrefixOf` Text
a
    isSqlName :: Text -> Bool
isSqlName Text
a =
        Text
"sql=" Text -> Text -> Bool
`T.isPrefixOf` Text
a
    isNonField :: Text -> Bool
isNonField Text
a =
        Text -> Bool
isAttr Text
a Bool -> Bool -> Bool
|| Text -> Bool
isSqlName Text
a
    ([Text]
fieldsList, [Text]
nonFields) =
        (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Text -> Bool
isNonField [Text]
rest
    mfields :: Maybe (NonEmpty Text)
mfields =
        [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [Text]
fieldsList

    attrs :: [Text]
attrs = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter Text -> Bool
isAttr [Text]
nonFields

    usualDbName :: ConstraintNameDB
usualDbName =
        Text -> ConstraintNameDB
ConstraintNameDB (Text -> ConstraintNameDB) -> Text -> ConstraintNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> Text
psToDBName PersistSettings
ps (Text
tableName Text -> Text -> Text
`T.append` Text
n)
    sqlName :: Maybe ConstraintNameDB
    sqlName :: Maybe ConstraintNameDB
sqlName =
        case (Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Text -> Bool
isSqlName [Text]
nonFields of
            Maybe Text
Nothing ->
                Maybe ConstraintNameDB
forall a. Maybe a
Nothing
            (Just Text
t) ->
                case Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"=" Text
t of
                    (Text
x : [Text]
_) -> ConstraintNameDB -> Maybe ConstraintNameDB
forall a. a -> Maybe a
Just (Text -> ConstraintNameDB
ConstraintNameDB Text
x)
                    [Text]
_ -> Maybe ConstraintNameDB
forall a. Maybe a
Nothing
    dbName :: ConstraintNameDB
dbName = ConstraintNameDB -> Maybe ConstraintNameDB -> ConstraintNameDB
forall a. a -> Maybe a -> a
fromMaybe ConstraintNameDB
usualDbName Maybe ConstraintNameDB
sqlName

    getDBName :: [UnboundFieldDef] -> Text -> FieldNameDB
getDBName [] Text
t = [Char] -> FieldNameDB
forall a. HasCallStack => [Char] -> a
error ([Char] -> FieldNameDB) -> [Char] -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Text -> [UnboundFieldDef] -> Text -> Text
unknownUniqueColumnError Text
t [UnboundFieldDef]
defs Text
n)
    getDBName (UnboundFieldDef
d : [UnboundFieldDef]
ds) Text
t
        | UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
d FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> FieldNameHS
FieldNameHS Text
t =
            UnboundFieldDef -> FieldNameDB
unboundFieldNameDB UnboundFieldDef
d
        | Bool
otherwise =
            [UnboundFieldDef] -> Text -> FieldNameDB
getDBName [UnboundFieldDef]
ds Text
t
takeUniq PersistSettings
_ Text
tableName [UnboundFieldDef]
_ [Text]
xs =
    [Char] -> Maybe UniqueDef
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maybe UniqueDef) -> [Char] -> Maybe UniqueDef
forall a b. (a -> b) -> a -> b
$
        [Char]
"invalid unique constraint on table["
            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
tableName
            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"] expecting an uppercase constraint name xs="
            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> [Char]
forall a. Show a => a -> [Char]
show [Text]
xs

unknownUniqueColumnError :: Text -> [UnboundFieldDef] -> Text -> Text
unknownUniqueColumnError :: Text -> [UnboundFieldDef] -> Text -> Text
unknownUniqueColumnError Text
t [UnboundFieldDef]
defs Text
n =
    Text
"Unknown column in \""
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" constraint: \""
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" possible fields: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack ([Text] -> [Char]
forall a. Show a => a -> [Char]
show (UnboundFieldDef -> Text
toFieldName (UnboundFieldDef -> Text) -> [UnboundFieldDef] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UnboundFieldDef]
defs))
  where
    toFieldName :: UnboundFieldDef -> Text
    toFieldName :: UnboundFieldDef -> Text
toFieldName UnboundFieldDef
fd =
        FieldNameHS -> Text
unFieldNameHS (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
fd)

-- | Define an explicit foreign key reference.
--
-- @
-- User
--     name Text
--     email Text
--
--     Primary name email
--
-- Dog
--     ownerName Text
--     ownerEmail Text
--
--     Foreign User fk_dog_user ownerName ownerEmail
-- @
--
-- @since 2.13.0.0
data UnboundForeignDef
    = UnboundForeignDef
    { UnboundForeignDef -> UnboundForeignFieldList
unboundForeignFields :: UnboundForeignFieldList
    -- ^ Fields in the source entity.
    --
    -- @since 2.13.0.0
    , UnboundForeignDef -> ForeignDef
unboundForeignDef :: ForeignDef
    -- ^ The 'ForeignDef' which needs information filled in.
    --
    -- This value is unreliable. See the parsing code to see what data is filled
    -- in here.
    --
    -- @since 2.13.0.0
    }
    deriving (UnboundForeignDef -> UnboundForeignDef -> Bool
(UnboundForeignDef -> UnboundForeignDef -> Bool)
-> (UnboundForeignDef -> UnboundForeignDef -> Bool)
-> Eq UnboundForeignDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnboundForeignDef -> UnboundForeignDef -> Bool
== :: UnboundForeignDef -> UnboundForeignDef -> Bool
$c/= :: UnboundForeignDef -> UnboundForeignDef -> Bool
/= :: UnboundForeignDef -> UnboundForeignDef -> Bool
Eq, Eq UnboundForeignDef
Eq UnboundForeignDef =>
(UnboundForeignDef -> UnboundForeignDef -> Ordering)
-> (UnboundForeignDef -> UnboundForeignDef -> Bool)
-> (UnboundForeignDef -> UnboundForeignDef -> Bool)
-> (UnboundForeignDef -> UnboundForeignDef -> Bool)
-> (UnboundForeignDef -> UnboundForeignDef -> Bool)
-> (UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef)
-> (UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef)
-> Ord UnboundForeignDef
UnboundForeignDef -> UnboundForeignDef -> Bool
UnboundForeignDef -> UnboundForeignDef -> Ordering
UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: UnboundForeignDef -> UnboundForeignDef -> Ordering
compare :: UnboundForeignDef -> UnboundForeignDef -> Ordering
$c< :: UnboundForeignDef -> UnboundForeignDef -> Bool
< :: UnboundForeignDef -> UnboundForeignDef -> Bool
$c<= :: UnboundForeignDef -> UnboundForeignDef -> Bool
<= :: UnboundForeignDef -> UnboundForeignDef -> Bool
$c> :: UnboundForeignDef -> UnboundForeignDef -> Bool
> :: UnboundForeignDef -> UnboundForeignDef -> Bool
$c>= :: UnboundForeignDef -> UnboundForeignDef -> Bool
>= :: UnboundForeignDef -> UnboundForeignDef -> Bool
$cmax :: UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef
max :: UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef
$cmin :: UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef
min :: UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef
Ord, Int -> UnboundForeignDef -> ShowS
[UnboundForeignDef] -> ShowS
UnboundForeignDef -> [Char]
(Int -> UnboundForeignDef -> ShowS)
-> (UnboundForeignDef -> [Char])
-> ([UnboundForeignDef] -> ShowS)
-> Show UnboundForeignDef
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnboundForeignDef -> ShowS
showsPrec :: Int -> UnboundForeignDef -> ShowS
$cshow :: UnboundForeignDef -> [Char]
show :: UnboundForeignDef -> [Char]
$cshowList :: [UnboundForeignDef] -> ShowS
showList :: [UnboundForeignDef] -> ShowS
Show, (forall (m :: * -> *). Quote m => UnboundForeignDef -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    UnboundForeignDef -> Code m UnboundForeignDef)
-> Lift UnboundForeignDef
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => UnboundForeignDef -> m Exp
forall (m :: * -> *).
Quote m =>
UnboundForeignDef -> Code m UnboundForeignDef
$clift :: forall (m :: * -> *). Quote m => UnboundForeignDef -> m Exp
lift :: forall (m :: * -> *). Quote m => UnboundForeignDef -> m Exp
$cliftTyped :: forall (m :: * -> *).
Quote m =>
UnboundForeignDef -> Code m UnboundForeignDef
liftTyped :: forall (m :: * -> *).
Quote m =>
UnboundForeignDef -> Code m UnboundForeignDef
Lift)

-- | A list of fields present on the foreign reference.
data UnboundForeignFieldList
    = -- | If no @References@ keyword is supplied, then it is assumed that you are
      -- referring to the @Primary@ key or @Id@ of the target entity.
      --
      -- @since 2.13.0.0
      FieldListImpliedId (NonEmpty FieldNameHS)
    | -- | You can specify the exact columns you're referring to here, if they
      -- aren't part of a primary key. Most databases expect a unique index on the
      -- columns you refer to, but Persistent doesnt' check that.
      --
      -- @
      -- User
      --     Id           UUID default="uuid_generate_v1mc()"
      --     name         Text
      --
      --     UniqueName name
      --
      -- Dog
      --     ownerName    Text
      --
      --     Foreign User fk_dog_user ownerName References name
      -- @
      --
      -- @since 2.13.0.0
      FieldListHasReferences (NonEmpty ForeignFieldReference)
    deriving (UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
(UnboundForeignFieldList -> UnboundForeignFieldList -> Bool)
-> (UnboundForeignFieldList -> UnboundForeignFieldList -> Bool)
-> Eq UnboundForeignFieldList
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
== :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
$c/= :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
/= :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
Eq, Eq UnboundForeignFieldList
Eq UnboundForeignFieldList =>
(UnboundForeignFieldList -> UnboundForeignFieldList -> Ordering)
-> (UnboundForeignFieldList -> UnboundForeignFieldList -> Bool)
-> (UnboundForeignFieldList -> UnboundForeignFieldList -> Bool)
-> (UnboundForeignFieldList -> UnboundForeignFieldList -> Bool)
-> (UnboundForeignFieldList -> UnboundForeignFieldList -> Bool)
-> (UnboundForeignFieldList
    -> UnboundForeignFieldList -> UnboundForeignFieldList)
-> (UnboundForeignFieldList
    -> UnboundForeignFieldList -> UnboundForeignFieldList)
-> Ord UnboundForeignFieldList
UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
UnboundForeignFieldList -> UnboundForeignFieldList -> Ordering
UnboundForeignFieldList
-> UnboundForeignFieldList -> UnboundForeignFieldList
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: UnboundForeignFieldList -> UnboundForeignFieldList -> Ordering
compare :: UnboundForeignFieldList -> UnboundForeignFieldList -> Ordering
$c< :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
< :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
$c<= :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
<= :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
$c> :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
> :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
$c>= :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
>= :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
$cmax :: UnboundForeignFieldList
-> UnboundForeignFieldList -> UnboundForeignFieldList
max :: UnboundForeignFieldList
-> UnboundForeignFieldList -> UnboundForeignFieldList
$cmin :: UnboundForeignFieldList
-> UnboundForeignFieldList -> UnboundForeignFieldList
min :: UnboundForeignFieldList
-> UnboundForeignFieldList -> UnboundForeignFieldList
Ord, Int -> UnboundForeignFieldList -> ShowS
[UnboundForeignFieldList] -> ShowS
UnboundForeignFieldList -> [Char]
(Int -> UnboundForeignFieldList -> ShowS)
-> (UnboundForeignFieldList -> [Char])
-> ([UnboundForeignFieldList] -> ShowS)
-> Show UnboundForeignFieldList
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnboundForeignFieldList -> ShowS
showsPrec :: Int -> UnboundForeignFieldList -> ShowS
$cshow :: UnboundForeignFieldList -> [Char]
show :: UnboundForeignFieldList -> [Char]
$cshowList :: [UnboundForeignFieldList] -> ShowS
showList :: [UnboundForeignFieldList] -> ShowS
Show, (forall (m :: * -> *). Quote m => UnboundForeignFieldList -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    UnboundForeignFieldList -> Code m UnboundForeignFieldList)
-> Lift UnboundForeignFieldList
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => UnboundForeignFieldList -> m Exp
forall (m :: * -> *).
Quote m =>
UnboundForeignFieldList -> Code m UnboundForeignFieldList
$clift :: forall (m :: * -> *). Quote m => UnboundForeignFieldList -> m Exp
lift :: forall (m :: * -> *). Quote m => UnboundForeignFieldList -> m Exp
$cliftTyped :: forall (m :: * -> *).
Quote m =>
UnboundForeignFieldList -> Code m UnboundForeignFieldList
liftTyped :: forall (m :: * -> *).
Quote m =>
UnboundForeignFieldList -> Code m UnboundForeignFieldList
Lift)

-- | A pairing of the 'FieldNameHS' for the source table to the 'FieldNameHS'
-- for the target table.
--
-- @since 2.13.0.0
data ForeignFieldReference
    = ForeignFieldReference
    { ForeignFieldReference -> FieldNameHS
ffrSourceField :: FieldNameHS
    -- ^ The column on the source table.
    --
    -- @since 2.13.0.0
    , ForeignFieldReference -> FieldNameHS
ffrTargetField :: FieldNameHS
    -- ^ The column on the target table.
    --
    -- @since 2.13.0.0
    }
    deriving (ForeignFieldReference -> ForeignFieldReference -> Bool
(ForeignFieldReference -> ForeignFieldReference -> Bool)
-> (ForeignFieldReference -> ForeignFieldReference -> Bool)
-> Eq ForeignFieldReference
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ForeignFieldReference -> ForeignFieldReference -> Bool
== :: ForeignFieldReference -> ForeignFieldReference -> Bool
$c/= :: ForeignFieldReference -> ForeignFieldReference -> Bool
/= :: ForeignFieldReference -> ForeignFieldReference -> Bool
Eq, Eq ForeignFieldReference
Eq ForeignFieldReference =>
(ForeignFieldReference -> ForeignFieldReference -> Ordering)
-> (ForeignFieldReference -> ForeignFieldReference -> Bool)
-> (ForeignFieldReference -> ForeignFieldReference -> Bool)
-> (ForeignFieldReference -> ForeignFieldReference -> Bool)
-> (ForeignFieldReference -> ForeignFieldReference -> Bool)
-> (ForeignFieldReference
    -> ForeignFieldReference -> ForeignFieldReference)
-> (ForeignFieldReference
    -> ForeignFieldReference -> ForeignFieldReference)
-> Ord ForeignFieldReference
ForeignFieldReference -> ForeignFieldReference -> Bool
ForeignFieldReference -> ForeignFieldReference -> Ordering
ForeignFieldReference
-> ForeignFieldReference -> ForeignFieldReference
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ForeignFieldReference -> ForeignFieldReference -> Ordering
compare :: ForeignFieldReference -> ForeignFieldReference -> Ordering
$c< :: ForeignFieldReference -> ForeignFieldReference -> Bool
< :: ForeignFieldReference -> ForeignFieldReference -> Bool
$c<= :: ForeignFieldReference -> ForeignFieldReference -> Bool
<= :: ForeignFieldReference -> ForeignFieldReference -> Bool
$c> :: ForeignFieldReference -> ForeignFieldReference -> Bool
> :: ForeignFieldReference -> ForeignFieldReference -> Bool
$c>= :: ForeignFieldReference -> ForeignFieldReference -> Bool
>= :: ForeignFieldReference -> ForeignFieldReference -> Bool
$cmax :: ForeignFieldReference
-> ForeignFieldReference -> ForeignFieldReference
max :: ForeignFieldReference
-> ForeignFieldReference -> ForeignFieldReference
$cmin :: ForeignFieldReference
-> ForeignFieldReference -> ForeignFieldReference
min :: ForeignFieldReference
-> ForeignFieldReference -> ForeignFieldReference
Ord, Int -> ForeignFieldReference -> ShowS
[ForeignFieldReference] -> ShowS
ForeignFieldReference -> [Char]
(Int -> ForeignFieldReference -> ShowS)
-> (ForeignFieldReference -> [Char])
-> ([ForeignFieldReference] -> ShowS)
-> Show ForeignFieldReference
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ForeignFieldReference -> ShowS
showsPrec :: Int -> ForeignFieldReference -> ShowS
$cshow :: ForeignFieldReference -> [Char]
show :: ForeignFieldReference -> [Char]
$cshowList :: [ForeignFieldReference] -> ShowS
showList :: [ForeignFieldReference] -> ShowS
Show, (forall (m :: * -> *). Quote m => ForeignFieldReference -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    ForeignFieldReference -> Code m ForeignFieldReference)
-> Lift ForeignFieldReference
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => ForeignFieldReference -> m Exp
forall (m :: * -> *).
Quote m =>
ForeignFieldReference -> Code m ForeignFieldReference
$clift :: forall (m :: * -> *). Quote m => ForeignFieldReference -> m Exp
lift :: forall (m :: * -> *). Quote m => ForeignFieldReference -> m Exp
$cliftTyped :: forall (m :: * -> *).
Quote m =>
ForeignFieldReference -> Code m ForeignFieldReference
liftTyped :: forall (m :: * -> *).
Quote m =>
ForeignFieldReference -> Code m ForeignFieldReference
Lift)

unbindForeignDef :: ForeignDef -> UnboundForeignDef
unbindForeignDef :: ForeignDef -> UnboundForeignDef
unbindForeignDef ForeignDef
fd =
    UnboundForeignDef
        { unboundForeignFields :: UnboundForeignFieldList
unboundForeignFields =
            NonEmpty ForeignFieldReference -> UnboundForeignFieldList
FieldListHasReferences (NonEmpty ForeignFieldReference -> UnboundForeignFieldList)
-> NonEmpty ForeignFieldReference -> UnboundForeignFieldList
forall a b. (a -> b) -> a -> b
$ [ForeignFieldReference] -> NonEmpty ForeignFieldReference
forall a. HasCallStack => [a] -> NonEmpty a
NEL.fromList ([ForeignFieldReference] -> NonEmpty ForeignFieldReference)
-> [ForeignFieldReference] -> NonEmpty ForeignFieldReference
forall a b. (a -> b) -> a -> b
$ (((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
 -> ForeignFieldReference)
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
-> [ForeignFieldReference]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> ForeignFieldReference
forall {b} {b}.
((FieldNameHS, b), (FieldNameHS, b)) -> ForeignFieldReference
mk (ForeignDef
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
foreignFields ForeignDef
fd)
        , unboundForeignDef :: ForeignDef
unboundForeignDef =
            ForeignDef
fd
        }
  where
    mk :: ((FieldNameHS, b), (FieldNameHS, b)) -> ForeignFieldReference
mk ((FieldNameHS
fH, b
_), (FieldNameHS
pH, b
_)) =
        ForeignFieldReference
            { ffrSourceField :: FieldNameHS
ffrSourceField = FieldNameHS
fH
            , ffrTargetField :: FieldNameHS
ffrTargetField = FieldNameHS
pH
            }

mkUnboundForeignFieldList
    :: [Text]
    -> [Text]
    -> Either String UnboundForeignFieldList
mkUnboundForeignFieldList :: [Text] -> [Text] -> Either [Char] UnboundForeignFieldList
mkUnboundForeignFieldList ((Text -> FieldNameHS) -> [Text] -> [FieldNameHS]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FieldNameHS
FieldNameHS -> [FieldNameHS]
source) ((Text -> FieldNameHS) -> [Text] -> [FieldNameHS]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FieldNameHS
FieldNameHS -> [FieldNameHS]
target) =
    case [FieldNameHS] -> Maybe (NonEmpty FieldNameHS)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [FieldNameHS]
source of
        Maybe (NonEmpty FieldNameHS)
Nothing ->
            [Char] -> Either [Char] UnboundForeignFieldList
forall a b. a -> Either a b
Left [Char]
"No fields on foreign reference."
        Just NonEmpty FieldNameHS
sources ->
            case [FieldNameHS] -> Maybe (NonEmpty FieldNameHS)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [FieldNameHS]
target of
                Maybe (NonEmpty FieldNameHS)
Nothing ->
                    UnboundForeignFieldList -> Either [Char] UnboundForeignFieldList
forall a b. b -> Either a b
Right (UnboundForeignFieldList -> Either [Char] UnboundForeignFieldList)
-> UnboundForeignFieldList -> Either [Char] UnboundForeignFieldList
forall a b. (a -> b) -> a -> b
$ NonEmpty FieldNameHS -> UnboundForeignFieldList
FieldListImpliedId NonEmpty FieldNameHS
sources
                Just NonEmpty FieldNameHS
targets ->
                    if NonEmpty FieldNameHS -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty FieldNameHS
targets Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= NonEmpty FieldNameHS -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty FieldNameHS
sources
                        then
                            [Char] -> Either [Char] UnboundForeignFieldList
forall a b. a -> Either a b
Left [Char]
"Target and source length differe on foreign reference."
                        else
                            UnboundForeignFieldList -> Either [Char] UnboundForeignFieldList
forall a b. b -> Either a b
Right (UnboundForeignFieldList -> Either [Char] UnboundForeignFieldList)
-> UnboundForeignFieldList -> Either [Char] UnboundForeignFieldList
forall a b. (a -> b) -> a -> b
$
                                NonEmpty ForeignFieldReference -> UnboundForeignFieldList
FieldListHasReferences (NonEmpty ForeignFieldReference -> UnboundForeignFieldList)
-> NonEmpty ForeignFieldReference -> UnboundForeignFieldList
forall a b. (a -> b) -> a -> b
$
                                    (FieldNameHS -> FieldNameHS -> ForeignFieldReference)
-> NonEmpty FieldNameHS
-> NonEmpty FieldNameHS
-> NonEmpty ForeignFieldReference
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NEL.zipWith FieldNameHS -> FieldNameHS -> ForeignFieldReference
ForeignFieldReference NonEmpty FieldNameHS
sources NonEmpty FieldNameHS
targets

takeForeign
    :: PersistSettings
    -> EntityNameHS
    -> [Text]
    -> UnboundForeignDef
takeForeign :: PersistSettings -> EntityNameHS -> [Text] -> UnboundForeignDef
takeForeign PersistSettings
ps EntityNameHS
entityName = [Text] -> UnboundForeignDef
takeRefTable
  where
    errorPrefix :: String
    errorPrefix :: [Char]
errorPrefix =
        [Char]
"invalid foreign key constraint on table["
            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show (EntityNameHS -> Text
unEntityNameHS EntityNameHS
entityName)
            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"] "

    takeRefTable :: [Text] -> UnboundForeignDef
    takeRefTable :: [Text] -> UnboundForeignDef
takeRefTable [] =
        [Char] -> UnboundForeignDef
forall a. HasCallStack => [Char] -> a
error ([Char] -> UnboundForeignDef) -> [Char] -> UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ [Char]
errorPrefix [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" expecting foreign table name"
    takeRefTable (Text
refTableName : [Text]
restLine) =
        [Text]
-> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef
go [Text]
restLine Maybe CascadeAction
forall a. Maybe a
Nothing Maybe CascadeAction
forall a. Maybe a
Nothing
      where
        go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef
        go :: [Text]
-> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef
go (Text
constraintNameText : [Text]
rest) Maybe CascadeAction
onDelete Maybe CascadeAction
onUpdate
            | Bool -> Bool
not (Text -> Bool
T.null Text
constraintNameText) Bool -> Bool -> Bool
&& Char -> Bool
isLower (HasCallStack => Text -> Char
Text -> Char
T.head Text
constraintNameText) =
                UnboundForeignDef
                    { unboundForeignFields :: UnboundForeignFieldList
unboundForeignFields =
                        ([Char] -> UnboundForeignFieldList)
-> (UnboundForeignFieldList -> UnboundForeignFieldList)
-> Either [Char] UnboundForeignFieldList
-> UnboundForeignFieldList
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> UnboundForeignFieldList
forall a. HasCallStack => [Char] -> a
error UnboundForeignFieldList -> UnboundForeignFieldList
forall a. a -> a
id (Either [Char] UnboundForeignFieldList -> UnboundForeignFieldList)
-> Either [Char] UnboundForeignFieldList -> UnboundForeignFieldList
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text] -> Either [Char] UnboundForeignFieldList
mkUnboundForeignFieldList [Text]
foreignFields [Text]
parentFields
                    , unboundForeignDef :: ForeignDef
unboundForeignDef =
                        ForeignDef
                            { foreignRefTableHaskell :: EntityNameHS
foreignRefTableHaskell =
                                Text -> EntityNameHS
EntityNameHS Text
refTableName
                            , foreignRefTableDBName :: EntityNameDB
foreignRefTableDBName =
                                Text -> EntityNameDB
EntityNameDB (Text -> EntityNameDB) -> Text -> EntityNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> Text
psToDBName PersistSettings
ps Text
refTableName
                            , foreignConstraintNameHaskell :: ConstraintNameHS
foreignConstraintNameHaskell =
                                ConstraintNameHS
constraintName
                            , foreignConstraintNameDBName :: ConstraintNameDB
foreignConstraintNameDBName =
                                PersistSettings
-> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB
toFKConstraintNameDB PersistSettings
ps EntityNameHS
entityName ConstraintNameHS
constraintName
                            , foreignFieldCascade :: FieldCascade
foreignFieldCascade =
                                FieldCascade
                                    { fcOnDelete :: Maybe CascadeAction
fcOnDelete = Maybe CascadeAction
onDelete
                                    , fcOnUpdate :: Maybe CascadeAction
fcOnUpdate = Maybe CascadeAction
onUpdate
                                    }
                            , foreignAttrs :: [Text]
foreignAttrs =
                                [Text]
attrs
                            , foreignFields :: [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
foreignFields =
                                []
                            , foreignNullable :: Bool
foreignNullable =
                                Bool
False
                            , foreignToPrimary :: Bool
foreignToPrimary =
                                [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
parentFields
                            }
                    }
          where
            constraintName :: ConstraintNameHS
constraintName =
                Text -> ConstraintNameHS
ConstraintNameHS Text
constraintNameText

            ([Text]
fields, [Text]
attrs) =
                (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text
"!" Text -> Text -> Bool
`T.isPrefixOf`) [Text]
rest
            ([Text]
foreignFields, [Text]
parentFields) =
                case (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"References") [Text]
fields of
                    ([Text]
ffs, []) ->
                        ([Text]
ffs, [])
                    ([Text]
ffs, Text
_ : [Text]
pfs) ->
                        case ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ffs, [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
pfs) of
                            (Int
flen, Int
plen)
                                | Int
flen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
plen ->
                                    ([Text]
ffs, [Text]
pfs)
                            (Int
flen, Int
plen) ->
                                [Char] -> ([Text], [Text])
forall a. HasCallStack => [Char] -> a
error ([Char] -> ([Text], [Text])) -> [Char] -> ([Text], [Text])
forall a b. (a -> b) -> a -> b
$
                                    [Char]
errorPrefix
                                        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                            [ [Char]
"Found "
                                            , Int -> [Char]
forall a. Show a => a -> [Char]
show Int
flen
                                            , [Char]
" foreign fields but "
                                            , Int -> [Char]
forall a. Show a => a -> [Char]
show Int
plen
                                            , [Char]
" parent fields"
                                            ]
        go ((CascadePrefix -> Text -> Maybe CascadeAction
parseCascadeAction CascadePrefix
CascadeDelete -> Just CascadeAction
cascadingAction) : [Text]
rest) Maybe CascadeAction
onDelete' Maybe CascadeAction
onUpdate =
            case Maybe CascadeAction
onDelete' of
                Maybe CascadeAction
Nothing ->
                    [Text]
-> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef
go [Text]
rest (CascadeAction -> Maybe CascadeAction
forall a. a -> Maybe a
Just CascadeAction
cascadingAction) Maybe CascadeAction
onUpdate
                Just CascadeAction
_ ->
                    [Char] -> UnboundForeignDef
forall a. HasCallStack => [Char] -> a
error ([Char] -> UnboundForeignDef) -> [Char] -> UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ [Char]
errorPrefix [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"found more than one OnDelete actions"
        go ((CascadePrefix -> Text -> Maybe CascadeAction
parseCascadeAction CascadePrefix
CascadeUpdate -> Just CascadeAction
cascadingAction) : [Text]
rest) Maybe CascadeAction
onDelete Maybe CascadeAction
onUpdate' =
            case Maybe CascadeAction
onUpdate' of
                Maybe CascadeAction
Nothing ->
                    [Text]
-> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef
go [Text]
rest Maybe CascadeAction
onDelete (CascadeAction -> Maybe CascadeAction
forall a. a -> Maybe a
Just CascadeAction
cascadingAction)
                Just CascadeAction
_ ->
                    [Char] -> UnboundForeignDef
forall a. HasCallStack => [Char] -> a
error ([Char] -> UnboundForeignDef) -> [Char] -> UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ [Char]
errorPrefix [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"found more than one OnUpdate actions"
        go [Text]
xs Maybe CascadeAction
_ Maybe CascadeAction
_ =
            [Char] -> UnboundForeignDef
forall a. HasCallStack => [Char] -> a
error ([Char] -> UnboundForeignDef) -> [Char] -> UnboundForeignDef
forall a b. (a -> b) -> a -> b
$
                [Char]
errorPrefix
                    [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"expecting a lower case constraint name or a cascading action xs="
                    [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> [Char]
forall a. Show a => a -> [Char]
show [Text]
xs

toFKConstraintNameDB
    :: PersistSettings -> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB
toFKConstraintNameDB :: PersistSettings
-> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB
toFKConstraintNameDB PersistSettings
ps EntityNameHS
entityName ConstraintNameHS
constraintName =
    Text -> ConstraintNameDB
ConstraintNameDB (Text -> ConstraintNameDB) -> Text -> ConstraintNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> Text
psToDBName PersistSettings
ps (PersistSettings -> EntityNameHS -> ConstraintNameHS -> Text
psToFKName PersistSettings
ps EntityNameHS
entityName ConstraintNameHS
constraintName)
data CascadePrefix = CascadeUpdate | CascadeDelete

parseCascade :: [Text] -> (FieldCascade, [Text])
parseCascade :: [Text] -> (FieldCascade, [Text])
parseCascade [Text]
allTokens =
    [Text]
-> Maybe CascadeAction
-> Maybe CascadeAction
-> [Text]
-> (FieldCascade, [Text])
go [] Maybe CascadeAction
forall a. Maybe a
Nothing Maybe CascadeAction
forall a. Maybe a
Nothing [Text]
allTokens
  where
    go :: [Text]
-> Maybe CascadeAction
-> Maybe CascadeAction
-> [Text]
-> (FieldCascade, [Text])
go [Text]
acc Maybe CascadeAction
mupd Maybe CascadeAction
mdel [Text]
tokens_ =
        case [Text]
tokens_ of
            [] ->
                ( FieldCascade
                    { fcOnDelete :: Maybe CascadeAction
fcOnDelete = Maybe CascadeAction
mdel
                    , fcOnUpdate :: Maybe CascadeAction
fcOnUpdate = Maybe CascadeAction
mupd
                    }
                , [Text]
acc
                )
            Text
this : [Text]
rest ->
                case CascadePrefix -> Text -> Maybe CascadeAction
parseCascadeAction CascadePrefix
CascadeUpdate Text
this of
                    Just CascadeAction
cascUpd ->
                        case Maybe CascadeAction
mupd of
                            Maybe CascadeAction
Nothing ->
                                [Text]
-> Maybe CascadeAction
-> Maybe CascadeAction
-> [Text]
-> (FieldCascade, [Text])
go [Text]
acc (CascadeAction -> Maybe CascadeAction
forall a. a -> Maybe a
Just CascadeAction
cascUpd) Maybe CascadeAction
mdel [Text]
rest
                            Just CascadeAction
_ ->
                                [Char] -> (FieldCascade, [Text])
nope [Char]
"found more than one OnUpdate action"
                    Maybe CascadeAction
Nothing ->
                        case CascadePrefix -> Text -> Maybe CascadeAction
parseCascadeAction CascadePrefix
CascadeDelete Text
this of
                            Just CascadeAction
cascDel ->
                                case Maybe CascadeAction
mdel of
                                    Maybe CascadeAction
Nothing ->
                                        [Text]
-> Maybe CascadeAction
-> Maybe CascadeAction
-> [Text]
-> (FieldCascade, [Text])
go [Text]
acc Maybe CascadeAction
mupd (CascadeAction -> Maybe CascadeAction
forall a. a -> Maybe a
Just CascadeAction
cascDel) [Text]
rest
                                    Just CascadeAction
_ ->
                                        [Char] -> (FieldCascade, [Text])
nope [Char]
"found more than one OnDelete action"
                            Maybe CascadeAction
Nothing ->
                                [Text]
-> Maybe CascadeAction
-> Maybe CascadeAction
-> [Text]
-> (FieldCascade, [Text])
go (Text
this Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc) Maybe CascadeAction
mupd Maybe CascadeAction
mdel [Text]
rest
    nope :: [Char] -> (FieldCascade, [Text])
nope [Char]
msg =
        [Char] -> (FieldCascade, [Text])
forall a. HasCallStack => [Char] -> a
error ([Char] -> (FieldCascade, [Text]))
-> [Char] -> (FieldCascade, [Text])
forall a b. (a -> b) -> a -> b
$ [Char]
msg [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", tokens: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Text] -> [Char]
forall a. Show a => a -> [Char]
show [Text]
allTokens

parseCascadeAction
    :: CascadePrefix
    -> Text
    -> Maybe CascadeAction
parseCascadeAction :: CascadePrefix -> Text -> Maybe CascadeAction
parseCascadeAction CascadePrefix
prfx Text
text = do
    Text
cascadeStr <- Text -> Text -> Maybe Text
T.stripPrefix (Text
"On" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CascadePrefix -> Text
forall {a}. IsString a => CascadePrefix -> a
toPrefix CascadePrefix
prfx) Text
text
    Text -> Maybe CascadeAction
forall a. Read a => Text -> Maybe a
readMaybe Text
cascadeStr
  where
    toPrefix :: CascadePrefix -> a
toPrefix CascadePrefix
cp =
        case CascadePrefix
cp of
            CascadePrefix
CascadeUpdate -> a
"Update"
            CascadePrefix
CascadeDelete -> a
"Delete"

takeDerives :: [Text] -> Maybe [Text]
takeDerives :: [Text] -> Maybe [Text]
takeDerives (Text
"deriving" : [Text]
rest) = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text]
rest
takeDerives [Text]
_ = Maybe [Text]
forall a. Maybe a
Nothing

-- | Returns 'True' if the 'UnboundFieldDef' does not have a 'MigrationOnly' or
-- 'SafeToRemove' flag from the QuasiQuoter.
--
-- @since 2.13.0.0
isHaskellUnboundField :: UnboundFieldDef -> Bool
isHaskellUnboundField :: UnboundFieldDef -> Bool
isHaskellUnboundField UnboundFieldDef
fd =
    FieldAttr
FieldAttrMigrationOnly FieldAttr -> [FieldAttr] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` UnboundFieldDef -> [FieldAttr]
unboundFieldAttrs UnboundFieldDef
fd
        Bool -> Bool -> Bool
&& FieldAttr
FieldAttrSafeToRemove FieldAttr -> [FieldAttr] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` UnboundFieldDef -> [FieldAttr]
unboundFieldAttrs UnboundFieldDef
fd

-- |  Return the 'EntityNameHS' for an 'UnboundEntityDef'.
--
-- @since 2.13.0.0
getUnboundEntityNameHS :: UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS :: UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS = EntityDef -> EntityNameHS
entityHaskell (EntityDef -> EntityNameHS)
-> (UnboundEntityDef -> EntityDef)
-> UnboundEntityDef
-> EntityNameHS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> EntityDef
unboundEntityDef

readMaybe :: (Read a) => Text -> Maybe a
readMaybe :: forall a. Read a => Text -> Maybe a
readMaybe = [Char] -> Maybe a
forall a. Read a => [Char] -> Maybe a
R.readMaybe ([Char] -> Maybe a) -> (Text -> [Char]) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack