combine field attributes and directive arguments

Author: dtpowl

persistent/Database/Persist/Quasi/Internal/ModelParser.hs

@@ -257,7 +257,7 @@ data SourceLoc = SourceLoc
     }
     deriving (Show, Lift)
 
--- | An attribute of an entity field definition.
+-- | An attribute of an entity field definition or a directive.
 --
 -- @since 2.17.1.0
 data Attribute
@@ -268,17 +268,6 @@ data Attribute
       Quotation Text
     deriving (Eq, Ord, Show)
 
--- | An argument to an entity field directive.
---
--- @since 2.17.1.0
-data DirectiveArgument
-    = -- This is too unstructured. We should rework directive parsing and make this smarter.
-      DText Text
-    | DParenthetical Text
-    | -- | Quoted directive arguments are deprecated since 2.17.1.0.
-      DQuotation Text
-    deriving (Eq, Ord, Show)
-
 -- | The name of an entity block or extra block.
 --
 -- @since 2.17.1.0
@@ -309,7 +298,7 @@ attributeContent = \case
 --
 -- @since 2.17.1.0
 directiveContent :: Directive -> [Text]
-directiveContent d = directiveArgumentContent <$> directiveArguments d
+directiveContent d = [directiveNameContent $ directiveName d] <> (attributeContent <$> directiveAttributes d)
 
 entityFieldContent :: EntityField -> [Text]
 entityFieldContent f =
@@ -321,6 +310,9 @@ entityFieldContent f =
 blockKeyContent :: BlockKey -> Text
 blockKeyContent (BlockKey t) = t
 
+directiveNameContent :: DirectiveName -> Text
+directiveNameContent (DirectiveName t) = t
+
 -- | Generates the field name of an EntityField, accompanied by
 -- its strictness sigil, if one is present.
 -- This is only needed temporarily, and can eventually be refactored away.
@@ -343,7 +335,7 @@ commentContent = \case
     DocComment s -> s
 
 quotedAttributeErrorMessage :: String
-quotedAttributeErrorMessage = "Unexpected quotation mark in entity field attribute"
+quotedAttributeErrorMessage = "Unexpected quotation mark in field or directive attribute"
 
 attribute :: Parser Attribute
 attribute = do
@@ -663,6 +655,9 @@ data FieldStrictness = Strict | Lazy
 newtype FieldName = FieldName Text
     deriving (Show)
 
+newtype DirectiveName = DirectiveName Text
+    deriving (Show)
+
 data EntityField = EntityField
     { entityFieldDocCommentBlock :: Maybe DocCommentBlock
     , entityFieldStrictness :: Maybe FieldStrictness
@@ -675,7 +670,8 @@ data EntityField = EntityField
 
 data Directive = Directive
     { directiveDocCommentBlock :: Maybe DocCommentBlock
-    , directiveArguments :: [DirectiveArgument]
+    , directiveName :: DirectiveName
+    , directiveAttributes :: [Attribute]
     , directivePos :: SourcePos
     }
     deriving (Show)
@@ -831,100 +827,32 @@ entityField = do
                 , entityFieldPos = pos
                 }
 
-directiveName :: Parser String
-directiveName =
-    label "directive name" $
-        choice
-            [ string "deriving"
-            , directiveName'
-            ]
+directiveNameP :: Parser DirectiveName
+directiveNameP = label "directive name" $
+  DirectiveName . Text.pack <$> choice
+      [ string "deriving"
+      , directiveName'
+      ]
   where
     directiveName' = do
         fl <- upperChar
         rl <- many alphaNumChar
         pure (fl : rl)
 
-quotedArgumentErrorMessage :: String
-quotedArgumentErrorMessage = "Unexpected quotation mark in directive argument"
-
--- Parses an argument to an entity definition directive. It's somewhat naive about it,
--- and we should refine this in the future.
-directiveArgument :: Parser DirectiveArgument
-directiveArgument = do
-    quotedArgumentErrorLevel <- asks psQuotedArgumentErrorLevel
-    tryOrReport
-        quotedArgumentErrorLevel
-        "Quoted directive arguments are deprecated since 2.17.1.0, and will be removed in or after 2.18.0.0"
-        isQuotedArgumentError
-        directiveArgument'
-        (DQuotation . Text.pack <$> quotation)
-  where
-    isQuotedArgumentError (FancyError _ s) = s == Set.singleton (ErrorFail quotedArgumentErrorMessage)
-    isQuotedArgumentError _ = False
-    parentheticalInner = do
-        str <- parenthetical'
-        pure . init . drop 1 $ str
-    directiveArgument' = do
-        q <- lookAhead (optional $ char '"')
-        case q of
-            Just _ -> fail quotedArgumentErrorMessage
-            Nothing ->
-                choice
-                    [ DParenthetical . Text.pack . init . drop 1 <$> L.lexeme spaceConsumer parenthetical'
-                    , DText . Text.pack <$> some directiveArgumentChar
-                    ]
-    -- This big random-looking character class is a sign that the parser is too lax.
-    -- When we improve directive parsing, we'll eliminate this.
-    -- Note that this character class is not identical to the class parsed by the top-level function `contentChar`.
-    directiveArgumentChar =
-        choice
-            [ alphaNumChar
-            , char '.'
-            , char '['
-            , char ']'
-            , char '('
-            , 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
-            ]
-
--- | Converts a directive argument into a Text representation for second-stage
--- parsing or presentation to the user
---
--- @since 2.17.1.0
-directiveArgumentContent :: DirectiveArgument -> Text
-directiveArgumentContent = \case
-    DText t -> t
-    DParenthetical t -> t
-    DQuotation t -> t
-
 directive :: Parser Member
 directive = do
     dcb <- getDcb
     pos <- getSourcePos
-    dn <- L.lexeme spaceConsumer directiveName
-    args <- some $ L.lexeme spaceConsumer directiveArgument
+    dn <- L.lexeme spaceConsumer directiveNameP
+    args <- some $ L.lexeme spaceConsumer attribute
     _ <- setLastDocumentablePosition
     lookAhead (void newline <|> eof)
     pure $
         MemberDirective
             Directive
                 { directiveDocCommentBlock = dcb
-                , directiveArguments = DText (Text.pack dn) : args
+                , directiveName = dn
+                , directiveAttributes = args
                 , directivePos = pos
                 }
 

persistent/test/Database/Persist/QuasiSpec.hs

@@ -436,7 +436,7 @@ spec = describe "Quasi" $ do
         it "rejects quoted attributes" $
           evaluate (unboundEntityDef user)
             `shouldErrorWithMessage`
-             "2:14:\n  |\n2 |  name String \"Maybe\"\n  |              ^\nUnexpected quotation mark in entity field attribute\n"
+             "2:14:\n  |\n2 |  name String \"Maybe\"\n  |              ^\nUnexpected quotation mark in field or directive attribute\n"
 
         describe "and the definition has quotation marks in the type" $ do
           let definitionsWithTypeLevelString = T.pack "User\n name \"String\"\n deriving Show"
@@ -464,7 +464,7 @@ spec = describe "Quasi" $ do
         it "rejects quoted arguments" $
           evaluate (unboundEntityDef user)
             `shouldErrorWithMessage`
-            "3:11:\n  |\n3 |  deriving \"Show\"\n  |           ^\nUnexpected quotation mark in directive argument\n"
+            "3:11:\n  |\n3 |  deriving \"Show\"\n  |           ^\nUnexpected quotation mark in field or directive attribute\n"
 
     describe "parse" $ do
         let