persistent/Database/Persist/Quasi/Internal.hs

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

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

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

import Prelude hiding (lines)

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

data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving (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

sourceLocFromTHLoc :: Loc -> SourceLoc
sourceLocFromTHLoc Loc{loc_filename = filename, loc_start = start} =
    SourceLoc
        { locFile = T.pack filename
        , locStartLine = fst start
        , locStartCol = snd start
        }

-- | Parses a quasi-quoted syntax into a list of entity definitions.
parse
    :: PersistSettings
    -> [(Maybe SourceLoc, Text)]
    -> CumulativeParseResult [UnboundEntityDef]
parse ps chunks = toCumulativeParseResult $ map parseChunk chunks
  where
    parseChunk :: (Maybe SourceLoc, Text) -> ParseResult [UnboundEntityDef]
    parseChunk (mSourceLoc, source) =
        (fmap . fmap) (mkUnboundEntityDef ps) <$> parseSource ps mSourceLoc source

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

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

-- | This type represents an @Id@ declaration in the QuasiQuoted syntax.
--
-- > Id
--
-- This uses the implied settings, and is equivalent to omitting the @Id@
-- statement entirely.
--
-- > Id Text
--
-- This will set the field type of the ID to be 'Text'.
--
-- > Id Text sql=foo_id
--
-- This will set the field type of the Id to be 'Text' and the SQL DB name to be @foo_id@.
--
-- > Id FooId
--
-- This results in a shared primary key - the @FooId@ refers to a @Foo@ table.
--
-- > Id FooId OnDelete Cascade
--
-- You can set a cascade behavior on an ID column.
--
-- @since 2.13.0.0
data UnboundIdDef = UnboundIdDef
    { unboundIdEntityName :: EntityNameHS
    , unboundIdDBName :: !FieldNameDB
    , unboundIdAttrs :: [FieldAttr]
    , unboundIdCascade :: FieldCascade
    , unboundIdType :: Maybe FieldType
    }
    deriving (Eq, Ord, Show, Lift)

-- | An 'EntityDef' produced by the QuasiQuoter. It contains information that
-- the QuasiQuoter is capable of knowing about the entities. It is inherently
-- unfinished, though - there are many other @Unbound@ datatypes that also
-- contain partial information.
--
-- The 'unboundEntityDef' is not complete or reliable - to know which fields are
-- safe to use, consult the parsing code.
--
-- This type was completely internal until 2.13.0.0, when it was exposed as part
-- of the "Database.Persist.Quasi.Internal" module.
--
-- TODO: refactor this so we can expose it for consumers.
--
-- @since 2.13.0.0
data UnboundEntityDef
    = UnboundEntityDef
    { 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
    , unboundEntityDefSpan :: Maybe SourceSpan
    -- ^ The source code span of this entity in the models file.
    --
    -- @since 2.15.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)
        , unboundEntityDefSpan = entitySpan 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
    = -- | A 'NaturalKey' contains columns that are defined on the datatype
      -- itself. This is defined using the @Primary@ keyword and given a non-empty
      -- list of columns.
      --
      -- @
      -- User
      --     name    Text
      --     email   Text
      --
      --     Primary name email
      -- @
      --
      -- A natural key may also contain only a single column. A natural key with
      -- multiple columns is called a 'composite key'.
      --
      -- @since 2.13.0.0
      NaturalKey UnboundCompositeDef
    | -- | A surrogate key is not part of the domain model for a database table.
      -- You can specify a custom surro
      --
      -- You can specify a custom surrogate key using the @Id@ syntax.
      --
      -- @
      -- User
      --     Id    Text
      --     name  Text
      -- @
      --
      -- Note that you must provide a @default=@ expression when using this in
      -- order to use 'insert' or related functions. The 'insertKey' function can
      -- be used instead, as it allows you to specify a key directly. Fixing this
      -- issue is tracked in #1247 on GitHub.
      --
      -- @since 2.13.0.0
      SurrogateKey UnboundIdDef
    | -- | The default key for the entity using the settings in
      -- 'MkPersistSettings'.
      --
      -- This is implicit - a table without an @Id@ or @Primary@ declaration will
      -- have a 'DefaultKey'.
      --
      -- @since 2.13.0.0
      DefaultKey FieldNameDB
    deriving (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
        , unboundEntityDefSpan = parsedEntityDefSpan parsedEntDef
        , 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 =
                    attributeContent <$> parsedEntityDefEntityAttributes parsedEntDef
                , entityFields = []
                , entityUniques = entityConstraintDefsUniquesList entityConstraintDefs
                , entityForeigns = []
                , entityDerives = concat $ mapMaybe takeDerives (textFields ++ textDirectives)
                , entityExtra = parsedEntityDefExtras parsedEntDef
                , entitySum = parsedEntityDefIsSum parsedEntDef
                , entityComments =
                    case parsedEntityDefComments parsedEntDef of
                        [] -> Nothing
                        comments -> Just (T.unlines comments)
                , entitySpan = parsedEntityDefSpan parsedEntDef
                }
        }
  where
    (entNameHS, entNameDB) =
        entityNamesFromParsedDef ps parsedEntDef

    fields = parsedEntityDefFields parsedEntDef
    directives = parsedEntityDefDirectives parsedEntDef

    cols :: [UnboundFieldDef]
    cols = foldMap (toList . commentedField ps) fields

    textFields :: [[Text]]
    textFields = entityFieldContent . fst <$> fields

    textDirectives :: [[Text]]
    textDirectives = directiveContent . fst <$> directives

    entityConstraintDefs =
        foldMap
            (maybe mempty (takeConstraint ps entNameHS cols) . NEL.nonEmpty)
            (textFields ++ textDirectives)

    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

    commentedField
        :: PersistSettings
        -> (EntityField, Maybe Text)
        -> Maybe UnboundFieldDef
    commentedField s (field, mCommentText) = do
        unb <- takeColsEx s (entityFieldContent field)
        pure $ unb{unboundFieldComments = mCommentText}

    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
        }

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

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"

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

-- 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
    = -- | If no @References@ keyword is supplied, then it is assumed that you are
      -- referring to the @Primary@ key or @Id@ of the target entity.
      --
      -- @since 2.13.0.0
      FieldListImpliedId (NonEmpty FieldNameHS)
    | -- | You can specify the exact columns you're referring to here, if they
      -- aren't part of a primary key. Most databases expect a unique index on the
      -- columns you refer to, but Persistent doesnt' check that.
      --
      -- @
      -- User
      --     Id           UUID default="uuid_generate_v1mc()"
      --     name         Text
      --
      --     UniqueName name
      --
      -- Dog
      --     ownerName    Text
      --
      --     Foreign User fk_dog_user ownerName References name
      -- @
      --
      -- @since 2.13.0.0
      FieldListHasReferences (NonEmpty ForeignFieldReference)
    deriving (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