persistent 2.15.1.0 → 2.16.0.0
raw patch · 19 files changed
+2494/−1960 lines, 19 filesdep +megaparsecdep +replace-megaparsec
Dependencies added: megaparsec, replace-megaparsec
Files
- ChangeLog.md +14/−0
- Database/Persist/Class/PersistField.hs +38/−16
- Database/Persist/Class/PersistUnique.hs +1/−1
- Database/Persist/EntityDef.hs +3/−3
- Database/Persist/Quasi.hs +12/−64
- Database/Persist/Quasi/Internal.hs +342/−608
- Database/Persist/Quasi/Internal/ModelParser.hs +790/−0
- Database/Persist/Quasi/PersistSettings.hs +25/−0
- Database/Persist/Quasi/PersistSettings/Internal.hs +183/−0
- Database/Persist/TH/Internal.hs +66/−11
- Database/Persist/Types.hs +0/−1
- Database/Persist/Types/Base.hs +3/−3
- Database/Persist/Types/SourceSpan.hs +24/−0
- Database/Persist/Types/Span.hs +0/−24
- persistent.cabal +8/−2
- test/Database/Persist/ClassSpec.hs +12/−4
- test/Database/Persist/QuasiSpec.hs +971/−1223
- test/Database/Persist/THSpec.hs +1/−0
- test/main.hs +1/−0
ChangeLog.md view
@@ -1,5 +1,19 @@ # Changelog for persistent +# 2.16.0.0++* [#1584](https://github.com/yesodweb/persistent/pull/1584)+ * Rename `Span` to `SourceSpan`+ * Parse entity definitions using Megaparsec.+ * Support Haddock-style multiline pre-comments.+* [#1589](https://github.com/yesodweb/persistent/pull/1589)+ * Support configurable parse errors and warnings+* [#1585](https://github.com/yesodweb/persistent/pull/1585)+ * Support parsing PersistField UTCTime from text with timezone, e.g. "2025-04-12T06:53:42Z".+ This is needed for Sqlite, which has no native datetime support but uses e.g. TEXT.+* [#1587](https://github.com/yesodweb/persistent/pull/1587)+ * Improve documentation of `mpsFieldLabelModifier`.+ # 2.15.1.0 * [#1519](https://github.com/yesodweb/persistent/pull/1519/files/9865a295f4545d30e55aacb6efc25f27f758e8ad#diff-5af2883367baae8f7f266df6a89fc2d1defb7572d94ed069e05c8135a883bc45)
Database/Persist/Class/PersistField.hs view
@@ -11,11 +11,11 @@ import Control.Arrow (second) import Control.Monad ((<=<))-import Control.Applicative ((<|>)) import qualified Data.Aeson as A import Data.ByteString.Char8 (ByteString, unpack, readInt) import qualified Data.ByteString.Lazy as L import Data.Fixed+import Data.Foldable (asum) import Data.Int (Int8, Int16, Int32, Int64) import qualified Data.IntMap as IM import qualified Data.List.NonEmpty as NonEmpty@@ -302,16 +302,37 @@ instance PersistField UTCTime where toPersistValue = PersistUTCTime- fromPersistValue (PersistUTCTime d) = Right d+ fromPersistValue = utcTimeFromPersistValue+ #ifdef HIGH_PRECISION_DATE- fromPersistValue (PersistInt64 i) = Right $ posixSecondsToUTCTime $ (/ (1000 * 1000 * 1000)) $ fromIntegral $ i+utcTimeFromPersistValue :: PersistValue -> Either Text UTCTime+utcTimeFromPersistValue (PersistUTCTime d) = Right d+utcTimeFromPersistValue (PersistInt64 i) = Right $ posixSecondsToUTCTime $ (/ (1000 * 1000 * 1000)) $ fromIntegral $ i+utcTimeFromPersistValue (PersistText t) = utcTimeFromPersistText t+utcTimeFromPersistValue x@(PersistByteString s) =+ case reads $ unpack s of+ (d, _):_ -> Right d+ _ -> Left $ fromPersistValueParseError "UTCTime" x+utcTimeFromPersistValue x = Left $ fromPersistValueError "UTCTime" "time, integer, string, or bytestring" x+#else+utcTimeFromPersistValue :: PersistValue -> Either Text UTCTime+utcTimeFromPersistValue (PersistUTCTime d) = Right d+utcTimeFromPersistValue (PersistText t) = utcTimeFromPersistText t+utcTimeFromPersistValue x@(PersistByteString s) =+ case reads $ unpack s of+ (d, _):_ -> Right d+ _ -> Left $ fromPersistValueParseError "UTCTime" x+utcTimeFromPersistValue x = Left $ fromPersistValueError "UTCTime" "time, integer, string, or bytestring" x #endif- fromPersistValue x@(PersistText t) =- let s = T.unpack t++utcTimeFromPersistText :: Text -> Either Text UTCTime+utcTimeFromPersistText t =+ let x = PersistText t+ s = T.unpack t in case NonEmpty.nonEmpty (reads s) of Nothing ->- case parse8601 s <|> parsePretty s of+ case asum [parse8601 s, parse8601NoTimezone s, parsePretty s, parsePrettyNoTimezone s] of Nothing -> Left $ fromPersistValueParseError "UTCTime" x Just x' -> Right x' Just matches ->@@ -322,19 +343,20 @@ -- precision parsed as posssible. Right $ fst $ NonEmpty.last matches where+ parse8601 = parseTime' "%FT%T%QZ"+ parsePretty = parseTime' "%F %T%QZ"+ -- Before 2.13.3.1 persistent-sqlite was missing the timezone "Z" for UTC,+ -- which was only implicit, so these functions ensure backwards-compatibility.+ parse8601NoTimezone = parseTime' "%FT%T%Q"+ parsePrettyNoTimezone = parseTime' "%F %T%Q"+ #if MIN_VERSION_time(1,5,0)- parseTime' = parseTimeM True defaultTimeLocale+parseTime' :: String -> String -> Maybe UTCTime+parseTime' = parseTimeM True defaultTimeLocale #else- parseTime' = parseTime defaultTimeLocale+parseTime' :: String -> String -> Maybe UTCTime+parseTime' = parseTime defaultTimeLocale #endif- parse8601 = parseTime' "%FT%T%Q"- parsePretty = parseTime' "%F %T%Q"- fromPersistValue x@(PersistByteString s) =- case reads $ unpack s of- (d, _):_ -> Right d- _ -> Left $ fromPersistValueParseError "UTCTime" x-- fromPersistValue x = Left $ fromPersistValueError "UTCTime" "time, integer, string, or bytestring" x -- | Prior to @persistent-2.11.0@, we provided an instance of -- 'PersistField' for the 'Natural' type. This was in error, because
Database/Persist/Class/PersistUnique.hs view
@@ -117,7 +117,7 @@ -- With <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1>, -- -- > deleteBySpjName :: MonadIO m => ReaderT SqlBackend m ()- -- > deleteBySpjName = deleteBy UniqueUserName "SPJ"+ -- > deleteBySpjName = deleteBy (UniqueUserName "SPJ") -- -- The above query when applied on <#dataset-persist-unique-1 dataset-1>, will produce this: --
Database/Persist/EntityDef.hs view
@@ -43,7 +43,7 @@ import Database.Persist.Names import Database.Persist.Types.Base- (ForeignDef, Span, UniqueDef(..), entityKeyFields)+ (ForeignDef, SourceSpan, UniqueDef(..), entityKeyFields) -- | Retrieve the list of 'UniqueDef' from an 'EntityDef'. This does not include -- a @Primary@ key, if one is defined. A future version of @persistent@ will@@ -209,12 +209,12 @@ overEntityFields f ed = setEntityFields (f (getEntityFieldsDatabase ed)) ed --- | Gets the 'Span' of the definition of the entity.+-- | Gets the 'Source' of the definition of the entity. -- -- Note that as of this writing the span covers the entire file or quasiquote -- where the item is defined due to parsing limitations. This may be changed in -- a future release to be more accurate. -- -- @since 2.15.0.0-getEntitySpan :: EntityDef -> Maybe Span+getEntitySpan :: EntityDef -> Maybe SourceSpan getEntitySpan = entitySpan
Database/Persist/Quasi.hs view
@@ -920,70 +920,18 @@ , upperCaseSettings , lowerCaseSettings -- ** Getters and Setters- , module Database.Persist.Quasi+ , getPsToDBName+ , setPsToDBName+ , setPsToFKName+ , setPsUseSnakeCaseForeignKeys+ , setPsUseSnakeCaseForiegnKeys+ , getPsStrictFields+ , setPsStrictFields+ , getPsIdName+ , setPsIdName+ , getPsTabErrorLevel+ , setPsTabErrorLevel ) where -import Data.Text (Text)-import Database.Persist.Names+import Database.Persist.Quasi.PersistSettings import Database.Persist.Quasi.Internal---- | Retrieve the function in the 'PersistSettings' that modifies the names into--- database names.------ @since 2.13.0.0-getPsToDBName :: PersistSettings -> Text -> Text-getPsToDBName = psToDBName---- | Set the name modification function that translates the QuasiQuoted names--- for use in the database.------ @since 2.13.0.0-setPsToDBName :: (Text -> Text) -> PersistSettings -> PersistSettings-setPsToDBName f ps = ps { psToDBName = f }---- | Set a custom function used to create the constraint name--- for a foreign key.------ @since 2.13.0.0-setPsToFKName :: (EntityNameHS -> ConstraintNameHS -> Text) -> PersistSettings -> PersistSettings-setPsToFKName setter ps = ps { psToFKName = setter }---- | A preset configuration function that puts an underscore--- between the entity name and the constraint name when--- creating a foreign key constraint name------ @since 2.14.2.0-setPsUseSnakeCaseForeignKeys :: PersistSettings -> PersistSettings-setPsUseSnakeCaseForeignKeys = setPsToFKName (toFKNameInfixed "_")---- Equivalent to 'setPsUseSnakeCaseForeignKeys', but misspelled.------ @since 2.13.0.0-setPsUseSnakeCaseForiegnKeys :: PersistSettings -> PersistSettings-setPsUseSnakeCaseForiegnKeys = setPsUseSnakeCaseForeignKeys-{-# DEPRECATED setPsUseSnakeCaseForiegnKeys "use the correctly spelled, equivalent, setPsUseSnakeCaseForeignKeys instead" #-}---- | Retrieve whether or not the 'PersistSettings' will generate code with--- strict fields.------ @since 2.13.0.0-getPsStrictFields :: PersistSettings -> Bool-getPsStrictFields = psStrictFields---- | Set whether or not the 'PersistSettings' will make fields strict.------ @since 2.13.0.0-setPsStrictFields :: Bool -> PersistSettings -> PersistSettings-setPsStrictFields a ps = ps { psStrictFields = a }---- | Retrieve the default name of the @id@ column.------ @since 2.13.0.0-getPsIdName :: PersistSettings -> Text-getPsIdName = psIdName---- | Set the default name of the @id@ column.------ @since 2.13.0.0-setPsIdName :: Text -> PersistSettings -> PersistSettings-setPsIdName n ps = ps { psIdName = n }
Database/Persist/Quasi/Internal.hs view
@@ -1,11 +1,8 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StrictData #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -19,60 +16,64 @@ , PersistSettings (..) , upperCaseSettings , lowerCaseSettings- , toFKNameInfixed , Token (..)- , Line (..)- , SourceLoc(..)+ , SourceLoc (..) , sourceLocFromTHLoc- , preparse- , parseLine , parseFieldType- , associateLines- , LinesWithComments(..)- , parseEntityFields , takeColsEx- -- * UnboundEntityDef- , UnboundEntityDef(..)+ , CumulativeParseResult+ , renderErrors+ , parserWarningMessage++ -- * UnboundEntityDef+ , UnboundEntityDef (..) , getUnboundEntityNameHS , unbindEntityDef , getUnboundFieldDefs- , UnboundForeignDef(..)+ , UnboundForeignDef (..) , getSqlNameOr- , UnboundFieldDef(..)- , UnboundCompositeDef(..)- , UnboundIdDef(..)+ , UnboundFieldDef (..)+ , UnboundCompositeDef (..)+ , UnboundIdDef (..) , unbindFieldDef , isUnboundFieldNullable , unboundIdDefToFieldDef- , PrimarySpec(..)+ , PrimarySpec (..) , mkAutoIdField'- , UnboundForeignFieldList(..)- , ForeignFieldReference(..)+ , UnboundForeignFieldList (..)+ , ForeignFieldReference (..) , mkKeyConType , isHaskellUnboundField- , FieldTypeLit(..)+ , FieldTypeLit (..) ) where import Prelude hiding (lines) -import Control.Applicative (Alternative((<|>)))+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 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.Quasi.PersistSettings+import Database.Persist.Quasi.PersistSettings.Internal ( psToFKName+ , psToDBName+ , psIdName+ , psStrictFields+ )+import Database.Persist.Quasi.Internal.ModelParser import Database.Persist.Types import Database.Persist.Types.Base-import Language.Haskell.TH.Syntax (Lift, Loc(..))+import Language.Haskell.TH.Syntax (Lift, Loc (..)) import qualified Text.Read as R -data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show+data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving (Show) parseFieldType :: Text -> Either String FieldType parseFieldType t0 =@@ -85,19 +86,22 @@ parseApplyFT :: Text -> ParseState FieldType parseApplyFT t = case goMany id t of- PSSuccess (ft:fts) t' -> PSSuccess (foldl' FTApp ft fts) t'+ 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+ :: 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+ 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@@ -105,11 +109,11 @@ Nothing -> pure PSDone Just (x, xs) -> parseSpace x xs- <|> parseParenEnclosed x xs- <|> parseList x xs- <|> parseNumericLit x xs- <|> parseTextLit x xs- <|> parseTypeCon 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@@ -127,26 +131,29 @@ parseTextLit :: Char -> Text -> Maybe (ParseState FieldType) parseTextLit c t = do guard (c == '"')- let (a, b) = T.break (== '"') t+ 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+ 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+ 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'+ PSSuccess x t' -> goMany (front . (x :)) t' PSFail err -> PSFail err PSDone -> PSSuccess (front []) t @@ -160,306 +167,79 @@ '\'' -> 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---- | Source location: file and line/col information. This is half of a 'Span'.-data SourceLoc = SourceLoc- { locFile :: Text- , locStartLine :: Int- , locStartCol :: Int- } deriving (Show, Lift)+ 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}-+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)] -> [UnboundEntityDef]-parse ps blocks =- mconcat $ handleBlock <$> blocks- where- handleBlock (mLoc, block) =- maybe []- (\(numLines, lns) -> parseLines ps (approximateSpan numLines block <$> mLoc) lns)- (preparse block)- -- FIXME: put an actually truthful span into here- -- We can't give a better result if we push any of this down into the- -- parser at the moment since the parser throws out location info by- -- e.g. discarding comment lines completely without keeping track of- -- where it is. The realistic fix to this is rewriting the parser in- -- Megaparsec, which is a reasonable idea that should actually be done.- approximateSpan numLines block loc =- Span- { spanFile = locFile loc- , spanStartLine = locStartLine loc- , spanStartCol = locStartCol loc- , spanEndLine = locStartLine loc + numLines - 1- -- Last line's length plus one (since we are one-past-the-end)- , spanEndCol = (+ 1) . T.length . T.takeWhileEnd (/= '\n') $ block- }--preparse :: Text -> Maybe (Int, NonEmpty Line)-preparse txt = do- lns <- NEL.nonEmpty (T.lines txt)- let rawLineCount = length lns- (rawLineCount,) <$> 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+parse+ :: PersistSettings+ -> [(Maybe SourceLoc, Text)]+ -> CumulativeParseResult [UnboundEntityDef]+parse ps chunks = toCumulativeParseResult $ map parseChunk chunks 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 -> Maybe Span -> NonEmpty Line -> [UnboundEntityDef]-parseLines ps mSpan = do- fmap (mkUnboundEntityDef ps . toParsedEntityDef mSpan) . associateLines--data ParsedEntityDef = ParsedEntityDef- { parsedEntityDefComments :: [Text]- , parsedEntityDefEntityName :: EntityNameHS- , parsedEntityDefIsSum :: Bool- , parsedEntityDefEntityAttributes :: [Attr]- , parsedEntityDefFieldAttributes :: [[Token]]- , parsedEntityDefExtras :: M.Map Text [ExtraLine]- , parsedEntityDefSpan :: Maybe Span- }+ parseChunk :: (Maybe SourceLoc, Text) -> ParseResult [UnboundEntityDef]+ parseChunk (mSourceLoc, source) =+ (fmap . fmap) (mkUnboundEntityDef ps) <$> parseSource ps mSourceLoc source -entityNamesFromParsedDef :: PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB)+entityNamesFromParsedDef+ :: PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB) entityNamesFromParsedDef ps parsedEntDef = (entNameHS, entNameDB) where entNameHS = parsedEntityDefEntityName parsedEntDef entNameDB =- EntityNameDB $ getDbName ps (unEntityNameHS entNameHS) (parsedEntityDefEntityAttributes parsedEntDef)+ EntityNameDB $+ getDbName+ ps+ (unEntityNameHS entNameHS)+ (parsedEntityDefEntityAttributes parsedEntDef) -toParsedEntityDef :: Maybe Span -> LinesWithComments -> ParsedEntityDef-toParsedEntityDef mSpan lwc = ParsedEntityDef- { parsedEntityDefComments = lwcComments lwc- , parsedEntityDefEntityName = entNameHS- , parsedEntityDefIsSum = isSum- , parsedEntityDefEntityAttributes = entAttribs- , parsedEntityDefFieldAttributes = attribs- , parsedEntityDefExtras = extras- , parsedEntityDefSpan = mSpan+-- | 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 }- 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+ 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@@ -497,7 +277,7 @@ -- the field?" yet, so we defer those to the Template Haskell execution. -- -- @since 2.13.0.0- , unboundEntityDefSpan :: Maybe Span+ , unboundEntityDefSpan :: Maybe SourceSpan -- ^ The source code span of this entity in the models file. -- -- @since 2.15.0.0@@ -631,24 +411,25 @@ -- -- @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- }+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 =@@ -663,55 +444,56 @@ -- -- @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+ = -- | 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+ -> ParsedEntityDef+ -- ^ parsed entity definition -> UnboundEntityDef mkUnboundEntityDef ps parsedEntDef = UnboundEntityDef@@ -719,14 +501,14 @@ entityConstraintDefsForeignsList entityConstraintDefs , unboundPrimarySpec = case (idField, primaryComposite) of- (Just {}, Just {}) ->+ (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+ then+ DefaultKey (FieldNameDB $ psIdName ps)+ else+ SurrogateKey a (Nothing, Just a) -> NaturalKey a (Nothing, Nothing) ->@@ -738,12 +520,12 @@ EntityDef { entityHaskell = entNameHS , entityDB = entNameDB- -- idField is the user-specified Id- -- otherwise useAutoIdField- -- but, adjust it if the user specified a Primary- , entityId =+ , -- 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+ maybe autoIdField (unboundIdDefToFieldDef (defaultIdName ps) entNameHS) idField , entityAttrs = parsedEntityDefEntityAttributes parsedEntDef , entityFields =@@ -767,12 +549,16 @@ attribs = parsedEntityDefFieldAttributes parsedEntDef + cols :: [UnboundFieldDef]+ cols = foldMap (toList . commentedField ps) attribs+ textAttribs :: [[Text]]- textAttribs =- fmap tokenText <$> attribs+ textAttribs = fmap tokenContent . fst <$> attribs entityConstraintDefs =- foldMap (maybe mempty (takeConstraint ps entNameHS cols) . NEL.nonEmpty) textAttribs+ foldMap+ (maybe mempty (takeConstraint ps entNameHS cols) . NEL.nonEmpty)+ textAttribs idField = case entityConstraintDefsIdField entityConstraintDefs of@@ -786,8 +572,13 @@ SetOnce a -> Just a NotSet -> Nothing - cols :: [UnboundFieldDef]- cols = reverse . fst . foldr (associateComments ps) ([], []) $ reverse attribs+ commentedField+ :: PersistSettings+ -> ([Token], Maybe Text)+ -> Maybe UnboundFieldDef+ commentedField s (tokens, mCommentText) = do+ unb <- takeColsEx s (tokenContent <$> tokens)+ pure $ unb{unboundFieldComments = mCommentText} autoIdField :: FieldDef autoIdField =@@ -864,35 +655,10 @@ 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@@ -900,8 +666,7 @@ , fieldDB = dbName , fieldType = FTTypeCon Nothing $ keyConName entName , fieldSqlType = idSqlType- , fieldReference =- NoReference+ , fieldReference = NoReference , fieldAttrs = [] , fieldStrict = True , fieldComments = Nothing@@ -913,23 +678,6 @@ 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)@@ -944,29 +692,31 @@ -> PersistSettings -> [Text] -> Maybe UnboundFieldDef-takeCols _ _ ("deriving":_) = Nothing-takeCols onErr ps (n':typ:rest')+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_- }+ 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_@@ -975,7 +725,6 @@ | 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@@ -1006,9 +755,9 @@ Nothing data SetOnceAtMost a- = NotSet- | SetOnce a- | SetMoreThanOnce+ = NotSet+ | SetOnce a+ | SetMoreThanOnce instance Semigroup (SetOnceAtMost a) where a <> b =@@ -1032,10 +781,14 @@ 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+ { entityConstraintDefsIdField =+ entityConstraintDefsIdField a <> entityConstraintDefsIdField b+ , entityConstraintDefsPrimaryComposite =+ entityConstraintDefsPrimaryComposite a <> entityConstraintDefsPrimaryComposite b+ , entityConstraintDefsUniques =+ entityConstraintDefsUniques a <> entityConstraintDefsUniques b+ , entityConstraintDefsForeigns =+ entityConstraintDefsForeigns a <> entityConstraintDefsForeigns b } instance Monoid EntityConstraintDefs where@@ -1070,7 +823,7 @@ let unboundComposite = takeComposite (unboundFieldNameHS <$> defs) rest- in+ in mempty { entityConstraintDefsPrimaryComposite = SetOnce unboundComposite@@ -1082,47 +835,15 @@ { entityConstraintDefsIdField = SetOnce (takeId ps entityName rest) }- _ | isCapitalizedText n ->- mempty- { entityConstraintDefsUniques =- pure <$> takeUniq ps "" defs (n : 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@@ -1168,8 +889,9 @@ } deriving (Eq, Ord, Show, Lift) -compositeToUniqueDef :: EntityNameHS -> [UnboundFieldDef] -> UnboundCompositeDef -> UniqueDef-compositeToUniqueDef entityName fields UnboundCompositeDef {..} =+compositeToUniqueDef+ :: EntityNameHS -> [UnboundFieldDef] -> UnboundCompositeDef -> UniqueDef+compositeToUniqueDef entityName fields UnboundCompositeDef{..} = UniqueDef { uniqueHaskell = ConstraintNameHS (unEntityNameHS entityName <> "PrimaryKey")@@ -1187,12 +909,10 @@ error "Unable to find `hsName` in fields" (a : _) -> a- matchHsName hsName UnboundFieldDef {..} = do+ matchHsName hsName UnboundFieldDef{..} = do guard $ unboundFieldNameHS == hsName pure unboundFieldNameDB -- takeComposite :: [FieldNameHS] -> [Text]@@ -1213,7 +933,7 @@ xs (cols, attrs) = break ("!" `T.isPrefixOf`) pkcols getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t- getDef (d:ds) t+ getDef (d : ds) t | d == FieldNameHS t = -- TODO: check for nullability in later step -- if nullable (fieldAttrs d) /= NotNullable@@ -1235,23 +955,24 @@ 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- }+ pure+ UniqueDef+ { uniqueHaskell =+ ConstraintNameHS n+ , uniqueDBName =+ dbName+ , uniqueFields =+ fmap (\a -> (FieldNameHS a, getDBName defs a)) fields+ , uniqueAttrs =+ attrs+ } where isAttr a =- "!" `T.isPrefixOf` a+ "!" `T.isPrefixOf` a isSqlName a =- "sql=" `T.isPrefixOf` a+ "sql=" `T.isPrefixOf` a isNonField a =- isAttr a || isSqlName a+ isAttr a || isSqlName a (fieldsList, nonFields) = break isNonField rest mfields =@@ -1260,39 +981,44 @@ attrs = filter isAttr nonFields usualDbName =- ConstraintNameDB $ psToDBName ps (tableName `T.append` n)+ 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+ 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+ 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+ 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)+ "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. --@@ -1329,38 +1055,38 @@ -- | 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+ = -- | 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+data ForeignFieldReference+ = ForeignFieldReference { ffrSourceField :: FieldNameHS -- ^ The column on the source table. --@@ -1381,7 +1107,7 @@ fd } where- mk ((fH, _), (pH, _)) =+ mk ((fH, _), (pH, _)) = ForeignFieldReference { ffrSourceField = fH , ffrTargetField = pH@@ -1401,12 +1127,12 @@ 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+ then+ Left "Target and source length differe on foreign reference."+ else+ Right $+ FieldListHasReferences $+ NEL.zipWith ForeignFieldReference sources targets takeForeign :: PersistSettings@@ -1416,16 +1142,19 @@ takeForeign ps entityName = takeRefTable where errorPrefix :: String- errorPrefix = "invalid foreign key constraint on table[" ++ show (unEntityNameHS entityName) ++ "] "+ errorPrefix =+ "invalid foreign key constraint on table["+ ++ show (unEntityNameHS entityName)+ ++ "] " takeRefTable :: [Text] -> UnboundForeignDef takeRefTable [] = error $ errorPrefix ++ " expecting foreign table name"- takeRefTable (refTableName:restLine) =+ takeRefTable (refTableName : restLine) = go restLine Nothing Nothing where go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef- go (constraintNameText:rest) onDelete onUpdate+ go (constraintNameText : rest) onDelete onUpdate | not (T.null constraintNameText) && isLower (T.head constraintNameText) = UnboundForeignDef { unboundForeignFields =@@ -1471,32 +1200,37 @@ | flen == plen -> (ffs, pfs) (flen, plen) ->- error $ errorPrefix ++ concat- [ "Found " , show flen- , " foreign fields but "- , show plen, " parent fields"- ]-+ 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+ go xs _ _ =+ error $+ errorPrefix+ ++ "expecting a lower case constraint name or a cascading action xs="+ ++ show xs -toFKConstraintNameDB :: PersistSettings -> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB+toFKConstraintNameDB+ :: PersistSettings -> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB toFKConstraintNameDB ps entityName constraintName = ConstraintNameDB $ psToDBName ps (psToFKName ps entityName constraintName)- data CascadePrefix = CascadeUpdate | CascadeDelete parseCascade :: [Text] -> (FieldCascade, [Text])@@ -1547,7 +1281,7 @@ CascadeDelete -> "Delete" takeDerives :: [Text] -> Maybe [Text]-takeDerives ("deriving":rest) = Just rest+takeDerives ("deriving" : rest) = Just rest takeDerives _ = Nothing -- | Returns 'True' if the 'UnboundFieldDef' does not have a 'MigrationOnly' or@@ -1556,8 +1290,8 @@ -- @since 2.13.0.0 isHaskellUnboundField :: UnboundFieldDef -> Bool isHaskellUnboundField fd =- FieldAttrMigrationOnly `notElem` unboundFieldAttrs fd &&- FieldAttrSafeToRemove `notElem` unboundFieldAttrs fd+ FieldAttrMigrationOnly `notElem` unboundFieldAttrs fd+ && FieldAttrSafeToRemove `notElem` unboundFieldAttrs fd -- | Return the 'EntityNameHS' for an 'UnboundEntityDef'. --@@ -1565,5 +1299,5 @@ getUnboundEntityNameHS :: UnboundEntityDef -> EntityNameHS getUnboundEntityNameHS = entityHaskell . unboundEntityDef -readMaybe :: Read a => Text -> Maybe a+readMaybe :: (Read a) => Text -> Maybe a readMaybe = R.readMaybe . T.unpack
+ Database/Persist/Quasi/Internal/ModelParser.hs view
@@ -0,0 +1,790 @@+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE CPP #-}++module Database.Persist.Quasi.Internal.ModelParser+ ( SourceLoc (..)+ , Token (..)+ , tokenContent+ , anyToken+ , ParsedEntityDef+ , parsedEntityDefComments+ , parsedEntityDefEntityName+ , parsedEntityDefIsSum+ , parsedEntityDefEntityAttributes+ , parsedEntityDefFieldAttributes+ , parsedEntityDefExtras+ , parsedEntityDefSpan+ , parseSource+ , memberBlockAttrs+ , ParserWarning+ , parserWarningMessage+ , ParseResult+ , CumulativeParseResult+ , toCumulativeParseResult+ , renderErrors+ , runConfiguredParser+ , ParserErrorLevel (..)+ , initialExtraState+ ) where++import Control.Applicative (Alternative)+import Control.Monad (MonadPlus, mzero, void)+import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT)+import Control.Monad.State+import Control.Monad.Writer+import Data.Char (isSpace)+import Data.Either (partitionEithers)+import Data.Foldable (fold)+import Data.Functor.Identity+import Data.List (find, intercalate)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NEL+import qualified Data.Map as M+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Void+import Database.Persist.Quasi.PersistSettings.Internal+import Database.Persist.Types+import Database.Persist.Types.SourceSpan+import Language.Haskell.TH.Syntax (Lift)+import Text.Megaparsec hiding (Token)+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L+import qualified Text.Megaparsec.Stream as TMS++-- We'll augment the parser with extra state to accumulate comments seen during parsing.+-- Comments are lexed as whitespace, but will be used to generate documentation later.+data ExtraState = ExtraState+ { esPositionedCommentTokens :: [(SourcePos, CommentToken)]+ , esLastDocumentablePosition :: Maybe SourcePos+ }++-- @since 2.16.0.0+initialExtraState :: ExtraState+initialExtraState =+ ExtraState+ { esPositionedCommentTokens = []+ , esLastDocumentablePosition = Nothing+ }++newtype Parser a = Parser+ { unParser+ :: ReaderT+ PersistSettings+ ( StateT+ ExtraState+ ( ParsecT+ Void+ String+ ( Writer+ (Set ParserWarning)+ )+ )+ )+ a+ }+ deriving newtype+ ( Functor+ , Applicative+ , Monad+ , Alternative+ , MonadPlus+ , MonadState ExtraState+ , MonadReader PersistSettings+ , MonadParsec Void String+ )++type EntityParseError = ParseErrorBundle String Void++-- | Result of parsing a single source text.+--+-- @since 2.16.0.0+type ParseResult a =+ (Set ParserWarning, Either (ParseErrorBundle String Void) a)++type InternalParseResult a = ParseResult (a, ExtraState)++-- | Cumulative result of parsing multiple source texts.+--+-- @since 2.16.0.0+type CumulativeParseResult a = (Set ParserWarning, Either [EntityParseError] a)++toCumulativeParseResult+ :: (Monoid a) => [ParseResult a] -> CumulativeParseResult a+toCumulativeParseResult prs = do+ let+ (warnings, eithers) = sequence prs+ case partitionEithers eithers of+ ([], results) -> (warnings, Right $ fold results)+ (errs, _) -> (warnings, Left errs)++-- | Run a parser using provided PersistSettings and ExtraState+-- @since 2.16.0.0+runConfiguredParser+ :: PersistSettings+ -> ExtraState+ -> Parser a+ -> String+ -> String+ -> InternalParseResult a+runConfiguredParser ps acc parser fp s = (warnings, either)+ where+ sm = runReaderT (unParser parser) ps+ pm = runStateT sm acc+ wm = runParserT' pm initialInternalState+ ((_is, either), warnings) = runWriter wm++ initialSourcePos =+ SourcePos+ { sourceName = fp+ , sourceLine = pos1+ , sourceColumn = pos1+ }+ initialPosState =+ PosState+ { pstateInput = s+ , pstateOffset = 0+ , pstateSourcePos = initialSourcePos+ , -- for legacy compatibility, we treat each tab as a single unit of whitespace+ pstateTabWidth = pos1+ , pstateLinePrefix = ""+ }+ initialInternalState =+ State+ { stateInput = s+ , stateOffset = 0+ , statePosState = initialPosState+ , stateParseErrors = []+ }++reportWarnings :: Set ParserWarning -> Parser ()+#if MIN_VERSION_megaparsec(9,5,0)+reportWarnings = Parser . tell+#else+reportWarnings _pw = pure ()+#endif++-- | Renders a list of EntityParseErrors as a String using `errorBundlePretty`,+-- separated by line breaks.+-- @since 2.16.0.0+renderErrors :: [EntityParseError] -> String+renderErrors errs = intercalate "\n" $ fmap errorBundlePretty errs++-- | Attempts to parse with a provided parser. If it fails with an error matching+-- the provided predicate, it registers a warning with the provided message and falls+-- back to the second provided parser.+tryOrWarn+ :: String+ -> (ParseError String Void -> Bool)+ -> Parser a+ -> Parser a+ -> Parser a+tryOrWarn msg p l r = do+ parserState <- getParserState+ withRecovery (warnAndRetry $ statePosState parserState) l+ where+ warnAndRetry posState err = do+ if p err+ then do+ let+ (pairs, _) = attachSourcePos errorOffset [err] posState+ reportWarnings . Set.fromList $+ map+ ( \(e, _pos) ->+ ParserWarning+ { parserWarningExtraMessage = msg <> "\n"+ , parserWarningUnderlyingError = e+ , parserWarningPosState = posState+ }+ )+ pairs+ r+ else parseError err++-- | Attempts to parse with a provided parser. If it fails with an error matching+-- the provided predicate, it registers a delayed error with the provided message and falls+-- back to the second provided parser.+--+-- This is useful when registering errors in space consumers and other parsers that are called+-- with `try`, since a non-delayed error in this context will cause backtracking and not+-- get reported to the user.+tryOrRegisterError+ :: String+ -> (ParseError String Void -> Bool)+ -> Parser a+ -> Parser a+ -> Parser a+tryOrRegisterError msg p l r = do+ parserState <- getParserState+ withRecovery (delayedError $ statePosState parserState) l+ where+ delayedError posState err = do+ if p err+ then do+ let+ (pairs, _) = attachSourcePos errorOffset [err] posState+ registerParseError err+ r+ else parseError err++tryOrReport+ :: Maybe ParserErrorLevel+ -> String+ -> (ParseError String Void -> Bool)+ -> Parser a+ -> Parser a+ -> Parser a+tryOrReport level msg p l r = case level of+ Just LevelError -> tryOrRegisterError msg p l r+ Just LevelWarning -> tryOrWarn msg p l r+ Nothing -> r++-- | Source location: file and line/col information. This is half of a 'SourceSpan'.+--+-- @since 2.16.0.0+data SourceLoc = SourceLoc+ { locFile :: Text+ , locStartLine :: Int+ , locStartCol :: Int+ }+ deriving (Show, Lift)++-- @since 2.16.0.0+data Token+ = Quotation Text+ | Equality Text Text+ | Parenthetical Text+ | BlockKey Text+ | PText Text+ deriving (Eq, Ord, Show)++-- @since 2.16.0.0+data CommentToken+ = DocComment Text+ | Comment Text+ deriving (Eq, Ord, Show)++-- | Converts a token into a Text representation for second-stage parsing or presentation to the user+--+-- @since 2.16.0.0+tokenContent :: Token -> Text+tokenContent = \case+ Quotation s -> s+ Equality l r -> mconcat [l, "=", r]+ Parenthetical s -> s+ PText s -> s+ BlockKey s -> s++commentContent :: CommentToken -> Text+commentContent = \case+ Comment s -> s+ DocComment s -> s++docComment :: Parser (SourcePos, CommentToken)+docComment = do+ pos <- getSourcePos+ content <-+ string "-- |" *> validHSpace *> takeWhileP (Just "character") (/= '\n')+ pure (pos, DocComment (Text.pack content))++comment :: Parser (SourcePos, CommentToken)+comment = do+ pos <- getSourcePos+ content <-+ (string "--" <|> string "#")+ *> validHSpace+ *> takeWhileP (Just "character") (/= '\n')+ pure (pos, Comment (Text.pack content))++skipComment :: Parser ()+skipComment = do+ content <- docComment <|> comment+ void $ appendCommentToState content++isValidHSpace :: Bool -> Char -> Bool+isValidHSpace allowTabs c =+ if allowTabs+ then isSpace c && c /= '\n'+ else isSpace c && c /= '\n' && c /= '\t'++isValidSpace :: Bool -> Char -> Bool+isValidSpace allowTabs c =+ if allowTabs+ then isSpace c+ else isSpace c && c /= '\t'++validSpaceParser+ :: (Maybe String -> (TMS.Token String -> Bool) -> Parser (Tokens String))+ -> (Bool -> Char -> Bool)+ -> Parser ()+validSpaceParser taker validator = do+ tabErrorLevel <- asks psTabErrorLevel+ void $+ tryOrReport+ tabErrorLevel+ "use spaces instead of tabs"+ isUnexpectedTabError+ (taker (Just "valid whitespace") (validator False))+ (taker (Just "valid whitespace") (validator True))++isUnexpectedTabError :: ParseError String Void -> Bool+isUnexpectedTabError (TrivialError _ ue l) =+ ue == Just (Tokens ('\t' :| ""))+ && l == Set.singleton (Label ('v' :| "alid whitespace"))+isUnexpectedTabError _ = False++someValidHSpace :: Parser ()+someValidHSpace = validSpaceParser takeWhile1P isValidHSpace++someValidSpace :: Parser ()+someValidSpace = validSpaceParser takeWhile1P isValidSpace++validHSpace :: Parser ()+validHSpace = validSpaceParser takeWhileP isValidHSpace++spaceConsumer :: Parser ()+spaceConsumer =+ L.space+ someValidHSpace+ skipComment+ empty++spaceConsumerN :: Parser ()+spaceConsumerN =+ L.space+ someValidSpace+ skipComment+ empty++contentChar :: Parser Char+contentChar =+ choice+ [ alphaNumChar+ , char '.'+ , char '['+ , char ']'+ , char '_'+ , char '\''+ , char '"'+ , char '!'+ , char '~'+ , char '-'+ , char ':'+ , char ','+ , do+ backslash <- char '\\'+ nextChar <- lookAhead anySingle+ if nextChar == '(' || nextChar == ')'+ then single nextChar+ else pure backslash+ ]++nonLineSpaceChar :: Parser Char+nonLineSpaceChar = choice [char ' ', char '\t']++-- This is a replacement for `Text.Megaparsec.Char.Lexer.charLiteral`;+-- it does nearly the same thing but additionally supports escaped parentheses.+charLiteral :: Parser Char+charLiteral = label "literal character" $ do+ char1 <- anySingle+ case char1 of+ '\\' -> do+ char2 <- anySingle+ case char2 of+ '(' -> pure '('+ ')' -> pure ')'+ '\\' -> pure '\\'+ '\"' -> pure '\"'+ '\'' -> pure '\''+ _ -> unexpected (Tokens $ char2 :| [])+ _ -> pure char1++equality :: Parser Token+equality = label "equality expression" $ do+ L.lexeme spaceConsumer $ do+ lhs <- some contentChar+ _ <- char '='+ rhs <-+ choice+ [ quotation'+ , sqlLiteral+ , parentheticalInner+ , some $ contentChar <|> char '(' <|> char ')'+ ]+ pure $ Equality (Text.pack lhs) (Text.pack rhs)+ where+ parentheticalInner = do+ str <- parenthetical'+ pure . init . drop 1 $ str++sqlTypeName :: Parser String+sqlTypeName =+ some $+ choice+ [ alphaNumChar+ , char '_'+ ]++sqlLiteral :: Parser String+sqlLiteral = label "SQL literal" $ do+ quote <- L.lexeme spaceConsumer $ char '\'' *> manyTill charLiteral (char '\'')+ st <- optional $ do+ colons <- string "::"+ tn <- sqlTypeName+ pure $ colons <> tn+ pure $+ mconcat+ [ "'"+ , quote+ , "'"+ , fromMaybe "" st+ ]++quotation :: Parser Token+quotation = label "quotation" $ do+ str <- L.lexeme spaceConsumer quotation'+ pure . Quotation $ Text.pack str++quotation' :: Parser String+quotation' = char '"' *> manyTill charLiteral (char '"')++parenthetical :: Parser Token+parenthetical = label "parenthetical" $ do+ str <- L.lexeme spaceConsumer parenthetical'+ pure . Parenthetical . Text.pack . init . drop 1 $ str++parenthetical' :: Parser String+parenthetical' = do+ str <- between (char '(') (char ')') q+ pure $ "(" ++ str ++ ")"+ where+ q = mconcat <$> some (c <|> parenthetical')+ c = (: []) <$> choice [contentChar, nonLineSpaceChar, char '"']++blockKey :: Parser Token+blockKey = label "block key" $ do+ fl <- upperChar+ rl <- many alphaNumChar+ pure . BlockKey . Text.pack $ fl : rl++ptext :: Parser Token+ptext = label "plain token" $ do+ str <- L.lexeme spaceConsumer $ some contentChar+ pure . PText . Text.pack $ str++-- @since 2.16.0.0+anyToken :: Parser Token+anyToken =+ choice+ [ try equality+ , quotation+ , parenthetical+ , ptext+ ]++data ParsedEntityDef = ParsedEntityDef+ { parsedEntityDefComments :: [Text]+ , parsedEntityDefEntityName :: EntityNameHS+ , parsedEntityDefIsSum :: Bool+ , parsedEntityDefEntityAttributes :: [Attr]+ , parsedEntityDefFieldAttributes :: [([Token], Maybe Text)]+ , parsedEntityDefExtras :: M.Map Text [ExtraLine]+ , parsedEntityDefSpan :: Maybe SourceSpan+ }+ deriving (Show)++data DocCommentBlock = DocCommentBlock+ { docCommentBlockLines :: [Text]+ , docCommentBlockPos :: SourcePos+ }+ deriving (Show)++data EntityHeader = EntityHeader+ { entityHeaderSum :: Bool+ , entityHeaderTableName :: Text+ , entityHeaderRemainingTokens :: [Token]+ , entityHeaderPos :: SourcePos+ }+ deriving (Show)++data EntityBlock = EntityBlock+ { entityBlockDocCommentBlock :: Maybe DocCommentBlock+ , entityBlockEntityHeader :: EntityHeader+ , entityBlockMembers :: [Member]+ }+ deriving (Show)++entityBlockFirstPos :: EntityBlock -> SourcePos+entityBlockFirstPos = entityHeaderPos . entityBlockEntityHeader++entityBlockLastPos :: EntityBlock -> SourcePos+entityBlockLastPos eb = case entityBlockMembers eb of+ [] -> entityBlockFirstPos eb+ members -> maximum $ fmap memberEndPos members++entityBlockBlockAttrs :: EntityBlock -> [BlockAttr]+entityBlockBlockAttrs = foldMap f <$> entityBlockMembers+ where+ f m = case m of+ MemberExtraBlock _ -> []+ MemberBlockAttr ba -> [ba]++entityBlockExtraBlocks :: EntityBlock -> [ExtraBlock]+entityBlockExtraBlocks = foldMap f <$> entityBlockMembers+ where+ f m = case m of+ MemberExtraBlock eb -> [eb]+ MemberBlockAttr _ -> []++data ExtraBlockHeader = ExtraBlockHeader+ { extraBlockHeaderKey :: Text+ , extraBlockHeaderRemainingTokens :: [Token]+ , extraBlockHeaderPos :: SourcePos+ }+ deriving (Show)++data ExtraBlock = ExtraBlock+ { extraBlockDocCommentBlock :: Maybe DocCommentBlock+ , extraBlockExtraBlockHeader :: ExtraBlockHeader+ , extraBlockMembers :: NonEmpty Member+ }+ deriving (Show)++data BlockAttr = BlockAttr+ { blockAttrDocCommentBlock :: Maybe DocCommentBlock+ , blockAttrTokens :: [Token]+ , blockAttrPos :: SourcePos+ }+ deriving (Show)++data Member = MemberExtraBlock ExtraBlock | MemberBlockAttr BlockAttr+ deriving (Show)++-- | The source position at the beginning of the member's final line.+memberEndPos :: Member -> SourcePos+memberEndPos (MemberBlockAttr fs) = blockAttrPos fs+memberEndPos (MemberExtraBlock ex) = memberEndPos . NEL.last . extraBlockMembers $ ex++-- | Represents an entity member as a list of BlockAttrs+--+-- @since 2.16.0.0+memberBlockAttrs :: Member -> [BlockAttr]+memberBlockAttrs (MemberBlockAttr fs) = [fs]+memberBlockAttrs (MemberExtraBlock ex) = foldMap memberBlockAttrs . extraBlockMembers $ ex++extraBlocksAsMap :: [ExtraBlock] -> M.Map Text [ExtraLine]+extraBlocksAsMap exs = M.fromList $ fmap asPair exs+ where+ asPair ex =+ (extraBlockHeaderKey . extraBlockExtraBlockHeader $ ex, extraLines ex)+ extraLines ex = foldMap asExtraLine (extraBlockMembers ex)+ asExtraLine (MemberBlockAttr fs) = [tokenContent <$> blockAttrTokens fs]+ asExtraLine _ = []++entityHeader :: Parser EntityHeader+entityHeader = do+ pos <- getSourcePos+ plus <- optional (char '+')+ en <- validHSpace *> L.lexeme spaceConsumer blockKey+ rest <- L.lexeme spaceConsumer (many anyToken)+ _ <- setLastDocumentablePosition+ pure+ EntityHeader+ { entityHeaderSum = isJust plus+ , entityHeaderTableName = tokenContent en+ , entityHeaderRemainingTokens = rest+ , entityHeaderPos = pos+ }++appendCommentToState :: (SourcePos, CommentToken) -> Parser ()+appendCommentToState ptok =+ modify $ \es ->+ let+ comments = esPositionedCommentTokens es+ in+ es{esPositionedCommentTokens = ptok : comments}++setLastDocumentablePosition :: Parser ()+setLastDocumentablePosition = do+ pos <- getSourcePos+ modify $ \es -> es{esLastDocumentablePosition = Just pos}++getDcb :: Parser (Maybe DocCommentBlock)+getDcb = do+ es <- get+ let+ comments = reverse $ esPositionedCommentTokens es+ _ <- put es{esPositionedCommentTokens = []}+ let+ candidates = dropWhile (\(_sp, ct) -> not (isDocComment ct)) comments+ filteredCandidates = dropWhile (commentIsIncorrectlyPositioned es) candidates+ pure $ docCommentBlockFromPositionedTokens filteredCandidates+ where+ commentIsIncorrectlyPositioned+ :: ExtraState -> (SourcePos, CommentToken) -> Bool+ commentIsIncorrectlyPositioned es ptok = case esLastDocumentablePosition es of+ Nothing -> False+ Just lastDocumentablePos -> (sourceLine . fst) ptok <= sourceLine lastDocumentablePos++extraBlock :: Parser Member+extraBlock = L.indentBlock spaceConsumerN innerParser+ where+ mkExtraBlockMember dcb (header, blockAttrs) =+ MemberExtraBlock+ ExtraBlock+ { extraBlockExtraBlockHeader = header+ , extraBlockMembers = ensureNonEmpty blockAttrs+ , extraBlockDocCommentBlock = dcb+ }+ ensureNonEmpty members = case NEL.nonEmpty members of+ Just nel -> nel+ Nothing -> error "unreachable" -- members is known to be non-empty+ innerParser = do+ dcb <- getDcb+ header <- extraBlockHeader+ pure $+ L.IndentSome Nothing (return . mkExtraBlockMember dcb . (header,)) blockAttr++extraBlockHeader :: Parser ExtraBlockHeader+extraBlockHeader = do+ pos <- getSourcePos+ tn <- L.lexeme spaceConsumer blockKey+ rest <- L.lexeme spaceConsumer (many anyToken)+ _ <- setLastDocumentablePosition+ pure $+ ExtraBlockHeader+ { extraBlockHeaderKey = tokenContent tn+ , extraBlockHeaderRemainingTokens = rest+ , extraBlockHeaderPos = pos+ }++blockAttr :: Parser Member+blockAttr = do+ dcb <- getDcb+ pos <- getSourcePos+ line <- some anyToken+ _ <- setLastDocumentablePosition+ pure $+ MemberBlockAttr+ BlockAttr+ { blockAttrDocCommentBlock = dcb+ , blockAttrTokens = line+ , blockAttrPos = pos+ }++member :: Parser Member+member = try extraBlock <|> blockAttr++entityBlock :: Parser EntityBlock+entityBlock = do+ L.indentBlock spaceConsumerN innerParser+ where+ mkEntityBlock dcb (header, members) =+ EntityBlock+ { entityBlockEntityHeader = header+ , entityBlockMembers = members+ , entityBlockDocCommentBlock = dcb+ }+ innerParser = do+ dcb <- getDcb+ header <- entityHeader+ pure $ L.IndentMany Nothing (return . mkEntityBlock dcb . (header,)) member++entitiesFromDocument :: Parser [EntityBlock]+entitiesFromDocument = many entityBlock++docCommentBlockText :: DocCommentBlock -> Text+docCommentBlockText dcb = Text.unlines $ docCommentBlockLines dcb++isDocComment :: CommentToken -> Bool+isDocComment tok = case tok of+ DocComment _ -> True+ _ -> False++docCommentBlockFromPositionedTokens+ :: [(SourcePos, CommentToken)] -> Maybe DocCommentBlock+docCommentBlockFromPositionedTokens ptoks =+ case NEL.nonEmpty ptoks of+ Nothing -> Nothing+ Just nel ->+ Just $+ DocCommentBlock+ { docCommentBlockLines = NEL.toList $ fmap (commentContent . snd) nel+ , docCommentBlockPos = fst $ NEL.head nel+ }++parseEntities+ :: PersistSettings+ -> Text+ -> String+ -> ParseResult [EntityBlock]+parseEntities ps fp s = do+ let+ (warnings, res) =+ runConfiguredParser ps initialExtraState entitiesFromDocument (Text.unpack fp) s+ case res of+ Left peb ->+ (warnings, Left peb)+ Right (entities, _comments) ->+ (warnings, pure entities)++toParsedEntityDef :: Maybe SourceLoc -> EntityBlock -> ParsedEntityDef+toParsedEntityDef mSourceLoc eb =+ ParsedEntityDef+ { parsedEntityDefComments = comments+ , parsedEntityDefEntityName = entityNameHS+ , parsedEntityDefIsSum = isSum+ , parsedEntityDefEntityAttributes = entityAttributes+ , parsedEntityDefFieldAttributes = parsedFieldAttributes+ , parsedEntityDefExtras = extras+ , parsedEntityDefSpan = mSpan+ }+ where+ comments =+ maybe+ []+ docCommentBlockLines+ (entityBlockDocCommentBlock eb)+ entityAttributes =+ tokenContent <$> (entityHeaderRemainingTokens . entityBlockEntityHeader) eb+ isSum = entityHeaderSum . entityBlockEntityHeader $ eb+ entityNameHS = EntityNameHS . entityHeaderTableName . entityBlockEntityHeader $ eb++ attributePair a = (blockAttrTokens a, docCommentBlockText <$> blockAttrDocCommentBlock a)+ parsedFieldAttributes = fmap attributePair (entityBlockBlockAttrs eb)++ extras = extraBlocksAsMap (entityBlockExtraBlocks eb)+ filepath = maybe "" locFile mSourceLoc+ relativeStartLine = maybe 0 locStartLine mSourceLoc+ relativeStartCol = maybe 0 locStartCol mSourceLoc+ mSpan =+ Just+ SourceSpan+ { spanFile = filepath+ , spanStartLine =+ relativeStartLine + (unPos . sourceLine $ entityBlockFirstPos eb)+ , spanEndLine = relativeStartLine + (unPos . sourceLine $ entityBlockLastPos eb)+ , spanStartCol =+ relativeStartCol + (unPos . sourceColumn $ entityBlockFirstPos eb)+ , spanEndCol = unPos . sourceColumn $ entityBlockLastPos eb+ }++parseSource+ :: PersistSettings+ -> Maybe SourceLoc+ -> Text+ -> ParseResult [ParsedEntityDef]+parseSource ps mSourceLoc source =+ fmap (fmap (toParsedEntityDef mSourceLoc))+ <$> parseEntities ps filepath (Text.unpack source)+ where+ filepath = maybe "" locFile mSourceLoc
+ Database/Persist/Quasi/PersistSettings.hs view
@@ -0,0 +1,25 @@+module Database.Persist.Quasi.PersistSettings+ ( PersistSettings+ , defaultPersistSettings+ , upperCaseSettings+ , lowerCaseSettings+ , ParserErrorLevel (..)+ , ParserWarning+ , warningPos+ , parserWarningMessage++ -- ** Getters and Setters+ , getPsToDBName+ , setPsToDBName+ , setPsToFKName+ , setPsUseSnakeCaseForeignKeys+ , setPsUseSnakeCaseForiegnKeys+ , getPsStrictFields+ , setPsStrictFields+ , getPsIdName+ , setPsIdName+ , getPsTabErrorLevel+ , setPsTabErrorLevel+ ) where++import Database.Persist.Quasi.PersistSettings.Internal
+ Database/Persist/Quasi/PersistSettings/Internal.hs view
@@ -0,0 +1,183 @@+module Database.Persist.Quasi.PersistSettings.Internal where++import Data.Char (isDigit, isLower, isSpace, isUpper, toLower)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Void (Void)+import Database.Persist.Names+import Database.Persist.Types+import Text.Megaparsec+ ( ParseError+ , ParseErrorBundle (..)+ , PosState+ , SourcePos+ , errorBundlePretty+ , pstateSourcePos+ )++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+ , psTabErrorLevel :: Maybe ParserErrorLevel+ -- ^ Whether and with what severity to disallow tabs in entity source text.+ --+ -- @since 2.16.0.0+ }++defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings+defaultPersistSettings =+ PersistSettings+ { psToDBName = id+ , psToFKName = \(EntityNameHS entName) (ConstraintNameHS conName) -> entName <> conName+ , psStrictFields = True+ , psIdName = "id"+ , psTabErrorLevel = Just LevelWarning+ }+upperCaseSettings = defaultPersistSettings+lowerCaseSettings =+ defaultPersistSettings+ { psToDBName =+ let+ go c+ | isUpper c = T.pack ['_', toLower c]+ | otherwise = T.singleton c+ in+ T.dropWhile (== '_') . T.concatMap go+ }++-- |+--+-- @since 2.16.0.0+data ParserErrorLevel = LevelError | LevelWarning deriving (Eq, Show)++-- |+--+-- @since 2.16.0.0+data ParserWarning = ParserWarning+ { parserWarningExtraMessage :: String+ , parserWarningUnderlyingError :: ParseError String Void+ , parserWarningPosState :: PosState String+ }+ deriving (Eq, Show)++warningPos :: ParserWarning -> SourcePos+warningPos = pstateSourcePos . parserWarningPosState++instance Ord ParserWarning where+ l <= r =+ if warningPos l == warningPos r+ then parserWarningMessage l <= parserWarningMessage r+ else warningPos l <= warningPos r++-- | Uses @errorBundlePretty@ to render a parser warning.+--+-- @since 2.16.0.0+parserWarningMessage :: ParserWarning -> String+parserWarningMessage pw =+ parserWarningExtraMessage pw+ <> ( errorBundlePretty $+ ParseErrorBundle+ { bundleErrors = parserWarningUnderlyingError pw :| []+ , bundlePosState = parserWarningPosState pw+ }+ )++toFKNameInfixed :: Text -> EntityNameHS -> ConstraintNameHS -> Text+toFKNameInfixed inf (EntityNameHS entName) (ConstraintNameHS conName) =+ entName <> inf <> conName++-- | Retrieve the function in the 'PersistSettings' that modifies the names into+-- database names.+--+-- @since 2.13.0.0+getPsToDBName :: PersistSettings -> Text -> Text+getPsToDBName = psToDBName++-- | Set the name modification function that translates the QuasiQuoted names+-- for use in the database.+--+-- @since 2.13.0.0+setPsToDBName :: (Text -> Text) -> PersistSettings -> PersistSettings+setPsToDBName f ps = ps{psToDBName = f}++-- | Set a custom function used to create the constraint name+-- for a foreign key.+--+-- @since 2.13.0.0+setPsToFKName+ :: (EntityNameHS -> ConstraintNameHS -> Text) -> PersistSettings -> PersistSettings+setPsToFKName setter ps = ps{psToFKName = setter}++-- | A preset configuration function that puts an underscore+-- between the entity name and the constraint name when+-- creating a foreign key constraint name+--+-- @since 2.14.2.0+setPsUseSnakeCaseForeignKeys :: PersistSettings -> PersistSettings+setPsUseSnakeCaseForeignKeys = setPsToFKName (toFKNameInfixed "_")++-- | Equivalent to 'setPsUseSnakeCaseForeignKeys', but misspelled.+--+-- @since 2.13.0.0+setPsUseSnakeCaseForiegnKeys :: PersistSettings -> PersistSettings+setPsUseSnakeCaseForiegnKeys = setPsUseSnakeCaseForeignKeys+{-# DEPRECATED+ setPsUseSnakeCaseForiegnKeys+ "use the correctly spelled, equivalent, setPsUseSnakeCaseForeignKeys instead"+ #-}++-- | Retrieve whether or not the 'PersistSettings' will generate code with+-- strict fields.+--+-- @since 2.13.0.0+getPsStrictFields :: PersistSettings -> Bool+getPsStrictFields = psStrictFields++-- | Set whether or not the 'PersistSettings' will make fields strict.+--+-- @since 2.13.0.0+setPsStrictFields :: Bool -> PersistSettings -> PersistSettings+setPsStrictFields a ps = ps{psStrictFields = a}++-- | Retrieve the default name of the @id@ column.+--+-- @since 2.13.0.0+getPsIdName :: PersistSettings -> Text+getPsIdName = psIdName++-- | Set the default name of the @id@ column.+--+-- @since 2.13.0.0+setPsIdName :: Text -> PersistSettings -> PersistSettings+setPsIdName n ps = ps{psIdName = n}++-- | Retrieve the severity of the error generated when the parser encounters a tab.+-- If it is @Nothing@, tabs are permitted in entity definitions.+--+-- @since 2.16.0.0+getPsTabErrorLevel :: PersistSettings -> Maybe ParserErrorLevel+getPsTabErrorLevel = psTabErrorLevel++-- | Set the severity of the error generated when the parser encounters a tab.+-- If set to @Nothing@, tabs are permitted in entity definitions.+--+-- @since 2.16.0.0+setPsTabErrorLevel+ :: Maybe ParserErrorLevel -> PersistSettings -> PersistSettings+setPsTabErrorLevel l ps = ps{psTabErrorLevel = l}
Database/Persist/TH/Internal.hs view
@@ -118,7 +118,7 @@ import Instances.TH.Lift () -- Bring `Lift (fmap k v)` instance into scope, as well as `Lift Text` -- instance on pre-1.2.4 versions of `text`-import Data.Foldable (asum, toList)+import Data.Foldable (asum, toList, traverse_) import qualified Data.Set as Set import Language.Haskell.TH.Lib (appT, conE, conK, conT, litT, strTyLit, varE, varP, varT)@@ -131,6 +131,7 @@ import Web.PathPieces (PathPiece(..)) import Database.Persist+import Database.Persist.Quasi.PersistSettings import Database.Persist.Class.PersistEntity import Database.Persist.Quasi import Database.Persist.Quasi.Internal@@ -280,9 +281,14 @@ -- In 2.13.0.0, this was changed to splice in @['UnboundEntityDef']@ -- instead of @['EntityDef']@. ----- @since 2.5.3+-- @since 2.16.0.0 parseReferences :: PersistSettings -> [(Maybe SourceLoc, Text)] -> Q Exp-parseReferences ps s = lift $ parse ps s+parseReferences ps s = do+ let (warnings, res) = parse ps s+ traverse_ (reportWarning . parserWarningMessage) $ warnings+ case res of+ Left errs -> fail $ renderErrors errs+ Right r -> lift r preprocessUnboundDefs :: [EntityDef]@@ -1053,7 +1059,9 @@ filter isHaskellUnboundField (unboundEntityFields ued) } --- | Settings to be passed to the 'mkPersist' function.+-- | Settings that can be passed to the 'mkPersist' (mps) function to control what code is generated.+-- This is (just) the data type definition, so you will most likely want to use and adapt concrete values+-- like 'sqlSettings'. data MkPersistSettings = MkPersistSettings { mpsBackend :: Type -- ^ Which database backend we\'re using. This type is used for the@@ -1079,16 +1087,64 @@ , mpsPrefixFields :: Bool -- ^ Prefix field names with the model name. Default: True. --- -- Note: this field is deprecated. Use the mpsFieldLabelModifier and+ -- Note: this field is deprecated. Use the 'mpsFieldLabelModifier' and -- 'mpsConstraintLabelModifier' instead. , mpsFieldLabelModifier :: Text -> Text -> Text- -- ^ Customise the field accessors and lens names using the entity and field- -- name. Both arguments are upper cased.+ -- ^ Customise the field names (and lens names) for generated entity data types. --- -- Default: appends entity and field.+ -- Default: appends entity name and field name, equivalent to --- -- Note: this setting is ignored if mpsPrefixFields is set to False.+ -- @+ -- mpsFieldLabelModifier = \\entityName fieldName -> entityName <> fieldName+ -- @ --+ -- to avoid duplicate record field collisions.+ --+ -- For example, with default 'sqlSettings' and+ --+ -- @+ -- 'mkPersistWith' 'sqlSettings' [] ['persistLowerCase'|+ -- Person+ -- name Text+ -- age Int+ -- |]+ -- @+ --+ -- it will generate the entity data type+ --+ -- @+ -- Person {+ -- personName :: Text, -- generated field name+ -- personAge :: Int -- generated field name+ -- }+ -- @+ --+ -- Note: this setting is ignored if the deprecated 'mpsPrefixFields' is set to False.+ --+ -- === __Example without entity name__+ --+ -- You may not want the entity name prefix for all fields, so use+ --+ -- @+ -- 'mkPersistWith' ('sqlSettings' { mpsFieldLabelModifier = \\\_entityName fieldName -> fieldName }) [] ['persistLowerCase'|+ -- Person+ -- name Text+ -- age Int+ -- |]+ -- @+ --+ -- instead. This will generate the entity data type+ --+ -- @+ -- Person {+ -- name :: Text,+ -- age :: Int+ -- }+ -- @+ --+ -- When you have multiple entites with the same field name, you might need to+ -- add @{-# LANGUAGE DuplicateRecordFields #-}@ for your code to compile.+ -- -- @since 2.11.0.0 , mpsAvoidHsKeyword :: Text -> Text -- ^ Customise function for field accessors applied only when the field name matches any of Haskell keywords.@@ -1102,7 +1158,7 @@ -- -- Default: appends entity and field --- -- Note: this setting is ignored if mpsPrefixFields is set to False.+ -- Note: this setting is ignored if the deprecated 'mpsPrefixFields' is set to False. -- -- @since 2.11.0.0 , mpsEntityHaddocks :: Bool@@ -1160,7 +1216,6 @@ -- , companyUserKeyUserId :: UserId -- } -- @- -- Default: False -- -- @since 2.14.2.0
Database/Persist/Types.hs view
@@ -69,7 +69,6 @@ , PersistValue(..) , ReferenceDef(..) , SqlType(..)- , Span(..) , UniqueDef(..) , UpdateException(..) , WhyNullable(..)
Database/Persist/Types/Base.hs view
@@ -13,7 +13,7 @@ , PersistValue(..) , fromPersistValueText , LiteralType(..)- , Span(..)+ , SourceSpan(..) ) where import Control.Exception (Exception)@@ -39,7 +39,7 @@ import Database.Persist.Names import Database.Persist.PersistValue-import Database.Persist.Types.Span (Span(..))+import Database.Persist.Types.SourceSpan (SourceSpan(..)) -- | A 'Checkmark' should be used as a field type whenever a -- uniqueness constraint should guarantee that a certain kind of@@ -157,7 +157,7 @@ -- ^ Optional comments on the entity. -- -- @since 2.10.0- , entitySpan :: !(Maybe Span)+ , entitySpan :: !(Maybe SourceSpan) -- ^ Source code span occupied by this entity. May be absent if it is not -- known. --
+ Database/Persist/Types/SourceSpan.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DeriveLift #-}++module Database.Persist.Types.SourceSpan (SourceSpan (..)) where++import Data.Text (Text)+import Language.Haskell.TH.Syntax (Lift)++-- | A pair of (start line/col, end line/col) coordinates. The end column will+-- be one past the final character (i.e. the span (1,1)->(1,1) is zero+-- characters long).+--+-- SourceSpans are 1-indexed in both lines and columns.+--+-- Conceptually identical to GHC's @RealSourceSpan@.+--+-- @since 2.16.0.0+data SourceSpan = SourceSpan+ { spanFile :: !Text+ , spanStartLine :: !Int+ , spanStartCol :: !Int+ , spanEndLine :: !Int+ , spanEndCol :: !Int+ }+ deriving (Show, Eq, Read, Ord, Lift)
− Database/Persist/Types/Span.hs
@@ -1,24 +0,0 @@-{-# LANGUAGE DeriveLift #-}--module Database.Persist.Types.Span (Span (..)) where--import Data.Text (Text)-import Language.Haskell.TH.Syntax (Lift)---- | A pair of (start line/col, end line/col) coordinates. The end column will--- be one past the final character (i.e. the span (1,1)->(1,1) is zero--- characters long).------ Spans are 1-indexed in both lines and columns.------ Conceptually identical to GHC's @RealSourceSpan@.------ @since 2.15.0.0-data Span = Span- { spanFile :: !Text- , spanStartLine :: !Int- , spanStartCol :: !Int- , spanEndLine :: !Int- , spanEndCol :: !Int- }- deriving (Show, Eq, Read, Ord, Lift)
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.15.1.0+version: 2.16.0.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -36,9 +36,11 @@ , fast-logger >=2.4 , http-api-data >=0.3 , lift-type >=0.1.0.0 && <0.2.0.0+ , megaparsec , monad-logger >=0.3.28 , mtl , path-pieces >=0.2+ , replace-megaparsec , resource-pool >=0.2.3 , resourcet >=1.1.10 , scientific@@ -78,7 +80,10 @@ Database.Persist.Names Database.Persist.PersistValue Database.Persist.Quasi+ Database.Persist.Quasi.PersistSettings+ Database.Persist.Quasi.PersistSettings.Internal Database.Persist.Quasi.Internal+ Database.Persist.Quasi.Internal.ModelParser Database.Persist.Sql Database.Persist.Sql.Migration Database.Persist.Sql.Types.Internal@@ -96,6 +101,7 @@ Database.Persist.TH Database.Persist.TH.Internal Database.Persist.Types+ Database.Persist.Types.SourceSpan other-modules: Database.Persist.Sql.Class@@ -107,7 +113,6 @@ Database.Persist.Sql.Run Database.Persist.Sql.Types Database.Persist.Types.Base- Database.Persist.Types.Span -- These modules only make sense for compilers with access to DerivingVia if impl(ghc >=8.6.1)@@ -135,6 +140,7 @@ , fast-logger , hspec >=2.4 , http-api-data+ , megaparsec , monad-logger , mtl , path-pieces
test/Database/Persist/ClassSpec.hs view
@@ -1,7 +1,7 @@ module Database.Persist.ClassSpec where -import Database.Persist.Class import Data.Time+import Database.Persist.Class import Database.Persist.Types import Test.Hspec @@ -9,7 +9,15 @@ spec = describe "Class" $ do describe "PersistField" $ do describe "UTCTime" $ do- it "fromPersistValue with format" $+ it "fromPersistValue with ISO8601 format including UTC timezone Z (canonical)" $+ fromPersistValue (PersistText "2018-02-27T10:49:42.123Z")+ `shouldBe` Right+ (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123)))+ it "fromPersistValue with ISO8601 format no timezone (backwards-compatibility)" $+ fromPersistValue (PersistText "2018-02-27T10:49:42.123")+ `shouldBe` Right+ (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123)))+ it "fromPersistValue with pretty format (backwards-compatibility)" $ fromPersistValue (PersistText "2018-02-27 10:49:42.123")- `shouldBe`- Right (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123)))+ `shouldBe` Right+ (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123)))
test/Database/Persist/QuasiSpec.hs view
@@ -8,1229 +8,977 @@ import Prelude hiding (lines) import Control.Exception-import Data.List hiding (lines)-import Data.List.NonEmpty (NonEmpty(..), (<|))-import qualified Data.List.NonEmpty as NEL-import qualified Data.Map as Map-import qualified Data.Text as T-import Database.Persist.EntityDef.Internal-import Database.Persist.Quasi-import Database.Persist.Quasi.Internal-import Database.Persist.Types-import Test.Hspec-import Test.Hspec.QuickCheck-import Test.QuickCheck-import Text.Shakespeare.Text (st)--defs :: T.Text -> [UnboundEntityDef]-defs t = parse lowerCaseSettings [(Nothing, t)]--defsSnake :: T.Text -> [UnboundEntityDef]-defsSnake t = parse (setPsUseSnakeCaseForeignKeys lowerCaseSettings) [(Nothing, t)]---spec :: Spec-spec = describe "Quasi" $ do- describe "parseEntityFields" $ do- let helloWorldTokens = Token "hello" :| [Token "world"]- foobarbazTokens = Token "foo" :| [Token "bar", Token "baz"]- it "works" $ do- parseEntityFields []- `shouldBe`- mempty- it "works2" $ do- parseEntityFields- [ Line 0 helloWorldTokens- ]- `shouldBe`- ( [NEL.toList helloWorldTokens], mempty )- it "works3" $ do- parseEntityFields- [ Line 0 helloWorldTokens- , Line 2 foobarbazTokens- ]- `shouldBe`- ( [NEL.toList helloWorldTokens, NEL.toList foobarbazTokens], mempty )- it "works4" $ do- parseEntityFields- [ Line 0 [Token "Product"]- , Line 2 (Token <$> ["name", "Text"])- , Line 2 (Token <$> ["added", "UTCTime", "default=CURRENT_TIMESTAMP"])- ]- `shouldBe`- ( []- , Map.fromList- [ ("Product",- [ ["name", "Text"]- , ["added", "UTCTime", "default=CURRENT_TIMESTAMP"]- ]- ) ]- )- it "works5" $ do- parseEntityFields- [ Line 0 [Token "Product"]- , Line 2 (Token <$> ["name", "Text"])- , Line 4 [Token "ExtraBlock"]- , Line 4 (Token <$> ["added", "UTCTime", "default=CURRENT_TIMESTAMP"])- ]- `shouldBe`- ( []- , Map.fromList- [ ("Product",- [ ["name", "Text"]- , ["ExtraBlock"]- , ["added", "UTCTime", "default=CURRENT_TIMESTAMP"]- ]- )]- )- describe "takeColsEx" $ do- let subject = takeColsEx upperCaseSettings- it "fails on a single word" $ do- subject ["asdf"]- `shouldBe`- Nothing- it "errors on invalid input" $ do- evaluate (subject ["name", "int"])- `shouldErrorWithMessage` "Invalid field type \"int\" PSFail \"int\""- it "works if it has a name and a type" $ do- subject ["asdf", "Int"]- `shouldBe`- Just UnboundFieldDef- { unboundFieldNameHS = FieldNameHS "asdf"- , unboundFieldNameDB = FieldNameDB "asdf"- , unboundFieldType = FTTypeCon Nothing "Int"- , unboundFieldAttrs = []- , unboundFieldStrict = True- , unboundFieldCascade = noCascade- , unboundFieldComments = Nothing- , unboundFieldGenerated = Nothing- }- it "works if it has a name, type, and cascade" $ do- subject ["asdf", "Int", "OnDeleteCascade", "OnUpdateCascade"]- `shouldBe`- Just UnboundFieldDef- { unboundFieldNameHS = FieldNameHS "asdf"- , unboundFieldNameDB = FieldNameDB "asdf"- , unboundFieldType = FTTypeCon Nothing "Int"- , unboundFieldAttrs = []- , unboundFieldStrict = True- , unboundFieldCascade = FieldCascade (Just Cascade) (Just Cascade)- , unboundFieldComments = Nothing- , unboundFieldGenerated = Nothing- }- it "never tries to make a refernece" $ do- subject ["asdf", "UserId", "OnDeleteCascade"]- `shouldBe`- Just UnboundFieldDef- { unboundFieldNameHS = FieldNameHS "asdf"- , unboundFieldNameDB = FieldNameDB "asdf"- , unboundFieldType = FTTypeCon Nothing "UserId"- , unboundFieldAttrs = []- , unboundFieldStrict = True- , unboundFieldCascade = FieldCascade Nothing (Just Cascade)- , unboundFieldComments = Nothing- , unboundFieldGenerated = Nothing- }-- describe "parseLine" $ do- it "returns nothing when line is just whitespace" $- parseLine " " `shouldBe` Nothing-- it "handles normal words" $- parseLine " foo bar baz" `shouldBe`- Just- ( Line 1- [ Token "foo"- , Token "bar"- , Token "baz"- ]- )-- it "handles numbers" $- parseLine " one (Finite 1)" `shouldBe`- Just- ( Line 2- [ Token "one"- , Token "Finite 1"- ]- )-- it "handles quotes" $- parseLine " \"foo bar\" \"baz\"" `shouldBe`- Just- ( Line 2- [ Token "foo bar"- , Token "baz"- ]- )-- it "should error if quotes are unterminated" $ do- evaluate (parseLine " \"foo bar")- `shouldErrorWithMessage`- "Unterminated quoted string starting with foo bar"-- it "handles quotes mid-token" $- parseLine " x=\"foo bar\" \"baz\"" `shouldBe`- Just- ( Line 2- [ Token "x=foo bar"- , Token "baz"- ]- )-- it "handles escaped quote mid-token" $- parseLine " x=\\\"foo bar\" \"baz\"" `shouldBe`- Just- ( Line 2- [ Token "x=\\\"foo"- , Token "bar\""- , Token "baz"- ]- )-- it "handles unnested parantheses" $- parseLine " (foo bar) (baz)" `shouldBe`- Just- ( Line 2- [ Token "foo bar"- , Token "baz"- ]- )-- it "handles unnested parantheses mid-token" $- parseLine " x=(foo bar) (baz)" `shouldBe`- Just- ( Line 2- [ Token "x=foo bar"- , Token "baz"- ]- )-- it "handles nested parantheses" $- parseLine " (foo (bar)) (baz)" `shouldBe`- Just- ( Line 2- [ Token "foo (bar)"- , Token "baz"- ]- )-- it "escaping" $- parseLine " (foo \\(bar) y=\"baz\\\"\"" `shouldBe`- Just- ( Line 2- [ Token "foo (bar"- , Token "y=baz\""- ]- )-- it "mid-token quote in later token" $- parseLine "foo bar baz=(bin\")" `shouldBe`- Just- ( Line 0- [ Token "foo"- , Token "bar"- , Token "baz=bin\""- ]- )-- describe "comments" $ do- it "recognizes one line" $ do- parseLine "-- | this is a comment" `shouldBe`- Just- ( Line 0- [ DocComment "this is a comment"- ]- )- it "recognizes empty line" $ do- parseLine "-- |" `shouldBe`- Just- ( Line 0- [ DocComment ""- ]- )-- it "works if comment is indented" $ do- parseLine " -- | comment" `shouldBe`- Just (Line 2 [DocComment "comment"])-- describe "parse" $ do- let subject =- [st|-Bicycle -- | this is a bike- brand String -- | the brand of the bike- ExtraBike- foo bar -- | this is a foo bar- baz- deriving Eq--- | This is a Car-Car- -- | the make of the Car- make String- -- | the model of the Car- model String- UniqueModel model- deriving Eq Show-+Vehicle- bicycle BicycleId -- | the bike reference- car CarId -- | the car reference-- |]- let [bicycle, car, vehicle] = defs subject-- it "should parse the `entityHaskell` field" $ do- getUnboundEntityNameHS bicycle `shouldBe` EntityNameHS "Bicycle"- getUnboundEntityNameHS car `shouldBe` EntityNameHS "Car"- getUnboundEntityNameHS vehicle `shouldBe` EntityNameHS "Vehicle"-- it "should parse the `entityDB` field" $ do- entityDB (unboundEntityDef bicycle) `shouldBe` EntityNameDB "bicycle"- entityDB (unboundEntityDef car) `shouldBe` EntityNameDB "car"- entityDB (unboundEntityDef vehicle) `shouldBe` EntityNameDB "vehicle"-- it "should parse the `entityAttrs` field" $ do- entityAttrs (unboundEntityDef bicycle) `shouldBe` ["-- | this is a bike"]- entityAttrs (unboundEntityDef car) `shouldBe` []- entityAttrs (unboundEntityDef vehicle) `shouldBe` []-- it "should parse the `unboundEntityFields` field" $ do- let simplifyField field =- (unboundFieldNameHS field, unboundFieldNameDB field, unboundFieldComments field)- (simplifyField <$> unboundEntityFields bicycle) `shouldBe`- [ (FieldNameHS "brand", FieldNameDB "brand", Nothing)- ]- (simplifyField <$> unboundEntityFields car) `shouldBe`- [ (FieldNameHS "make", FieldNameDB "make", Just "the make of the Car\n")- , (FieldNameHS "model", FieldNameDB "model", Just "the model of the Car\n")- ]- (simplifyField <$> unboundEntityFields vehicle) `shouldBe`- [ (FieldNameHS "bicycle", FieldNameDB "bicycle", Nothing)- , (FieldNameHS "car", FieldNameDB "car", Nothing)- ]-- it "should parse the `entityUniques` field" $ do- let simplifyUnique unique =- (uniqueHaskell unique, uniqueFields unique)- (simplifyUnique <$> entityUniques (unboundEntityDef bicycle)) `shouldBe` []- (simplifyUnique <$> entityUniques (unboundEntityDef car)) `shouldBe`- [ (ConstraintNameHS "UniqueModel", [(FieldNameHS "model", FieldNameDB "model")])- ]- (simplifyUnique <$> entityUniques (unboundEntityDef vehicle)) `shouldBe` []-- it "should parse the `entityForeigns` field" $ do- let [user, notification] = defs [st|-User- name Text- emailFirst Text- emailSecond Text-- UniqueEmail emailFirst emailSecond--Notification- content Text- sentToFirst Text- sentToSecond Text-- Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond-|]- unboundForeignDefs user `shouldBe` []- map unboundForeignDef (unboundForeignDefs notification) `shouldBe`- [ ForeignDef- { foreignRefTableHaskell = EntityNameHS "User"- , foreignRefTableDBName = EntityNameDB "user"- , foreignConstraintNameHaskell = ConstraintNameHS "fk_noti_user"- , foreignConstraintNameDBName = ConstraintNameDB "notificationfk_noti_user"- , foreignFieldCascade = FieldCascade Nothing Nothing- , foreignFields =- []- -- the foreign fields are not set yet in an unbound- -- entity def- , foreignAttrs = []- , foreignNullable = False- , foreignToPrimary = False- }- ]-- it "should parse the `entityDerives` field" $ do- entityDerives (unboundEntityDef bicycle) `shouldBe` ["Eq"]- entityDerives (unboundEntityDef car) `shouldBe` ["Eq", "Show"]- entityDerives (unboundEntityDef vehicle) `shouldBe` []-- it "should parse the `entityEntities` field" $ do- entityExtra (unboundEntityDef bicycle) `shouldBe` Map.singleton "ExtraBike" [["foo", "bar", "-- | this is a foo bar"], ["baz"]]- entityExtra (unboundEntityDef car) `shouldBe` mempty- entityExtra (unboundEntityDef vehicle) `shouldBe` mempty-- it "should parse the `entitySum` field" $ do- entitySum (unboundEntityDef bicycle) `shouldBe` False- entitySum (unboundEntityDef car) `shouldBe` False- entitySum (unboundEntityDef vehicle) `shouldBe` True-- it "should parse the `entityComments` field" $ do- entityComments (unboundEntityDef bicycle) `shouldBe` Nothing- entityComments (unboundEntityDef car) `shouldBe` Just "This is a Car\n"- entityComments (unboundEntityDef vehicle) `shouldBe` Nothing-- it "should error on malformed input, unterminated parens" $ do- let definitions = [st|-User- name Text- age (Maybe Int-|]- let [user] = defs definitions- evaluate (unboundEntityDef user)- `shouldErrorWithMessage`- "Unterminated parens string starting with Maybe Int"-- it "errors on duplicate cascade update declarations" $ do- let definitions = [st|-User- age Int OnUpdateCascade OnUpdateCascade-|]- let [user] = defs definitions- mapM (evaluate . unboundFieldCascade) (unboundEntityFields user)- `shouldErrorWithMessage`- "found more than one OnUpdate action, tokens: [\"OnUpdateCascade\",\"OnUpdateCascade\"]"-- it "errors on duplicate cascade delete declarations" $ do- let definitions = [st|-User- age Int OnDeleteCascade OnDeleteCascade-|]- let [user] = defs definitions- mapM (evaluate . unboundFieldCascade) (unboundEntityFields user)- `shouldErrorWithMessage`- "found more than one OnDelete action, tokens: [\"OnDeleteCascade\",\"OnDeleteCascade\"]"-- describe "custom Id column" $ do- it "parses custom Id column" $ do- let definitions = [st|-User- Id Text- name Text- age Int-|]- let [user] = defs definitions- getUnboundEntityNameHS user `shouldBe` EntityNameHS "User"- entityDB (unboundEntityDef user) `shouldBe` EntityNameDB "user"- let idFields = NEL.toList (entitiesPrimary (unboundEntityDef user))- (fieldHaskell <$> idFields) `shouldBe` [FieldNameHS "Id"]- (fieldDB <$> idFields) `shouldBe` [FieldNameDB "id"]- (fieldType <$> idFields) `shouldBe` [FTTypeCon Nothing "Text"]- (unboundFieldNameHS <$> unboundEntityFields user) `shouldBe`- [ FieldNameHS "name"- , FieldNameHS "age"- ]-- it "errors on duplicate custom Id column" $ do- let definitions = [st|-User- Id Text- Id Text- name Text- age Int-|]- let [user] = defs definitions- errMsg = [st|expected only one Id declaration per entity|]- evaluate (unboundEntityDef user) `shouldErrorWithMessage`- (T.unpack errMsg)-- describe "primary declaration" $ do- it "parses Primary declaration" $ do- let definitions = [st|-User- ref Text- name Text- age Int- Primary ref-|]- let [user] = defs definitions- getUnboundEntityNameHS user `shouldBe` EntityNameHS "User"- entityDB (unboundEntityDef user) `shouldBe` EntityNameDB "user"- let idFields = NEL.toList (entitiesPrimary (unboundEntityDef user))- (fieldHaskell <$> idFields) `shouldBe` [FieldNameHS "Id"]- (fieldDB <$> idFields) `shouldBe` [FieldNameDB "id"]- (fieldType <$> idFields) `shouldBe` [FTTypeCon Nothing "UserId"]- (unboundFieldNameHS <$> unboundEntityFields user) `shouldBe`- [ FieldNameHS "ref"- , FieldNameHS "name"- , FieldNameHS "age"- ]- entityUniques (unboundEntityDef user) `shouldBe`- [ UniqueDef- { uniqueHaskell =- ConstraintNameHS "UserPrimaryKey"- , uniqueDBName =- ConstraintNameDB "primary_key"- , uniqueFields =- pure (FieldNameHS "ref", FieldNameDB "ref")- , uniqueAttrs =- []- }- ]-- it "errors on duplicate custom Primary declaration" $ do- let definitions = [st|-User- ref Text- name Text- age Int- Primary ref- Primary name-|]- let [user] = defs definitions- errMsg = "expected only one Primary declaration per entity"- evaluate (unboundEntityDef user) `shouldErrorWithMessage`- errMsg-- it "errors on conflicting Primary/Id declarations" $ do- let definitions = [st|-User- Id Text- ref Text- name Text- age Int- Primary ref-|]- let [user] = defs definitions- errMsg = [st|Specified both an ID field and a Primary field|]- evaluate (unboundEntityDef user) `shouldErrorWithMessage`- (T.unpack errMsg)-- it "triggers error on invalid declaration" $ do- let definitions = [st|-User- age Text- Primary ref-|]- let [user] = defs definitions- case unboundPrimarySpec user of- NaturalKey ucd -> do- evaluate (NEL.head $ unboundCompositeCols ucd) `shouldErrorWithMessage`- "Unknown column in primary key constraint: \"ref\""- _ ->- error "Expected NaturalKey, failing"-- describe "entity unique constraints" $ do- it "triggers error if declared field does not exist" $ do- let definitions = [st|-User- name Text- emailFirst Text-- UniqueEmail emailFirst emailSecond-|]- let [user] = defs definitions- uniques = entityUniques (unboundEntityDef user)- [dbNames] = fmap snd . uniqueFields <$> uniques- errMsg = unwords- [ "Unknown column in \"UniqueEmail\" constraint: \"emailSecond\""- , "possible fields: [\"name\",\"emailFirst\"]"- ]- evaluate (head (NEL.tail dbNames)) `shouldErrorWithMessage`- errMsg-- it "triggers error if no valid constraint name provided" $ do- let definitions = [st|-User- age Text- Unique some-|]- let [user] = defs definitions- evaluate (unboundPrimarySpec user) `shouldErrorWithMessage`- "invalid unique constraint on table[\"User\"] expecting an uppercase constraint name xs=[\"some\"]"-- describe "foreign keys" $ do- let validDefinitions = [st|-User- name Text- emailFirst Text- emailSecond Text-- UniqueEmail emailFirst emailSecond--Notification- content Text- sentToFirst Text- sentToSecond Text-- Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond-|]-- it "should allow you to modify the FK name via provided function" $ do- let- flippedFK (EntityNameHS entName) (ConstraintNameHS conName) =- conName <> entName- [_user, notification] =- parse (setPsToFKName flippedFK lowerCaseSettings) [(Nothing, validDefinitions)]- [notificationForeignDef] =- unboundForeignDef <$> unboundForeignDefs notification- foreignConstraintNameDBName notificationForeignDef- `shouldBe`- ConstraintNameDB "fk_noti_user_notification"-- it "should error when insufficient params provided" $ do- let definitions = [st|-User- name Text- emailFirst Text- emailSecond Text-- UniqueEmail emailFirst emailSecond--Notification- content Text- sentToFirst Text- sentToSecond Text- Foreign User-|]- let [_user, notification] = defsSnake definitions- mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)- `shouldErrorWithMessage`- "invalid foreign key constraint on table[\"Notification\"] expecting a lower case constraint name or a cascading action xs=[]"-- it "should error when foreign fields not provided" $ do- let definitions = [st|-User- name Text- emailFirst Text- emailSecond Text-- UniqueEmail emailFirst emailSecond--Notification- content Text- sentToFirst Text- sentToSecond Text- Foreign User fk_noti_user-|]- let [_user, notification] = defsSnake definitions- mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)- `shouldErrorWithMessage`- "No fields on foreign reference."-- it "should error when number of parent and foreign fields differ" $ do- let definitions = [st|-User- name Text- emailFirst Text- emailSecond Text-- UniqueEmail emailFirst emailSecond--Notification- content Text- sentToFirst Text- sentToSecond Text- Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst-|]- let [_user, notification] = defsSnake definitions- mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)- `shouldErrorWithMessage`- "invalid foreign key constraint on table[\"Notification\"] Found 2 foreign fields but 1 parent fields"-- it "should throw error when there is more than one delete cascade on the declaration" $ do- let definitions = [st|-User- name Text- emailFirst Text- emailSecond Text-- UniqueEmail emailFirst emailSecond--Notification- content Text- sentToFirst Text- sentToSecond Text- Foreign User OnDeleteCascade OnDeleteCascade-|]- let [_user, notification] = defsSnake definitions- mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)- `shouldErrorWithMessage`- "invalid foreign key constraint on table[\"Notification\"] found more than one OnDelete actions"-- it "should throw error when there is more than one update cascade on the declaration" $ do- let definitions = [st|-User- name Text- emailFirst Text- emailSecond Text-- UniqueEmail emailFirst emailSecond--Notification- content Text- sentToFirst Text- sentToSecond Text- Foreign User OnUpdateCascade OnUpdateCascade-|]- let [_user, notification] = defsSnake definitions- mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)- `shouldErrorWithMessage`- "invalid foreign key constraint on table[\"Notification\"] found more than one OnUpdate actions"-- it "should allow you to enable snake cased foriegn keys via a preset configuration function" $ do- let [_user, notification] =- defsSnake validDefinitions- [notificationForeignDef] =- unboundForeignDef <$> unboundForeignDefs notification- foreignConstraintNameDBName notificationForeignDef- `shouldBe`- ConstraintNameDB "notification_fk_noti_user"-- describe "ticked types" $ do- it "should be able to parse ticked types" $ do- let simplifyField field =- (unboundFieldNameHS field, unboundFieldType field)- let tickedDefinition = [st|-CustomerTransfer- customerId CustomerId- moneyAmount (MoneyAmount 'Customer 'Debit)- currencyCode CurrencyCode- uuid TransferUuid-|]- let [customerTransfer] = defs tickedDefinition- let expectedType =- FTTypeCon Nothing "MoneyAmount" `FTApp` FTTypePromoted "Customer" `FTApp` FTTypePromoted "Debit"-- (simplifyField <$> unboundEntityFields customerTransfer) `shouldBe`- [ (FieldNameHS "customerId", FTTypeCon Nothing "CustomerId")- , (FieldNameHS "moneyAmount", expectedType)- , (FieldNameHS "currencyCode", FTTypeCon Nothing "CurrencyCode")- , (FieldNameHS "uuid", FTTypeCon Nothing "TransferUuid")- ]-- describe "type literals" $ do- it "should be able to parse type literals" $ do- let simplifyField field =- (unboundFieldNameHS field, unboundFieldType field)- let tickedDefinition = [st|-WithFinite- one (Finite 1)- twenty (Labelled "twenty")-|]- let [withFinite] = defs tickedDefinition-- (simplifyField <$> unboundEntityFields withFinite) `shouldBe`- [ (FieldNameHS "one", FTApp (FTTypeCon Nothing "Finite") (FTLit (IntTypeLit 1)))- , (FieldNameHS "twenty", FTApp (FTTypeCon Nothing "Labelled") (FTLit (TextTypeLit "twenty")))- ]-- describe "parseFieldType" $ do- it "simple types" $- parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar")- it "module types" $- parseFieldType "Data.Map.FooBar" `shouldBe` Right (FTTypeCon (Just "Data.Map") "FooBar")- it "application" $- parseFieldType "Foo Bar" `shouldBe` Right (- FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar")- it "application multiple" $- parseFieldType "Foo Bar Baz" `shouldBe` Right (- (FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar")- `FTApp` FTTypeCon Nothing "Baz"- )- it "parens" $ do- let foo = FTTypeCon Nothing "Foo"- bar = FTTypeCon Nothing "Bar"- baz = FTTypeCon Nothing "Baz"- parseFieldType "Foo (Bar Baz)" `shouldBe` Right (- foo `FTApp` (bar `FTApp` baz))- it "lists" $ do- let foo = FTTypeCon Nothing "Foo"- bar = FTTypeCon Nothing "Bar"- bars = FTList bar- baz = FTTypeCon Nothing "Baz"- parseFieldType "Foo [Bar] Baz" `shouldBe` Right (- foo `FTApp` bars `FTApp` baz)- it "numeric type literals" $ do- let expected = FTApp (FTTypeCon Nothing "Finite") (FTLit (IntTypeLit 1))- parseFieldType "Finite 1" `shouldBe` Right expected- it "string type literals" $ do- let expected = FTApp (FTTypeCon Nothing "Labelled") (FTLit (TextTypeLit "twenty"))- parseFieldType "Labelled \"twenty\"" `shouldBe` Right expected- it "nested list / parens (list inside parens)" $ do- let maybeCon = FTTypeCon Nothing "Maybe"- int = FTTypeCon Nothing "Int"- parseFieldType "Maybe (Maybe [Int])" `shouldBe` Right- (maybeCon `FTApp` (maybeCon `FTApp` FTList int))- it "nested list / parens (parens inside list)" $ do- let maybeCon = FTTypeCon Nothing "Maybe"- int = FTTypeCon Nothing "Int"- parseFieldType "[Maybe (Maybe Int)]" `shouldBe` Right- (FTList (maybeCon `FTApp` (maybeCon `FTApp` int)))- it "fails on lowercase starts" $ do- parseFieldType "nothanks" `shouldBe` Left "PSFail \"nothanks\""-- describe "#1175 empty entity" $ do- let subject =- [st|-Foo- name String- age Int--EmptyEntity--Bar- name String--Baz- a Int- b String- c FooId- |]-- let preparsed =- preparse subject- it "preparse works" $ do- (length . snd <$> preparsed) `shouldBe` Just 10-- let fooLines =- [ Line- { lineIndent = 0- , tokens = Token "Foo" :| []- }- , Line- { lineIndent = 4- , tokens = Token "name" :| [Token "String"]- }- , Line- { lineIndent = 4- , tokens = Token "age" :| [Token "Int"]- }- ]- emptyLines =- [ Line- { lineIndent = 0- , tokens = Token "EmptyEntity" :| []- }- ]- barLines =- [ Line- { lineIndent = 0- , tokens = Token "Bar" :| []- }- , Line- { lineIndent = 4- , tokens = Token "name" :| [Token "String"]- }- ]- bazLines =- [ Line- { lineIndent = 0- , tokens = Token "Baz" :| []- }- , Line- { lineIndent = 4- , tokens = Token "a" :| [Token "Int"]- }- , Line- { lineIndent = 4- , tokens = Token "b" :| [Token "String"]- }- , Line- { lineIndent = 4- , tokens = Token "c" :| [Token "FooId"]- }- ]-- let- linesAssociated =- case snd <$> preparsed of- Nothing -> error "preparsed failed"- Just lines -> associateLines lines- it "associateLines works" $ do- linesAssociated `shouldMatchList`- [ LinesWithComments- { lwcLines = NEL.fromList fooLines- , lwcComments = []- }- , LinesWithComments (NEL.fromList emptyLines) []- , LinesWithComments (NEL.fromList barLines) []- , LinesWithComments (NEL.fromList bazLines) []- ]-- it "parse works" $ do- let test name'fieldCount parsedList = do- case (name'fieldCount, parsedList) of- ([], []) ->- pure ()- ((name, fieldCount) : _, []) ->- expectationFailure- $ "Expected an entity with name "- <> name- <> " and " <> show fieldCount <> " fields"- <> ", but the list was empty..."-- ((name, fieldCount) : ys, (x : xs)) -> do- let- UnboundEntityDef {..} =- x- (unEntityNameHS (getUnboundEntityNameHS x), length unboundEntityFields)- `shouldBe`- (T.pack name, fieldCount)- test ys xs- ([], _:_) ->- expectationFailure- "more entities parsed than expected"-- result =- defs subject- length result `shouldBe` 4-- test- [ ("Foo", 2)- , ("EmptyEntity", 0)- , ("Bar", 1)- , ("Baz", 3)- ]- result--- describe "preparse" $ do- prop "omits lines that are only whitespace" $ \len -> do- ws <- vectorOf len arbitraryWhiteSpaceChar- pure $ preparse (T.pack ws) === Nothing-- it "recognizes entity" $ do- let expected =- Line { lineIndent = 0, tokens = pure (Token "Person") } :|- [ Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] }- , Line { lineIndent = 2, tokens = Token "age" :| [Token "Int"] }- ]- preparse "Person\n name String\n age Int" `shouldBe` Just (3, expected)-- it "recognizes comments" $ do- let text = "Foo\n x X\n-- | Hello\nBar\n name String"- let expected =- Line { lineIndent = 0, tokens = pure (Token "Foo") } :|- [ Line { lineIndent = 2, tokens = Token "x" :| [Token "X"] }- , Line { lineIndent = 0, tokens = pure (DocComment "Hello") }- , Line { lineIndent = 0, tokens = pure (Token "Bar") }- , Line { lineIndent = 1, tokens = Token "name" :| [Token "String"] }- ]- preparse text `shouldBe` Just (5, expected)-- it "preparse indented" $ do- let t = T.unlines- [ " Foo"- , " x X"- , " -- | Comment"- , " -- hidden comment"- , " Bar"- , " name String"- ]- expected =- Line { lineIndent = 2, tokens = pure (Token "Foo") } :|- [ Line { lineIndent = 4, tokens = Token "x" :| [Token "X"] }- , Line { lineIndent = 2, tokens = pure (DocComment "Comment") }- , Line { lineIndent = 2, tokens = pure (Token "Bar") }- , Line { lineIndent = 4, tokens = Token "name" :| [Token "String"] }- ]- preparse t `shouldBe` Just (6, expected)-- it "preparse extra blocks" $ do- let t = T.unlines- [ "LowerCaseTable"- , " name String"- , " ExtraBlock"- , " foo bar"- , " baz"- , " ExtraBlock2"- , " something"- ]- expected =- Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :|- [ Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] }- , Line { lineIndent = 2, tokens = pure (Token "ExtraBlock") }- , Line { lineIndent = 4, tokens = Token "foo" :| [Token "bar"] }- , Line { lineIndent = 4, tokens = pure (Token "baz") }- , Line { lineIndent = 2, tokens = pure (Token "ExtraBlock2") }- , Line { lineIndent = 4, tokens = pure (Token "something") }- ]- preparse t `shouldBe` Just (7, expected)-- it "field comments" $ do- let text = T.unlines- [ "-- | Model"- , "Foo"- , " -- | Field"- , " name String"- ]- expected =- Line { lineIndent = 0, tokens = [DocComment "Model"] } :|- [ Line { lineIndent = 0, tokens = [Token "Foo"] }- , Line { lineIndent = 2, tokens = [DocComment "Field"] }- , Line { lineIndent = 2, tokens = (Token <$> ["name", "String"]) }- ]- preparse text `shouldBe` Just (4, expected)-- describe "associateLines" $ do- let foo =- Line- { lineIndent = 0- , tokens = pure (Token "Foo")- }- name'String =- Line- { lineIndent = 2- , tokens = Token "name" :| [Token "String"]- }- comment =- Line- { lineIndent = 0- , tokens = pure (DocComment "comment")- }- it "works" $ do- associateLines- ( comment :|- [ foo- , name'String- ])- `shouldBe`- [ LinesWithComments- { lwcComments = ["comment"]- , lwcLines = foo :| [name'String]- }- ]- let bar =- Line- { lineIndent = 0- , tokens = Token "Bar" :| [Token "sql", Token "=", Token "bars"]- }- age'Int =- Line- { lineIndent = 1- , tokens = Token "age" :| [Token "Int"]- }- it "works when used consecutively" $ do- associateLines- ( bar :|- [ age'Int- , comment- , foo- , name'String- ])- `shouldBe`- [ LinesWithComments- { lwcComments = []- , lwcLines = bar :| [age'Int]- }- , LinesWithComments- { lwcComments = ["comment"]- , lwcLines = foo :| [name'String]- }- ]- it "works with textual input" $ do- let text = snd <$> preparse "Foo\n x X\n-- | Hello\nBar\n name String"- associateLines <$> text- `shouldBe` Just- [ LinesWithComments- { lwcLines =- Line {lineIndent = 0, tokens = Token "Foo" :| []}- :| [ Line {lineIndent = 2, tokens = Token "x" :| [Token "X"]} ]- , lwcComments =- []- }- , LinesWithComments- { lwcLines =- Line {lineIndent = 0, tokens = Token "Bar" :| []}- :| [ Line {lineIndent = 1, tokens = Token "name" :| [Token "String"]}]- , lwcComments =- ["Hello"]- }- ]- it "works with extra blocks" $ do- let text = fmap snd . preparse . T.unlines $- [ "LowerCaseTable"- , " Id sql=my_id"- , " fullName Text"- , " ExtraBlock"- , " foo bar"- , " baz"- , " bin"- , " ExtraBlock2"- , " something"- ]- associateLines <$> text `shouldBe` Just- [ LinesWithComments- { lwcLines =- Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :|- [ Line { lineIndent = 4, tokens = Token "Id" :| [Token "sql=my_id"] }- , Line { lineIndent = 4, tokens = Token "fullName" :| [Token "Text"] }- , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock") }- , Line { lineIndent = 8, tokens = Token "foo" :| [Token "bar"] }- , Line { lineIndent = 8, tokens = pure (Token "baz") }- , Line { lineIndent = 8, tokens = pure (Token "bin") }- , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock2") }- , Line { lineIndent = 8, tokens = pure (Token "something") }- ]- , lwcComments = []- }- ]-- it "works with extra blocks twice" $ do- let text = fmap snd . preparse . T.unlines $- [ "IdTable"- , " Id Day default=CURRENT_DATE"- , " name Text"- , ""- , "LowerCaseTable"- , " Id sql=my_id"- , " fullName Text"- , " ExtraBlock"- , " foo bar"- , " baz"- , " bin"- , " ExtraBlock2"- , " something"- ]- associateLines <$> text `shouldBe` Just- [ LinesWithComments- { lwcLines = Line 0 (pure (Token "IdTable")) :|- [ Line 4 (Token "Id" <| Token "Day" :| [Token "default=CURRENT_DATE"])- , Line 4 (Token "name" :| [Token "Text"])- ]- , lwcComments = []- }- , LinesWithComments- { lwcLines =- Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :|- [ Line { lineIndent = 4, tokens = Token "Id" :| [Token "sql=my_id"] }- , Line { lineIndent = 4, tokens = Token "fullName" :| [Token "Text"] }- , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock") }- , Line { lineIndent = 8, tokens = Token "foo" :| [Token "bar"] }- , Line { lineIndent = 8, tokens = pure (Token "baz") }- , Line { lineIndent = 8, tokens = pure (Token "bin") }- , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock2") }- , Line { lineIndent = 8, tokens = pure (Token "something") }- ]- , lwcComments = []- }- ]--- it "works with field comments" $ do- let text = fmap snd . preparse . T.unlines $- [ "-- | Model"- , "Foo"- , " -- | Field"- , " name String"- ]- associateLines <$> text `shouldBe` Just- [ LinesWithComments- { lwcLines =- Line { lineIndent = 0, tokens = (Token "Foo") :| [] } :|- [ Line { lineIndent = 2, tokens = pure (DocComment "Field") }- , Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] }- ]- , lwcComments =- ["Model"]- }- ]---- describe "parseLines" $ do- let lines =- T.unlines- [ "-- | Comment"- , "Foo"- , " -- | Field"- , " name String"- , " age Int"- , " Extra"- , " foo bar"- , " baz"- , " Extra2"- , " something"- ]- let [subject] = defs lines- it "produces the right name" $ do- getUnboundEntityNameHS subject `shouldBe` EntityNameHS "Foo"- describe "unboundEntityFields" $ do- let fields = unboundEntityFields subject- it "has the right field names" $ do- map unboundFieldNameHS fields `shouldMatchList`- [ FieldNameHS "name"- , FieldNameHS "age"- ]- it "has comments" $ do- map unboundFieldComments fields `shouldBe`- [ Just "Field\n"- , Nothing- ]- it "has the comments" $ do- entityComments (unboundEntityDef subject) `shouldBe`- Just "Comment\n"- it "combines extrablocks" $ do- entityExtra (unboundEntityDef subject) `shouldBe` Map.fromList- [ ("Extra", [["foo", "bar"], ["baz"]])- , ("Extra2", [["something"]])- ]- describe "works with extra blocks" $ do- let [_, lowerCaseTable, idTable] =- case defs $ T.unlines- [ ""- , "IdTable"- , " Id Day default=CURRENT_DATE"- , " name Text"- , ""- , "LowerCaseTable"- , " Id sql=my_id"- , " fullName Text"- , " ExtraBlock"- , " foo bar"- , " baz"- , " bin"- , " ExtraBlock2"- , " something"- , ""- , "IdTable"- , " Id Day default=CURRENT_DATE"- , " name Text"- , ""- ] of- [a, b, c] ->- [a, b, c] :: [UnboundEntityDef]- xs ->- error- $ "Expected 3 elements in list, got: "- <> show (length xs)- <> ", list contents: \n\n" <> intercalate "\n" (map show xs)- describe "idTable" $ do- let UnboundEntityDef { unboundEntityDef = EntityDef {..}, .. } = idTable- it "has no extra blocks" $ do- entityExtra `shouldBe` mempty- it "has the right name" $ do- entityHaskell `shouldBe` EntityNameHS "IdTable"- it "has the right fields" $ do- map unboundFieldNameHS unboundEntityFields `shouldMatchList`- [ FieldNameHS "name"- ]- describe "lowerCaseTable" $ do- let UnboundEntityDef { unboundEntityDef = EntityDef {..}, ..} = lowerCaseTable- it "has the right name" $ do- entityHaskell `shouldBe` EntityNameHS "LowerCaseTable"- it "has the right fields" $ do- map unboundFieldNameHS unboundEntityFields `shouldMatchList`- [ FieldNameHS "fullName"- ]- it "has ExtraBlock" $ do- Map.lookup "ExtraBlock" entityExtra- `shouldBe` Just- [ ["foo", "bar"]- , ["baz"]- , ["bin"]- ]- it "has ExtraBlock2" $ do- Map.lookup "ExtraBlock2" entityExtra- `shouldBe` Just- [ ["something"]- ]--arbitraryWhiteSpaceChar :: Gen Char-arbitraryWhiteSpaceChar =- oneof $ pure <$> [' ', '\t', '\n', '\r']+import Data.Bifunctor+import qualified Data.List.NonEmpty as NEL+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Text as T+import Database.Persist.EntityDef.Internal+import Database.Persist.Quasi+import Database.Persist.Quasi.PersistSettings+import Database.Persist.Quasi.PersistSettings.Internal (psTabErrorLevel)+import Database.Persist.Quasi.Internal+import Database.Persist.Quasi.Internal.ModelParser+import Database.Persist.Types+import Test.Hspec+import Test.QuickCheck+import Text.Shakespeare.Text (st)+import Text.Megaparsec (errorBundlePretty, some)++defs :: T.Text -> [UnboundEntityDef]+defs = defsWithSettings lowerCaseSettings++defsSnake :: T.Text -> [UnboundEntityDef]+defsSnake = defsWithSettings $ setPsUseSnakeCaseForeignKeys lowerCaseSettings++defsWithWarnings :: PersistSettings -> T.Text -> (Set ParserWarning, [UnboundEntityDef])+defsWithWarnings ps t = case cpr of+ (warnings, Right res) -> (warnings, res)+ (_warnings, Left errs) -> error $ renderErrors errs+ where+ cpr = parse ps [(Nothing, t)]++defsWithSettings :: PersistSettings -> T.Text -> [UnboundEntityDef]+defsWithSettings ps t = snd $ defsWithWarnings ps t++#if MIN_VERSION_megaparsec(9,5,0)+warningSpecs :: Spec+warningSpecs =+ describe "Quasi" $ do+ describe "parser settings" $ do+ let+ definitions = T.pack "User\n\tId Text\n\tname String"+ (warnings, [user]) = defsWithWarnings lowerCaseSettings{ psTabErrorLevel = Just LevelWarning } definitions+ it "generates warnings" $ do+ Set.map parserWarningMessage warnings+ `shouldBe` [ "use spaces instead of tabs\n2:1:\n |\n2 | Id Text\n | ^\nunexpected tab\nexpecting valid whitespace\n"+ , "use spaces instead of tabs\n3:1:\n |\n3 | name String\n | ^\nunexpected tab\nexpecting valid whitespace\n"+ ]+#else+warningSpecs :: Spec+warningSpecs = pure ()+#endif++spec :: Spec+spec = describe "Quasi" $ do+ describe "takeColsEx" $ do+ let+ subject = takeColsEx upperCaseSettings+ it "fails on a single word" $ do+ subject ["asdf"]+ `shouldBe` Nothing+ it "errors on invalid input" $ do+ evaluate (subject ["name", "int"])+ `shouldErrorWithMessage` "Invalid field type \"int\" PSFail \"int\""+ it "works if it has a name and a type" $ do+ subject ["asdf", "Int"]+ `shouldBe` Just+ UnboundFieldDef+ { unboundFieldNameHS = FieldNameHS "asdf"+ , unboundFieldNameDB = FieldNameDB "asdf"+ , unboundFieldType = FTTypeCon Nothing "Int"+ , unboundFieldAttrs = []+ , unboundFieldStrict = True+ , unboundFieldCascade = noCascade+ , unboundFieldComments = Nothing+ , unboundFieldGenerated = Nothing+ }+ it "works if it has a name, type, and cascade" $ do+ subject ["asdf", "Int", "OnDeleteCascade", "OnUpdateCascade"]+ `shouldBe` Just+ UnboundFieldDef+ { unboundFieldNameHS = FieldNameHS "asdf"+ , unboundFieldNameDB = FieldNameDB "asdf"+ , unboundFieldType = FTTypeCon Nothing "Int"+ , unboundFieldAttrs = []+ , unboundFieldStrict = True+ , unboundFieldCascade = FieldCascade (Just Cascade) (Just Cascade)+ , unboundFieldComments = Nothing+ , unboundFieldGenerated = Nothing+ }+ it "never tries to make a refernece" $ do+ subject ["asdf", "UserId", "OnDeleteCascade"]+ `shouldBe` Just+ UnboundFieldDef+ { unboundFieldNameHS = FieldNameHS "asdf"+ , unboundFieldNameDB = FieldNameDB "asdf"+ , unboundFieldType = FTTypeCon Nothing "UserId"+ , unboundFieldAttrs = []+ , unboundFieldStrict = True+ , unboundFieldCascade = FieldCascade Nothing (Just Cascade)+ , unboundFieldComments = Nothing+ , unboundFieldGenerated = Nothing+ }++ describe "tokenization" $ do+ let+ tokenize :: String -> ParseResult [Token]+ tokenize s = do+ let (warnings, res) = runConfiguredParser defaultPersistSettings initialExtraState (some anyToken) "" s+ case res of+ Left peb ->+ (warnings, Left peb)+ Right (tokens, _acc) -> (warnings, Right tokens)++ it "handles normal words" $+ tokenize "foo bar baz"+ `shouldBe` ([], Right+ ( [ PText "foo"+ , PText "bar"+ , PText "baz"+ ]+ )+ )++ it "handles numbers" $+ tokenize "one (Finite 1)"+ `shouldBe` ([], Right+ ( [ PText "one"+ , Parenthetical "Finite 1"+ ]+ )+ )++ it "handles quotes" $+ tokenize "\"foo bar\" \"baz\""+ `shouldBe` ([], Right+ ( [ Quotation "foo bar"+ , Quotation "baz"+ ]+ )+ )++ it "handles SQL literals with no specified type" $+ tokenize "attr='[\"ab\\'cd\", 1, 2]'"+ `shouldBe` ([], Right+ ( [Equality "attr" "'[\"ab'cd\", 1, 2]'"]+ )+ )++ it "handles SQL literals with a specified type" $+ tokenize "attr='{\"\\'a\\'\": [1, 2.2, \"\\'3\\'\"]}'::type_name"+ `shouldBe` ([], Right+ ( [Equality "attr" "'{\"'a'\": [1, 2.2, \"'3'\"]}'::type_name"]+ )+ )++ it "should error if quotes are unterminated" $ do+ (fmap . first) errorBundlePretty (tokenize "\"foo bar")+ `shouldBe` ([], Left+ ( "1:9:\n |\n1 | \"foo bar\n | ^\nunexpected end of input\nexpecting '\"' or literal character\n"+ )+ )++ it "handles commas in tokens" $+ tokenize "x=COALESCE(left,right) \"baz\""+ `shouldBe` ([], Right+ ( [ Equality "x" "COALESCE(left,right)"+ , Quotation "baz"+ ]+ )+ )++ it "handles quotes mid-token" $+ tokenize "x=\"foo bar\" \"baz\""+ `shouldBe` ([], Right+ ( [ Equality "x" "foo bar"+ , Quotation "baz"+ ]+ )+ )++ it "handles escaped quotes mid-token" $+ tokenize "x=\\\"foo bar\" \"baz\""+ `shouldBe` ([], Right+ ( [ Equality "x" "\\\"foo"+ , PText "bar\""+ , Quotation "baz"+ ]+ )+ )++ it "handles unnested parentheses" $+ tokenize "(foo bar) (baz)"+ `shouldBe` ([], Right+ ( [ Parenthetical "foo bar"+ , Parenthetical "baz"+ ]+ )+ )++ it "handles unnested parentheses mid-token" $+ tokenize "x=(foo bar) (baz)"+ `shouldBe` ([], Right+ ( [ Equality "x" "foo bar"+ , Parenthetical "baz"+ ]+ )+ )++ it "handles nested parentheses" $+ tokenize "(foo (bar)) (baz)"+ `shouldBe` ([], Right+ ( [ Parenthetical "foo (bar)"+ , Parenthetical "baz"+ ]+ )+ )++ it "handles escaped quotation marks in plain tokens" $+ tokenize "foo bar\\\"baz"+ `shouldBe` ([], Right+ ( [ PText "foo"+ , PText "bar\\\"baz"+ ]+ )+ )++ it "handles escaped quotation marks in quotations" $+ tokenize "foo \"bar\\\"baz\""+ `shouldBe` ([], Right+ ( [ PText "foo"+ , Quotation "bar\"baz"+ ]+ )+ )++ it "handles escaped quotation marks in equalities" $+ tokenize "y=\"baz\\\"\""+ `shouldBe` ([], Right+ ( [ Equality "y" "baz\""+ ]+ )+ )++ it "handles escaped quotation marks in parentheticals" $+ tokenize "(foo \\\"bar)"+ `shouldBe` ([], Right+ ( [ Parenthetical "foo \\\"bar"+ ]+ )+ )++ it "handles escaped parentheses in quotations" $+ tokenize "foo \"bar\\(baz\""+ `shouldBe` ([], Right+ ( [ PText "foo"+ , Quotation "bar(baz"+ ]+ )+ )++ it "handles escaped parentheses in plain tokens" $+ tokenize "foo bar\\(baz"+ `shouldBe` ([], Right+ ( [ PText "foo"+ , PText "bar(baz"+ ]+ )+ )++ it "handles escaped parentheses in parentheticals" $+ tokenize "(foo \\(bar)"+ `shouldBe` ([], Right+ ( [ Parenthetical "foo (bar"+ ]+ )+ )++ it "handles escaped parentheses in equalities" $+ tokenize "y=baz\\("+ `shouldBe` ([], Right+ ( [ Equality "y" "baz("+ ]+ )+ )++ it "handles mid-token quote in later token" $+ tokenize "foo bar baz=(bin\")"+ `shouldBe` ([], Right+ ( [ PText "foo"+ , PText "bar"+ , Equality "baz" "bin\""+ ]+ )+ )++ describe "parser settings" $ do+ let definitions = T.pack "User\n\tId Text\n\tname String"++ describe "when configured to permit tabs" $ do+ let+ [user] = defsWithSettings lowerCaseSettings{ psTabErrorLevel = Nothing } definitions+ it "permits tab indentation" $+ getUnboundEntityNameHS user `shouldBe` EntityNameHS "User"++ describe "when configured to warn on tabs" $ do+ let+ (warnings, [user]) = defsWithWarnings lowerCaseSettings{ psTabErrorLevel = Just LevelWarning } definitions+ it "permits tab indentation" $+ getUnboundEntityNameHS user `shouldBe` EntityNameHS "User"++ describe "when configured to disallow tabs" $ do+ let+ [user] = defsWithSettings lowerCaseSettings{ psTabErrorLevel = Just LevelError } definitions+ it "rejects tab indentation" $+ evaluate (unboundEntityDef user) `shouldErrorWithMessage` "2:1:\n |\n2 | Id Text\n | ^\nunexpected tab\nexpecting valid whitespace\n\n3:1:\n |\n3 | name String\n | ^\nunexpected tab\nexpecting valid whitespace\n"++ describe "parse" $ do+ let+ subject =+ [st|+Bicycle -- | this is a bike+ brand String -- | the brand of the bike+ ExtraBike+ foo bar -- | this is a foo bar+ baz+ deriving Eq+-- | This is a Car+Car+ -- | the make of the Car+ make String+ -- | the model of the Car+ model String+ UniqueModel model+ deriving Eq Show++Vehicle+ bicycle BicycleId -- | the bike reference+ car CarId -- | the car reference++ |]+ let+ [bicycle, car, vehicle] = defs subject++ it "should parse the `entityHaskell` field" $ do+ getUnboundEntityNameHS bicycle `shouldBe` EntityNameHS "Bicycle"+ getUnboundEntityNameHS car `shouldBe` EntityNameHS "Car"+ getUnboundEntityNameHS vehicle `shouldBe` EntityNameHS "Vehicle"++ it "should parse the `entityDB` field" $ do+ entityDB (unboundEntityDef bicycle) `shouldBe` EntityNameDB "bicycle"+ entityDB (unboundEntityDef car) `shouldBe` EntityNameDB "car"+ entityDB (unboundEntityDef vehicle) `shouldBe` EntityNameDB "vehicle"++ it "should parse the `entityAttrs` field" $ do+ entityAttrs (unboundEntityDef bicycle) `shouldBe` []+ entityAttrs (unboundEntityDef car) `shouldBe` []+ entityAttrs (unboundEntityDef vehicle) `shouldBe` []++ it "should parse the `unboundEntityFields` field" $ do+ let+ simplifyField field =+ (unboundFieldNameHS field, unboundFieldNameDB field, unboundFieldComments field)+ (simplifyField <$> unboundEntityFields bicycle)+ `shouldBe` [ (FieldNameHS "brand", FieldNameDB "brand", Nothing)+ ]+ (simplifyField <$> unboundEntityFields car)+ `shouldBe` [ (FieldNameHS "make", FieldNameDB "make", Just "the make of the Car\n")+ , (FieldNameHS "model", FieldNameDB "model", Just "the model of the Car\n")+ ]+ (simplifyField <$> unboundEntityFields vehicle)+ `shouldBe` [ (FieldNameHS "bicycle", FieldNameDB "bicycle", Nothing)+ , (FieldNameHS "car", FieldNameDB "car", Nothing)+ ]++ it "should parse the `entityUniques` field" $ do+ let+ simplifyUnique unique =+ (uniqueHaskell unique, uniqueFields unique)+ (simplifyUnique <$> entityUniques (unboundEntityDef bicycle)) `shouldBe` []+ (simplifyUnique <$> entityUniques (unboundEntityDef car))+ `shouldBe` [ (ConstraintNameHS "UniqueModel", [(FieldNameHS "model", FieldNameDB "model")])+ ]+ (simplifyUnique <$> entityUniques (unboundEntityDef vehicle)) `shouldBe` []++ it "should parse the `entityForeigns` field" $ do+ let+ [user, notification] =+ defs+ [st|+User+ name Text+ emailFirst Text+ emailSecond Text+ !yes Int+ ~no Int++ UniqueEmail emailFirst emailSecond++Notification+ content Text+ sentToFirst Text+ sentToSecond Text++ Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond+|]+ unboundForeignDefs user `shouldBe` []+ map unboundForeignDef (unboundForeignDefs notification)+ `shouldBe` [ ForeignDef+ { foreignRefTableHaskell = EntityNameHS "User"+ , foreignRefTableDBName = EntityNameDB "user"+ , foreignConstraintNameHaskell = ConstraintNameHS "fk_noti_user"+ , foreignConstraintNameDBName = ConstraintNameDB "notificationfk_noti_user"+ , foreignFieldCascade = FieldCascade Nothing Nothing+ , foreignFields =+ []+ , -- the foreign fields are not set yet in an unbound+ -- entity def+ foreignAttrs = []+ , foreignNullable = False+ , foreignToPrimary = False+ }+ ]++ it "should parse the `entityDerives` field" $ do+ entityDerives (unboundEntityDef bicycle) `shouldBe` ["Eq"]+ entityDerives (unboundEntityDef car) `shouldBe` ["Eq", "Show"]+ entityDerives (unboundEntityDef vehicle) `shouldBe` []++ it "should parse the `entityEntities` field" $ do+ entityExtra (unboundEntityDef bicycle)+ `shouldBe` Map.singleton "ExtraBike" [["foo", "bar"], ["baz"]]+ entityExtra (unboundEntityDef car) `shouldBe` mempty+ entityExtra (unboundEntityDef vehicle) `shouldBe` mempty++ it "should parse the `entitySum` field" $ do+ entitySum (unboundEntityDef bicycle) `shouldBe` False+ entitySum (unboundEntityDef car) `shouldBe` False+ entitySum (unboundEntityDef vehicle) `shouldBe` True++ it "should parse the `entityComments` field" $ do+ entityComments (unboundEntityDef bicycle) `shouldBe` Nothing+ entityComments (unboundEntityDef car) `shouldBe` Just "This is a Car\n"+ entityComments (unboundEntityDef vehicle) `shouldBe` Nothing++ it "should error on malformed input, unterminated parens" $ do+ let+ definitions =+ [st|+User+ name Text+ age (Maybe Int+|]+ let+ [user] = defs definitions+ evaluate (unboundEntityDef user)+ `shouldErrorWithMessage` "4:20:\n |\n4 | age (Maybe Int\n | ^\nunexpected newline\nexpecting '!', '\"', ''', '(', ')', ',', '-', '.', ':', '[', '\\', ']', '_', '~', alphanumeric character, space, or tab\n"++ it "errors on duplicate cascade update declarations" $ do+ let+ definitions =+ [st|+User+ age Int OnUpdateCascade OnUpdateCascade+|]+ let+ [user] = defs definitions+ mapM (evaluate . unboundFieldCascade) (unboundEntityFields user)+ `shouldErrorWithMessage` "found more than one OnUpdate action, tokens: [\"OnUpdateCascade\",\"OnUpdateCascade\"]"++ it "errors on duplicate cascade delete declarations" $ do+ let+ definitions =+ [st|+User+ age Int OnDeleteCascade OnDeleteCascade+|]+ let+ [user] = defs definitions+ mapM (evaluate . unboundFieldCascade) (unboundEntityFields user)+ `shouldErrorWithMessage` "found more than one OnDelete action, tokens: [\"OnDeleteCascade\",\"OnDeleteCascade\"]"++ describe "custom Id column" $ do+ it "parses custom Id column" $ do+ let+ definitions =+ [st|+User+ Id Text+ name Text+ age Int+|]+ let+ [user] = defs definitions+ getUnboundEntityNameHS user `shouldBe` EntityNameHS "User"+ entityDB (unboundEntityDef user) `shouldBe` EntityNameDB "user"+ let+ idFields = NEL.toList (entitiesPrimary (unboundEntityDef user))+ (fieldHaskell <$> idFields) `shouldBe` [FieldNameHS "Id"]+ (fieldDB <$> idFields) `shouldBe` [FieldNameDB "id"]+ (fieldType <$> idFields) `shouldBe` [FTTypeCon Nothing "Text"]+ (unboundFieldNameHS <$> unboundEntityFields user)+ `shouldBe` [ FieldNameHS "name"+ , FieldNameHS "age"+ ]++ it "errors on duplicate custom Id column" $ do+ let+ definitions =+ [st|+User+ Id Text+ Id Text+ name Text+ age Int+|]+ let+ [user] = defs definitions+ errMsg = [st|expected only one Id declaration per entity|]+ evaluate (unboundEntityDef user)+ `shouldErrorWithMessage` (T.unpack errMsg)++ describe "primary declaration" $ do+ it "parses Primary declaration" $ do+ let+ definitions =+ [st|+User+ ref Text+ name Text+ age Int+ Primary ref+|]+ let+ [user] = defs definitions+ getUnboundEntityNameHS user `shouldBe` EntityNameHS "User"+ entityDB (unboundEntityDef user) `shouldBe` EntityNameDB "user"+ let+ idFields = NEL.toList (entitiesPrimary (unboundEntityDef user))+ (fieldHaskell <$> idFields) `shouldBe` [FieldNameHS "Id"]+ (fieldDB <$> idFields) `shouldBe` [FieldNameDB "id"]+ (fieldType <$> idFields) `shouldBe` [FTTypeCon Nothing "UserId"]+ (unboundFieldNameHS <$> unboundEntityFields user)+ `shouldBe` [ FieldNameHS "ref"+ , FieldNameHS "name"+ , FieldNameHS "age"+ ]+ entityUniques (unboundEntityDef user)+ `shouldBe` [ UniqueDef+ { uniqueHaskell =+ ConstraintNameHS "UserPrimaryKey"+ , uniqueDBName =+ ConstraintNameDB "primary_key"+ , uniqueFields =+ pure (FieldNameHS "ref", FieldNameDB "ref")+ , uniqueAttrs =+ []+ }+ ]++ it "errors on duplicate custom Primary declaration" $ do+ let+ definitions =+ [st|+User+ ref Text+ name Text+ age Int+ Primary ref+ Primary name+|]+ let+ [user] = defs definitions+ errMsg = "expected only one Primary declaration per entity"+ evaluate (unboundEntityDef user)+ `shouldErrorWithMessage` errMsg++ it "errors on conflicting Primary/Id declarations" $ do+ let+ definitions =+ [st|+User+ Id Text+ ref Text+ name Text+ age Int+ Primary ref+|]+ let+ [user] = defs definitions+ errMsg = [st|Specified both an ID field and a Primary field|]+ evaluate (unboundEntityDef user)+ `shouldErrorWithMessage` (T.unpack errMsg)++ it "triggers error on invalid declaration" $ do+ let+ definitions =+ [st|+User+ age Text+ Primary ref+|]+ let+ [user] = defs definitions+ case unboundPrimarySpec user of+ NaturalKey ucd -> do+ evaluate (NEL.head $ unboundCompositeCols ucd)+ `shouldErrorWithMessage` "Unknown column in primary key constraint: \"ref\""+ _ ->+ error "Expected NaturalKey, failing"++ describe "entity unique constraints" $ do+ it "triggers error if declared field does not exist" $ do+ let+ definitions =+ [st|+User+ name Text+ emailFirst Text++ UniqueEmail emailFirst emailSecond+|]+ let+ [user] = defs definitions+ uniques = entityUniques (unboundEntityDef user)+ [dbNames] = fmap snd . uniqueFields <$> uniques+ errMsg =+ unwords+ [ "Unknown column in \"UniqueEmail\" constraint: \"emailSecond\""+ , "possible fields: [\"name\",\"emailFirst\"]"+ ]+ evaluate (head (NEL.tail dbNames))+ `shouldErrorWithMessage` errMsg++ it "triggers error if no valid constraint name provided" $ do+ let+ definitions =+ [st|+User+ age Text+ Unique some+|]+ let+ [user] = defs definitions+ evaluate (unboundPrimarySpec user)+ `shouldErrorWithMessage` "invalid unique constraint on table[\"User\"] expecting an uppercase constraint name xs=[\"some\"]"++ describe "foreign keys" $ do+ let+ validDefinitions =+ [st|+User+ name Text+ emailFirst Text+ emailSecond Text++ UniqueEmail emailFirst emailSecond++Notification+ content Text+ sentToFirst Text+ sentToSecond Text++ Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond+|]++ it "should allow you to modify the FK name via provided function" $ do+ let+ flippedFK (EntityNameHS entName) (ConstraintNameHS conName) =+ conName <> entName+ [_user, notification] = defsWithSettings (setPsToFKName flippedFK lowerCaseSettings) validDefinitions+ [notificationForeignDef] =+ unboundForeignDef <$> unboundForeignDefs notification+ foreignConstraintNameDBName notificationForeignDef+ `shouldBe` ConstraintNameDB "fk_noti_user_notification"++ it "should error when insufficient params provided" $ do+ let+ definitions =+ [st|+User+ name Text+ emailFirst Text+ emailSecond Text++ UniqueEmail emailFirst emailSecond++Notification+ content Text+ sentToFirst Text+ sentToSecond Text+ Foreign User+|]+ let+ [_user, notification] = defsSnake definitions+ mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)+ `shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] expecting a lower case constraint name or a cascading action xs=[]"++ it "should error when foreign fields not provided" $ do+ let+ definitions =+ [st|+User+ name Text+ emailFirst Text+ emailSecond Text++ UniqueEmail emailFirst emailSecond++Notification+ content Text+ sentToFirst Text+ sentToSecond Text+ Foreign User fk_noti_user+|]+ let+ [_user, notification] = defsSnake definitions+ mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)+ `shouldErrorWithMessage` "No fields on foreign reference."++ it "should error when number of parent and foreign fields differ" $ do+ let+ definitions =+ [st|+User+ name Text+ emailFirst Text+ emailSecond Text++ UniqueEmail emailFirst emailSecond++Notification+ content Text+ sentToFirst Text+ sentToSecond Text+ Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst+|]+ let+ [_user, notification] = defsSnake definitions+ mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)+ `shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] Found 2 foreign fields but 1 parent fields"++ it+ "should throw error when there is more than one delete cascade on the declaration"+ $ do+ let+ definitions =+ [st|+User+ name Text+ emailFirst Text+ emailSecond Text++ UniqueEmail emailFirst emailSecond++Notification+ content Text+ sentToFirst Text+ sentToSecond Text+ Foreign User OnDeleteCascade OnDeleteCascade+|]+ let+ [_user, notification] = defsSnake definitions+ mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)+ `shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] found more than one OnDelete actions"++ it+ "should throw error when there is more than one update cascade on the declaration"+ $ do+ let+ definitions =+ [st|+User+ name Text+ emailFirst Text+ emailSecond Text++ UniqueEmail emailFirst emailSecond++Notification+ content Text+ sentToFirst Text+ sentToSecond Text+ Foreign User OnUpdateCascade OnUpdateCascade+|]+ let+ [_user, notification] = defsSnake definitions+ mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)+ `shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] found more than one OnUpdate actions"++ it+ "should allow you to enable snake cased foriegn keys via a preset configuration function"+ $ do+ let+ [_user, notification] =+ defsSnake validDefinitions+ [notificationForeignDef] =+ unboundForeignDef <$> unboundForeignDefs notification+ foreignConstraintNameDBName notificationForeignDef+ `shouldBe` ConstraintNameDB "notification_fk_noti_user"++ describe "ticked types" $ do+ it "should be able to parse ticked types" $ do+ let+ simplifyField field =+ (unboundFieldNameHS field, unboundFieldType field)+ let+ tickedDefinition =+ [st|+CustomerTransfer+ customerId CustomerId+ moneyAmount (MoneyAmount 'Customer 'Debit)+ currencyCode CurrencyCode+ uuid TransferUuid+|]+ let+ [customerTransfer] = defs tickedDefinition+ let+ expectedType =+ FTTypeCon Nothing "MoneyAmount"+ `FTApp` FTTypePromoted "Customer"+ `FTApp` FTTypePromoted "Debit"++ (simplifyField <$> unboundEntityFields customerTransfer)+ `shouldBe` [ (FieldNameHS "customerId", FTTypeCon Nothing "CustomerId")+ , (FieldNameHS "moneyAmount", expectedType)+ , (FieldNameHS "currencyCode", FTTypeCon Nothing "CurrencyCode")+ , (FieldNameHS "uuid", FTTypeCon Nothing "TransferUuid")+ ]++ describe "type literals" $ do+ it "should be able to parse type literals" $ do+ let+ simplifyField field =+ (unboundFieldNameHS field, unboundFieldType field)+ let+ tickedDefinition =+ [st|+WithFinite+ one (Finite 1)+ twenty (Labelled "twenty")+|]+ let+ [withFinite] = defs tickedDefinition++ (simplifyField <$> unboundEntityFields withFinite)+ `shouldBe` [ (FieldNameHS "one", FTApp (FTTypeCon Nothing "Finite") (FTLit (IntTypeLit 1)))+ ,+ ( FieldNameHS "twenty"+ , FTApp (FTTypeCon Nothing "Labelled") (FTLit (TextTypeLit "twenty"))+ )+ ]++ describe "parseFieldType" $ do+ it "simple types" $+ parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar")+ it "module types" $+ parseFieldType "Data.Map.FooBar"+ `shouldBe` Right (FTTypeCon (Just "Data.Map") "FooBar")+ it "application" $+ parseFieldType "Foo Bar"+ `shouldBe` Right+ ( FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar"+ )+ it "application multiple" $+ parseFieldType "Foo Bar Baz"+ `shouldBe` Right+ ( (FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar")+ `FTApp` FTTypeCon Nothing "Baz"+ )+ it "parens" $ do+ let+ foo = FTTypeCon Nothing "Foo"+ bar = FTTypeCon Nothing "Bar"+ baz = FTTypeCon Nothing "Baz"+ parseFieldType "Foo (Bar Baz)"+ `shouldBe` Right+ ( foo `FTApp` (bar `FTApp` baz)+ )+ it "lists" $ do+ let+ foo = FTTypeCon Nothing "Foo"+ bar = FTTypeCon Nothing "Bar"+ bars = FTList bar+ baz = FTTypeCon Nothing "Baz"+ parseFieldType "Foo [Bar] Baz"+ `shouldBe` Right+ ( foo `FTApp` bars `FTApp` baz+ )+ it "numeric type literals" $ do+ let+ expected = FTApp (FTTypeCon Nothing "Finite") (FTLit (IntTypeLit 1))+ parseFieldType "Finite 1" `shouldBe` Right expected+ it "string type literals" $ do+ let+ expected = FTApp (FTTypeCon Nothing "Labelled") (FTLit (TextTypeLit "twenty"))+ parseFieldType "Labelled \"twenty\"" `shouldBe` Right expected+ it "nested list / parens (list inside parens)" $ do+ let+ maybeCon = FTTypeCon Nothing "Maybe"+ int = FTTypeCon Nothing "Int"+ parseFieldType "Maybe (Maybe [Int])"+ `shouldBe` Right+ (maybeCon `FTApp` (maybeCon `FTApp` FTList int))+ it "nested list / parens (parens inside list)" $ do+ let+ maybeCon = FTTypeCon Nothing "Maybe"+ int = FTTypeCon Nothing "Int"+ parseFieldType "[Maybe (Maybe Int)]"+ `shouldBe` Right+ (FTList (maybeCon `FTApp` (maybeCon `FTApp` int)))+ it "fails on lowercase starts" $ do+ parseFieldType "nothanks" `shouldBe` Left "PSFail \"nothanks\""++ describe "#1175 empty entity" $ do+ let+ subject =+ [st|+Foo+ name String+ age Int++EmptyEntity++Bar+ name String++Baz+ a Int+ b String+ c FooId+ |]++ it "parse works" $ do+ let+ test name'fieldCount parsedList = do+ case (name'fieldCount, parsedList) of+ ([], []) ->+ pure ()+ ((name, fieldCount) : _, []) ->+ expectationFailure $+ "Expected an entity with name "+ <> name+ <> " and "+ <> show fieldCount+ <> " fields"+ <> ", but the list was empty..."+ ((name, fieldCount) : ys, (x : xs)) -> do+ let+ UnboundEntityDef{..} =+ x+ (unEntityNameHS (getUnboundEntityNameHS x), length unboundEntityFields)+ `shouldBe` (T.pack name, fieldCount)+ test ys xs+ ([], _ : _) ->+ expectationFailure+ "more entities parsed than expected"++ result =+ defs subject+ length result `shouldBe` 4++ test+ [ ("Foo", 2)+ , ("EmptyEntity", 0)+ , ("Bar", 1)+ , ("Baz", 3)+ ]+ result++arbitraryWhiteSpaceChar :: Gen Char+arbitraryWhiteSpaceChar =+ oneof $ pure <$> [' ', '\t', '\n', '\r'] shouldErrorWithMessage :: IO a -> String -> Expectation shouldErrorWithMessage action expectedMsg = do
test/Database/Persist/THSpec.hs view
@@ -45,6 +45,7 @@ import Database.Persist import Database.Persist.EntityDef.Internal import Database.Persist.Quasi.Internal (SourceLoc(..), sourceLocFromTHLoc)+import Database.Persist.Types.SourceSpan import Database.Persist.Sql import Database.Persist.Sql.Util import Database.Persist.TH
test/main.hs view
@@ -12,5 +12,6 @@ describe "Database" $ describe "Persist" $ do THSpec.spec QuasiSpec.spec+ QuasiSpec.warningSpecs ClassSpec.spec PersistValueSpec.spec