From dde5b8f42cf018dff848cc0d00f26aeb8b01fae1 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Sat, 29 Mar 2025 21:34:54 +0000 Subject: [PATCH 1/2] Add test to illustrate current comments behavior --- persistent/persistent.cabal | 3 +- .../test/Database/Persist/TH/CommentSpec.hs | 69 ------ .../test/Database/Persist/TH/CommentsSpec.hs | 227 ++++++++++++++++++ .../Database/Persist/TH/EntityHaddockSpec.hs | 11 +- .../TH/EntityHaddockSpec/CommentModel.hs | 34 +++ persistent/test/Database/Persist/THSpec.hs | 4 +- 6 files changed, 275 insertions(+), 73 deletions(-) delete mode 100644 persistent/test/Database/Persist/TH/CommentSpec.hs create mode 100644 persistent/test/Database/Persist/TH/CommentsSpec.hs create mode 100644 persistent/test/Database/Persist/TH/EntityHaddockSpec/CommentModel.hs diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 6ea58bcad..aa43a4f8b 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -171,11 +171,12 @@ test-suite test Database.Persist.ClassSpec Database.Persist.PersistValueSpec Database.Persist.QuasiSpec - Database.Persist.TH.CommentSpec + Database.Persist.TH.CommentsSpec Database.Persist.TH.CompositeKeyStyleSpec Database.Persist.TH.DiscoverEntitiesSpec Database.Persist.TH.EmbedSpec Database.Persist.TH.EntityHaddockSpec + Database.Persist.TH.EntityHaddockSpec.CommentModel Database.Persist.TH.ForeignRefSpec Database.Persist.TH.ImplicitIdColSpec Database.Persist.TH.JsonEncodingSpec diff --git a/persistent/test/Database/Persist/TH/CommentSpec.hs b/persistent/test/Database/Persist/TH/CommentSpec.hs deleted file mode 100644 index 9663ac956..000000000 --- a/persistent/test/Database/Persist/TH/CommentSpec.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -haddock #-} - -module Database.Persist.TH.CommentSpec - ( CommentModel (..) - , spec - ) where - -import TemplateTestImports - -import Database.Persist.EntityDef.Internal (EntityDef(..)) -import Database.Persist.FieldDef.Internal (FieldDef(..)) - -mkPersist (sqlSettings {mpsEntityHaddocks = True}) [persistLowerCase| - --- | Doc comments work. --- | Has multiple lines. -CommentModel - -- | First line of comment on column. - -- | Second line of comment on column. - name String - - deriving Eq Show - -|] - -pass :: IO () -pass = pure () - -asIO :: IO a -> IO a -asIO = id - -spec :: Spec -spec = describe "CommentSpec" $ do - let - ed = - entityDef (Proxy @CommentModel) - it "has entity comments" $ do - entityComments ed - `shouldBe` do - Just $ mconcat - [ "Doc comments work.\n" - , "Has multiple lines.\n" - ] - - describe "fieldComments" $ do - let - [nameComments] = - map fieldComments $ entityFields ed - it "has the right name comments" $ do - nameComments - `shouldBe` do - Just $ mconcat - [ "First line of comment on column.\n" - , "Second line of comment on column.\n" - ] diff --git a/persistent/test/Database/Persist/TH/CommentsSpec.hs b/persistent/test/Database/Persist/TH/CommentsSpec.hs new file mode 100644 index 000000000..e3b5668ba --- /dev/null +++ b/persistent/test/Database/Persist/TH/CommentsSpec.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + +module Database.Persist.TH.CommentsSpec + ( spec + ) where + +import Data.Time +import TemplateTestImports + +share [mkPersist sqlSettings, mkMigrate "commentsMigrate"] [persistLowerCase| +-- -- User accounts in the system. +-- Includes auth info and basic profile data. +User + email Text + -- ^ The user's email. Must be unique. + + -- Password hash for login. + -- Stored using bcrypt or similar. + password Text + + -- When the user signed up. + createdAt UTCTime -- ^ UTC timestamp, used for auditing + + isAdmin Bool -- True if the user is an admin + +-- | Product listing +Product + -- | Stock keeping unit + sku Text + + -- | Cost of the product + price Int + + -- | Whether this product is discontinued + isActive Bool + +-- | A customer’s shipping address. +-- Multiple addresses can be associated with one customer. +ShippingAddress + customerId Text + -- ^ Reference to the customer. + street Text + -- ^ Street address, including house number. + city Text + -- ^ City name. + countryCode Text + -- ^ ISO 3166-1 alpha-2 country code. + +Upload -- | Represents an uploaded file + path Text -- | Filesystem path + uploaded UTCTime -- | when the file was uploaded + size Int -- | in bytes + mimeType Text -- | MIME type, like image/png + +-- | Tracks failed login attempts. +-- | Used for rate limiting and security audits. +LoginFailure + -- | IP address from which the attempt originated. + -- | Stored as plain text. + ipAddress Text + + -- | Number of consecutive failed attempts. + -- | Reset after a successful login. + failureCount Int + + -- | Time of the most recent failure. + -- | Used to determine lockout duration. + lastFailureAt UTCTime + +-- | User session tokens +-- Used for user authentication, these expire after a certain duration. +Session + -- | Foreign key to the user + -- Used to associate the session with a specific account. + userId UserId + + -- | Randomly generated token string + -- Should be treated as opaque and unique. + token Text + + -- | Expiry timestamp + -- The time the session will expire. + expiresAt UTCTime +|] + +spec :: Spec +spec = describe "Comments" $ do + it "User example" $ do + let edef = entityDef (Proxy :: Proxy User) + + getEntityComments edef + `shouldBe` Nothing + -- `shouldBe` Just "User accounts in the system.\nIncludes auth info and basic profile data." + + let [emailField, passwordField, createdAtField, isAdminField] = getEntityFields edef + + fieldComments emailField + `shouldBe` Nothing + -- `shouldBe` Just "The user's email. Must be unique." + + fieldComments passwordField + `shouldBe` Nothing + -- `shouldBe` Just "Password hash for login.\nStored using bcrypt or similar." + + fieldComments createdAtField + `shouldBe` Nothing + -- `shouldBe` Just "UTC timestamp, used for auditing" + + fieldComments isAdminField + `shouldBe` Nothing + -- `shouldBe` Just "True if the user is an admin" + + it "Product example" $ do + let edef = entityDef (Proxy :: Proxy Product) + + getEntityComments edef + `shouldBe` Just "Product listing\n" + + let [skuField, priceField, isActiveField] = getEntityFields edef + + fieldComments skuField + `shouldBe` Just "Stock keeping unit\n" + + fieldComments priceField + `shouldBe` Just "Cost of the product\n" + + fieldComments isActiveField + `shouldBe` Just "Whether this product is discontinued\n" + + it "ShippingAddress example" $ do + let edef = entityDef (Proxy :: Proxy ShippingAddress) + + getEntityComments edef + `shouldBe` Just "A customer’s shipping address.\n" + -- `shouldBe` Just "A customer’s shipping address.\nMultiple addresses can be associated with one customer." + + let [customerIdField, streetField, cityField, countryCodeField] = getEntityFields edef + + fieldComments customerIdField + `shouldBe` Nothing + -- `shouldBe` Just "Reference to the customer." + + fieldComments streetField + `shouldBe` Nothing + -- `shouldBe` Just "Street address, including house number." + + fieldComments cityField + `shouldBe` Nothing + -- `shouldBe` Just "City name." + + fieldComments countryCodeField + `shouldBe` Nothing + -- `shouldBe` Just "ISO 3166-1 alpha-2 country code." + + it "LoginFailure example" $ do + let edef = entityDef (Proxy :: Proxy LoginFailure) + + getEntityComments edef + `shouldBe` Just "Tracks failed login attempts.\nUsed for rate limiting and security audits.\n" + + let [ipAddressField, failureCountField, lastFailureAtField] = getEntityFields edef + + fieldComments ipAddressField + `shouldBe` Just "IP address from which the attempt originated.\nStored as plain text.\n" + + fieldComments failureCountField + `shouldBe` Just "Number of consecutive failed attempts.\nReset after a successful login.\n" + + fieldComments lastFailureAtField + `shouldBe` Just "Time of the most recent failure.\nUsed to determine lockout duration.\n" + + it "Session entity comments" $ do + let edef = entityDef (Proxy :: Proxy Session) + + getEntityComments edef + `shouldBe` Just "User session tokens\n" + -- `shouldBe` Just "User session tokens\nUsed for user authentication, these expire after a certain duration." + + let [userIdField, tokenField, expiresAtField] = getEntityFields edef + + fieldComments userIdField + `shouldBe` Just "Foreign key to the user\n" + -- `shouldBe` Just "Foreign key to the user\nUsed to associate the session with a specific account." + + fieldComments tokenField + `shouldBe` Just "Randomly generated token string\n" + -- `shouldBe` Just "Randomly generated token string\nShould be treated as opaque and unique." + + fieldComments expiresAtField + `shouldBe` Just "Expiry timestamp\n" + -- `shouldBe` Just "Expiry timestamp\nThe time the session will expire." + + it "Upload with inline comments" $ do + let edef = entityDef (Proxy :: Proxy Upload) + + getEntityComments edef + `shouldBe` Nothing + -- `shouldBe` Just "Represents an uploaded file" + + let [pathField, uploadedField, sizeField, mimeField] = getEntityFields edef + + fieldComments pathField + `shouldBe` Nothing + -- `shouldBe` Just "Filesystem path" + + fieldComments uploadedField + `shouldBe` Nothing + -- `shouldBe` Just "when the file was uploaded" + + fieldComments sizeField + `shouldBe` Nothing + -- `shouldBe` Just "in bytes" + + fieldComments mimeField + `shouldBe` Nothing + -- `shouldBe` Just "MIME type, like image/png" + diff --git a/persistent/test/Database/Persist/TH/EntityHaddockSpec.hs b/persistent/test/Database/Persist/TH/EntityHaddockSpec.hs index c7088c7a4..04606d73d 100644 --- a/persistent/test/Database/Persist/TH/EntityHaddockSpec.hs +++ b/persistent/test/Database/Persist/TH/EntityHaddockSpec.hs @@ -1,12 +1,21 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -haddock #-} module Database.Persist.TH.EntityHaddockSpec (spec) where import TemplateTestImports +import Database.Persist.TH.EntityHaddockSpec.CommentModel #if MIN_VERSION_template_haskell(2,18,0) -import Database.Persist.TH.CommentSpec (CommentModel (..)) import Language.Haskell.TH (DocLoc (DeclDoc), getDoc) import Language.Haskell.TH.Syntax (lift) diff --git a/persistent/test/Database/Persist/TH/EntityHaddockSpec/CommentModel.hs b/persistent/test/Database/Persist/TH/EntityHaddockSpec/CommentModel.hs new file mode 100644 index 000000000..0340a6978 --- /dev/null +++ b/persistent/test/Database/Persist/TH/EntityHaddockSpec/CommentModel.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -haddock #-} + +module Database.Persist.TH.EntityHaddockSpec.CommentModel + ( CommentModel (..) + ) where + +import TemplateTestImports + +mkPersist (sqlSettings {mpsEntityHaddocks = True}) [persistLowerCase| + +-- | Doc comments work. +-- | Has multiple lines. +CommentModel + -- | First line of comment on column. + -- | Second line of comment on column. + name String + + deriving Eq Show + +|] diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index 77a330fdd..f2b9b378e 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -50,7 +50,7 @@ import Database.Persist.Sql.Util import Database.Persist.TH import TemplateTestImports -import qualified Database.Persist.TH.CommentSpec as CommentSpec +import qualified Database.Persist.TH.CommentsSpec as CommentsSpec import qualified Database.Persist.TH.CompositeKeyStyleSpec as CompositeKeyStyleSpec import qualified Database.Persist.TH.DiscoverEntitiesSpec as DiscoverEntitiesSpec import qualified Database.Persist.TH.EmbedSpec as EmbedSpec @@ -217,7 +217,7 @@ spec = describe "THSpec" $ do ForeignRefSpec.spec ToFromPersistValuesSpec.spec JsonEncodingSpec.spec - CommentSpec.spec + CommentsSpec.spec EntityHaddockSpec.spec CompositeKeyStyleSpec.spec it "QualifiedReference" $ do From 54be9d68125984249587f81971269f1c7c599a4a Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Tue, 1 Apr 2025 21:48:16 +0100 Subject: [PATCH 2/2] Refactor entity block parsing --- persistent/Database/Persist/Quasi/Internal.hs | 393 ++++----- persistent/test/Database/Persist/QuasiSpec.hs | 748 +++++++++--------- .../test/Database/Persist/TH/CommentsSpec.hs | 15 +- 3 files changed, 607 insertions(+), 549 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index bca36e546..c959e5b0f 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -20,16 +20,13 @@ module Database.Persist.Quasi.Internal , upperCaseSettings , lowerCaseSettings , toFKNameInfixed - , Token (..) , Line (..) + , Comment(..) , SourceLoc(..) , sourceLocFromTHLoc , preparse , parseLine , parseFieldType - , associateLines - , LinesWithComments(..) - , parseEntityFields , takeColsEx -- * UnboundEntityDef , UnboundEntityDef(..) @@ -51,6 +48,9 @@ module Database.Persist.Quasi.Internal , mkKeyConType , isHaskellUnboundField , FieldTypeLit(..) + , parseEntityDefs + , ParsedEntityDef(..) + , ParsedFieldDef(..) ) where import Prelude hiding (lines) @@ -219,7 +219,6 @@ sourceLocFromTHLoc :: Loc -> SourceLoc sourceLocFromTHLoc Loc {loc_filename=filename, loc_start=start} = SourceLoc {locFile = T.pack filename, locStartLine = fst start, locStartCol = snd start} - -- | Parses a quasi-quoted syntax into a list of entity definitions. parse :: PersistSettings -> [(Maybe SourceLoc, Text)] -> [UnboundEntityDef] parse ps blocks = @@ -227,7 +226,7 @@ parse ps blocks = where handleBlock (mLoc, block) = maybe [] - (\(numLines, lns) -> parseLines ps (approximateSpan numLines block <$> mLoc) lns) + (\(numLines, lns) -> parseLines (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 @@ -245,26 +244,52 @@ parse ps blocks = , spanEndCol = (+ 1) . T.length . T.takeWhileEnd (/= '\n') $ block } + parseLines mSpan lines = + mkUnboundEntityDef ps <$> parseEntityDefs mSpan lines + 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)) + lns <- NEL.nonEmpty (mapMaybe parseLine (T.lines txt)) + pure (length lns, lns) parseLine :: Text -> Maybe Line parseLine txt = do - Line (parseIndentationAmount txt) <$> NEL.nonEmpty (tokenize txt) + guard (not (tokens == [] && comments == Nothing)) + pure $ Line + { lineIndent = parseIndentationAmount txt + , lineTokens = tokens + , lineComment = comments + } + where + tokens = tokenize rawTokens + (rawTokens, comments) = splitComment txt + +splitComment :: Text -> (Text, Maybe Comment) +splitComment t + | Just c <- parseComment "-- |" t = ("", Just c) + | Just c <- parseComment "-- ^" t = ("", Just c) + | Just c <- parseComment "--" t = ("", Just c) -- Comment until the end of the line. + | Just c <- parseComment "#" t = ("", Just c) -- Also comment to the end of the line, needed for a CPP bug (#110) + | otherwise = + case T.uncons t of + Nothing -> ("", Nothing) + Just (c, rest) -> do + let (a, comms) = splitComment rest + in (T.cons c a, comms) + where + parseComment sep txt = do + t' <- T.stripPrefix sep txt + pure (Comment sep (T.stripStart t')) -- | 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. +data Comment = Comment Text Text deriving (Show, Eq) -tokenText :: Token -> Text -tokenText tok = - case tok of - Token t -> t - DocComment t -> "-- | " <> t +toDocComment :: Comment -> Maybe Text +toDocComment c = + case c of + Comment "-- |" t -> pure t + _ -> mempty parseIndentationAmount :: Text -> Int parseIndentationAmount txt = @@ -272,27 +297,25 @@ parseIndentationAmount txt = in T.length spaces -- | Tokenize a string. -tokenize :: Text -> [Token] +tokenize :: Text -> [Text] 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.null t = mempty | 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 - + | isSpace (T.head t) = tokenize (T.dropWhile isSpace t) + | Just res <- handleMidToken t = res | otherwise = let (token, rest) = T.break isSpace t - in Token token : tokenize rest + in token : tokenize rest where + -- | support mid-token quotes and parens + handleMidToken :: Text -> Maybe [Text] + handleMidToken t' = do + (beforeEquals, afterEquals) <- findMidToken t' + guard (not (T.any isSpace beforeEquals)) + next :| rest <- NEL.nonEmpty (tokenize afterEquals) + pure (T.concat [beforeEquals, "=", next] : rest) + findMidToken :: Text -> Maybe (Text, Text) findMidToken t' = case T.break (== '=') t' of @@ -300,24 +323,24 @@ tokenize t | "\"" `T.isPrefixOf` y || "(" `T.isPrefixOf` y -> Just (x, y) _ -> Nothing - quotes :: Text -> ([Text] -> [Text]) -> [Token] + quotes :: Text -> ([Text] -> [Text]) -> [Text] 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.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 :: Int -> Text -> ([Text] -> [Text]) -> [Text] 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') + then (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 . ("(":)) @@ -329,30 +352,40 @@ tokenize t -- | A line of parsed tokens data Line = Line - { lineIndent :: Int - , tokens :: NonEmpty Token + { lineIndent :: Int + -- ^ Indentation of the line + + , lineTokens :: [Text] + -- ^ Non-comment content of the line + + , lineComment :: Maybe Comment + -- ^ Comment contained in the line } deriving (Eq, Show) -lineText :: Line -> NonEmpty Text -lineText = fmap tokenText . tokens +foldLineComment :: Line -> [Comment] +foldLineComment = maybe [] pure . lineComment + +lineIsOnlyComment :: Line -> Maybe Comment +lineIsOnlyComment line = do + guard (lineTokens line == []) + lineComment line 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] + { parsedEntityDefComments :: [Comment] , parsedEntityDefEntityName :: EntityNameHS , parsedEntityDefIsSum :: Bool , parsedEntityDefEntityAttributes :: [Attr] - , parsedEntityDefFieldAttributes :: [[Token]] + , parsedEntityDefFieldAttributes :: [ParsedFieldDef] , parsedEntityDefExtras :: M.Map Text [ExtraLine] , parsedEntityDefSpan :: Maybe Span - } + } deriving (Show, Eq) + +parsedEntityDefDocComments :: ParsedEntityDef -> [Text] +parsedEntityDefDocComments pd = + mapMaybe toDocComment (parsedEntityDefComments pd) entityNamesFromParsedDef :: PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB) entityNamesFromParsedDef ps parsedEntDef = (entNameHS, entNameDB) @@ -363,103 +396,98 @@ entityNamesFromParsedDef ps parsedEntDef = (entNameHS, entNameDB) entNameDB = 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 - } +parseEntityDefs :: Maybe Span -> NonEmpty Line -> [ParsedEntityDef] +parseEntityDefs mSpan lines = + mapMaybe (parseEntityDef mSpan) (associateLines lines) + +parseEntityDef :: Maybe Span -> EntityDefBlock -> Maybe ParsedEntityDef +parseEntityDef mSpan entDefBlock = do + let entityLine = entityDefBlockEntityLine entDefBlock + entityComments = entityDefBlockEntityComments entDefBlock + (entityName :| entAttribs) <- NEL.nonEmpty (lineTokens entityLine) + let (isSum, entNameHS) = + case T.uncons entityName of + Just ('+', x) -> (True, EntityNameHS x) + _ -> (False, EntityNameHS entityName) + + pure $ ParsedEntityDef + { parsedEntityDefComments = entityComments + , parsedEntityDefEntityName = entNameHS + , parsedEntityDefIsSum = isSum + , parsedEntityDefEntityAttributes = entAttribs + , parsedEntityDefFieldAttributes = attribs + , parsedEntityDefExtras = extras + , parsedEntityDefSpan = mSpan + } 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 + parseEntityFields (entityDefBlockFieldLines entDefBlock) -data LinesWithComments = LinesWithComments - { lwcLines :: NonEmpty Line - , lwcComments :: [Text] +data EntityDefBlock = EntityDefBlock + { entityDefBlockEntityLine :: Line + , entityDefBlockEntityComments :: [Comment] + , entityDefBlockFieldLines :: [Line] } 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) } +parseNewEntityDefBlock :: Int -> Line -> [Line] -> Maybe EntityDefBlock +parseNewEntityDefBlock baseIndent line fieldLines = + if lineIndent line == baseIndent && lineTokens line /= [] + then Just $ EntityDefBlock line (maybe [] pure (lineComment line)) fieldLines + else Nothing + +lineIsEntityComment :: Int -> Line -> Maybe Comment +lineIsEntityComment indent line = do + comment <- lineIsOnlyComment line + guard (lineIndent line == indent) + pure comment + +consEntityComment :: Comment -> EntityDefBlock -> EntityDefBlock +consEntityComment comment edb = edb { entityDefBlockEntityComments = comment : entityDefBlockEntityComments edb } + +associateLines :: NonEmpty Line -> [EntityDefBlock] +associateLines inputLines = + case result of + Just blocks -> NEL.toList blocks + _ -> [] + where + baseIndent :: Int + baseIndent = lowestIndent inputLines + + result :: Maybe (NonEmpty EntityDefBlock) + result = snd $ foldr processLine (mempty, mempty) inputLines + + processLine :: Line -> ([Line], Maybe (NonEmpty EntityDefBlock)) -> ([Line], Maybe (NonEmpty EntityDefBlock)) + processLine nextLine (accFieldLines, definitions) = + case definitions of + Nothing -> parseInitialLine nextLine accFieldLines + Just defs -> parseNextLine nextLine accFieldLines defs + + -- | the function has not encountered a top level entity definition line yet + -- create an EntityDefBlock when it does, otherwise accumulate the lines until we do + parseInitialLine :: Line -> [Line] -> ([Line], Maybe (NonEmpty EntityDefBlock)) + parseInitialLine nextLine accFieldLines = + case parseNewEntityDefBlock baseIndent nextLine accFieldLines of + Just block -> ([], Just (pure block)) + Nothing -> (nextLine : accFieldLines, Nothing) + + -- | We have parsed at least one EntityDefBlock + parseNextLine :: Line -> [Line] -> NonEmpty EntityDefBlock -> ([Line], Maybe (NonEmpty EntityDefBlock)) + parseNextLine nextLine accFieldLines defs@(currentDef :| rest) = + case lineIsEntityComment baseIndent nextLine of + + -- | The next line we encountered was a comment so append it to the current EntityDefBlock + Just comment -> + (accFieldLines, Just (consEntityComment comment currentDef :| rest)) -consComment :: Text -> LinesWithComments -> LinesWithComments -consComment l lwc = lwc { lwcComments = l : lwcComments lwc } + Nothing -> + case parseNewEntityDefBlock baseIndent nextLine accFieldLines of + -- | The next line is an entity definition, so start a new EntityDefBlock + Just block -> + ([], Just (NEL.cons block defs)) -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 + -- | We didn't parse any entity related stuff, so just accumulate the line + Nothing -> + (nextLine : accFieldLines, Just defs) -- | An 'EntityDef' produced by the QuasiQuoter. It contains information that -- the QuasiQuoter is capable of knowing about the entities. It is inherently @@ -732,7 +760,7 @@ mkUnboundEntityDef ps parsedEntDef = (Nothing, Nothing) -> DefaultKey (FieldNameDB $ psIdName ps) , unboundEntityFields = - cols + unboundFieldDefs , unboundEntityDefSpan = parsedEntityDefSpan parsedEntDef , unboundEntityDef = EntityDef @@ -750,11 +778,11 @@ mkUnboundEntityDef ps parsedEntDef = [] , entityUniques = entityConstraintDefsUniquesList entityConstraintDefs , entityForeigns = [] - , entityDerives = concat $ mapMaybe takeDerives textAttribs + , entityDerives = concat $ mapMaybe takeDerives attribs , entityExtra = parsedEntityDefExtras parsedEntDef , entitySum = parsedEntityDefIsSum parsedEntDef , entityComments = - case parsedEntityDefComments parsedEntDef of + case parsedEntityDefDocComments parsedEntDef of [] -> Nothing comments -> Just (T.unlines comments) , entitySpan = parsedEntityDefSpan parsedEntDef @@ -767,12 +795,8 @@ mkUnboundEntityDef ps parsedEntDef = attribs = parsedEntityDefFieldAttributes parsedEntDef - textAttribs :: [[Text]] - textAttribs = - fmap tokenText <$> attribs - entityConstraintDefs = - foldMap (maybe mempty (takeConstraint ps entNameHS cols) . NEL.nonEmpty) textAttribs + foldMap (maybe mempty (takeConstraint ps entNameHS unboundFieldDefs) . NEL.nonEmpty . parsedFieldDefTokens) attribs idField = case entityConstraintDefsIdField entityConstraintDefs of @@ -786,8 +810,8 @@ mkUnboundEntityDef ps parsedEntDef = SetOnce a -> Just a NotSet -> Nothing - cols :: [UnboundFieldDef] - cols = reverse . fst . foldr (associateComments ps) ([], []) $ reverse attribs + unboundFieldDefs :: [UnboundFieldDef] + unboundFieldDefs = mapMaybe (unboundFromParsedFieldDef ps) attribs autoIdField :: FieldDef autoIdField = @@ -864,27 +888,16 @@ unbindIdDef entityName fd = 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, []) +unboundFromParsedFieldDef :: PersistSettings -> ParsedFieldDef -> Maybe UnboundFieldDef +unboundFromParsedFieldDef ps parsedFieldDef = do + unbound <- takeColsEx ps (parsedFieldDefTokens parsedFieldDef) + pure $ setFieldComments (parsedFieldDefComments parsedFieldDef) unbound -setFieldComments :: [Text] -> UnboundFieldDef -> UnboundFieldDef +setFieldComments :: [Comment] -> UnboundFieldDef -> UnboundFieldDef setFieldComments xs fld = - case xs of + case mapMaybe toDocComment xs of [] -> fld - _ -> fld { unboundFieldComments = Just (T.unlines xs) } + docComments -> fld { unboundFieldComments = Just (T.unlines docComments) } mkAutoIdField :: PersistSettings -> EntityNameHS -> SqlType -> FieldDef mkAutoIdField ps = @@ -913,27 +926,53 @@ mkAutoIdField' dbName entName idSqlType = keyConName :: EntityNameHS -> Text keyConName entName = unEntityNameHS entName `mappend` "Id" +data ParsedFieldDef = ParsedFieldDef + { parsedFieldDefTokens :: [Text] + , parsedFieldDefComments :: [Comment] + } deriving (Show, Eq) + parseEntityFields :: [Line] - -> ([[Token]], M.Map Text [ExtraLine]) + -> ([ParsedFieldDef], M.Map Text [ExtraLine]) parseEntityFields lns = case lns of [] -> ([], M.empty) (line : rest) -> - case NEL.toList (tokens line) of - [Token name] + case lineTokens line of + [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) + in (x, M.insert name (lineTokens <$> children) y) + _ -> do + let (xs, extras) = parseEntityFields rest + ents = parseEntityField xs line + in (ents, extras) isCapitalizedText :: Text -> Bool isCapitalizedText t = not (T.null t) && isUpper (T.head t) +parseEntityField :: [ParsedFieldDef] -> Line -> [ParsedFieldDef] +parseEntityField currParsed line = + case currParsed of + [] -> + pure $ ParsedFieldDef + { parsedFieldDefTokens = lineTokens line + , parsedFieldDefComments = foldLineComment line + } + curr : xs -> + case lineTokens line of + [] -> + curr { parsedFieldDefComments = foldLineComment line <> parsedFieldDefComments curr } : xs + tokens -> + let fieldDef = + ParsedFieldDef + { parsedFieldDefTokens = tokens + , parsedFieldDefComments = foldLineComment line + } + in fieldDef : curr : xs + takeColsEx :: PersistSettings -> [Text] -> Maybe UnboundFieldDef takeColsEx = takeCols @@ -1546,9 +1585,11 @@ parseCascadeAction prfx text = do CascadeUpdate -> "Update" CascadeDelete -> "Delete" -takeDerives :: [Text] -> Maybe [Text] -takeDerives ("deriving":rest) = Just rest -takeDerives _ = Nothing +takeDerives :: ParsedFieldDef -> Maybe [Text] +takeDerives fieldDef = + case parsedFieldDefTokens fieldDef of + ("deriving":rest) -> Just rest + _ -> Nothing -- | Returns 'True' if the 'UnboundFieldDef' does not have a 'MigrationOnly' or -- 'SafeToRemove' flag from the QuasiQuoter. diff --git a/persistent/test/Database/Persist/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs index b38aca598..d9aa20782 100644 --- a/persistent/test/Database/Persist/QuasiSpec.hs +++ b/persistent/test/Database/Persist/QuasiSpec.hs @@ -9,8 +9,9 @@ import Prelude hiding (lines) import Control.Exception import Data.List hiding (lines) -import Data.List.NonEmpty (NonEmpty(..), (<|)) +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as Map import qualified Data.Text as T import Database.Persist.EntityDef.Internal @@ -18,9 +19,8 @@ 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) +import Text.Shakespeare.Text (st, sbt) defs :: T.Text -> [UnboundEntityDef] defs t = parse lowerCaseSettings [(Nothing, t)] @@ -28,61 +28,19 @@ defs t = parse lowerCaseSettings [(Nothing, t)] defsSnake :: T.Text -> [UnboundEntityDef] defsSnake t = parse (setPsUseSnakeCaseForeignKeys lowerCaseSettings) [(Nothing, t)] +parseLines :: T.Text -> NonEmpty Line +parseLines txt = + fromMaybe (error "parseLines failed to parse any lines") $ do + NEL.nonEmpty (mapMaybe parseLine (T.lines txt)) + +expectLength :: MonadFail m => Int -> T.Text -> [a] -> m [a] +expectLength n description els = + if length els == n + then pure els + else fail $ "Expected there to be " <> show n <> " " <> T.unpack description <> " but there were " <> show (length els) 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 @@ -139,29 +97,41 @@ spec = describe "Quasi" $ do it "handles normal words" $ parseLine " foo bar baz" `shouldBe` Just - ( Line 1 - [ Token "foo" - , Token "bar" - , Token "baz" - ] + ( Line + { lineIndent = 1 + , lineTokens = + [ "foo" + , "bar" + , "baz" + ] + , lineComment = Nothing + } ) it "handles numbers" $ parseLine " one (Finite 1)" `shouldBe` Just - ( Line 2 - [ Token "one" - , Token "Finite 1" - ] + ( Line + { lineIndent = 2 + , lineTokens = + [ "one" + , "Finite 1" + ] + , lineComment = Nothing + } ) it "handles quotes" $ parseLine " \"foo bar\" \"baz\"" `shouldBe` Just - ( Line 2 - [ Token "foo bar" - , Token "baz" - ] + ( Line + { lineIndent = 2 + , lineTokens = + [ "foo bar" + , "baz" + ] + , lineComment = Nothing + } ) it "should error if quotes are unterminated" $ do @@ -172,87 +142,126 @@ spec = describe "Quasi" $ do it "handles quotes mid-token" $ parseLine " x=\"foo bar\" \"baz\"" `shouldBe` Just - ( Line 2 - [ Token "x=foo bar" - , Token "baz" - ] + ( Line + { lineIndent = 2 + , lineTokens = + [ "x=foo bar" + , "baz" + ] + , lineComment = Nothing + } ) it "handles escaped quote mid-token" $ parseLine " x=\\\"foo bar\" \"baz\"" `shouldBe` Just - ( Line 2 - [ Token "x=\\\"foo" - , Token "bar\"" - , Token "baz" - ] + ( Line + { lineIndent = 2 + , lineTokens = + [ "x=\\\"foo" + , "bar\"" + , "baz" + ] + , lineComment = Nothing + } ) it "handles unnested parantheses" $ parseLine " (foo bar) (baz)" `shouldBe` Just - ( Line 2 - [ Token "foo bar" - , Token "baz" - ] + ( Line + { lineIndent = 2 + , lineTokens = + [ "foo bar" + , "baz" + ] + , lineComment = Nothing + } ) it "handles unnested parantheses mid-token" $ parseLine " x=(foo bar) (baz)" `shouldBe` Just - ( Line 2 - [ Token "x=foo bar" - , Token "baz" - ] + ( Line + { lineIndent = 2 + , lineTokens = + [ "x=foo bar" + , "baz" + ] + , lineComment = Nothing + } ) it "handles nested parantheses" $ parseLine " (foo (bar)) (baz)" `shouldBe` Just - ( Line 2 - [ Token "foo (bar)" - , Token "baz" - ] + ( Line + { lineIndent = 2 + , lineTokens = + [ "foo (bar)" + , "baz" + ] + , lineComment = Nothing + } ) it "escaping" $ parseLine " (foo \\(bar) y=\"baz\\\"\"" `shouldBe` Just - ( Line 2 - [ Token "foo (bar" - , Token "y=baz\"" - ] + ( Line + { lineIndent = 2 + , lineTokens = + [ "foo (bar" + , "y=baz\"" + ] + , lineComment = Nothing + } ) it "mid-token quote in later token" $ parseLine "foo bar baz=(bin\")" `shouldBe` Just - ( Line 0 - [ Token "foo" - , Token "bar" - , Token "baz=bin\"" - ] + ( Line + { lineIndent = 0 + , lineTokens = + [ "foo" + , "bar" + , "baz=bin\"" + ] + , lineComment = Nothing + } ) describe "comments" $ do it "recognizes one line" $ do parseLine "-- | this is a comment" `shouldBe` Just - ( Line 0 - [ DocComment "this is a comment" - ] + ( Line + { lineIndent = 0 + , lineTokens = [] + , lineComment = Just (Comment "-- |" "this is a comment") + } ) + it "recognizes empty line" $ do parseLine "-- |" `shouldBe` Just - ( Line 0 - [ DocComment "" - ] + ( Line + { lineIndent = 0 + , lineTokens = [] + , lineComment = Just (Comment "-- |" "") + } ) it "works if comment is indented" $ do parseLine " -- | comment" `shouldBe` - Just (Line 2 [DocComment "comment"]) + Just + ( Line + { lineIndent = 2 + , lineTokens = [] + , lineComment = Just (Comment "-- |" "comment") + } + ) describe "parse" $ do let subject = @@ -289,7 +298,7 @@ Car entityDB (unboundEntityDef vehicle) `shouldBe` EntityNameDB "vehicle" it "should parse the `entityAttrs` field" $ do - entityAttrs (unboundEntityDef bicycle) `shouldBe` ["-- | this is a bike"] + entityAttrs (unboundEntityDef bicycle) `shouldBe` [] entityAttrs (unboundEntityDef car) `shouldBe` [] entityAttrs (unboundEntityDef vehicle) `shouldBe` [] @@ -297,15 +306,15 @@ Car let simplifyField field = (unboundFieldNameHS field, unboundFieldNameDB field, unboundFieldComments field) (simplifyField <$> unboundEntityFields bicycle) `shouldBe` - [ (FieldNameHS "brand", FieldNameDB "brand", Nothing) + [ (FieldNameHS "brand", FieldNameDB "brand", Just "the brand of the bike\n") ] (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) + [ (FieldNameHS "bicycle", FieldNameDB "bicycle", Just "the bike reference\n") + , (FieldNameHS "car", FieldNameDB "car", Just "the car reference\n") ] it "should parse the `entityUniques` field" $ do @@ -357,7 +366,7 @@ Notification 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 bicycle) `shouldBe` Map.singleton "ExtraBike" [["foo", "bar"], ["baz"]] entityExtra (unboundEntityDef car) `shouldBe` mempty entityExtra (unboundEntityDef vehicle) `shouldBe` mempty @@ -367,7 +376,7 @@ Notification entitySum (unboundEntityDef vehicle) `shouldBe` True it "should parse the `entityComments` field" $ do - entityComments (unboundEntityDef bicycle) `shouldBe` Nothing + entityComments (unboundEntityDef bicycle) `shouldBe` Just "this is a bike\n" entityComments (unboundEntityDef car) `shouldBe` Just "This is a Car\n" entityComments (unboundEntityDef vehicle) `shouldBe` Nothing @@ -779,75 +788,44 @@ Baz c FooId |] - let preparsed = - preparse subject + let preparsed = parseLines subject + it "preparse works" $ do - (length . snd <$> preparsed) `shouldBe` Just 10 + length preparsed `shouldBe` 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"] - } - ] + it "parseEntityDefs works" $ do + let simplifyParsedFieldDef pfa = + (parsedFieldDefTokens pfa, parsedFieldDefComments pfa) - 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) [] - ] + let parsedDefs = parseEntityDefs Nothing preparsed + + [fooDef, emptyEntityDef, barDef, bazDef] <- expectLength 4 "parsed definitions" parsedDefs + + parsedEntityDefEntityName fooDef `shouldBe` EntityNameHS "Foo" + parsedEntityDefComments fooDef `shouldBe` [] + + [fooName, fooAge] <- expectLength 2 "Foo fields" (parsedEntityDefFieldAttributes fooDef) + simplifyParsedFieldDef fooName `shouldBe` (["name", "String"], []) + simplifyParsedFieldDef fooAge `shouldBe` (["age", "Int"], []) + + parsedEntityDefEntityName emptyEntityDef `shouldBe` EntityNameHS "EmptyEntity" + parsedEntityDefComments emptyEntityDef `shouldBe` [] + + [] <- expectLength 0 "EmptyEntity fields" (parsedEntityDefFieldAttributes emptyEntityDef) + + parsedEntityDefEntityName barDef `shouldBe` EntityNameHS "Bar" + parsedEntityDefComments barDef `shouldBe` [] + + [barName] <- expectLength 1 "Bar fields" (parsedEntityDefFieldAttributes barDef) + simplifyParsedFieldDef barName `shouldBe` (["name", "String"], []) + + parsedEntityDefEntityName bazDef `shouldBe` EntityNameHS "Baz" + parsedEntityDefComments bazDef `shouldBe` [] + + [bazA, bazB, bazC] <- expectLength 3 "Baz fields" (parsedEntityDefFieldAttributes bazDef) + simplifyParsedFieldDef bazA `shouldBe` (["a", "Int"], []) + simplifyParsedFieldDef bazB `shouldBe` (["b", "String"], []) + simplifyParsedFieldDef bazC `shouldBe` (["c", "FooId"], []) it "parse works" $ do let test name'fieldCount parsedList = do @@ -885,28 +863,24 @@ Baz ] 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"] } + Line { lineIndent = 0, lineTokens = ["Person"], lineComment = Nothing } :| + [ Line { lineIndent = 2, lineTokens = ["name", "String"], lineComment = Nothing } + , Line { lineIndent = 2, lineTokens = ["age", "Int"], lineComment = Nothing } ] + 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"] } + Line { lineIndent = 0, lineTokens = ["Foo"], lineComment = Nothing } :| + [ Line { lineIndent = 2, lineTokens = ["x", "X"], lineComment = Nothing } + , Line { lineIndent = 0, lineTokens = [], lineComment = Just (Comment "-- |" "Hello") } + , Line { lineIndent = 0, lineTokens = ["Bar"], lineComment = Nothing } + , Line { lineIndent = 1, lineTokens = ["name", "String"], lineComment = Nothing } ] preparse text `shouldBe` Just (5, expected) @@ -920,11 +894,12 @@ Baz , " 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"] } + Line { lineIndent = 2, lineTokens = ["Foo"], lineComment = Nothing } :| + [ Line { lineIndent = 4, lineTokens = ["x", "X"], lineComment = Nothing } + , Line { lineIndent = 2, lineTokens = [], lineComment = Just (Comment "-- |" "Comment") } + , Line { lineIndent = 2, lineTokens = [], lineComment = Just (Comment "--" "hidden comment") } + , Line { lineIndent = 2, lineTokens = ["Bar"], lineComment = Nothing } + , Line { lineIndent = 4, lineTokens = ["name", "String"], lineComment = Nothing } ] preparse t `shouldBe` Just (6, expected) @@ -939,13 +914,13 @@ Baz , " 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") } + Line { lineIndent = 0, lineTokens = ["LowerCaseTable"], lineComment = Nothing } :| + [ Line { lineIndent = 2, lineTokens = ["name", "String"], lineComment = Nothing } + , Line { lineIndent = 2, lineTokens = ["ExtraBlock"], lineComment = Nothing } + , Line { lineIndent = 4, lineTokens = ["foo", "bar"], lineComment = Nothing } + , Line { lineIndent = 4, lineTokens = ["baz"], lineComment = Nothing } + , Line { lineIndent = 2, lineTokens = ["ExtraBlock2"], lineComment = Nothing } + , Line { lineIndent = 4, lineTokens = ["something"], lineComment = Nothing } ] preparse t `shouldBe` Just (7, expected) @@ -957,178 +932,225 @@ Baz , " 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"]) } + Line { lineIndent = 0, lineTokens = [], lineComment = Just (Comment "-- |" "Model") } :| + [ Line { lineIndent = 0, lineTokens = ["Foo"], lineComment = Nothing } + , Line { lineIndent = 2, lineTokens = [], lineComment = Just (Comment "-- |" "Field") } + , Line { lineIndent = 2, lineTokens = ["name", "String"], lineComment = Nothing } ] 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 = [] - } + describe "parseEntityDefs" $ do + let simplifyParsedFieldDef pfa = + (parsedFieldDefTokens pfa, parsedFieldDefComments pfa) + + it "parses an entity with one field" $ do + let simpleEntity = + parseLines + [sbt|Foo + | name String + |] + let [fooDef] = parseEntityDefs Nothing simpleEntity + parsedEntityDefComments fooDef `shouldBe` [] + parsedEntityDefEntityName fooDef `shouldBe` EntityNameHS "Foo" + let [fooName] = parsedEntityDefFieldAttributes fooDef + simplifyParsedFieldDef fooName `shouldBe` (["name", "String"], []) + + let foo = parseLines + [sbt|-- | comment + |Foo + | name String + |] + + it "parses an entity with a comment" $ do + let [fooDef] = parseEntityDefs Nothing foo + parsedEntityDefComments fooDef `shouldBe` [Comment "-- |" "comment"] + parsedEntityDefEntityName fooDef `shouldBe` EntityNameHS "Foo" + let [fooName] = parsedEntityDefFieldAttributes fooDef + simplifyParsedFieldDef fooName `shouldBe` (["name", "String"], []) + + it "works with field comments" $ do + let text = parseLines + [sbt|-- | Model + |Foo + | -- | Field + | name String + |] + let [fooDef] = parseEntityDefs Nothing text + parsedEntityDefComments fooDef `shouldBe` [Comment "-- |" "Model"] + parsedEntityDefEntityName fooDef `shouldBe` EntityNameHS "Foo" + let simpleFields = simplifyParsedFieldDef <$> parsedEntityDefFieldAttributes fooDef + simpleFields `shouldBe` + [ (["name", "String"], [Comment "-- |" "Field"]) ] - 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 = [] - } + let bar = parseLines + [sbt|Bar sql=bars + | age Int + |] + + it "works when used for multiple definitions" $ do + let [fooDef, barDef] = parseEntityDefs Nothing (foo <> bar) + + parsedEntityDefComments fooDef `shouldBe` [Comment "-- |" "comment"] + parsedEntityDefEntityName fooDef `shouldBe` EntityNameHS "Foo" + let simpleFooFields = simplifyParsedFieldDef <$> parsedEntityDefFieldAttributes fooDef + simpleFooFields `shouldBe` + [ (["name", "String"], []) ] + parsedEntityDefComments barDef `shouldBe` [] + parsedEntityDefEntityName barDef `shouldBe` EntityNameHS "Bar" + let simpleBarFields = simplifyParsedFieldDef <$> parsedEntityDefFieldAttributes barDef + simpleBarFields `shouldBe` + [ (["age", "Int"], []) + ] - 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"] - } + it "can parse one indented entity" $ do + let indentedLines = parseLines + [sbt| CompanyUser + | name Text + |] + let [companyUserDef] = parseEntityDefs Nothing indentedLines + parsedEntityDefEntityName companyUserDef `shouldBe` EntityNameHS "CompanyUser" + let simpleFields = simplifyParsedFieldDef <$> parsedEntityDefFieldAttributes companyUserDef + simpleFields `shouldBe` + [ (["name", "Text"], []) + ] + + it "can parse indented entities" $ do + let companyUserLines = parseLines + [sbt| CompanyUser + | companyName Text + | userName Text + | Primary companyName userName + | + | CompanyUser2 + | companyName Text + | userName Text + | Primary companyName userName + |] + let [companyUserDef, _] = parseEntityDefs Nothing companyUserLines + parsedEntityDefComments companyUserDef `shouldBe` [] + parsedEntityDefEntityName companyUserDef `shouldBe` EntityNameHS "CompanyUser" + let simpleFields = simplifyParsedFieldDef <$> parsedEntityDefFieldAttributes companyUserDef + simpleFields `shouldBe` + [ (["companyName", "Text"], []) + , (["userName", "Text"], []) + , (["Primary", "companyName", "userName"], []) + ] + + it "parse entity example - entity with default field" $ do + let productLines = parseLines + [sbt|Product + | name Text + | added UTCTime default=CURRENT_TIMESTAMP + |] + let [productDef] = parseEntityDefs Nothing productLines + parsedEntityDefComments productDef `shouldBe` [] + parsedEntityDefEntityName productDef `shouldBe` EntityNameHS "Product" + let simpleFields = simplifyParsedFieldDef <$> parsedEntityDefFieldAttributes productDef + simpleFields `shouldBe` + [ (["name", "Text"], []) + , (["added", "UTCTime", "default=CURRENT_TIMESTAMP"], []) ] + it "parse entity example - entity with extra block 1" $ do + let productLines = parseLines + [sbt|Product + | name Text + | ExtraBlock + | added UTCTime default=CURRENT_TIMESTAMP + |] + let [productDef] = parseEntityDefs Nothing productLines + parsedEntityDefComments productDef `shouldBe` [] + parsedEntityDefEntityName productDef `shouldBe` EntityNameHS "Product" + let simpleFields = simplifyParsedFieldDef <$> parsedEntityDefFieldAttributes productDef + simpleFields `shouldBe` + [ (["name", "Text"], []) + , (["added", "UTCTime", "default=CURRENT_TIMESTAMP"], []) + ] + let extras = parsedEntityDefExtras productDef + extras `shouldBe` + [ ("ExtraBlock", []) + ] + + it "parse entity example - entity with extra block 2" $ do + let lowerCaseTableLines = parseLines + [sbt|LowerCaseTable + | Id sql=my_id + | fullName Text + | ExtraBlock + | foo bar + | baz + | bin + | ExtraBlock2 + | something + |] + let [lowerCaseTableDef] = parseEntityDefs Nothing lowerCaseTableLines + parsedEntityDefComments lowerCaseTableDef `shouldBe` [] + parsedEntityDefEntityName lowerCaseTableDef `shouldBe` EntityNameHS "LowerCaseTable" + let simpleFields = simplifyParsedFieldDef <$> parsedEntityDefFieldAttributes lowerCaseTableDef + simpleFields `shouldBe` + [ (["Id", "sql=my_id"], []) + , (["fullName", "Text"], []) + ] + let extras = parsedEntityDefExtras lowerCaseTableDef + extras `shouldBe` + [ ("ExtraBlock", + [ ["foo", "bar"] + , ["baz"] + , ["bin"] + ]) + , ("ExtraBlock2", + [ ["something"] + ]) + ] + it "works with two extra blocks" $ do + let lowerCaseTableLines = parseLines + [sbt|IdTable + | Id Day default=CURRENT_DATE + | name Text + | + |LowerCaseTable + | Id sql=my_id + | fullName Text + | ExtraBlock + | foo bar + | baz + | bin + | ExtraBlock2 + | something + |] + let [idTableDef, lowerCaseTableDef] = parseEntityDefs Nothing lowerCaseTableLines + parsedEntityDefComments idTableDef `shouldBe` [] + parsedEntityDefEntityName idTableDef `shouldBe` EntityNameHS "IdTable" + let simpleFieldsId = simplifyParsedFieldDef <$> parsedEntityDefFieldAttributes idTableDef + simpleFieldsId `shouldBe` + [ (["Id", "Day", "default=CURRENT_DATE"], []) + , (["name", "Text"], []) + ] + let idExtras = parsedEntityDefExtras idTableDef + idExtras `shouldBe` [] + + parsedEntityDefComments lowerCaseTableDef `shouldBe` [] + parsedEntityDefEntityName lowerCaseTableDef `shouldBe` EntityNameHS "LowerCaseTable" + let simpleFields = simplifyParsedFieldDef <$> parsedEntityDefFieldAttributes lowerCaseTableDef + simpleFields `shouldBe` + [ (["Id", "sql=my_id"], []) + , (["fullName", "Text"], []) + ] + let extras = parsedEntityDefExtras lowerCaseTableDef + extras `shouldBe` + [ ("ExtraBlock", + [ ["foo", "bar"] + , ["baz"] + , ["bin"] + ]) + , ("ExtraBlock2", + [ ["something"] + ]) + ] describe "parseLines" $ do let lines = diff --git a/persistent/test/Database/Persist/TH/CommentsSpec.hs b/persistent/test/Database/Persist/TH/CommentsSpec.hs index e3b5668ba..f6c9f7dd7 100644 --- a/persistent/test/Database/Persist/TH/CommentsSpec.hs +++ b/persistent/test/Database/Persist/TH/CommentsSpec.hs @@ -204,24 +204,19 @@ spec = describe "Comments" $ do let edef = entityDef (Proxy :: Proxy Upload) getEntityComments edef - `shouldBe` Nothing - -- `shouldBe` Just "Represents an uploaded file" + `shouldBe` Just "Represents an uploaded file\n" let [pathField, uploadedField, sizeField, mimeField] = getEntityFields edef fieldComments pathField - `shouldBe` Nothing - -- `shouldBe` Just "Filesystem path" + `shouldBe` Just "Filesystem path\n" fieldComments uploadedField - `shouldBe` Nothing - -- `shouldBe` Just "when the file was uploaded" + `shouldBe` Just "when the file was uploaded\n" fieldComments sizeField - `shouldBe` Nothing - -- `shouldBe` Just "in bytes" + `shouldBe` Just "in bytes\n" fieldComments mimeField - `shouldBe` Nothing - -- `shouldBe` Just "MIME type, like image/png" + `shouldBe` Just "MIME type, like image/png\n"