{-# 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(..)
    , splitExtras
    , takeColsEx
    -- * UnboundEntityDef
    , UnboundEntityDef(..)
    , getUnboundEntityNameHS
    , unbindEntityDef
    , getUnboundFieldDefs
    , UnboundForeignDef(..)
    , getSqlNameOr
    , UnboundFieldDef(..)
    , UnboundCompositeDef(..)
    , UnboundIdDef(..)
    , unbindFieldDef
    , isUnboundFieldNullable
    , unboundIdDefToFieldDef
    , PrimarySpec(..)
    , mkAutoIdField'
    , UnboundForeignFieldList(..)
    , ForeignFieldReference(..)
    , mkKeyConType
    , isHaskellUnboundField
    ) where

import Prelude hiding (lines)

import Control.Applicative (Alternative((<|>)))
import Control.Monad (mplus)
import Data.Char (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, maybeToList)
import Data.Monoid (mappend)
import Data.Text (Text)
import qualified Data.Text as T
import Database.Persist.EntityDef.Internal
import Database.Persist.Types
import Language.Haskell.TH.Syntax (Lift)
import Text.Read (readEither)

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

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

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

    parse1 :: Text -> ParseState FieldType
    parse1 :: Text -> ParseState FieldType
parse1 Text
t =
        case Text -> Maybe (Char, Text)
T.uncons Text
t of
            Maybe (Char, Text)
Nothing -> ParseState FieldType
forall a. ParseState a
PSDone
            Just (Char
c, Text
t')
                | Char -> Bool
isSpace Char
c -> Text -> ParseState FieldType
parse1 (Text -> ParseState FieldType) -> Text -> ParseState FieldType
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
t'
                | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' -> Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType
parseEnclosed Char
')' FieldType -> FieldType
forall a. a -> a
id Text
t'
                | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'[' -> Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType
parseEnclosed Char
']' FieldType -> FieldType
FTList Text
t'
                | Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' ->
                    let (Text
a, Text
b) = (Char -> Bool) -> Text -> (Text, Text)
T.break (\Char
x -> Char -> Bool
isSpace Char
x Bool -> Bool -> Bool
|| Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"()[]"::String)) Text
t'
                     in FieldType -> Text -> ParseState FieldType
forall a. a -> Text -> ParseState a
PSSuccess (Char -> Text -> FieldType
parseFieldTypePiece Char
c Text
a) Text
b
                | Bool
otherwise -> String -> ParseState FieldType
forall a. String -> ParseState a
PSFail (String -> ParseState FieldType) -> String -> ParseState FieldType
forall a b. (a -> b) -> a -> b
$ (Char, Text) -> String
forall a. Show a => a -> String
show (Char
c, Text
t')

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

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 Maybe Text
forall a. Maybe a
Nothing Text
t
                (Text
"", Text
_) -> Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing Text
t
                (Text
a, Text
b) -> Maybe Text -> Text -> FieldType
FTTypeCon (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ 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 :: (Text -> Text)
-> (EntityNameHS -> ConstraintNameHS -> Text)
-> Bool
-> Text
-> PersistSettings
PersistSettings
    { psToDBName :: Text -> Text
psToDBName = Text -> Text
forall a. a -> a
id
    , psToFKName :: EntityNameHS -> ConstraintNameHS -> Text
psToFKName = \(EntityNameHS Text
entName) (ConstraintNameHS Text
conName) -> Text
entName Text -> Text -> Text
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 = String -> Text
T.pack [Char
'_', Char -> Char
toLower Char
c]
                | Bool
otherwise = Char -> Text
T.singleton Char
c
         in (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') (Text -> Text) -> (Text -> Text) -> Text -> Text
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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
inf Text -> Text -> Text
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 = [UnboundEntityDef]
-> (NonEmpty Line -> [UnboundEntityDef])
-> Maybe (NonEmpty Line)
-> [UnboundEntityDef]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (PersistSettings -> NonEmpty Line -> [UnboundEntityDef]
parseLines PersistSettings
ps) (Maybe (NonEmpty Line) -> [UnboundEntityDef])
-> (Text -> Maybe (NonEmpty Line)) -> Text -> [UnboundEntityDef]
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 <- [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty (Text -> [Text]
T.lines Text
txt)
    [Line] -> Maybe (NonEmpty Line)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty ([Line] -> Maybe (NonEmpty Line))
-> [Line] -> Maybe (NonEmpty Line)
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe Line) -> [Text] -> [Line]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Line
parseLine (NonEmpty Text -> [Text]
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) (NonEmpty Token -> Line) -> Maybe (NonEmpty Token) -> Maybe Line
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token] -> Maybe (NonEmpty Token)
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 -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show, Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
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
"-- | " Text -> Text -> 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
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' = Text -> ([Text] -> [Text]) -> [Token]
quotes (Text -> Text
T.tail Text
t) [Text] -> [Text]
forall a. a -> a
id
    | Text -> Char
T.head Text
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' = Int -> Text -> ([Text] -> [Text]) -> [Token]
parens Int
1 (Text -> Text
T.tail Text
t) [Text] -> [Text]
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]) Token -> [Token] -> [Token]
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 Token -> [Token] -> [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 (Char -> Char -> Bool
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 -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
x, Text
y)
            (Text, Text)
_ -> Maybe (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' = String -> [Token]
forall a. HasCallStack => String -> a
error (String -> [Token]) -> String -> [Token]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
            Text
"Unterminated quoted string starting with " Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
front []
        | Text -> Char
T.head Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' = Text -> Token
Token ([Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
front []) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize (Text -> Text
T.tail Text
t')
        | Text -> Char
T.head Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
&& Text -> Int
T.length Text
t' Int -> Int -> Bool
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 ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
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')Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
        | Bool
otherwise =
            let (Text
x, Text
y) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> String -> Bool
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 ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
xText -> [Text] -> [Text]
forall 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' = String -> [Token]
forall a. HasCallStack => String -> a
error (String -> [Token]) -> String -> [Token]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
            Text
"Unterminated parens string starting with " Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
front []
        | Text -> Char
T.head Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' =
            if Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
1 :: Int)
                then Text -> Token
Token ([Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
front []) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize (Text -> Text
T.tail Text
t')
                else Int -> Text -> ([Text] -> [Text]) -> [Token]
parens (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Text -> Text
T.tail Text
t') ([Text] -> [Text]
front ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
")"Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
        | Text -> Char
T.head Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' =
            Int -> Text -> ([Text] -> [Text]) -> [Token]
parens (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Text -> Text
T.tail Text
t') ([Text] -> [Text]
front ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"("Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
        | Text -> Char
T.head Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
&& Text -> Int
T.length Text
t' Int -> Int -> Bool
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 ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
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')Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
        | Bool
otherwise =
            let (Text
x, Text
y) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> String -> Bool
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 ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
xText -> [Text] -> [Text]
forall 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
(Line -> Line -> Bool) -> (Line -> Line -> Bool) -> Eq Line
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 -> String
(Int -> Line -> ShowS)
-> (Line -> String) -> ([Line] -> ShowS) -> Show Line
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Line] -> ShowS
$cshowList :: [Line] -> ShowS
show :: Line -> String
$cshow :: Line -> String
showsPrec :: Int -> Line -> ShowS
$cshowsPrec :: Int -> Line -> ShowS
Show)

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

lowestIndent :: NonEmpty Line -> Int
lowestIndent :: NonEmpty Line -> Int
lowestIndent = NonEmpty Int -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (NonEmpty Int -> Int)
-> (NonEmpty Line -> NonEmpty Int) -> NonEmpty Line -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Line -> Int) -> NonEmpty Line -> NonEmpty Int
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
    (LinesWithComments -> UnboundEntityDef)
-> [LinesWithComments] -> [UnboundEntityDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PersistSettings -> ParsedEntityDef -> UnboundEntityDef
mkUnboundEntityDef PersistSettings
ps (ParsedEntityDef -> UnboundEntityDef)
-> (LinesWithComments -> ParsedEntityDef)
-> LinesWithComments
-> UnboundEntityDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinesWithComments -> ParsedEntityDef
toParsedEntityDef) ([LinesWithComments] -> [UnboundEntityDef])
-> (NonEmpty Line -> [LinesWithComments])
-> NonEmpty Line
-> [UnboundEntityDef]
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 (Text -> EntityNameDB) -> Text -> EntityNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [Text] -> Text
getDbName PersistSettings
ps (EntityNameHS -> Text
unEntityNameHS EntityNameHS
entNameHS) (ParsedEntityDef -> [Text]
parsedEntityDefEntityAttributes ParsedEntityDef
parsedEntDef)

toParsedEntityDef :: LinesWithComments -> ParsedEntityDef
toParsedEntityDef :: LinesWithComments -> ParsedEntityDef
toParsedEntityDef LinesWithComments
lwc = ParsedEntityDef :: [Text]
-> EntityNameHS
-> Bool
-> [Text]
-> [[Token]]
-> Map Text [[Text]]
-> ParsedEntityDef
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]])
splitExtras [Line]
fieldLines

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

data LinesWithComments = LinesWithComments
    { LinesWithComments -> NonEmpty Line
lwcLines :: NonEmpty Line
    , LinesWithComments -> [Text]
lwcComments :: [Text]
    } deriving (LinesWithComments -> LinesWithComments -> Bool
(LinesWithComments -> LinesWithComments -> Bool)
-> (LinesWithComments -> LinesWithComments -> Bool)
-> Eq LinesWithComments
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 -> String
(Int -> LinesWithComments -> ShowS)
-> (LinesWithComments -> String)
-> ([LinesWithComments] -> ShowS)
-> Show LinesWithComments
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LinesWithComments] -> ShowS
$cshowList :: [LinesWithComments] -> ShowS
show :: LinesWithComments -> String
$cshow :: LinesWithComments -> String
showsPrec :: Int -> LinesWithComments -> ShowS
$cshowsPrec :: Int -> LinesWithComments -> ShowS
Show)

instance Semigroup LinesWithComments where
    LinesWithComments
a <> :: LinesWithComments -> LinesWithComments -> LinesWithComments
<> LinesWithComments
b =
        LinesWithComments :: NonEmpty Line -> [Text] -> LinesWithComments
LinesWithComments
            { lwcLines :: NonEmpty Line
lwcLines =
                (Line -> NonEmpty Line -> NonEmpty Line)
-> NonEmpty Line -> NonEmpty Line -> NonEmpty Line
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Line -> NonEmpty Line -> NonEmpty Line
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 [Text] -> [Text] -> [Text]
forall a. Monoid a => a -> a -> a
`mappend` LinesWithComments -> [Text]
lwcComments LinesWithComments
b
            }

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

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

firstLine :: LinesWithComments -> Line
firstLine :: LinesWithComments -> Line
firstLine = NonEmpty Line -> Line
forall a. NonEmpty a -> a
NEL.head (NonEmpty Line -> Line)
-> (LinesWithComments -> NonEmpty Line)
-> LinesWithComments
-> Line
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 = Line -> NonEmpty Line -> NonEmpty Line
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 Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: LinesWithComments -> [Text]
lwcComments LinesWithComments
lwc }

associateLines :: NonEmpty Line -> [LinesWithComments]
associateLines :: NonEmpty Line -> [LinesWithComments]
associateLines NonEmpty Line
lines =
    (LinesWithComments -> [LinesWithComments] -> [LinesWithComments])
-> [LinesWithComments]
-> [LinesWithComments]
-> [LinesWithComments]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
combine [] ([LinesWithComments] -> [LinesWithComments])
-> [LinesWithComments] -> [LinesWithComments]
forall a b. (a -> b) -> a -> b
$
    (Line -> [LinesWithComments] -> [LinesWithComments])
-> [LinesWithComments] -> NonEmpty Line -> [LinesWithComments]
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 (NonEmpty Token -> Token
forall a. NonEmpty a -> a
NEL.head (Line -> NonEmpty Token
tokens Line
line)) of
                    Just Text
comment
                        | Line -> Int
lineIndent Line
line Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== NonEmpty Line -> Int
lowestIndent NonEmpty Line
lines ->
                        Text -> LinesWithComments -> LinesWithComments
consComment Text
comment LinesWithComments
lwc LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs
                    Maybe Text
_ ->
                        if Line -> Int
lineIndent Line
line Int -> Int -> Bool
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) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= NonEmpty Line -> Int
lowestIndent NonEmpty Line
lines
                        then
                            Line -> LinesWithComments -> LinesWithComments
consLine Line
line LinesWithComments
lwc LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs
                        else
                            Line -> LinesWithComments
newLine Line
line LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: LinesWithComments
lwc LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
otherIndent then
                LinesWithComments -> LinesWithComments -> LinesWithComments
appendLwc LinesWithComments
lwc LinesWithComments
lwc' LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs
            else
                LinesWithComments
lwc LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: LinesWithComments
lwc' LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs

    minimumIndentOf :: LinesWithComments -> Int
    minimumIndentOf :: LinesWithComments -> Int
minimumIndentOf = NonEmpty Line -> Int
lowestIndent (NonEmpty Line -> Int)
-> (LinesWithComments -> NonEmpty Line) -> LinesWithComments -> Int
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
(UnboundEntityDef -> UnboundEntityDef -> Bool)
-> (UnboundEntityDef -> UnboundEntityDef -> Bool)
-> Eq UnboundEntityDef
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
Eq UnboundEntityDef
-> (UnboundEntityDef -> UnboundEntityDef -> Ordering)
-> (UnboundEntityDef -> UnboundEntityDef -> Bool)
-> (UnboundEntityDef -> UnboundEntityDef -> Bool)
-> (UnboundEntityDef -> UnboundEntityDef -> Bool)
-> (UnboundEntityDef -> UnboundEntityDef -> Bool)
-> (UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef)
-> (UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef)
-> Ord UnboundEntityDef
UnboundEntityDef -> UnboundEntityDef -> Bool
UnboundEntityDef -> UnboundEntityDef -> Ordering
UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
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
$cp1Ord :: Eq UnboundEntityDef
Ord, Int -> UnboundEntityDef -> ShowS
[UnboundEntityDef] -> ShowS
UnboundEntityDef -> String
(Int -> UnboundEntityDef -> ShowS)
-> (UnboundEntityDef -> String)
-> ([UnboundEntityDef] -> ShowS)
-> Show UnboundEntityDef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnboundEntityDef] -> ShowS
$cshowList :: [UnboundEntityDef] -> ShowS
show :: UnboundEntityDef -> String
$cshow :: UnboundEntityDef -> String
showsPrec :: Int -> UnboundEntityDef -> ShowS
$cshowsPrec :: Int -> UnboundEntityDef -> ShowS
Show, UnboundEntityDef -> Q Exp
UnboundEntityDef -> Q (TExp UnboundEntityDef)
(UnboundEntityDef -> Q Exp)
-> (UnboundEntityDef -> Q (TExp UnboundEntityDef))
-> Lift UnboundEntityDef
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: UnboundEntityDef -> Q (TExp UnboundEntityDef)
$cliftTyped :: UnboundEntityDef -> Q (TExp UnboundEntityDef)
lift :: UnboundEntityDef -> Q Exp
$clift :: UnboundEntityDef -> Q 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 :: [UnboundForeignDef]
-> PrimarySpec
-> EntityDef
-> [UnboundFieldDef]
-> UnboundEntityDef
UnboundEntityDef
        { unboundForeignDefs :: [UnboundForeignDef]
unboundForeignDefs =
            (ForeignDef -> UnboundForeignDef)
-> [ForeignDef] -> [UnboundForeignDef]
forall a b. (a -> b) -> [a] -> [b]
map ForeignDef -> UnboundForeignDef
unbindForeignDef (EntityDef -> [ForeignDef]
entityForeigns EntityDef
ed)
        , unboundPrimarySpec :: PrimarySpec
unboundPrimarySpec =
            case EntityDef -> EntityIdDef
entityId EntityDef
ed of
                EntityIdField FieldDef
fd ->
                    UnboundIdDef -> PrimarySpec
SurrogateKey (EntityNameHS -> FieldDef -> UnboundIdDef
unbindIdDef (EntityDef -> EntityNameHS
entityHaskell EntityDef
ed) FieldDef
fd)
                EntityIdNaturalKey CompositeDef
cd ->
                    UnboundCompositeDef -> PrimarySpec
NaturalKey (CompositeDef -> UnboundCompositeDef
unbindCompositeDef CompositeDef
cd)
        , unboundEntityDef :: EntityDef
unboundEntityDef =
            EntityDef
ed
        , unboundEntityFields :: [UnboundFieldDef]
unboundEntityFields =
            (FieldDef -> UnboundFieldDef) -> [FieldDef] -> [UnboundFieldDef]
forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> UnboundFieldDef
unbindFieldDef (EntityDef -> [FieldDef]
entityFields EntityDef
ed)
        }

-- | 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 :: [FieldNameHS] -> [Text] -> UnboundCompositeDef
UnboundCompositeDef
        { unboundCompositeCols :: [FieldNameHS]
unboundCompositeCols =
            NonEmpty FieldNameHS -> [FieldNameHS]
forall a. NonEmpty a -> [a]
NEL.toList (NonEmpty FieldNameHS -> [FieldNameHS])
-> NonEmpty FieldNameHS -> [FieldNameHS]
forall a b. (a -> b) -> a -> b
$ (FieldDef -> FieldNameHS)
-> NonEmpty FieldDef -> NonEmpty FieldNameHS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldDef -> FieldNameHS
fieldHaskell (CompositeDef -> NonEmpty FieldDef
compositeFields CompositeDef
cd)
        , unboundCompositeAttrs :: [Text]
unboundCompositeAttrs =
            CompositeDef -> [Text]
compositeAttrs CompositeDef
cd
        }

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

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

-- | The specification for how an entity's primary key should be formed.
--
-- Persistent requires that every table have a primary key. By default, an
-- implied ID is assigned, based on the 'mpsImplicitIdDef' field on
-- 'MkPersistSettings'. Because we can't access that type at parse-time, we
-- defer that decision until later.
--
-- @since 2.13.0.0
data PrimarySpec
    = 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
(PrimarySpec -> PrimarySpec -> Bool)
-> (PrimarySpec -> PrimarySpec -> Bool) -> Eq PrimarySpec
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
Eq PrimarySpec
-> (PrimarySpec -> PrimarySpec -> Ordering)
-> (PrimarySpec -> PrimarySpec -> Bool)
-> (PrimarySpec -> PrimarySpec -> Bool)
-> (PrimarySpec -> PrimarySpec -> Bool)
-> (PrimarySpec -> PrimarySpec -> Bool)
-> (PrimarySpec -> PrimarySpec -> PrimarySpec)
-> (PrimarySpec -> PrimarySpec -> PrimarySpec)
-> Ord PrimarySpec
PrimarySpec -> PrimarySpec -> Bool
PrimarySpec -> PrimarySpec -> Ordering
PrimarySpec -> PrimarySpec -> PrimarySpec
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
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
$cp1Ord :: Eq PrimarySpec
Ord, Int -> PrimarySpec -> ShowS
[PrimarySpec] -> ShowS
PrimarySpec -> String
(Int -> PrimarySpec -> ShowS)
-> (PrimarySpec -> String)
-> ([PrimarySpec] -> ShowS)
-> Show PrimarySpec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrimarySpec] -> ShowS
$cshowList :: [PrimarySpec] -> ShowS
show :: PrimarySpec -> String
$cshow :: PrimarySpec -> String
showsPrec :: Int -> PrimarySpec -> ShowS
$cshowsPrec :: Int -> PrimarySpec -> ShowS
Show, PrimarySpec -> Q Exp
PrimarySpec -> Q (TExp PrimarySpec)
(PrimarySpec -> Q Exp)
-> (PrimarySpec -> Q (TExp PrimarySpec)) -> Lift PrimarySpec
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: PrimarySpec -> Q (TExp PrimarySpec)
$cliftTyped :: PrimarySpec -> Q (TExp PrimarySpec)
lift :: PrimarySpec -> Q Exp
$clift :: PrimarySpec -> Q Exp
Lift)

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

    (Maybe UnboundIdDef
idField, Maybe UnboundCompositeDef
primaryComposite, [UniqueDef]
uniqs, [UnboundForeignDef]
foreigns) =
        ((Maybe UnboundIdDef, Maybe UnboundCompositeDef, [UniqueDef],
  [UnboundForeignDef])
 -> [Text]
 -> (Maybe UnboundIdDef, Maybe UnboundCompositeDef, [UniqueDef],
     [UnboundForeignDef]))
-> (Maybe UnboundIdDef, Maybe UnboundCompositeDef, [UniqueDef],
    [UnboundForeignDef])
-> [[Text]]
-> (Maybe UnboundIdDef, Maybe UnboundCompositeDef, [UniqueDef],
    [UnboundForeignDef])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
            (\(Maybe UnboundIdDef
mid, Maybe UnboundCompositeDef
mp, [UniqueDef]
us, [UnboundForeignDef]
fs) [Text]
attr ->
                let
                    (Maybe UnboundIdDef
i, Maybe UnboundCompositeDef
p, Maybe UniqueDef
u, Maybe UnboundForeignDef
f) = PersistSettings
-> EntityNameHS
-> [UnboundFieldDef]
-> [Text]
-> (Maybe UnboundIdDef, Maybe UnboundCompositeDef, Maybe UniqueDef,
    Maybe UnboundForeignDef)
takeConstraint PersistSettings
ps EntityNameHS
entNameHS [UnboundFieldDef]
cols [Text]
attr
                    squish :: [a] -> Maybe a -> [a]
squish [a]
xs Maybe a
m = [a]
xs [a] -> [a] -> [a]
forall a. Monoid a => a -> a -> a
`mappend` Maybe a -> [a]
forall a. Maybe a -> [a]
maybeToList Maybe a
m
                in
                    (Maybe UnboundIdDef -> Maybe UnboundIdDef -> Maybe UnboundIdDef
forall x. Show x => Maybe x -> Maybe x -> Maybe x
just1 Maybe UnboundIdDef
mid Maybe UnboundIdDef
i, Maybe UnboundCompositeDef
-> Maybe UnboundCompositeDef -> Maybe UnboundCompositeDef
forall x. Show x => Maybe x -> Maybe x -> Maybe x
just1 Maybe UnboundCompositeDef
mp Maybe UnboundCompositeDef
p, [UniqueDef] -> Maybe UniqueDef -> [UniqueDef]
forall a. [a] -> Maybe a -> [a]
squish [UniqueDef]
us Maybe UniqueDef
u, [UnboundForeignDef]
-> Maybe UnboundForeignDef -> [UnboundForeignDef]
forall a. [a] -> Maybe a -> [a]
squish [UnboundForeignDef]
fs Maybe UnboundForeignDef
f)
            )
            (Maybe UnboundIdDef
forall a. Maybe a
Nothing, Maybe UnboundCompositeDef
forall a. Maybe a
Nothing, [],[])
            [[Text]]
textAttribs

    cols :: [UnboundFieldDef]
    cols :: [UnboundFieldDef]
cols = [UnboundFieldDef] -> [UnboundFieldDef]
forall a. [a] -> [a]
reverse ([UnboundFieldDef] -> [UnboundFieldDef])
-> ([[Token]] -> [UnboundFieldDef])
-> [[Token]]
-> [UnboundFieldDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([UnboundFieldDef], [Text]) -> [UnboundFieldDef]
forall a b. (a, b) -> a
fst (([UnboundFieldDef], [Text]) -> [UnboundFieldDef])
-> ([[Token]] -> ([UnboundFieldDef], [Text]))
-> [[Token]]
-> [UnboundFieldDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Token]
 -> ([UnboundFieldDef], [Text]) -> ([UnboundFieldDef], [Text]))
-> ([UnboundFieldDef], [Text])
-> [[Token]]
-> ([UnboundFieldDef], [Text])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (PersistSettings
-> [Token]
-> ([UnboundFieldDef], [Text])
-> ([UnboundFieldDef], [Text])
associateComments PersistSettings
ps) ([], []) ([[Token]] -> [UnboundFieldDef]) -> [[Token]] -> [UnboundFieldDef]
forall a b. (a -> b) -> a -> b
$ [[Token]] -> [[Token]]
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 =
        SqlType
-> (UnboundCompositeDef -> SqlType)
-> Maybe UnboundCompositeDef
-> SqlType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SqlType
SqlInt64 (SqlType -> UnboundCompositeDef -> SqlType
forall a b. a -> b -> a
const (SqlType -> UnboundCompositeDef -> SqlType)
-> SqlType -> UnboundCompositeDef -> SqlType
forall a b. (a -> b) -> a -> b
$ Text -> SqlType
SqlOther Text
"Primary Key") Maybe UnboundCompositeDef
primaryComposite

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

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

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

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

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

just1 :: (Show x) => Maybe x -> Maybe x -> Maybe x
just1 :: Maybe x -> Maybe x -> Maybe x
just1 (Just x
x) (Just x
y) = String -> Maybe x
forall a. HasCallStack => String -> a
error (String -> Maybe x) -> String -> Maybe x
forall a b. (a -> b) -> a -> b
$ String
"expected only one of: "
  String -> ShowS
forall a. Monoid a => a -> a -> a
`mappend` x -> String
forall a. Show a => a -> String
show x
x String -> ShowS
forall a. Monoid a => a -> a -> a
`mappend` String
" " String -> ShowS
forall a. Monoid a => a -> a -> a
`mappend` x -> String
forall a. Show a => a -> String
show x
y
just1 Maybe x
x Maybe x
y = Maybe x
x Maybe x -> Maybe x -> Maybe x
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe x
y

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

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

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

splitExtras
    :: [Line]
    -> ( [[Token]]
       , M.Map Text [ExtraLine]
       )
splitExtras :: [Line] -> ([[Token]], Map Text [[Text]])
splitExtras [Line]
lns =
    case [Line]
lns of
        [] -> ([], Map Text [[Text]]
forall k a. Map k a
M.empty)
        (Line
line : [Line]
rest) ->
            case NonEmpty Token -> [Token]
forall a. NonEmpty a -> [a]
NEL.toList (Line -> NonEmpty Token
tokens Line
line) of
                [Token Text
name]
                  | Text -> Bool
isCapitalizedText Text
name ->
                    let indent :: Int
indent = Line -> Int
lineIndent Line
line
                        ([Line]
children, [Line]
rest') = (Line -> Bool) -> [Line] -> ([Line], [Line])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
indent) (Int -> Bool) -> (Line -> Int) -> Line -> Bool
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]])
splitExtras [Line]
rest'
                     in ([[Token]]
x, Text -> [[Text]] -> Map Text [[Text]] -> Map Text [[Text]]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
name (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NEL.toList (NonEmpty Text -> [Text])
-> (Line -> NonEmpty Text) -> Line -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> NonEmpty Text
lineText (Line -> [Text]) -> [Line] -> [[Text]]
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]])
splitExtras [Line]
rest
                     in ([Token]
ts[Token] -> [[Token]] -> [[Token]]
forall 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 -> String -> Maybe UnboundFieldDef)
-> PersistSettings -> [Text] -> Maybe UnboundFieldDef
takeCols
        (\Text
ft String
perr -> String -> Maybe UnboundFieldDef
forall a. HasCallStack => String -> a
error (String -> Maybe UnboundFieldDef)
-> String -> Maybe UnboundFieldDef
forall a b. (a -> b) -> a -> b
$ String
"Invalid field type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
ft String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
perr)

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

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

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

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

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

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

takeConstraint
    :: PersistSettings
    -> EntityNameHS
    -> [UnboundFieldDef]
    -> [Text]
    -> (Maybe UnboundIdDef, Maybe UnboundCompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef)
takeConstraint :: PersistSettings
-> EntityNameHS
-> [UnboundFieldDef]
-> [Text]
-> (Maybe UnboundIdDef, Maybe UnboundCompositeDef, Maybe UniqueDef,
    Maybe UnboundForeignDef)
takeConstraint PersistSettings
ps EntityNameHS
entityName [UnboundFieldDef]
defs (Text
n:[Text]
rest) | Text -> Bool
isCapitalizedText Text
n = (Maybe UnboundIdDef, Maybe UnboundCompositeDef, Maybe UniqueDef,
 Maybe UnboundForeignDef)
takeConstraint'
  where
    takeConstraint' :: (Maybe UnboundIdDef, Maybe UnboundCompositeDef, Maybe UniqueDef,
 Maybe UnboundForeignDef)
takeConstraint'
          | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Unique"  =
              (Maybe UnboundIdDef
forall a. Maybe a
Nothing, Maybe UnboundCompositeDef
forall a. Maybe a
Nothing, PersistSettings
-> Text -> [UnboundFieldDef] -> [Text] -> Maybe UniqueDef
takeUniq PersistSettings
ps (EntityNameHS -> Text
unEntityNameHS EntityNameHS
entityName) [UnboundFieldDef]
defs [Text]
rest, Maybe UnboundForeignDef
forall a. Maybe a
Nothing)
          | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Foreign" =
              (Maybe UnboundIdDef
forall a. Maybe a
Nothing, Maybe UnboundCompositeDef
forall a. Maybe a
Nothing, Maybe UniqueDef
forall a. Maybe a
Nothing, UnboundForeignDef -> Maybe UnboundForeignDef
forall a. a -> Maybe a
Just (UnboundForeignDef -> Maybe UnboundForeignDef)
-> UnboundForeignDef -> Maybe UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ PersistSettings -> EntityNameHS -> [Text] -> UnboundForeignDef
takeForeign PersistSettings
ps EntityNameHS
entityName [Text]
rest)
          | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Primary" =
              (Maybe UnboundIdDef
forall a. Maybe a
Nothing, UnboundCompositeDef -> Maybe UnboundCompositeDef
forall a. a -> Maybe a
Just (UnboundCompositeDef -> Maybe UnboundCompositeDef)
-> UnboundCompositeDef -> Maybe UnboundCompositeDef
forall a b. (a -> b) -> a -> b
$ [FieldNameHS] -> [Text] -> UnboundCompositeDef
takeComposite [FieldNameHS]
defNames [Text]
rest, Maybe UniqueDef
forall a. Maybe a
Nothing, Maybe UnboundForeignDef
forall a. Maybe a
Nothing)
          | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Id"      =
              (UnboundIdDef -> Maybe UnboundIdDef
forall a. a -> Maybe a
Just (UnboundIdDef -> Maybe UnboundIdDef)
-> UnboundIdDef -> Maybe UnboundIdDef
forall a b. (a -> b) -> a -> b
$ PersistSettings -> EntityNameHS -> [Text] -> UnboundIdDef
takeId PersistSettings
ps EntityNameHS
entityName [Text]
rest, Maybe UnboundCompositeDef
forall a. Maybe a
Nothing, Maybe UniqueDef
forall a. Maybe a
Nothing, Maybe UnboundForeignDef
forall a. Maybe a
Nothing)
          | Bool
otherwise      =
              (Maybe UnboundIdDef
forall a. Maybe a
Nothing, Maybe UnboundCompositeDef
forall a. Maybe a
Nothing, PersistSettings
-> Text -> [UnboundFieldDef] -> [Text] -> Maybe UniqueDef
takeUniq PersistSettings
ps Text
"" [UnboundFieldDef]
defs (Text
nText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
rest), Maybe UnboundForeignDef
forall a. Maybe a
Nothing) -- retain compatibility with original unique constraint
    defNames :: [FieldNameHS]
defNames =
        (UnboundFieldDef -> FieldNameHS)
-> [UnboundFieldDef] -> [FieldNameHS]
forall a b. (a -> b) -> [a] -> [b]
map UnboundFieldDef -> FieldNameHS
unboundFieldNameHS [UnboundFieldDef]
defs
takeConstraint PersistSettings
_ EntityNameHS
_ [UnboundFieldDef]
_ [Text]
_ = (Maybe UnboundIdDef
forall a. Maybe a
Nothing, Maybe UnboundCompositeDef
forall a. Maybe a
Nothing, Maybe UniqueDef
forall a. Maybe a
Nothing, Maybe UnboundForeignDef
forall a. Maybe a
Nothing)

-- | This type represents an @Id@ declaration in the QuasiQuoted syntax.
--
-- > Id
--
-- This uses the implied settings, and is equivalent to omitting the @Id@
-- statement entirely.
--
-- > Id Text
--
-- This will set the field type of the ID to be 'Text'.
--
-- > Id Text sql=foo_id
--
-- This will set the field type of the Id to be 'Text' and the SQL DB name to be @foo_id@.
--
-- > Id FooId
--
-- This results in a shared primary key - the @FooId@ refers to a @Foo@ table.
--
-- > Id FooId OnDelete Cascade
--
-- You can set a cascade behavior on an ID column.
--
-- @since 2.13.0.0
data UnboundIdDef = UnboundIdDef
    { UnboundIdDef -> EntityNameHS
unboundIdEntityName :: EntityNameHS
    , UnboundIdDef -> FieldNameDB
unboundIdDBName :: !FieldNameDB
    , UnboundIdDef -> [FieldAttr]
unboundIdAttrs :: [FieldAttr]
    , UnboundIdDef -> FieldCascade
unboundIdCascade :: FieldCascade
    , UnboundIdDef -> Maybe FieldType
unboundIdType :: Maybe FieldType
    }
    deriving (UnboundIdDef -> UnboundIdDef -> Bool
(UnboundIdDef -> UnboundIdDef -> Bool)
-> (UnboundIdDef -> UnboundIdDef -> Bool) -> Eq UnboundIdDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnboundIdDef -> UnboundIdDef -> Bool
$c/= :: UnboundIdDef -> UnboundIdDef -> Bool
== :: UnboundIdDef -> UnboundIdDef -> Bool
$c== :: UnboundIdDef -> UnboundIdDef -> Bool
Eq, Eq UnboundIdDef
Eq UnboundIdDef
-> (UnboundIdDef -> UnboundIdDef -> Ordering)
-> (UnboundIdDef -> UnboundIdDef -> Bool)
-> (UnboundIdDef -> UnboundIdDef -> Bool)
-> (UnboundIdDef -> UnboundIdDef -> Bool)
-> (UnboundIdDef -> UnboundIdDef -> Bool)
-> (UnboundIdDef -> UnboundIdDef -> UnboundIdDef)
-> (UnboundIdDef -> UnboundIdDef -> UnboundIdDef)
-> Ord UnboundIdDef
UnboundIdDef -> UnboundIdDef -> Bool
UnboundIdDef -> UnboundIdDef -> Ordering
UnboundIdDef -> UnboundIdDef -> UnboundIdDef
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
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
$cp1Ord :: Eq UnboundIdDef
Ord, Int -> UnboundIdDef -> ShowS
[UnboundIdDef] -> ShowS
UnboundIdDef -> String
(Int -> UnboundIdDef -> ShowS)
-> (UnboundIdDef -> String)
-> ([UnboundIdDef] -> ShowS)
-> Show UnboundIdDef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnboundIdDef] -> ShowS
$cshowList :: [UnboundIdDef] -> ShowS
show :: UnboundIdDef -> String
$cshow :: UnboundIdDef -> String
showsPrec :: Int -> UnboundIdDef -> ShowS
$cshowsPrec :: Int -> UnboundIdDef -> ShowS
Show, UnboundIdDef -> Q Exp
UnboundIdDef -> Q (TExp UnboundIdDef)
(UnboundIdDef -> Q Exp)
-> (UnboundIdDef -> Q (TExp UnboundIdDef)) -> Lift UnboundIdDef
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: UnboundIdDef -> Q (TExp UnboundIdDef)
$cliftTyped :: UnboundIdDef -> Q (TExp UnboundIdDef)
lift :: UnboundIdDef -> Q Exp
$clift :: UnboundIdDef -> Q 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 :: EntityNameHS
-> FieldNameDB
-> [FieldAttr]
-> FieldCascade
-> Maybe FieldType
-> UnboundIdDef
UnboundIdDef
        { unboundIdDBName :: FieldNameDB
unboundIdDBName =
            Text -> FieldNameDB
FieldNameDB (Text -> FieldNameDB) -> Text -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text
psIdName PersistSettings
ps
        , unboundIdEntityName :: EntityNameHS
unboundIdEntityName =
            EntityNameHS
entityName
        , unboundIdCascade :: FieldCascade
unboundIdCascade =
            FieldCascade
cascade_
        , unboundIdAttrs :: [FieldAttr]
unboundIdAttrs =
            [Text] -> [FieldAttr]
parseFieldAttrs [Text]
attrs_
        , unboundIdType :: Maybe FieldType
unboundIdType =
            Maybe FieldType
typ
        }
  where
    typ :: Maybe FieldType
typ =
        case [Text]
texts of
            [] ->
                Maybe FieldType
forall a. Maybe a
Nothing
            (Text
t : [Text]
_) ->
                case Text -> Either String FieldType
parseFieldType Text
t of
                    Left String
_ ->
                        Maybe FieldType
forall a. Maybe a
Nothing
                    Right FieldType
ft ->
                        FieldType -> Maybe FieldType
forall a. a -> Maybe a
Just FieldType
ft
    (FieldCascade
cascade_, [Text]
attrs_) = [Text] -> (FieldCascade, [Text])
parseCascade [Text]
texts

-- | A definition for a composite primary key.
--
-- @since.2.13.0.0
data UnboundCompositeDef = UnboundCompositeDef
    { UnboundCompositeDef -> [FieldNameHS]
unboundCompositeCols :: [FieldNameHS]
    -- ^ The field names for the primary key.
    --
    -- @since 2.13.0.0
    , UnboundCompositeDef -> [Text]
unboundCompositeAttrs :: [Attr]
    -- ^ A list of attributes defined on the primary key. This is anything that
    -- occurs after a @!@ character.
    --
    -- @since 2.13.0.0
    }
    deriving (UnboundCompositeDef -> UnboundCompositeDef -> Bool
(UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> (UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> Eq UnboundCompositeDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
$c/= :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
== :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
$c== :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
Eq, Eq UnboundCompositeDef
Eq UnboundCompositeDef
-> (UnboundCompositeDef -> UnboundCompositeDef -> Ordering)
-> (UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> (UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> (UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> (UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> (UnboundCompositeDef
    -> UnboundCompositeDef -> UnboundCompositeDef)
-> (UnboundCompositeDef
    -> UnboundCompositeDef -> UnboundCompositeDef)
-> Ord UnboundCompositeDef
UnboundCompositeDef -> UnboundCompositeDef -> Bool
UnboundCompositeDef -> UnboundCompositeDef -> Ordering
UnboundCompositeDef -> UnboundCompositeDef -> UnboundCompositeDef
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
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
$cp1Ord :: Eq UnboundCompositeDef
Ord, Int -> UnboundCompositeDef -> ShowS
[UnboundCompositeDef] -> ShowS
UnboundCompositeDef -> String
(Int -> UnboundCompositeDef -> ShowS)
-> (UnboundCompositeDef -> String)
-> ([UnboundCompositeDef] -> ShowS)
-> Show UnboundCompositeDef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnboundCompositeDef] -> ShowS
$cshowList :: [UnboundCompositeDef] -> ShowS
show :: UnboundCompositeDef -> String
$cshow :: UnboundCompositeDef -> String
showsPrec :: Int -> UnboundCompositeDef -> ShowS
$cshowsPrec :: Int -> UnboundCompositeDef -> ShowS
Show, UnboundCompositeDef -> Q Exp
UnboundCompositeDef -> Q (TExp UnboundCompositeDef)
(UnboundCompositeDef -> Q Exp)
-> (UnboundCompositeDef -> Q (TExp UnboundCompositeDef))
-> Lift UnboundCompositeDef
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: UnboundCompositeDef -> Q (TExp UnboundCompositeDef)
$cliftTyped :: UnboundCompositeDef -> Q (TExp UnboundCompositeDef)
lift :: UnboundCompositeDef -> Q Exp
$clift :: UnboundCompositeDef -> Q Exp
Lift)

takeComposite
    :: [FieldNameHS]
    -> [Text]
    -> UnboundCompositeDef
takeComposite :: [FieldNameHS] -> [Text] -> UnboundCompositeDef
takeComposite [FieldNameHS]
fields [Text]
pkcols =
    UnboundCompositeDef :: [FieldNameHS] -> [Text] -> UnboundCompositeDef
UnboundCompositeDef
        { unboundCompositeCols :: [FieldNameHS]
unboundCompositeCols =
            (Text -> FieldNameHS) -> [Text] -> [FieldNameHS]
forall a b. (a -> b) -> [a] -> [b]
map ([FieldNameHS] -> Text -> FieldNameHS
getDef [FieldNameHS]
fields) [Text]
cols
        , unboundCompositeAttrs :: [Text]
unboundCompositeAttrs =
            [Text]
attrs
        }
  where
    ([Text]
cols, [Text]
attrs) = (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text
"!" Text -> Text -> Bool
`T.isPrefixOf`) [Text]
pkcols
    getDef :: [FieldNameHS] -> Text -> FieldNameHS
getDef [] Text
t = String -> FieldNameHS
forall a. HasCallStack => String -> a
error (String -> FieldNameHS) -> String -> FieldNameHS
forall a b. (a -> b) -> a -> b
$ String
"Unknown column in primary key constraint: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
t
    getDef (FieldNameHS
d:[FieldNameHS]
ds) Text
t
        | FieldNameHS
d FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> FieldNameHS
FieldNameHS Text
t =
            -- TODO: check for nullability in later step
            -- if nullable (fieldAttrs d) /= NotNullable
            --     then error $ "primary key column cannot be nullable: " ++ show t ++ show fields
            FieldNameHS
d
        | Bool
otherwise =
            [FieldNameHS] -> Text -> FieldNameHS
getDef [FieldNameHS]
ds Text
t

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

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

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

    getDBName :: [UnboundFieldDef] -> Text -> FieldNameDB
getDBName [] Text
t =
      String -> FieldNameDB
forall a. HasCallStack => String -> a
error (String -> FieldNameDB) -> String -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ String
"Unknown column in unique constraint: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
t
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [UnboundFieldDef] -> String
forall a. Show a => a -> String
show [UnboundFieldDef]
defs String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
attrs
    getDBName (UnboundFieldDef
d:[UnboundFieldDef]
ds) Text
t
        | UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
d FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> FieldNameHS
FieldNameHS Text
t =
            UnboundFieldDef -> FieldNameDB
unboundFieldNameDB UnboundFieldDef
d
        | Bool
otherwise =
            [UnboundFieldDef] -> Text -> FieldNameDB
getDBName [UnboundFieldDef]
ds Text
t

takeUniq PersistSettings
_ Text
tableName [UnboundFieldDef]
_ [Text]
xs =
  String -> Maybe UniqueDef
forall a. HasCallStack => String -> a
error (String -> Maybe UniqueDef) -> String -> Maybe UniqueDef
forall a b. (a -> b) -> a -> b
$ String
"invalid unique constraint on table["
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
tableName
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] expecting an uppercase constraint name xs="
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
xs

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

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

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

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

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

            ([Text]
fields, [Text]
attrs) =
                (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text
"!" Text -> Text -> Bool
`T.isPrefixOf`) [Text]
rest
            ([Text]
foreignFields, [Text]
parentFields) =
                case (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"References") [Text]
fields of
                    ([Text]
ffs, []) ->
                        ([Text]
ffs, [])
                    ([Text]
ffs, Text
_ : [Text]
pfs) ->
                        case ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ffs, [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
pfs) of
                            (Int
flen, Int
plen)
                                | Int
flen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
plen ->
                                    ([Text]
ffs, [Text]
pfs)
                            (Int
flen, Int
plen) ->
                                String -> ([Text], [Text])
forall a. HasCallStack => String -> a
error (String -> ([Text], [Text])) -> String -> ([Text], [Text])
forall a b. (a -> b) -> a -> b
$ String
errorPrefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                    [ String
"Found " , Int -> String
forall a. Show a => a -> String
show Int
flen
                                    , String
" foreign fields but "
                                    , Int -> String
forall a. Show a => a -> String
show Int
plen, String
" parent fields"
                                    ]

        go ((CascadePrefix -> Text -> Maybe CascadeAction
parseCascadeAction CascadePrefix
CascadeDelete -> Just CascadeAction
cascadingAction) : [Text]
rest) Maybe CascadeAction
onDelete' Maybe CascadeAction
onUpdate =
            case Maybe CascadeAction
onDelete' of
                Maybe CascadeAction
Nothing ->
                    [Text]
-> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef
go [Text]
rest (CascadeAction -> Maybe CascadeAction
forall a. a -> Maybe a
Just CascadeAction
cascadingAction) Maybe CascadeAction
onUpdate
                Just CascadeAction
_ ->
                    String -> UnboundForeignDef
forall a. HasCallStack => String -> a
error (String -> UnboundForeignDef) -> String -> UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ String
errorPrefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"found more than one OnDelete actions"

        go ((CascadePrefix -> Text -> Maybe CascadeAction
parseCascadeAction CascadePrefix
CascadeUpdate -> Just CascadeAction
cascadingAction) : [Text]
rest) Maybe CascadeAction
onDelete Maybe CascadeAction
onUpdate' =
            case Maybe CascadeAction
onUpdate' of
                Maybe CascadeAction
Nothing ->
                    [Text]
-> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef
go [Text]
rest Maybe CascadeAction
onDelete (CascadeAction -> Maybe CascadeAction
forall a. a -> Maybe a
Just CascadeAction
cascadingAction)
                Just CascadeAction
_ ->
                    String -> UnboundForeignDef
forall a. HasCallStack => String -> a
error (String -> UnboundForeignDef) -> String -> UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ String
errorPrefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"found more than one OnUpdate actions"

        go [Text]
xs Maybe CascadeAction
_ Maybe CascadeAction
_ = String -> UnboundForeignDef
forall a. HasCallStack => String -> a
error (String -> UnboundForeignDef) -> String -> UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ String
errorPrefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"expecting a lower case constraint name or a cascading action xs=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
xs

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

data CascadePrefix = CascadeUpdate | CascadeDelete

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

parseCascadeAction
    :: CascadePrefix
    -> Text
    -> Maybe CascadeAction
parseCascadeAction :: CascadePrefix -> Text -> Maybe CascadeAction
parseCascadeAction CascadePrefix
prfx Text
text = do
    Text
cascadeStr <- Text -> Text -> Maybe Text
T.stripPrefix (Text
"On" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CascadePrefix -> Text
forall p. IsString p => CascadePrefix -> p
toPrefix CascadePrefix
prfx) Text
text
    case String -> Either String CascadeAction
forall a. Read a => String -> Either String a
readEither (Text -> String
T.unpack Text
cascadeStr) of
        Right CascadeAction
a ->
            CascadeAction -> Maybe CascadeAction
forall a. a -> Maybe a
Just CascadeAction
a
        Left String
_ ->
            Maybe CascadeAction
forall a. Maybe a
Nothing
  where
    toPrefix :: CascadePrefix -> p
toPrefix CascadePrefix
cp =
        case CascadePrefix
cp of
            CascadePrefix
CascadeUpdate -> p
"Update"
            CascadePrefix
CascadeDelete -> p
"Delete"

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

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

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