persistent-2.17.1.0: 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