{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# 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
    , toFKNameInfixed
    , Token (..)
    , Line (..)
    , preparse
    , parseLine
    , parseFieldType
    , associateLines
    , LinesWithComments(..)
    , parseEntityFields
    , takeColsEx
    -- * 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.List (find, foldl')
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as M
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.Types
import Database.Persist.Types.Base
import Language.Haskell.TH.Syntax (Lift)
import qualified Text.Read as R

data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Int -> ParseState a -> ShowS
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
showList :: [ParseState a] -> ShowS
$cshowList :: forall a. Show a => [ParseState a] -> ShowS
show :: ParseState a -> [Char]
$cshow :: forall a. Show a => ParseState a -> [Char]
showsPrec :: Int -> ParseState a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> 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' -> forall a b. b -> Either a b
Right FieldType
ft
        PSFail [Char]
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
"PSFail " forall a. [a] -> [a] -> [a]
++ [Char]
err
        ParseState FieldType
other -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show ParseState FieldType
other
  where
    parseApplyFT :: Text -> ParseState FieldType
    parseApplyFT :: Text -> ParseState FieldType
parseApplyFT Text
t =
        case forall a. ([FieldType] -> a) -> Text -> ParseState a
goMany forall a. a -> a
id Text
t of
            PSSuccess (FieldType
ft:[FieldType]
fts) Text
t' -> forall a. a -> Text -> ParseState a
PSSuccess (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
_ -> forall a. [Char] -> ParseState a
PSFail [Char]
"empty"
            PSFail [Char]
err -> forall a. [Char] -> ParseState a
PSFail [Char]
err
            ParseState [FieldType]
PSDone -> 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 (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 forall a. Eq a => a -> a -> Bool
== Char
end -> forall a. a -> Text -> ParseState a
PSSuccess (FieldType -> FieldType
ftMod FieldType
ft) (Text
t'' forall a. Monoid a => a -> a -> a
`Data.Monoid.mappend` Text
t')
              (Text
x, Maybe (Char, Text)
y) -> forall a. [Char] -> ParseState a
PSFail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show (Text
b, Text
x, Maybe (Char, Text)
y)
          ParseState FieldType
x -> forall a. [Char] -> ParseState a
PSFail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show ParseState FieldType
x

    parse1 :: Text -> ParseState FieldType
    parse1 :: Text -> ParseState FieldType
parse1 Text
t = forall a. a -> Maybe a -> a
fromMaybe (forall a. [Char] -> ParseState a
PSFail (forall a. Show a => a -> [Char]
show Text
t)) forall a b. (a -> b) -> a -> b
$ do
        case Text -> Maybe (Char, Text)
T.uncons Text
t of
            Maybe (Char, Text)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. ParseState a
PSDone
            Just (Char
x, Text
xs) ->
                Char -> Text -> Maybe (ParseState FieldType)
parseSpace Char
x Text
xs
                forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {m :: * -> *}.
(Monad m, Alternative m) =>
Char -> Text -> m (ParseState FieldType)
parseParenEnclosed Char
x Text
xs
                forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {m :: * -> *}.
(Monad m, Alternative m) =>
Char -> Text -> m (ParseState FieldType)
parseList Char
x Text
xs
                forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Text -> Maybe (ParseState FieldType)
parseNumericLit Char
x Text
xs
                forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Text -> Maybe (ParseState FieldType)
parseTextLit Char
x Text
xs
                forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char -> Bool
isSpace Char
c)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char
c forall a. Eq a => a -> a -> Bool
== Char
'(')
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType
parseEnclosed Char
')' forall a. a -> a
id Text
t

    parseList :: Char -> Text -> m (ParseState FieldType)
parseList Char
c Text
t = do
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char
c forall a. Eq a => a -> a -> Bool
== Char
'[')
        forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char
c forall a. Eq a => a -> a -> Bool
== Char
'"')
        let (Text
a, Text
b) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
'"') Text
t
            lit :: FieldType
lit = FieldTypeLit -> FieldType
FTLit (Text -> FieldTypeLit
TextTypeLit Text
a)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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
        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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> FieldTypeLit
IntTypeLit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Read a => Text -> Maybe a
readMaybe (Char -> Text -> Text
T.cons Char
c Text
a)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Text -> ParseState a
PSSuccess FieldType
lit Text
b

    parseTypeCon :: Char -> Text -> m (ParseState FieldType)
parseTypeCon Char
c Text
t = do
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\'')
        let (Text
a, Text
b) = Text -> (Text, Text)
breakAtNextSpace Text
t
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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' -> forall a. ([FieldType] -> a) -> Text -> ParseState a
goMany ([FieldType] -> a
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldType
xforall a. a -> [a] -> [a]
:)) Text
t'
            PSFail [Char]
err -> forall a. [Char] -> ParseState a
PSFail [Char]
err
            ParseState FieldType
PSDone -> 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 Text -> Text -> (Text, Text)
T.breakOnEnd Text
"." Text
t of
                (Text
_, Text
"") -> Maybe Text -> Text -> FieldType
FTTypeCon forall a. Maybe a
Nothing Text
t
                (Text
"", Text
_) -> Maybe Text -> Text -> FieldType
FTTypeCon forall a. Maybe a
Nothing Text
t
                (Text
a, Text
b) -> Maybe Text -> Text -> FieldType
FTTypeCon (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Text
T.init Text
a) Text
b

data PersistSettings = PersistSettings
    { PersistSettings -> Text -> Text
psToDBName :: !(Text -> Text)
    -- ^ Modify the Haskell-style name into a database-style name.
    , PersistSettings -> EntityNameHS -> ConstraintNameHS -> Text
psToFKName :: !(EntityNameHS -> ConstraintNameHS -> Text)
    -- ^ A function for generating the constraint name, with access to
    -- the entity and constraint names. Default value: @mappend@
    --
    -- @since 2.13.0.0
    , PersistSettings -> Bool
psStrictFields :: !Bool
    -- ^ Whether fields are by default strict. Default value: @True@.
    --
    -- @since 1.2
    , PersistSettings -> Text
psIdName :: !Text
    -- ^ The name of the id column. Default value: @id@
    -- The name of the id column can also be changed on a per-model basis
    -- <https://github.com/yesodweb/persistent/wiki/Persistent-entity-syntax>
    --
    -- @since 2.0
    }

defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings
defaultPersistSettings :: PersistSettings
defaultPersistSettings = PersistSettings
    { psToDBName :: Text -> Text
psToDBName = forall a. a -> a
id
    , psToFKName :: EntityNameHS -> ConstraintNameHS -> Text
psToFKName = \(EntityNameHS Text
entName) (ConstraintNameHS Text
conName) -> Text
entName forall a. Semigroup a => a -> a -> a
<> Text
conName
    , psStrictFields :: Bool
psStrictFields = Bool
True
    , psIdName :: Text
psIdName       = Text
"id"
    }

upperCaseSettings :: PersistSettings
upperCaseSettings = PersistSettings
defaultPersistSettings

lowerCaseSettings :: PersistSettings
lowerCaseSettings = PersistSettings
defaultPersistSettings
    { psToDBName :: Text -> Text
psToDBName =
        let go :: Char -> Text
go Char
c
                | Char -> Bool
isUpper Char
c = [Char] -> Text
T.pack [Char
'_', Char -> Char
toLower Char
c]
                | Bool
otherwise = Char -> Text
T.singleton Char
c
         in (Char -> Bool) -> Text -> Text
T.dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'_') forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
go
    }

toFKNameInfixed :: Text -> EntityNameHS -> ConstraintNameHS -> Text
toFKNameInfixed :: Text -> EntityNameHS -> ConstraintNameHS -> Text
toFKNameInfixed Text
inf (EntityNameHS Text
entName) (ConstraintNameHS Text
conName) =
    Text
entName forall a. Semigroup a => a -> a -> a
<> Text
inf forall a. Semigroup a => a -> a -> a
<> Text
conName

-- | Parses a quasi-quoted syntax into a list of entity definitions.
parse :: PersistSettings -> Text -> [UnboundEntityDef]
parse :: PersistSettings -> Text -> [UnboundEntityDef]
parse PersistSettings
ps = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (PersistSettings -> NonEmpty Line -> [UnboundEntityDef]
parseLines PersistSettings
ps) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe (NonEmpty Line)
preparse

preparse :: Text -> Maybe (NonEmpty Line)
preparse :: Text -> Maybe (NonEmpty Line)
preparse Text
txt = do
    NonEmpty Text
lns <- forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty (Text -> [Text]
T.lines Text
txt)
    forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Line
parseLine (forall a. NonEmpty a -> [a]
NEL.toList NonEmpty Text
lns)

parseLine :: Text -> Maybe Line
parseLine :: Text -> Maybe Line
parseLine Text
txt = do
    Int -> NonEmpty Token -> Line
Line (Text -> Int
parseIndentationAmount Text
txt) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty (Text -> [Token]
tokenize Text
txt)

-- | A token used by the parser.
data Token = Token Text    -- ^ @Token tok@ is token @tok@ already unquoted.
           | DocComment Text -- ^ @DocComment@ is a documentation comment, unmodified.
  deriving (Int -> Token -> ShowS
[Token] -> ShowS
Token -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> [Char]
$cshow :: Token -> [Char]
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show, Token -> Token -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq)

tokenText :: Token -> Text
tokenText :: Token -> Text
tokenText Token
tok =
    case Token
tok of
        Token Text
t -> Text
t
        DocComment Text
t -> Text
"-- | " forall a. Semigroup a => a -> a -> a
<> Text
t

parseIndentationAmount :: Text -> Int
parseIndentationAmount :: Text -> Int
parseIndentationAmount Text
txt =
    let (Text
spaces, Text
_) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isSpace Text
txt
     in Text -> Int
T.length Text
spaces

-- | Tokenize a string.
tokenize :: Text -> [Token]
tokenize :: Text -> [Token]
tokenize Text
t
    | Text -> Bool
T.null Text
t = []
    | Just Text
txt <- Text -> Text -> Maybe Text
T.stripPrefix Text
"-- |" Text
t = [Text -> Token
DocComment (Text -> Text
T.stripStart Text
txt)]
    | Text
"--" Text -> Text -> Bool
`T.isPrefixOf` Text
t = [] -- Comment until the end of the line.
    | Text
"#" Text -> Text -> Bool
`T.isPrefixOf` Text
t = [] -- Also comment to the end of the line, needed for a CPP bug (#110)
    | Text -> Char
T.head Text
t forall a. Eq a => a -> a -> Bool
== Char
'"' = Text -> ([Text] -> [Text]) -> [Token]
quotes (Text -> Text
T.tail Text
t) forall a. a -> a
id
    | Text -> Char
T.head Text
t forall a. Eq a => a -> a -> Bool
== Char
'(' = Int -> Text -> ([Text] -> [Text]) -> [Token]
parens Int
1 (Text -> Text
T.tail Text
t) forall a. a -> a
id
    | Char -> Bool
isSpace (Text -> Char
T.head Text
t) =
        Text -> [Token]
tokenize ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
t)

    -- support mid-token quotes and parens
    | Just (Text
beforeEquals, Text
afterEquals) <- Text -> Maybe (Text, Text)
findMidToken Text
t
    , Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
T.any Char -> Bool
isSpace Text
beforeEquals)
    , Token Text
next : [Token]
rest <- Text -> [Token]
tokenize Text
afterEquals =
        Text -> Token
Token ([Text] -> Text
T.concat [Text
beforeEquals, Text
"=", Text
next]) forall a. a -> [a] -> [a]
: [Token]
rest

    | Bool
otherwise =
        let (Text
token, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isSpace Text
t
         in Text -> Token
Token Text
token forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize Text
rest
  where
    findMidToken :: Text -> Maybe (Text, Text)
    findMidToken :: Text -> Maybe (Text, Text)
findMidToken Text
t' =
        case (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
'=') Text
t' of
            (Text
x, Int -> Text -> Text
T.drop Int
1 -> Text
y)
                | Text
"\"" Text -> Text -> Bool
`T.isPrefixOf` Text
y Bool -> Bool -> Bool
|| Text
"(" Text -> Text -> Bool
`T.isPrefixOf` Text
y -> forall a. a -> Maybe a
Just (Text
x, Text
y)
            (Text, Text)
_ -> forall a. Maybe a
Nothing

    quotes :: Text -> ([Text] -> [Text]) -> [Token]
    quotes :: Text -> ([Text] -> [Text]) -> [Token]
quotes Text
t' [Text] -> [Text]
front
        | Text -> Bool
T.null Text
t' = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$
            Text
"Unterminated quoted string starting with " forall a. a -> [a] -> [a]
: [Text] -> [Text]
front []
        | Text -> Char
T.head Text
t' forall a. Eq a => a -> a -> Bool
== Char
'"' = Text -> Token
Token ([Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
front []) forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize (Text -> Text
T.tail Text
t')
        | Text -> Char
T.head Text
t' forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
&& Text -> Int
T.length Text
t' forall a. Ord a => a -> a -> Bool
> Int
1 =
            Text -> ([Text] -> [Text]) -> [Token]
quotes (Int -> Text -> Text
T.drop Int
2 Text
t') ([Text] -> [Text]
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Text -> Text
T.take Int
1 (Int -> Text -> Text
T.drop Int
1 Text
t')forall a. a -> [a] -> [a]
:))
        | Bool
otherwise =
            let (Text
x, Text
y) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\\',Char
'\"']) Text
t'
             in Text -> ([Text] -> [Text]) -> [Token]
quotes Text
y ([Text] -> [Text]
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
xforall a. a -> [a] -> [a]
:))

    parens :: Int -> Text -> ([Text] -> [Text]) -> [Token]
    parens :: Int -> Text -> ([Text] -> [Text]) -> [Token]
parens Int
count Text
t' [Text] -> [Text]
front
        | Text -> Bool
T.null Text
t' = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$
            Text
"Unterminated parens string starting with " forall a. a -> [a] -> [a]
: [Text] -> [Text]
front []
        | Text -> Char
T.head Text
t' forall a. Eq a => a -> a -> Bool
== Char
')' =
            if Int
count forall a. Eq a => a -> a -> Bool
== (Int
1 :: Int)
                then Text -> Token
Token ([Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
front []) forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize (Text -> Text
T.tail Text
t')
                else Int -> Text -> ([Text] -> [Text]) -> [Token]
parens (Int
count forall a. Num a => a -> a -> a
- Int
1) (Text -> Text
T.tail Text
t') ([Text] -> [Text]
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
")"forall a. a -> [a] -> [a]
:))
        | Text -> Char
T.head Text
t' forall a. Eq a => a -> a -> Bool
== Char
'(' =
            Int -> Text -> ([Text] -> [Text]) -> [Token]
parens (Int
count forall a. Num a => a -> a -> a
+ Int
1) (Text -> Text
T.tail Text
t') ([Text] -> [Text]
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"("forall a. a -> [a] -> [a]
:))
        | Text -> Char
T.head Text
t' forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
&& Text -> Int
T.length Text
t' forall a. Ord a => a -> a -> Bool
> Int
1 =
            Int -> Text -> ([Text] -> [Text]) -> [Token]
parens Int
count (Int -> Text -> Text
T.drop Int
2 Text
t') ([Text] -> [Text]
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Text -> Text
T.take Int
1 (Int -> Text -> Text
T.drop Int
1 Text
t')forall a. a -> [a] -> [a]
:))
        | Bool
otherwise =
            let (Text
x, Text
y) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\\',Char
'(',Char
')']) Text
t'
             in Int -> Text -> ([Text] -> [Text]) -> [Token]
parens Int
count Text
y ([Text] -> [Text]
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
xforall a. a -> [a] -> [a]
:))

-- | A line of parsed tokens
data Line = Line
    { Line -> Int
lineIndent   :: Int
    , Line -> NonEmpty Token
tokens       :: NonEmpty Token
    } deriving (Line -> Line -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Line -> Line -> Bool
$c/= :: Line -> Line -> Bool
== :: Line -> Line -> Bool
$c== :: Line -> Line -> Bool
Eq, Int -> Line -> ShowS
[Line] -> ShowS
Line -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Line] -> ShowS
$cshowList :: [Line] -> ShowS
show :: Line -> [Char]
$cshow :: Line -> [Char]
showsPrec :: Int -> Line -> ShowS
$cshowsPrec :: Int -> Line -> ShowS
Show)

lineText :: Line -> NonEmpty Text
lineText :: Line -> NonEmpty Text
lineText = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Token -> Text
tokenText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> NonEmpty Token
tokens

lowestIndent :: NonEmpty Line -> Int
lowestIndent :: NonEmpty Line -> Int
lowestIndent = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Line -> Int
lineIndent

-- | Divide lines into blocks and make entity definitions.
parseLines :: PersistSettings -> NonEmpty Line -> [UnboundEntityDef]
parseLines :: PersistSettings -> NonEmpty Line -> [UnboundEntityDef]
parseLines PersistSettings
ps = do
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PersistSettings -> ParsedEntityDef -> UnboundEntityDef
mkUnboundEntityDef PersistSettings
ps forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinesWithComments -> ParsedEntityDef
toParsedEntityDef) forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Line -> [LinesWithComments]
associateLines

data ParsedEntityDef = ParsedEntityDef
    { ParsedEntityDef -> [Text]
parsedEntityDefComments :: [Text]
    , ParsedEntityDef -> EntityNameHS
parsedEntityDefEntityName :: EntityNameHS
    , ParsedEntityDef -> Bool
parsedEntityDefIsSum :: Bool
    , ParsedEntityDef -> [Text]
parsedEntityDefEntityAttributes :: [Attr]
    , ParsedEntityDef -> [[Token]]
parsedEntityDefFieldAttributes :: [[Token]]
    , ParsedEntityDef -> Map Text [[Text]]
parsedEntityDefExtras :: M.Map Text [ExtraLine]
    }

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 forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [Text] -> Text
getDbName PersistSettings
ps (EntityNameHS -> Text
unEntityNameHS EntityNameHS
entNameHS) (ParsedEntityDef -> [Text]
parsedEntityDefEntityAttributes ParsedEntityDef
parsedEntDef)

toParsedEntityDef :: LinesWithComments -> ParsedEntityDef
toParsedEntityDef :: LinesWithComments -> ParsedEntityDef
toParsedEntityDef LinesWithComments
lwc = ParsedEntityDef
    { parsedEntityDefComments :: [Text]
parsedEntityDefComments = LinesWithComments -> [Text]
lwcComments LinesWithComments
lwc
    , parsedEntityDefEntityName :: EntityNameHS
parsedEntityDefEntityName = EntityNameHS
entNameHS
    , parsedEntityDefIsSum :: Bool
parsedEntityDefIsSum = Bool
isSum
    , parsedEntityDefEntityAttributes :: [Text]
parsedEntityDefEntityAttributes = [Text]
entAttribs
    , parsedEntityDefFieldAttributes :: [[Token]]
parsedEntityDefFieldAttributes = [[Token]]
attribs
    , parsedEntityDefExtras :: Map Text [[Text]]
parsedEntityDefExtras = Map Text [[Text]]
extras
    }
  where
    Line
entityLine :| [Line]
fieldLines =
        LinesWithComments -> NonEmpty Line
lwcLines LinesWithComments
lwc

    (Text
entityName :| [Text]
entAttribs) =
        Line -> NonEmpty Text
lineText Line
entityLine

    (Bool
isSum, EntityNameHS
entNameHS) =
        case Text -> Maybe (Char, Text)
T.uncons Text
entityName of
            Just (Char
'+', Text
x) -> (Bool
True, Text -> EntityNameHS
EntityNameHS Text
x)
            Maybe (Char, Text)
_ -> (Bool
False, Text -> EntityNameHS
EntityNameHS Text
entityName)

    ([[Token]]
attribs, Map Text [[Text]]
extras) =
        [Line] -> ([[Token]], Map Text [[Text]])
parseEntityFields [Line]
fieldLines

isDocComment :: Token -> Maybe Text
isDocComment :: Token -> Maybe Text
isDocComment Token
tok =
    case Token
tok of
        DocComment Text
txt -> forall a. a -> Maybe a
Just Text
txt
        Token
_ -> forall a. Maybe a
Nothing

data LinesWithComments = LinesWithComments
    { LinesWithComments -> NonEmpty Line
lwcLines :: NonEmpty Line
    , LinesWithComments -> [Text]
lwcComments :: [Text]
    } deriving (LinesWithComments -> LinesWithComments -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LinesWithComments -> LinesWithComments -> Bool
$c/= :: LinesWithComments -> LinesWithComments -> Bool
== :: LinesWithComments -> LinesWithComments -> Bool
$c== :: LinesWithComments -> LinesWithComments -> Bool
Eq, Int -> LinesWithComments -> ShowS
[LinesWithComments] -> ShowS
LinesWithComments -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [LinesWithComments] -> ShowS
$cshowList :: [LinesWithComments] -> ShowS
show :: LinesWithComments -> [Char]
$cshow :: LinesWithComments -> [Char]
showsPrec :: Int -> LinesWithComments -> ShowS
$cshowsPrec :: Int -> LinesWithComments -> ShowS
Show)

instance Semigroup LinesWithComments where
    LinesWithComments
a <> :: LinesWithComments -> LinesWithComments -> LinesWithComments
<> LinesWithComments
b =
        LinesWithComments
            { lwcLines :: NonEmpty Line
lwcLines =
                forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. a -> NonEmpty a -> NonEmpty a
NEL.cons (LinesWithComments -> NonEmpty Line
lwcLines LinesWithComments
b) (LinesWithComments -> NonEmpty Line
lwcLines LinesWithComments
a)
            , lwcComments :: [Text]
lwcComments =
                LinesWithComments -> [Text]
lwcComments LinesWithComments
a forall a. Monoid a => a -> a -> a
`mappend` LinesWithComments -> [Text]
lwcComments LinesWithComments
b
            }

appendLwc :: LinesWithComments -> LinesWithComments -> LinesWithComments
appendLwc :: LinesWithComments -> LinesWithComments -> LinesWithComments
appendLwc = forall a. Semigroup a => a -> a -> a
(<>)

newLine :: Line -> LinesWithComments
newLine :: Line -> LinesWithComments
newLine Line
l = NonEmpty Line -> [Text] -> LinesWithComments
LinesWithComments (forall (f :: * -> *) a. Applicative f => a -> f a
pure Line
l) []

firstLine :: LinesWithComments -> Line
firstLine :: LinesWithComments -> Line
firstLine = forall a. NonEmpty a -> a
NEL.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinesWithComments -> NonEmpty Line
lwcLines

consLine :: Line -> LinesWithComments -> LinesWithComments
consLine :: Line -> LinesWithComments -> LinesWithComments
consLine Line
l LinesWithComments
lwc = LinesWithComments
lwc { lwcLines :: NonEmpty Line
lwcLines = forall a. a -> NonEmpty a -> NonEmpty a
NEL.cons Line
l (LinesWithComments -> NonEmpty Line
lwcLines LinesWithComments
lwc) }

consComment :: Text -> LinesWithComments -> LinesWithComments
consComment :: Text -> LinesWithComments -> LinesWithComments
consComment Text
l LinesWithComments
lwc = LinesWithComments
lwc { lwcComments :: [Text]
lwcComments = Text
l forall a. a -> [a] -> [a]
: LinesWithComments -> [Text]
lwcComments LinesWithComments
lwc }

associateLines :: NonEmpty Line -> [LinesWithComments]
associateLines :: NonEmpty Line -> [LinesWithComments]
associateLines NonEmpty Line
lines =
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
combine [] forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Line -> [LinesWithComments] -> [LinesWithComments]
toLinesWithComments [] NonEmpty Line
lines
  where
    toLinesWithComments :: Line -> [LinesWithComments] -> [LinesWithComments]
    toLinesWithComments :: Line -> [LinesWithComments] -> [LinesWithComments]
toLinesWithComments Line
line [LinesWithComments]
linesWithComments =
        case [LinesWithComments]
linesWithComments of
            [] ->
                [Line -> LinesWithComments
newLine Line
line]
            (LinesWithComments
lwc : [LinesWithComments]
lwcs) ->
                case Token -> Maybe Text
isDocComment (forall a. NonEmpty a -> a
NEL.head (Line -> NonEmpty Token
tokens Line
line)) of
                    Just Text
comment
                        | Line -> Int
lineIndent Line
line forall a. Eq a => a -> a -> Bool
== NonEmpty Line -> Int
lowestIndent NonEmpty Line
lines ->
                        Text -> LinesWithComments -> LinesWithComments
consComment Text
comment LinesWithComments
lwc forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs
                    Maybe Text
_ ->
                        if Line -> Int
lineIndent Line
line forall a. Ord a => a -> a -> Bool
<= Line -> Int
lineIndent (LinesWithComments -> Line
firstLine LinesWithComments
lwc)
                            Bool -> Bool -> Bool
&& Line -> Int
lineIndent (LinesWithComments -> Line
firstLine LinesWithComments
lwc) forall a. Eq a => a -> a -> Bool
/= NonEmpty Line -> Int
lowestIndent NonEmpty Line
lines
                        then
                            Line -> LinesWithComments -> LinesWithComments
consLine Line
line LinesWithComments
lwc forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs
                        else
                            Line -> LinesWithComments
newLine Line
line forall a. a -> [a] -> [a]
: LinesWithComments
lwc forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs

    combine :: LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
    combine :: LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
combine LinesWithComments
lwc [] =
        [LinesWithComments
lwc]
    combine LinesWithComments
lwc (LinesWithComments
lwc' : [LinesWithComments]
lwcs) =
        let minIndent :: Int
minIndent = LinesWithComments -> Int
minimumIndentOf LinesWithComments
lwc
            otherIndent :: Int
otherIndent = LinesWithComments -> Int
minimumIndentOf LinesWithComments
lwc'
         in
            if Int
minIndent forall a. Ord a => a -> a -> Bool
< Int
otherIndent then
                LinesWithComments -> LinesWithComments -> LinesWithComments
appendLwc LinesWithComments
lwc LinesWithComments
lwc' forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs
            else
                LinesWithComments
lwc forall a. a -> [a] -> [a]
: LinesWithComments
lwc' forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs

    minimumIndentOf :: LinesWithComments -> Int
    minimumIndentOf :: LinesWithComments -> Int
minimumIndentOf = NonEmpty Line -> Int
lowestIndent forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinesWithComments -> NonEmpty Line
lwcLines

-- | 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
    }
    deriving (UnboundEntityDef -> UnboundEntityDef -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnboundEntityDef -> UnboundEntityDef -> Bool
$c/= :: UnboundEntityDef -> UnboundEntityDef -> Bool
== :: UnboundEntityDef -> UnboundEntityDef -> Bool
$c== :: UnboundEntityDef -> UnboundEntityDef -> Bool
Eq, Eq 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
min :: UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef
$cmin :: UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef
max :: UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef
$cmax :: UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef
>= :: UnboundEntityDef -> UnboundEntityDef -> Bool
$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
compare :: UnboundEntityDef -> UnboundEntityDef -> Ordering
$ccompare :: UnboundEntityDef -> UnboundEntityDef -> Ordering
Ord, Int -> UnboundEntityDef -> ShowS
[UnboundEntityDef] -> ShowS
UnboundEntityDef -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [UnboundEntityDef] -> ShowS
$cshowList :: [UnboundEntityDef] -> ShowS
show :: UnboundEntityDef -> [Char]
$cshow :: UnboundEntityDef -> [Char]
showsPrec :: Int -> UnboundEntityDef -> ShowS
$cshowsPrec :: Int -> UnboundEntityDef -> ShowS
Show, 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
liftTyped :: forall (m :: * -> *).
Quote m =>
UnboundEntityDef -> Code m UnboundEntityDef
$cliftTyped :: forall (m :: * -> *).
Quote m =>
UnboundEntityDef -> Code m UnboundEntityDef
lift :: forall (m :: * -> *). Quote m => UnboundEntityDef -> m Exp
$clift :: forall (m :: * -> *). Quote m => UnboundEntityDef -> m Exp
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 =
            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 =
            forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> UnboundFieldDef
unbindFieldDef (EntityDef -> [FieldDef]
entityFields 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 =
            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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnboundFieldDef -> UnboundFieldDef -> Bool
$c/= :: UnboundFieldDef -> UnboundFieldDef -> Bool
== :: UnboundFieldDef -> UnboundFieldDef -> Bool
$c== :: UnboundFieldDef -> UnboundFieldDef -> Bool
Eq, Eq 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
min :: UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef
$cmin :: UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef
max :: UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef
$cmax :: UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef
>= :: UnboundFieldDef -> UnboundFieldDef -> Bool
$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
compare :: UnboundFieldDef -> UnboundFieldDef -> Ordering
$ccompare :: UnboundFieldDef -> UnboundFieldDef -> Ordering
Ord, Int -> UnboundFieldDef -> ShowS
[UnboundFieldDef] -> ShowS
UnboundFieldDef -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [UnboundFieldDef] -> ShowS
$cshowList :: [UnboundFieldDef] -> ShowS
show :: UnboundFieldDef -> [Char]
$cshow :: UnboundFieldDef -> [Char]
showsPrec :: Int -> UnboundFieldDef -> ShowS
$cshowsPrec :: Int -> UnboundFieldDef -> ShowS
Show, 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
liftTyped :: forall (m :: * -> *).
Quote m =>
UnboundFieldDef -> Code m UnboundFieldDef
$cliftTyped :: forall (m :: * -> *).
Quote m =>
UnboundFieldDef -> Code m UnboundFieldDef
lift :: forall (m :: * -> *). Quote m => UnboundFieldDef -> m Exp
$clift :: forall (m :: * -> *). Quote m => UnboundFieldDef -> m Exp
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 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
    = NaturalKey UnboundCompositeDef
    -- ^ 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
    | SurrogateKey UnboundIdDef
    -- ^ 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
    | DefaultKey FieldNameDB
    -- ^ 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
    deriving (PrimarySpec -> PrimarySpec -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PrimarySpec -> PrimarySpec -> Bool
$c/= :: PrimarySpec -> PrimarySpec -> Bool
== :: PrimarySpec -> PrimarySpec -> Bool
$c== :: PrimarySpec -> PrimarySpec -> Bool
Eq, Eq 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
min :: PrimarySpec -> PrimarySpec -> PrimarySpec
$cmin :: PrimarySpec -> PrimarySpec -> PrimarySpec
max :: PrimarySpec -> PrimarySpec -> PrimarySpec
$cmax :: PrimarySpec -> PrimarySpec -> PrimarySpec
>= :: PrimarySpec -> PrimarySpec -> Bool
$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
compare :: PrimarySpec -> PrimarySpec -> Ordering
$ccompare :: PrimarySpec -> PrimarySpec -> Ordering
Ord, Int -> PrimarySpec -> ShowS
[PrimarySpec] -> ShowS
PrimarySpec -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PrimarySpec] -> ShowS
$cshowList :: [PrimarySpec] -> ShowS
show :: PrimarySpec -> [Char]
$cshow :: PrimarySpec -> [Char]
showsPrec :: Int -> PrimarySpec -> ShowS
$cshowsPrec :: Int -> PrimarySpec -> ShowS
Show, 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
liftTyped :: forall (m :: * -> *). Quote m => PrimarySpec -> Code m PrimarySpec
$cliftTyped :: forall (m :: * -> *). Quote m => PrimarySpec -> Code m PrimarySpec
lift :: forall (m :: * -> *). Quote m => PrimarySpec -> m Exp
$clift :: forall (m :: * -> *). Quote m => PrimarySpec -> m Exp
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 {}) ->
                    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 forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (EntityNameHS -> FieldType
mkKeyConType (UnboundIdDef -> EntityNameHS
unboundIdEntityName UnboundIdDef
a))
                    then
                        FieldNameDB -> PrimarySpec
DefaultKey (Text -> FieldNameDB
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 forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text
psIdName PersistSettings
ps)
        , unboundEntityFields :: [UnboundFieldDef]
unboundEntityFields =
            [UnboundFieldDef]
cols
        , 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 forall a b. (a -> b) -> a -> b
$
                    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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ 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
                        [] -> forall a. Maybe a
Nothing
                        [Text]
comments -> forall a. a -> Maybe a
Just ([Text] -> Text
T.unlines [Text]
comments)
                }
        }
  where
    (EntityNameHS
entNameHS, EntityNameDB
entNameDB) =
        PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB)
entityNamesFromParsedDef PersistSettings
ps ParsedEntityDef
parsedEntDef

    attribs :: [[Token]]
attribs =
        ParsedEntityDef -> [[Token]]
parsedEntityDefFieldAttributes ParsedEntityDef
parsedEntDef

    textAttribs :: [[Text]]
    textAttribs :: [[Text]]
textAttribs =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Token -> Text
tokenText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Token]]
attribs

    entityConstraintDefs :: EntityConstraintDefs
entityConstraintDefs =
        forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (PersistSettings
-> EntityNameHS
-> [UnboundFieldDef]
-> NonEmpty Text
-> EntityConstraintDefs
takeConstraint PersistSettings
ps EntityNameHS
entNameHS [UnboundFieldDef]
cols) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> forall a. HasCallStack => [Char] -> a
error [Char]
"expected only one Id declaration per entity"
            SetOnce UnboundIdDef
a -> forall a. a -> Maybe a
Just UnboundIdDef
a
            SetOnceAtMost UnboundIdDef
NotSet -> forall a. Maybe a
Nothing

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

    cols :: [UnboundFieldDef]
    cols :: [UnboundFieldDef]
cols = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (PersistSettings
-> [Token]
-> ([UnboundFieldDef], [Text])
-> ([UnboundFieldDef], [Text])
associateComments PersistSettings
ps) ([], []) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [[Token]]
attribs

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

    idSqlType :: SqlType
    idSqlType :: SqlType
idSqlType =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe SqlType
SqlInt64 (forall a b. a -> b -> a
const 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 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 =
            forall a. a -> Maybe a -> a
fromMaybe (EntityNameHS -> FieldType
mkKeyConType EntityNameHS
entNameHS) 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 =
            forall a. Maybe a
Nothing
        , fieldCascade :: FieldCascade
fieldCascade = UnboundIdDef -> FieldCascade
unboundIdCascade UnboundIdDef
uid
        , fieldGenerated :: Maybe Text
fieldGenerated = 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 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 =
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldType
fieldType FieldDef
fd
        }

associateComments
    :: PersistSettings
    -> [Token]
    -> ([UnboundFieldDef], [Text])
    -> ([UnboundFieldDef], [Text])
associateComments :: PersistSettings
-> [Token]
-> ([UnboundFieldDef], [Text])
-> ([UnboundFieldDef], [Text])
associateComments PersistSettings
ps [Token]
x (![UnboundFieldDef]
acc, ![Text]
comments) =
    case forall a. [a] -> Maybe a
listToMaybe [Token]
x of
        Just (DocComment Text
comment) ->
            ([UnboundFieldDef]
acc, Text
comment forall a. a -> [a] -> [a]
: [Text]
comments)
        Maybe Token
_ ->
            case ([Text] -> UnboundFieldDef -> UnboundFieldDef
setFieldComments (forall a. [a] -> [a]
reverse [Text]
comments) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistSettings -> [Text] -> Maybe UnboundFieldDef
takeColsEx PersistSettings
ps (Token -> Text
tokenText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token]
x)) of
              Just UnboundFieldDef
sm ->
                  (UnboundFieldDef
sm forall a. a -> [a] -> [a]
: [UnboundFieldDef]
acc, [])
              Maybe UnboundFieldDef
Nothing ->
                  ([UnboundFieldDef]
acc, [])

setFieldComments :: [Text] -> UnboundFieldDef -> UnboundFieldDef
setFieldComments :: [Text] -> UnboundFieldDef -> UnboundFieldDef
setFieldComments [Text]
xs UnboundFieldDef
fld =
    case [Text]
xs of
        [] -> UnboundFieldDef
fld
        [Text]
_ -> UnboundFieldDef
fld { unboundFieldComments :: Maybe Text
unboundFieldComments = forall a. a -> Maybe a
Just ([Text] -> Text
T.unlines [Text]
xs) }

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

-- | Creates a default ID field.
--
-- @since 2.13.0.0
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 forall a. Maybe a
Nothing 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 = forall a. Maybe a
Nothing
        , fieldCascade :: FieldCascade
fieldCascade = FieldCascade
noCascade
        , fieldGenerated :: Maybe Text
fieldGenerated = forall a. Maybe a
Nothing
        , fieldIsImplicitIdColumn :: Bool
fieldIsImplicitIdColumn = Bool
True
        }

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

parseEntityFields
    :: [Line]
    -> ([[Token]], M.Map Text [ExtraLine])
parseEntityFields :: [Line] -> ([[Token]], Map Text [[Text]])
parseEntityFields [Line]
lns =
    case [Line]
lns of
        [] -> ([], forall k a. Map k a
M.empty)
        (Line
line : [Line]
rest) ->
            case forall a. NonEmpty a -> [a]
NEL.toList (Line -> NonEmpty Token
tokens Line
line) of
                [Token Text
name]
                  | Text -> Bool
isCapitalizedText Text
name ->
                    let ([Line]
children, [Line]
rest') = forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((forall a. Ord a => a -> a -> Bool
> Line -> Int
lineIndent Line
line) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> Int
lineIndent) [Line]
rest
                        ([[Token]]
x, Map Text [[Text]]
y) = [Line] -> ([[Token]], Map Text [[Text]])
parseEntityFields [Line]
rest'
                     in ([[Token]]
x, forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
name (forall a. NonEmpty a -> [a]
NEL.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> NonEmpty Text
lineText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Line]
children) Map Text [[Text]]
y)
                [Token]
ts ->
                    let ([[Token]]
x, Map Text [[Text]]
y) = [Line] -> ([[Token]], Map Text [[Text]])
parseEntityFields [Line]
rest
                     in ([Token]
tsforall a. a -> [a] -> [a]
:[[Token]]
x, Map Text [[Text]]
y)

isCapitalizedText :: Text -> Bool
isCapitalizedText :: Text -> Bool
isCapitalizedText Text
t =
    Bool -> Bool
not (Text -> Bool
T.null Text
t) Bool -> Bool -> Bool
&& Char -> Bool
isUpper (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 -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid field type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
ft forall a. [a] -> [a] -> [a]
++ [Char]
" " 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]
_) = 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 (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 -> 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 =
                    forall a. a -> Maybe a -> a
fromMaybe (PersistSettings -> Bool
psStrictFields PersistSettings
ps) Maybe Bool
mstrict
                , unboundFieldComments :: Maybe Text
unboundFieldComments =
                    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' = (forall a. a -> Maybe a
Just Bool
True, Text
x)
        | Just Text
x <- Text -> Text -> Maybe Text
T.stripPrefix Text
"~" Text
n' = (forall a. a -> Maybe a
Just Bool
False, Text
x)
        | Bool
otherwise = (forall a. Maybe a
Nothing, Text
n')

takeCols Text -> [Char] -> Maybe UnboundFieldDef
_ PersistSettings
_ [Text]
_ = forall a. Maybe a
Nothing

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

getDbName :: PersistSettings -> Text -> [Text] -> Text
getDbName :: PersistSettings -> Text -> [Text] -> Text
getDbName PersistSettings
ps Text
n =
    forall a. a -> Maybe a -> a
fromMaybe (PersistSettings -> Text -> Text
psToDBName PersistSettings
ps Text
n) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe FieldNameDB
def Text -> FieldNameDB
FieldNameDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FieldAttr] -> Maybe Text
findAttrSql
  where
    findAttrSql :: [FieldAttr] -> Maybe Text
findAttrSql =
        forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 ->
                forall a. a -> Maybe a
Just Text
t
            FieldAttr
_ ->
                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
_) -> forall a. SetOnceAtMost a
SetMoreThanOnce
            (SetOnceAtMost a, SetOnceAtMost a)
_ -> SetOnceAtMost a
a

instance Monoid (SetOnceAtMost a) where
    mempty :: SetOnceAtMost a
mempty =
        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 forall a. Semigroup a => a -> a -> a
<> EntityConstraintDefs -> SetOnceAtMost UnboundIdDef
entityConstraintDefsIdField EntityConstraintDefs
b
            , entityConstraintDefsPrimaryComposite :: SetOnceAtMost UnboundCompositeDef
entityConstraintDefsPrimaryComposite = EntityConstraintDefs -> SetOnceAtMost UnboundCompositeDef
entityConstraintDefsPrimaryComposite EntityConstraintDefs
a 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 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 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 forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Maybe a
Nothing forall a. Maybe a
Nothing

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

entityConstraintDefsForeignsList :: EntityConstraintDefs -> [UnboundForeignDef]
entityConstraintDefsForeignsList :: EntityConstraintDefs -> [UnboundForeignDef]
entityConstraintDefsForeignsList = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. NonEmpty a -> [a]
NEL.toList 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" ->
            forall a. Monoid a => a
mempty
                { entityConstraintDefsUniques :: Maybe (NonEmpty UniqueDef)
entityConstraintDefsUniques =
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistSettings
-> Text -> [UnboundFieldDef] -> [Text] -> Maybe UniqueDef
takeUniq PersistSettings
ps (EntityNameHS -> Text
unEntityNameHS EntityNameHS
entityName) [UnboundFieldDef]
defs [Text]
rest
                }
        Text
"Foreign" ->
            forall a. Monoid a => a
mempty
                { entityConstraintDefsForeigns :: Maybe (NonEmpty UnboundForeignDef)
entityConstraintDefsForeigns =
                    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (PersistSettings -> EntityNameHS -> [Text] -> UnboundForeignDef
takeForeign PersistSettings
ps EntityNameHS
entityName [Text]
rest)
                }
        Text
"Primary" ->
            let
                unboundComposite :: UnboundCompositeDef
unboundComposite =
                    [FieldNameHS] -> [Text] -> UnboundCompositeDef
takeComposite (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UnboundFieldDef]
defs) [Text]
rest
            in
                forall a. Monoid a => a
mempty
                    { entityConstraintDefsPrimaryComposite :: SetOnceAtMost UnboundCompositeDef
entityConstraintDefsPrimaryComposite =
                        forall a. a -> SetOnceAtMost a
SetOnce UnboundCompositeDef
unboundComposite
                    , entityConstraintDefsUniques :: Maybe (NonEmpty UniqueDef)
entityConstraintDefsUniques =
                        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ EntityNameHS
-> [UnboundFieldDef] -> UnboundCompositeDef -> UniqueDef
compositeToUniqueDef EntityNameHS
entityName [UnboundFieldDef]
defs UnboundCompositeDef
unboundComposite
                    }
        Text
"Id" ->
            forall a. Monoid a => a
mempty
                { entityConstraintDefsIdField :: SetOnceAtMost UnboundIdDef
entityConstraintDefsIdField =
                    forall a. a -> SetOnceAtMost a
SetOnce (PersistSettings -> EntityNameHS -> [Text] -> UnboundIdDef
takeId PersistSettings
ps EntityNameHS
entityName [Text]
rest)
                }
        Text
_ | Text -> Bool
isCapitalizedText Text
n ->
            forall a. Monoid a => a
mempty
                { entityConstraintDefsUniques :: Maybe (NonEmpty UniqueDef)
entityConstraintDefsUniques =
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistSettings
-> Text -> [UnboundFieldDef] -> [Text] -> Maybe UniqueDef
takeUniq PersistSettings
ps Text
"" [UnboundFieldDef]
defs (Text
n forall a. a -> [a] -> [a]
: [Text]
rest)
                }
        Text
_ ->
            forall a. Monoid a => a
mempty

-- | 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnboundIdDef -> UnboundIdDef -> Bool
$c/= :: UnboundIdDef -> UnboundIdDef -> Bool
== :: UnboundIdDef -> UnboundIdDef -> Bool
$c== :: UnboundIdDef -> UnboundIdDef -> Bool
Eq, Eq 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
min :: UnboundIdDef -> UnboundIdDef -> UnboundIdDef
$cmin :: UnboundIdDef -> UnboundIdDef -> UnboundIdDef
max :: UnboundIdDef -> UnboundIdDef -> UnboundIdDef
$cmax :: UnboundIdDef -> UnboundIdDef -> UnboundIdDef
>= :: UnboundIdDef -> UnboundIdDef -> Bool
$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
compare :: UnboundIdDef -> UnboundIdDef -> Ordering
$ccompare :: UnboundIdDef -> UnboundIdDef -> Ordering
Ord, Int -> UnboundIdDef -> ShowS
[UnboundIdDef] -> ShowS
UnboundIdDef -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [UnboundIdDef] -> ShowS
$cshowList :: [UnboundIdDef] -> ShowS
show :: UnboundIdDef -> [Char]
$cshow :: UnboundIdDef -> [Char]
showsPrec :: Int -> UnboundIdDef -> ShowS
$cshowsPrec :: Int -> UnboundIdDef -> ShowS
Show, 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
liftTyped :: forall (m :: * -> *).
Quote m =>
UnboundIdDef -> Code m UnboundIdDef
$cliftTyped :: forall (m :: * -> *).
Quote m =>
UnboundIdDef -> Code m UnboundIdDef
lift :: forall (m :: * -> *). Quote m => UnboundIdDef -> m Exp
$clift :: forall (m :: * -> *). Quote m => UnboundIdDef -> m Exp
Lift)

-- 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 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
            [] ->
                forall a. Maybe a
Nothing
            (Text
t : [Text]
_) ->
                case Text -> Either [Char] FieldType
parseFieldType Text
t of
                    Left [Char]
_ ->
                        forall a. Maybe a
Nothing
                    Right FieldType
ft ->
                        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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
$c/= :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
== :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
$c== :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
Eq, Eq 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
min :: UnboundCompositeDef -> UnboundCompositeDef -> UnboundCompositeDef
$cmin :: UnboundCompositeDef -> UnboundCompositeDef -> UnboundCompositeDef
max :: UnboundCompositeDef -> UnboundCompositeDef -> UnboundCompositeDef
$cmax :: UnboundCompositeDef -> UnboundCompositeDef -> UnboundCompositeDef
>= :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
$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
compare :: UnboundCompositeDef -> UnboundCompositeDef -> Ordering
$ccompare :: UnboundCompositeDef -> UnboundCompositeDef -> Ordering
Ord, Int -> UnboundCompositeDef -> ShowS
[UnboundCompositeDef] -> ShowS
UnboundCompositeDef -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [UnboundCompositeDef] -> ShowS
$cshowList :: [UnboundCompositeDef] -> ShowS
show :: UnboundCompositeDef -> [Char]
$cshow :: UnboundCompositeDef -> [Char]
showsPrec :: Int -> UnboundCompositeDef -> ShowS
$cshowsPrec :: Int -> UnboundCompositeDef -> ShowS
Show, 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
liftTyped :: forall (m :: * -> *).
Quote m =>
UnboundCompositeDef -> Code m UnboundCompositeDef
$cliftTyped :: forall (m :: * -> *).
Quote m =>
UnboundCompositeDef -> Code m UnboundCompositeDef
lift :: forall (m :: * -> *). Quote m => UnboundCompositeDef -> m Exp
$clift :: forall (m :: * -> *). Quote m => UnboundCompositeDef -> m Exp
Lift)

compositeToUniqueDef :: EntityNameHS -> [UnboundFieldDef] -> UnboundCompositeDef -> UniqueDef
compositeToUniqueDef :: EntityNameHS
-> [UnboundFieldDef] -> UnboundCompositeDef -> UniqueDef
compositeToUniqueDef EntityNameHS
entityName [UnboundFieldDef]
fields UnboundCompositeDef {[Text]
NonEmpty FieldNameHS
unboundCompositeAttrs :: [Text]
unboundCompositeCols :: NonEmpty FieldNameHS
unboundCompositeAttrs :: UnboundCompositeDef -> [Text]
unboundCompositeCols :: UnboundCompositeDef -> NonEmpty FieldNameHS
..} =
    UniqueDef
        { uniqueHaskell :: ConstraintNameHS
uniqueHaskell =
            Text -> ConstraintNameHS
ConstraintNameHS (EntityNameHS -> Text
unEntityNameHS EntityNameHS
entityName forall a. Semigroup a => a -> a -> a
<> Text
"PrimaryKey")
        , uniqueDBName :: ConstraintNameDB
uniqueDBName =
            Text -> ConstraintNameDB
ConstraintNameDB Text
"primary_key"
        , uniqueFields :: NonEmpty (FieldNameHS, FieldNameDB)
uniqueFields =
            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 forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall {m :: * -> *}.
(Monad m, Alternative m) =>
FieldNameHS -> UnboundFieldDef -> m FieldNameDB
matchHsName FieldNameHS
hsName) [UnboundFieldDef]
fields of
            [] ->
                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
unboundFieldComments :: Maybe Text
unboundFieldGenerated :: Maybe Text
unboundFieldCascade :: FieldCascade
unboundFieldType :: FieldType
unboundFieldStrict :: Bool
unboundFieldAttrs :: [FieldAttr]
unboundFieldNameDB :: FieldNameDB
unboundFieldNameHS :: FieldNameHS
unboundFieldComments :: UnboundFieldDef -> Maybe Text
unboundFieldGenerated :: UnboundFieldDef -> Maybe Text
unboundFieldCascade :: UnboundFieldDef -> FieldCascade
unboundFieldType :: UnboundFieldDef -> FieldType
unboundFieldStrict :: UnboundFieldDef -> Bool
unboundFieldAttrs :: UnboundFieldDef -> [FieldAttr]
unboundFieldNameDB :: UnboundFieldDef -> FieldNameDB
unboundFieldNameHS :: UnboundFieldDef -> FieldNameHS
..} = do
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ FieldNameHS
unboundFieldNameHS forall a. Eq a => a -> a -> Bool
== FieldNameHS
hsName
        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 =
            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 forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [Text]
cols of
            Maybe (NonEmpty Text)
Nothing ->
                forall a. HasCallStack => [Char] -> a
error [Char]
"No fields provided for primary key"
            Just NonEmpty Text
xs ->
                NonEmpty Text
xs
    ([Text]
cols, [Text]
attrs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text
"!" Text -> Text -> Bool
`T.isPrefixOf`) [Text]
pkcols
    getDef :: [FieldNameHS] -> Text -> FieldNameHS
getDef [] Text
t = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown column in primary key constraint: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
t
    getDef (FieldNameHS
d:[FieldNameHS]
ds) Text
t
        | FieldNameHS
d 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
        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 =
                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) =
        forall a. (a -> Bool) -> [a] -> ([a], [a])
break Text -> Bool
isNonField [Text]
rest
    mfields :: Maybe (NonEmpty Text)
mfields =
        forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [Text]
fieldsList

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

    usualDbName :: ConstraintNameDB
usualDbName =
      Text -> ConstraintNameDB
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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Text -> Bool
isSqlName [Text]
nonFields of
        Maybe Text
Nothing ->
          forall a. Maybe a
Nothing
        (Just Text
t) ->
          case forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"=" Text
t of
            (Text
x : [Text]
_) -> forall a. a -> Maybe a
Just (Text -> ConstraintNameDB
ConstraintNameDB Text
x)
            [Text]
_ -> forall a. Maybe a
Nothing
    dbName :: ConstraintNameDB
dbName = forall a. a -> Maybe a -> a
fromMaybe ConstraintNameDB
usualDbName Maybe ConstraintNameDB
sqlName

    getDBName :: [UnboundFieldDef] -> Text -> FieldNameDB
getDBName [] Text
t = forall a. HasCallStack => [Char] -> a
error 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 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 =
  forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"invalid unique constraint on table["
          forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
tableName
          forall a. [a] -> [a] -> [a]
++ [Char]
"] expecting an uppercase constraint name xs="
          forall a. [a] -> [a] -> [a]
++ 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 \"" forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
"\" constraint: \"" forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
"\""
        forall a. Semigroup a => a -> a -> a
<> Text
" possible fields: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show (UnboundFieldDef -> Text
toFieldName 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnboundForeignDef -> UnboundForeignDef -> Bool
$c/= :: UnboundForeignDef -> UnboundForeignDef -> Bool
== :: UnboundForeignDef -> UnboundForeignDef -> Bool
$c== :: UnboundForeignDef -> UnboundForeignDef -> Bool
Eq, Eq 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
min :: UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef
$cmin :: UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef
max :: UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef
$cmax :: UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef
>= :: UnboundForeignDef -> UnboundForeignDef -> Bool
$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
compare :: UnboundForeignDef -> UnboundForeignDef -> Ordering
$ccompare :: UnboundForeignDef -> UnboundForeignDef -> Ordering
Ord, Int -> UnboundForeignDef -> ShowS
[UnboundForeignDef] -> ShowS
UnboundForeignDef -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [UnboundForeignDef] -> ShowS
$cshowList :: [UnboundForeignDef] -> ShowS
show :: UnboundForeignDef -> [Char]
$cshow :: UnboundForeignDef -> [Char]
showsPrec :: Int -> UnboundForeignDef -> ShowS
$cshowsPrec :: Int -> UnboundForeignDef -> ShowS
Show, 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
liftTyped :: forall (m :: * -> *).
Quote m =>
UnboundForeignDef -> Code m UnboundForeignDef
$cliftTyped :: forall (m :: * -> *).
Quote m =>
UnboundForeignDef -> Code m UnboundForeignDef
lift :: forall (m :: * -> *). Quote m => UnboundForeignDef -> m Exp
$clift :: forall (m :: * -> *). Quote m => UnboundForeignDef -> m Exp
Lift)

-- | A list of fields present on the foreign reference.
data UnboundForeignFieldList
    = FieldListImpliedId (NonEmpty FieldNameHS)
    -- ^ 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
    | FieldListHasReferences (NonEmpty ForeignFieldReference)
    -- ^ 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
    deriving (UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
$c/= :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
== :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
$c== :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
Eq, Eq 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
min :: UnboundForeignFieldList
-> UnboundForeignFieldList -> UnboundForeignFieldList
$cmin :: UnboundForeignFieldList
-> UnboundForeignFieldList -> UnboundForeignFieldList
max :: UnboundForeignFieldList
-> UnboundForeignFieldList -> UnboundForeignFieldList
$cmax :: UnboundForeignFieldList
-> UnboundForeignFieldList -> UnboundForeignFieldList
>= :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
$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
compare :: UnboundForeignFieldList -> UnboundForeignFieldList -> Ordering
$ccompare :: UnboundForeignFieldList -> UnboundForeignFieldList -> Ordering
Ord, Int -> UnboundForeignFieldList -> ShowS
[UnboundForeignFieldList] -> ShowS
UnboundForeignFieldList -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [UnboundForeignFieldList] -> ShowS
$cshowList :: [UnboundForeignFieldList] -> ShowS
show :: UnboundForeignFieldList -> [Char]
$cshow :: UnboundForeignFieldList -> [Char]
showsPrec :: Int -> UnboundForeignFieldList -> ShowS
$cshowsPrec :: Int -> UnboundForeignFieldList -> ShowS
Show, 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
liftTyped :: forall (m :: * -> *).
Quote m =>
UnboundForeignFieldList -> Code m UnboundForeignFieldList
$cliftTyped :: forall (m :: * -> *).
Quote m =>
UnboundForeignFieldList -> Code m UnboundForeignFieldList
lift :: forall (m :: * -> *). Quote m => UnboundForeignFieldList -> m Exp
$clift :: forall (m :: * -> *). Quote m => UnboundForeignFieldList -> m Exp
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ForeignFieldReference -> ForeignFieldReference -> Bool
$c/= :: ForeignFieldReference -> ForeignFieldReference -> Bool
== :: ForeignFieldReference -> ForeignFieldReference -> Bool
$c== :: ForeignFieldReference -> ForeignFieldReference -> Bool
Eq, Eq 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
min :: ForeignFieldReference
-> ForeignFieldReference -> ForeignFieldReference
$cmin :: ForeignFieldReference
-> ForeignFieldReference -> ForeignFieldReference
max :: ForeignFieldReference
-> ForeignFieldReference -> ForeignFieldReference
$cmax :: ForeignFieldReference
-> ForeignFieldReference -> ForeignFieldReference
>= :: ForeignFieldReference -> ForeignFieldReference -> Bool
$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
compare :: ForeignFieldReference -> ForeignFieldReference -> Ordering
$ccompare :: ForeignFieldReference -> ForeignFieldReference -> Ordering
Ord, Int -> ForeignFieldReference -> ShowS
[ForeignFieldReference] -> ShowS
ForeignFieldReference -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ForeignFieldReference] -> ShowS
$cshowList :: [ForeignFieldReference] -> ShowS
show :: ForeignFieldReference -> [Char]
$cshow :: ForeignFieldReference -> [Char]
showsPrec :: Int -> ForeignFieldReference -> ShowS
$cshowsPrec :: Int -> ForeignFieldReference -> ShowS
Show, 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
liftTyped :: forall (m :: * -> *).
Quote m =>
ForeignFieldReference -> Code m ForeignFieldReference
$cliftTyped :: forall (m :: * -> *).
Quote m =>
ForeignFieldReference -> Code m ForeignFieldReference
lift :: forall (m :: * -> *). Quote m => ForeignFieldReference -> m Exp
$clift :: forall (m :: * -> *). Quote m => ForeignFieldReference -> m Exp
Lift)

unbindForeignDef :: ForeignDef -> UnboundForeignDef
unbindForeignDef :: ForeignDef -> UnboundForeignDef
unbindForeignDef ForeignDef
fd =
    UnboundForeignDef
        { unboundForeignFields :: UnboundForeignFieldList
unboundForeignFields =
            NonEmpty ForeignFieldReference -> UnboundForeignFieldList
FieldListHasReferences forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NEL.fromList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FieldNameHS
FieldNameHS -> [FieldNameHS]
source) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FieldNameHS
FieldNameHS -> [FieldNameHS]
target) =
    case forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [FieldNameHS]
source of
        Maybe (NonEmpty FieldNameHS)
Nothing ->
            forall a b. a -> Either a b
Left [Char]
"No fields on foreign reference."
        Just NonEmpty FieldNameHS
sources ->
            case forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [FieldNameHS]
target of
                Maybe (NonEmpty FieldNameHS)
Nothing ->
                    forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ NonEmpty FieldNameHS -> UnboundForeignFieldList
FieldListImpliedId NonEmpty FieldNameHS
sources
                Just NonEmpty FieldNameHS
targets ->
                    if forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty FieldNameHS
targets forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty FieldNameHS
sources
                    then
                        forall a b. a -> Either a b
Left [Char]
"Target and source length differe on foreign reference."
                    else
                        forall a b. b -> Either a b
Right
                        forall a b. (a -> b) -> a -> b
$ NonEmpty ForeignFieldReference -> UnboundForeignFieldList
FieldListHasReferences
                        forall a b. (a -> b) -> a -> b
$ 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[" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (EntityNameHS -> Text
unEntityNameHS EntityNameHS
entityName) forall a. [a] -> [a] -> [a]
++ [Char]
"] "

    takeRefTable :: [Text] -> UnboundForeignDef
    takeRefTable :: [Text] -> UnboundForeignDef
takeRefTable [] =
        forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
errorPrefix forall a. [a] -> [a] -> [a]
++ [Char]
" expecting foreign table name"
    takeRefTable (Text
refTableName:[Text]
restLine) =
        [Text]
-> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef
go [Text]
restLine forall a. Maybe a
Nothing 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 (Text -> Char
T.head Text
constraintNameText) =
                UnboundForeignDef
                    { unboundForeignFields :: UnboundForeignFieldList
unboundForeignFields =
                        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error forall a. a -> a
id 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 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 =
                                forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
parentFields
                            }
                    }
          where
            constraintName :: ConstraintNameHS
constraintName =
                Text -> ConstraintNameHS
ConstraintNameHS Text
constraintNameText

            ([Text]
fields, [Text]
attrs) =
                forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text
"!" Text -> Text -> Bool
`T.isPrefixOf`) [Text]
rest
            ([Text]
foreignFields, [Text]
parentFields) =
                case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Text
"References") [Text]
fields of
                    ([Text]
ffs, []) ->
                        ([Text]
ffs, [])
                    ([Text]
ffs, Text
_ : [Text]
pfs) ->
                        case (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ffs, forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
pfs) of
                            (Int
flen, Int
plen)
                                | Int
flen forall a. Eq a => a -> a -> Bool
== Int
plen ->
                                    ([Text]
ffs, [Text]
pfs)
                            (Int
flen, Int
plen) ->
                                forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
errorPrefix forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                    [ [Char]
"Found " , forall a. Show a => a -> [Char]
show Int
flen
                                    , [Char]
" foreign fields but "
                                    , 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 (forall a. a -> Maybe a
Just CascadeAction
cascadingAction) Maybe CascadeAction
onUpdate
                Just CascadeAction
_ ->
                    forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
errorPrefix 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 (forall a. a -> Maybe a
Just CascadeAction
cascadingAction)
                Just CascadeAction
_ ->
                    forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
errorPrefix forall a. [a] -> [a] -> [a]
++ [Char]
"found more than one OnUpdate actions"

        go [Text]
xs Maybe CascadeAction
_ Maybe CascadeAction
_ = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
errorPrefix forall a. [a] -> [a] -> [a]
++ [Char]
"expecting a lower case constraint name or a cascading action xs=" forall a. [a] -> [a] -> [a]
++ 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 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 [] forall a. Maybe a
Nothing 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 (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 (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 forall a. a -> [a] -> [a]
: [Text]
acc) Maybe CascadeAction
mupd Maybe CascadeAction
mdel [Text]
rest
    nope :: [Char] -> (FieldCascade, [Text])
nope [Char]
msg =
        forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
msg forall a. Semigroup a => a -> a -> a
<> [Char]
", tokens: " forall a. Semigroup a => a -> a -> a
<> 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" forall a. Semigroup a => a -> a -> a
<> forall {a}. IsString a => CascadePrefix -> a
toPrefix CascadePrefix
prfx) Text
text
    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) = forall a. a -> Maybe a
Just [Text]
rest
takeDerives [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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` UnboundFieldDef -> [FieldAttr]
unboundFieldAttrs UnboundFieldDef
fd Bool -> Bool -> Bool
&&
    FieldAttr
FieldAttrSafeToRemove 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 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 = forall a. Read a => [Char] -> Maybe a
R.readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack