diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/Database/Persist/Class/PersistField.hs b/Database/Persist/Class/PersistField.hs --- a/Database/Persist/Class/PersistField.hs +++ b/Database/Persist/Class/PersistField.hs @@ -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 diff --git a/Database/Persist/Class/PersistUnique.hs b/Database/Persist/Class/PersistUnique.hs --- a/Database/Persist/Class/PersistUnique.hs +++ b/Database/Persist/Class/PersistUnique.hs @@ -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: -- diff --git a/Database/Persist/EntityDef.hs b/Database/Persist/EntityDef.hs --- a/Database/Persist/EntityDef.hs +++ b/Database/Persist/EntityDef.hs @@ -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 diff --git a/Database/Persist/Quasi.hs b/Database/Persist/Quasi.hs --- a/Database/Persist/Quasi.hs +++ b/Database/Persist/Quasi.hs @@ -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 } diff --git a/Database/Persist/Quasi/Internal.hs b/Database/Persist/Quasi/Internal.hs --- a/Database/Persist/Quasi/Internal.hs +++ b/Database/Persist/Quasi/Internal.hs @@ -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 - -- - -- - -- @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 diff --git a/Database/Persist/Quasi/Internal/ModelParser.hs b/Database/Persist/Quasi/Internal/ModelParser.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Quasi/Internal/ModelParser.hs @@ -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 diff --git a/Database/Persist/Quasi/PersistSettings.hs b/Database/Persist/Quasi/PersistSettings.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Quasi/PersistSettings.hs @@ -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 diff --git a/Database/Persist/Quasi/PersistSettings/Internal.hs b/Database/Persist/Quasi/PersistSettings/Internal.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Quasi/PersistSettings/Internal.hs @@ -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 + -- + -- + -- @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} diff --git a/Database/Persist/TH/Internal.hs b/Database/Persist/TH/Internal.hs --- a/Database/Persist/TH/Internal.hs +++ b/Database/Persist/TH/Internal.hs @@ -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 diff --git a/Database/Persist/Types.hs b/Database/Persist/Types.hs --- a/Database/Persist/Types.hs +++ b/Database/Persist/Types.hs @@ -69,7 +69,6 @@ , PersistValue(..) , ReferenceDef(..) , SqlType(..) - , Span(..) , UniqueDef(..) , UpdateException(..) , WhyNullable(..) diff --git a/Database/Persist/Types/Base.hs b/Database/Persist/Types/Base.hs --- a/Database/Persist/Types/Base.hs +++ b/Database/Persist/Types/Base.hs @@ -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. -- diff --git a/Database/Persist/Types/SourceSpan.hs b/Database/Persist/Types/SourceSpan.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Types/SourceSpan.hs @@ -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) diff --git a/Database/Persist/Types/Span.hs b/Database/Persist/Types/Span.hs deleted file mode 100644 --- a/Database/Persist/Types/Span.hs +++ /dev/null @@ -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) diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.15.1.0 +version: 2.16.0.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -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 diff --git a/test/Database/Persist/ClassSpec.hs b/test/Database/Persist/ClassSpec.hs --- a/test/Database/Persist/ClassSpec.hs +++ b/test/Database/Persist/ClassSpec.hs @@ -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))) diff --git a/test/Database/Persist/QuasiSpec.hs b/test/Database/Persist/QuasiSpec.hs --- a/test/Database/Persist/QuasiSpec.hs +++ b/test/Database/Persist/QuasiSpec.hs @@ -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 diff --git a/test/Database/Persist/THSpec.hs b/test/Database/Persist/THSpec.hs --- a/test/Database/Persist/THSpec.hs +++ b/test/Database/Persist/THSpec.hs @@ -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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -12,5 +12,6 @@ describe "Database" $ describe "Persist" $ do THSpec.spec QuasiSpec.spec + QuasiSpec.warningSpecs ClassSpec.spec PersistValueSpec.spec