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

-- | This @Internal@ module may have breaking changes that will not be reflected
-- in major version bumps. Please use "Database.Persist.Quasi" instead. If you
-- need something in this module, please file an issue on GitHub.
--
-- @since 2.13.0.0
module Database.Persist.Quasi.Internal
    ( parse
    , PersistSettings (..)
    , upperCaseSettings
    , lowerCaseSettings
    , toFKNameInfixed
    , Token (..)
    , Line (..)
    , preparse
    , parseLine
    , parseFieldType
    , associateLines
    , LinesWithComments(..)
    , parseEntityFields
    , takeColsEx
    -- * UnboundEntityDef
    , UnboundEntityDef(..)
    , getUnboundEntityNameHS
    , unbindEntityDef
    , getUnboundFieldDefs
    , UnboundForeignDef(..)
    , getSqlNameOr
    , UnboundFieldDef(..)
    , UnboundCompositeDef(..)
    , UnboundIdDef(..)
    , unbindFieldDef
    , isUnboundFieldNullable
    , unboundIdDefToFieldDef
    , PrimarySpec(..)
    , mkAutoIdField'
    , UnboundForeignFieldList(..)
    , ForeignFieldReference(..)
    , mkKeyConType
    , isHaskellUnboundField
    , FieldTypeLit(..)
    ) where

import Prelude hiding (lines)

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

data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show

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

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

    parse1 :: Text -> ParseState FieldType
    parse1 t = fromMaybe (PSFail (show t)) $ do
        case T.uncons t of
            Nothing -> pure PSDone
            Just (x, xs) ->
                parseSpace x xs
                <|> parseParenEnclosed x xs
                <|> parseList x xs
                <|> parseNumericLit x xs
                <|> parseTextLit x xs
                <|> parseTypeCon x xs

    parseSpace :: Char -> Text -> Maybe (ParseState FieldType)
    parseSpace c t = do
        guard (isSpace c)
        pure $ parse1 (T.dropWhile isSpace t)

    parseParenEnclosed c t = do
        guard (c == '(')
        pure $ parseEnclosed ')' id t

    parseList c t = do
        guard (c == '[')
        pure $ parseEnclosed ']' FTList t

    parseTextLit :: Char -> Text -> Maybe (ParseState FieldType)
    parseTextLit c t = do
        guard (c == '"')
        let (a, b) = T.break (== '"') t
            lit = FTLit (TextTypeLit a)
        pure $ PSSuccess lit (T.drop 1 b)

    parseNumericLit :: Char -> Text -> Maybe (ParseState FieldType)
    parseNumericLit c t = do
        guard (isDigit c && T.all isDigit t)
        let (a, b) = breakAtNextSpace t
        lit <- FTLit . IntTypeLit <$> readMaybe (T.cons c a)
        pure $ PSSuccess lit b

    parseTypeCon c t = do
        guard (isUpper c || c == '\'')
        let (a, b) = breakAtNextSpace t
        pure $ PSSuccess (parseFieldTypePiece c a) b

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

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

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

data PersistSettings = PersistSettings
    { psToDBName :: !(Text -> Text)
    -- ^ Modify the Haskell-style name into a database-style name.
    , 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
    , psStrictFields :: !Bool
    -- ^ Whether fields are by default strict. Default value: @True@.
    --
    -- @since 1.2
    , 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
    { psToDBName = id
    , psToFKName = \(EntityNameHS entName) (ConstraintNameHS conName) -> entName <> conName
    , psStrictFields = True
    , psIdName       = "id"
    }

upperCaseSettings = defaultPersistSettings

lowerCaseSettings = defaultPersistSettings
    { psToDBName =
        let go c
                | isUpper c = T.pack ['_', toLower c]
                | otherwise = T.singleton c
         in T.dropWhile (== '_') . T.concatMap go
    }

toFKNameInfixed :: Text -> EntityNameHS -> ConstraintNameHS -> Text
toFKNameInfixed inf (EntityNameHS entName) (ConstraintNameHS conName) =
    entName <> inf <> conName

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

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

parseLine :: Text -> Maybe Line
parseLine txt = do
    Line (parseIndentationAmount txt) <$> NEL.nonEmpty (tokenize 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 (Show, Eq)

tokenText :: Token -> Text
tokenText tok =
    case tok of
        Token t -> t
        DocComment t -> "-- | " <> t

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

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

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

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

    quotes :: Text -> ([Text] -> [Text]) -> [Token]
    quotes t' front
        | T.null t' = error $ T.unpack $ T.concat $
            "Unterminated quoted string starting with " : front []
        | T.head t' == '"' = Token (T.concat $ front []) : tokenize (T.tail t')
        | T.head t' == '\\' && T.length t' > 1 =
            quotes (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):))
        | otherwise =
            let (x, y) = T.break (`elem` ['\\','\"']) t'
             in quotes y (front . (x:))

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

-- | A line of parsed tokens
data Line = Line
    { lineIndent   :: Int
    , tokens       :: NonEmpty Token
    } deriving (Eq, Show)

lineText :: Line -> NonEmpty Text
lineText = fmap tokenText . tokens

lowestIndent :: NonEmpty Line -> Int
lowestIndent = minimum . fmap lineIndent

-- | Divide lines into blocks and make entity definitions.
parseLines :: PersistSettings -> NonEmpty Line -> [UnboundEntityDef]
parseLines ps = do
    fmap (mkUnboundEntityDef ps . toParsedEntityDef) . associateLines

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

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

    entNameDB =
        EntityNameDB $ getDbName ps (unEntityNameHS entNameHS) (parsedEntityDefEntityAttributes parsedEntDef)

toParsedEntityDef :: LinesWithComments -> ParsedEntityDef
toParsedEntityDef lwc = ParsedEntityDef
    { parsedEntityDefComments = lwcComments lwc
    , parsedEntityDefEntityName = entNameHS
    , parsedEntityDefIsSum = isSum
    , parsedEntityDefEntityAttributes = entAttribs
    , parsedEntityDefFieldAttributes = attribs
    , parsedEntityDefExtras = extras
    }
  where
    entityLine :| fieldLines =
        lwcLines lwc

    (entityName :| entAttribs) =
        lineText entityLine

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

    (attribs, extras) =
        parseEntityFields fieldLines

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

data LinesWithComments = LinesWithComments
    { lwcLines :: NonEmpty Line
    , lwcComments :: [Text]
    } deriving (Eq, Show)

instance Semigroup LinesWithComments where
    a <> b =
        LinesWithComments
            { lwcLines =
                foldr NEL.cons (lwcLines b) (lwcLines a)
            , lwcComments =
                lwcComments a `mappend` lwcComments b
            }

appendLwc :: LinesWithComments -> LinesWithComments -> LinesWithComments
appendLwc = (<>)

newLine :: Line -> LinesWithComments
newLine l = LinesWithComments (pure l) []

firstLine :: LinesWithComments -> Line
firstLine = NEL.head . lwcLines

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

consComment :: Text -> LinesWithComments -> LinesWithComments
consComment l lwc = lwc { lwcComments = l : lwcComments lwc }

associateLines :: NonEmpty Line -> [LinesWithComments]
associateLines lines =
    foldr combine [] $
    foldr toLinesWithComments [] lines
  where
    toLinesWithComments :: Line -> [LinesWithComments] -> [LinesWithComments]
    toLinesWithComments line linesWithComments =
        case linesWithComments of
            [] ->
                [newLine line]
            (lwc : lwcs) ->
                case isDocComment (NEL.head (tokens line)) of
                    Just comment
                        | lineIndent line == lowestIndent lines ->
                        consComment comment lwc : lwcs
                    _ ->
                        if lineIndent line <= lineIndent (firstLine lwc)
                            && lineIndent (firstLine lwc) /= lowestIndent lines
                        then
                            consLine line lwc : lwcs
                        else
                            newLine line : lwc : lwcs

    combine :: LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
    combine lwc [] =
        [lwc]
    combine lwc (lwc' : lwcs) =
        let minIndent = minimumIndentOf lwc
            otherIndent = minimumIndentOf lwc'
         in
            if minIndent < otherIndent then
                appendLwc lwc lwc' : lwcs
            else
                lwc : lwc' : lwcs

    minimumIndentOf :: LinesWithComments -> Int
    minimumIndentOf = lowestIndent . 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
    { unboundForeignDefs :: [UnboundForeignDef]
    -- ^ A list of foreign definitions on the parsed entity.
    --
    -- @since 2.13.0.0
    , unboundPrimarySpec :: PrimarySpec
    -- ^ The specification for the primary key of the unbound entity.
    --
    -- @since 2.13.0.0
    , 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
    , 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 (Eq, Ord, Show, 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 ed =
    UnboundEntityDef
        { unboundForeignDefs =
            map unbindForeignDef (entityForeigns ed)
        , unboundPrimarySpec =
            case entityId ed of
                EntityIdField fd ->
                    SurrogateKey (unbindIdDef (entityHaskell ed) fd)
                EntityIdNaturalKey cd ->
                    NaturalKey (unbindCompositeDef cd)
        , unboundEntityDef =
            ed
        , unboundEntityFields =
            map unbindFieldDef (entityFields ed)
        }

-- | Returns the @['UnboundFieldDef']@ for an 'UnboundEntityDef'. This returns
-- all fields defined on the entity.
--
-- @since 2.13.0.0
getUnboundFieldDefs :: UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs = 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 cd =
    UnboundCompositeDef
        { unboundCompositeCols =
            fmap fieldHaskell (compositeFields cd)
        , unboundCompositeAttrs =
            compositeAttrs cd
        }

-- | A representation of a database column, with everything that can be known at
-- parse time.
--
-- @since 2.13.0.0
data UnboundFieldDef
    = UnboundFieldDef
    { 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
    , 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
    , 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
    , unboundFieldStrict :: Bool
    -- ^ Whether or not the field should be strict in the generated Haskell
    -- code.
    --
    -- @since 2.13.0.0
    , 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
    , 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
    , 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
    , 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 (Eq, Ord, Show, Lift)

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

isUnboundFieldNullable :: UnboundFieldDef -> IsNullable
isUnboundFieldNullable =
    fieldAttrsContainsNullable . 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 (Eq, Ord, Show, Lift)

-- | Construct an entity definition.
mkUnboundEntityDef
    :: PersistSettings
    -> ParsedEntityDef -- ^ parsed entity definition
    -> UnboundEntityDef
mkUnboundEntityDef ps parsedEntDef =
    UnboundEntityDef
        { unboundForeignDefs =
            entityConstraintDefsForeignsList entityConstraintDefs
        , unboundPrimarySpec =
            case (idField, primaryComposite) of
                (Just {}, Just {}) ->
                    error "Specified both an ID field and a Primary field"
                (Just a, Nothing) ->
                    if unboundIdType a == Just (mkKeyConType (unboundIdEntityName a))
                    then
                        DefaultKey (FieldNameDB $ psIdName ps)
                    else
                        SurrogateKey a
                (Nothing, Just a) ->
                    NaturalKey a
                (Nothing, Nothing) ->
                    DefaultKey (FieldNameDB $ psIdName ps)
        , unboundEntityFields =
            cols
        , unboundEntityDef =
            EntityDef
                { entityHaskell = entNameHS
                , entityDB = entNameDB
                -- idField is the user-specified Id
                -- otherwise useAutoIdField
                -- but, adjust it if the user specified a Primary
                , entityId =
                    EntityIdField $
                    maybe autoIdField (unboundIdDefToFieldDef (defaultIdName ps) entNameHS) idField
                , entityAttrs =
                    parsedEntityDefEntityAttributes parsedEntDef
                , entityFields =
                    []
                , entityUniques = entityConstraintDefsUniquesList entityConstraintDefs
                , entityForeigns = []
                , entityDerives = concat $ mapMaybe takeDerives textAttribs
                , entityExtra = parsedEntityDefExtras parsedEntDef
                , entitySum = parsedEntityDefIsSum parsedEntDef
                , entityComments =
                    case parsedEntityDefComments parsedEntDef of
                        [] -> Nothing
                        comments -> Just (T.unlines comments)
                }
        }
  where
    (entNameHS, entNameDB) =
        entityNamesFromParsedDef ps parsedEntDef

    attribs =
        parsedEntityDefFieldAttributes parsedEntDef

    textAttribs :: [[Text]]
    textAttribs =
        fmap tokenText <$> attribs

    entityConstraintDefs =
        foldMap (maybe mempty (takeConstraint ps entNameHS cols) . NEL.nonEmpty) textAttribs

    idField =
        case entityConstraintDefsIdField entityConstraintDefs of
            SetMoreThanOnce -> error "expected only one Id declaration per entity"
            SetOnce a -> Just a
            NotSet -> Nothing

    primaryComposite =
        case entityConstraintDefsPrimaryComposite entityConstraintDefs of
            SetMoreThanOnce -> error "expected only one Primary declaration per entity"
            SetOnce a -> Just a
            NotSet -> Nothing

    cols :: [UnboundFieldDef]
    cols = reverse . fst . foldr (associateComments ps) ([], []) $ reverse attribs

    autoIdField :: FieldDef
    autoIdField =
        mkAutoIdField ps entNameHS idSqlType

    idSqlType :: SqlType
    idSqlType =
        maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite

defaultIdName :: PersistSettings -> FieldNameDB
defaultIdName = FieldNameDB . 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 dbField entNameHS uid =
    FieldDef
        { fieldHaskell =
            FieldNameHS "Id"
        , fieldDB =
            getSqlNameOr dbField (unboundIdAttrs uid)
        , fieldType =
            fromMaybe (mkKeyConType entNameHS) $ unboundIdType uid
        , fieldSqlType =
            SqlOther "SqlType unset for Id"
        , fieldStrict =
            False
        , fieldReference =
            ForeignRef entNameHS
        , fieldAttrs =
            unboundIdAttrs uid
        , fieldComments =
            Nothing
        , fieldCascade = unboundIdCascade uid
        , fieldGenerated = Nothing
        , fieldIsImplicitIdColumn = 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 entNameHs =
    FTTypeCon Nothing (keyConName 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 entityName fd =
    UnboundIdDef
        { unboundIdEntityName =
            entityName
        , unboundIdDBName =
            fieldDB fd
        , unboundIdAttrs =
            fieldAttrs fd
        , unboundIdCascade =
            fieldCascade fd
        , unboundIdType =
            Just $ fieldType fd
        }

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

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

mkAutoIdField :: PersistSettings -> EntityNameHS -> SqlType -> FieldDef
mkAutoIdField ps =
    mkAutoIdField' (FieldNameDB $ psIdName ps)

-- | Creates a default ID field.
--
-- @since 2.13.0.0
mkAutoIdField' :: FieldNameDB -> EntityNameHS -> SqlType -> FieldDef
mkAutoIdField' dbName entName idSqlType =
    FieldDef
        { fieldHaskell = FieldNameHS "Id"
        , fieldDB = dbName
        , fieldType = FTTypeCon Nothing $ keyConName entName
        , fieldSqlType = idSqlType
        , fieldReference =
            NoReference
        , fieldAttrs = []
        , fieldStrict = True
        , fieldComments = Nothing
        , fieldCascade = noCascade
        , fieldGenerated = Nothing
        , fieldIsImplicitIdColumn = True
        }

keyConName :: EntityNameHS -> Text
keyConName entName = unEntityNameHS entName `mappend` "Id"

parseEntityFields
    :: [Line]
    -> ([[Token]], M.Map Text [ExtraLine])
parseEntityFields lns =
    case lns of
        [] -> ([], M.empty)
        (line : rest) ->
            case NEL.toList (tokens line) of
                [Token name]
                  | isCapitalizedText name ->
                    let (children, rest') = span ((> lineIndent line) . lineIndent) rest
                        (x, y) = parseEntityFields rest'
                     in (x, M.insert name (NEL.toList . lineText <$> children) y)
                ts ->
                    let (x, y) = parseEntityFields rest
                     in (ts:x, y)

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

takeColsEx :: PersistSettings -> [Text] -> Maybe UnboundFieldDef
takeColsEx =
    takeCols
        (\ft perr -> error $ "Invalid field type " ++ show ft ++ " " ++ perr)

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

takeCols _ _ _ = Nothing

parseGenerated :: [Text] -> Maybe Text
parseGenerated = foldl' (\acc x -> acc <|> T.stripPrefix "generated=" x) Nothing

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

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

getSqlNameOr
    :: FieldNameDB
    -> [FieldAttr]
    -> FieldNameDB
getSqlNameOr def =
    maybe def FieldNameDB . findAttrSql
  where
    findAttrSql =
        listToMaybe . mapMaybe isAttrSql
    isAttrSql attr =
        case attr of
            FieldAttrSql t ->
                Just t
            _ ->
                Nothing

data SetOnceAtMost a
  = NotSet
  | SetOnce a
  | SetMoreThanOnce

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

instance Monoid (SetOnceAtMost a) where
    mempty =
        NotSet

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

instance Semigroup EntityConstraintDefs where
    a <> b =
        EntityConstraintDefs
            { entityConstraintDefsIdField = entityConstraintDefsIdField a <> entityConstraintDefsIdField b
            , entityConstraintDefsPrimaryComposite = entityConstraintDefsPrimaryComposite a <> entityConstraintDefsPrimaryComposite b
            , entityConstraintDefsUniques = entityConstraintDefsUniques a <> entityConstraintDefsUniques b
            , entityConstraintDefsForeigns = entityConstraintDefsForeigns a <> entityConstraintDefsForeigns b
            }

instance Monoid EntityConstraintDefs where
    mempty =
        EntityConstraintDefs mempty mempty Nothing Nothing

entityConstraintDefsUniquesList :: EntityConstraintDefs -> [UniqueDef]
entityConstraintDefsUniquesList = foldMap NEL.toList . entityConstraintDefsUniques

entityConstraintDefsForeignsList :: EntityConstraintDefs -> [UnboundForeignDef]
entityConstraintDefsForeignsList = foldMap NEL.toList . entityConstraintDefsForeigns

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

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

-- | A definition for a composite primary key.
--
-- @since.2.13.0.0
data UnboundCompositeDef = UnboundCompositeDef
    { unboundCompositeCols :: NonEmpty FieldNameHS
    -- ^ The field names for the primary key.
    --
    -- @since 2.13.0.0
    , 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 (Eq, Ord, Show, Lift)

compositeToUniqueDef :: EntityNameHS -> [UnboundFieldDef] -> UnboundCompositeDef -> UniqueDef
compositeToUniqueDef entityName fields UnboundCompositeDef {..} =
    UniqueDef
        { uniqueHaskell =
            ConstraintNameHS (unEntityNameHS entityName <> "PrimaryKey")
        , uniqueDBName =
            ConstraintNameDB "primary_key"
        , uniqueFields =
            fmap (\hsName -> (hsName, getDbNameFor hsName)) unboundCompositeCols
        , uniqueAttrs =
            unboundCompositeAttrs
        }
  where
    getDbNameFor hsName =
        case mapMaybe (matchHsName hsName) fields of
            [] ->
                error "Unable to find `hsName` in fields"
            (a : _) ->
                a
    matchHsName hsName UnboundFieldDef {..} = do
        guard $ unboundFieldNameHS == hsName
        pure unboundFieldNameDB



takeComposite
    :: [FieldNameHS]
    -> [Text]
    -> UnboundCompositeDef
takeComposite fields pkcols =
    UnboundCompositeDef
        { unboundCompositeCols =
            fmap (getDef fields) neCols
        , unboundCompositeAttrs =
            attrs
        }
  where
    neCols =
        case NEL.nonEmpty cols of
            Nothing ->
                error "No fields provided for primary key"
            Just xs ->
                xs
    (cols, attrs) = break ("!" `T.isPrefixOf`) pkcols
    getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t
    getDef (d:ds) t
        | d == FieldNameHS 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
            d
        | otherwise =
            getDef ds 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 ps tableName defs (n : rest)
    | isCapitalizedText n = do
        fields <- mfields
        pure UniqueDef
            { uniqueHaskell =
                ConstraintNameHS n
            , uniqueDBName =
                dbName
            , uniqueFields =
                fmap (\a -> (FieldNameHS a, getDBName defs a)) fields
            , uniqueAttrs =
                attrs
            }
  where
    isAttr a =
      "!" `T.isPrefixOf` a
    isSqlName a =
      "sql=" `T.isPrefixOf` a
    isNonField a =
       isAttr a || isSqlName a
    (fieldsList, nonFields) =
        break isNonField rest
    mfields =
        NEL.nonEmpty fieldsList

    attrs = filter isAttr nonFields

    usualDbName =
      ConstraintNameDB $ psToDBName ps (tableName `T.append` n)
    sqlName :: Maybe ConstraintNameDB
    sqlName =
      case find isSqlName nonFields of
        Nothing ->
          Nothing
        (Just t) ->
          case drop 1 $ T.splitOn "=" t of
            (x : _) -> Just (ConstraintNameDB x)
            _ -> Nothing
    dbName = fromMaybe usualDbName sqlName

    getDBName [] t = error $ T.unpack (unknownUniqueColumnError t defs n)
    getDBName (d:ds) t
        | unboundFieldNameHS d == FieldNameHS t =
            unboundFieldNameDB d
        | otherwise =
            getDBName ds t

takeUniq _ tableName _ xs =
  error $ "invalid unique constraint on table["
          ++ show tableName
          ++ "] expecting an uppercase constraint name xs="
          ++ show xs

unknownUniqueColumnError :: Text -> [UnboundFieldDef] -> Text -> Text
unknownUniqueColumnError t defs n =
    "Unknown column in \"" <> n <> "\" constraint: \"" <> t <> "\""
        <> " possible fields: " <> T.pack (show (toFieldName <$> defs))
    where
        toFieldName :: UnboundFieldDef -> Text
        toFieldName fd =
            unFieldNameHS (unboundFieldNameHS fd)

-- | Define an explicit foreign key reference.
--
-- @
-- User
--     name Text
--     email Text
--
--     Primary name email
--
-- Dog
--     ownerName Text
--     ownerEmail Text
--
--     Foreign User fk_dog_user ownerName ownerEmail
-- @
--
-- @since 2.13.0.0
data UnboundForeignDef
    = UnboundForeignDef
    { unboundForeignFields :: UnboundForeignFieldList
    -- ^ Fields in the source entity.
    --
    -- @since 2.13.0.0
    , 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 (Eq, Ord, Show, 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 (Eq, Ord, Show, 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
    { ffrSourceField :: FieldNameHS
    -- ^ The column on the source table.
    --
    -- @since 2.13.0.0
    , ffrTargetField :: FieldNameHS
    -- ^ The column on the target table.
    --
    -- @since 2.13.0.0
    }
    deriving (Eq, Ord, Show, Lift)

unbindForeignDef :: ForeignDef -> UnboundForeignDef
unbindForeignDef fd =
    UnboundForeignDef
        { unboundForeignFields =
            FieldListHasReferences $ NEL.fromList $ fmap mk (foreignFields fd)
        , unboundForeignDef =
            fd
        }
  where
    mk ((fH, _), (pH, _))  =
        ForeignFieldReference
            { ffrSourceField = fH
            , ffrTargetField = pH
            }

mkUnboundForeignFieldList
    :: [Text]
    -> [Text]
    -> Either String UnboundForeignFieldList
mkUnboundForeignFieldList (fmap FieldNameHS -> source) (fmap FieldNameHS -> target) =
    case NEL.nonEmpty source of
        Nothing ->
            Left "No fields on foreign reference."
        Just sources ->
            case NEL.nonEmpty target of
                Nothing ->
                    Right $ FieldListImpliedId sources
                Just targets ->
                    if length targets /= length sources
                    then
                        Left "Target and source length differe on foreign reference."
                    else
                        Right
                        $ FieldListHasReferences
                        $ NEL.zipWith ForeignFieldReference sources targets

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

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

            (fields, attrs) =
                break ("!" `T.isPrefixOf`) rest
            (foreignFields, parentFields) =
                case break (== "References") fields of
                    (ffs, []) ->
                        (ffs, [])
                    (ffs, _ : pfs) ->
                        case (length ffs, length pfs) of
                            (flen, plen)
                                | flen == plen ->
                                    (ffs, pfs)
                            (flen, plen) ->
                                error $ errorPrefix ++ concat
                                    [ "Found " , show flen
                                    , " foreign fields but "
                                    , show plen, " parent fields"
                                    ]

        go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) onDelete' onUpdate =
            case onDelete' of
                Nothing ->
                    go rest (Just cascadingAction) onUpdate
                Just _ ->
                    error $ errorPrefix ++ "found more than one OnDelete actions"

        go ((parseCascadeAction CascadeUpdate -> Just cascadingAction) : rest) onDelete onUpdate' =
            case onUpdate' of
                Nothing ->
                    go rest onDelete (Just cascadingAction)
                Just _ ->
                    error $ errorPrefix ++ "found more than one OnUpdate actions"

        go xs _ _ = error $ errorPrefix ++ "expecting a lower case constraint name or a cascading action xs=" ++ show xs

toFKConstraintNameDB :: PersistSettings -> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB
toFKConstraintNameDB ps entityName constraintName =
    ConstraintNameDB $ psToDBName ps (psToFKName ps entityName constraintName)

data CascadePrefix = CascadeUpdate | CascadeDelete

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

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

takeDerives :: [Text] -> Maybe [Text]
takeDerives ("deriving":rest) = Just rest
takeDerives _ = 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 fd =
    FieldAttrMigrationOnly `notElem` unboundFieldAttrs fd &&
    FieldAttrSafeToRemove `notElem` unboundFieldAttrs fd

-- |  Return the 'EntityNameHS' for an 'UnboundEntityDef'.
--
-- @since 2.13.0.0
getUnboundEntityNameHS :: UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS = entityHaskell . unboundEntityDef

readMaybe :: Read a => Text -> Maybe a
readMaybe = R.readMaybe . T.unpack