Skip to content

Change documentation comment syntax #6

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
blujupiter32 wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Change documentation comment syntax #6

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
59 changes: 42 additions & 17 deletions persistent/Database/Persist/Quasi/Internal.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -19,6 +19,7 @@ module Database.Persist.Quasi.Internal
, upperCaseSettings
, lowerCaseSettings
, toFKNameInfixed
, CommentStyle (..)
, Token (..)
, Line (..)
, preparse
Expand Down Expand Up @@ -214,20 +215,44 @@ preparse txt = do
lns <- NEL.nonEmpty (T.lines txt)
NEL.nonEmpty $ mapMaybe parseLine (NEL.toList lns)

-- TEMP: ignore NonDoc and PostDoc comments
parseLine :: Text -> Maybe Line
parseLine txt = do
Line (parseIndentationAmount txt) <$> NEL.nonEmpty (tokenize txt)
parseLine txt = fmap (Line (parseIndentationAmount txt))
. NEL.nonEmpty
. filter isPreDocOrToken
$ tokenize txt

isPreDocOrToken :: Token -> Bool
isPreDocOrToken (Token _) = True
isPreDocOrToken (Comment PreDoc _) = True
isPreDocOrToken _ = False

-- | Type of comment, determined by the presence of @|@ or @^@ after @-- @.
data CommentStyle = NonDoc
-- ^ No @|@ or @^@.
| PreDoc
-- ^ Documentation comment before declaration (@-- |@).
| PostDoc
-- ^ Documentation comment after declaration (@-- ^@).
deriving (Show, Eq)

-- | 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 Token = Token Text
-- ^ @Token tok@ is token @tok@ already unquoted.
| Comment CommentStyle Text
-- ^ @Comment@ is a comment could be part of a documentation comment.
deriving (Show, Eq)

commentPrefix :: CommentStyle -> Text
commentPrefix NonDoc = "-- "
commentPrefix PreDoc = "-- | "
commentPrefix PostDoc = "-- ^ "

tokenText :: Token -> Text
tokenText tok =
case tok of
Token t -> t
DocComment t -> "-- | " <> t
Comment style t -> commentPrefix style <> t

parseIndentationAmount :: Text -> Int
parseIndentationAmount txt =
Expand All @@ -238,8 +263,9 @@ parseIndentationAmount txt =
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.
| Just txt <- T.stripPrefix "-- |" t = [Comment PreDoc (T.stripStart txt)]
| Just txt <- T.stripPrefix "-- ^" t = [Comment PostDoc (T.stripStart txt)]
| Just txt <- T.stripPrefix "--" t = [Comment NonDoc (T.stripStart txt)]
| "#" `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
Expand Down Expand Up @@ -349,12 +375,6 @@ toParsedEntityDef lwc = ParsedEntityDef
(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]
Expand Down Expand Up @@ -395,10 +415,13 @@ associateLines lines =
[] ->
[newLine line]
(lwc : lwcs) ->
case isDocComment (NEL.head (tokens line)) of
Just comment
case NEL.head (tokens line) of
Comment PreDoc comment
| lineIndent line == lowestIndent lines ->
consComment comment lwc : lwcs
Comment style _
| style /= PreDoc ->
lwc : lwcs
_ ->
if lineIndent line <= lineIndent (firstLine lwc)
&& lineIndent (firstLine lwc) /= lowestIndent lines
Expand Down Expand Up @@ -823,16 +846,18 @@ associateComments
-> [Token]
-> ([UnboundFieldDef], [Text])
-> ([UnboundFieldDef], [Text])
associateComments ps x (!acc, !comments) =
associateComments ps toks (!acc, !comments) =
case listToMaybe x of
Just (DocComment comment) ->
Just (Comment PreDoc comment) ->
(acc, comment : comments)
_ ->
case (setFieldComments (reverse comments) <$> takeColsEx ps (tokenText <$> x)) of
Just sm ->
(sm : acc, [])
Nothing ->
(acc, [])
where
x = filter isPreDocOrToken toks

setFieldComments :: [Text] -> UnboundFieldDef -> UnboundFieldDef
setFieldComments xs fld =
Expand Down
18 changes: 9 additions & 9 deletions persistent/test/Database/Persist/QuasiSpec.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -233,20 +233,20 @@ spec = describe "Quasi" $ do
parseLine "-- | this is a comment" `shouldBe`
Just
( Line 0
[ DocComment "this is a comment"
[ Comment PreDoc "this is a comment"
]
)
it "recognizes empty line" $ do
parseLine "-- |" `shouldBe`
Just
( Line 0
[ DocComment ""
[ Comment PreDoc ""
]
)

it "works if comment is indented" $ do
parseLine " -- | comment" `shouldBe`
Just (Line 2 [DocComment "comment"])
Just (Line 2 [Comment PreDoc "comment"])

describe "parse" $ do
let subject =
Expand Down Expand Up @@ -898,7 +898,7 @@ Baz
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 (Comment PreDoc "Hello") }
, Line { lineIndent = 0, tokens = pure (Token "Bar") }
, Line { lineIndent = 1, tokens = Token "name" :| [Token "String"] }
]
Expand All @@ -916,7 +916,7 @@ Baz
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 (Comment PreDoc "Comment") }
, Line { lineIndent = 2, tokens = pure (Token "Bar") }
, Line { lineIndent = 4, tokens = Token "name" :| [Token "String"] }
]
Expand Down Expand Up @@ -951,9 +951,9 @@ Baz
, " name String"
]
expected =
Line { lineIndent = 0, tokens = [DocComment "Model"] } :|
Line { lineIndent = 0, tokens = [Comment PreDoc "Model"] } :|
[ Line { lineIndent = 0, tokens = [Token "Foo"] }
, Line { lineIndent = 2, tokens = [DocComment "Field"] }
, Line { lineIndent = 2, tokens = [Comment PreDoc "Field"] }
, Line { lineIndent = 2, tokens = (Token <$> ["name", "String"]) }
]
preparse text `shouldBe` Just expected
Expand All @@ -972,7 +972,7 @@ Baz
comment =
Line
{ lineIndent = 0
, tokens = pure (DocComment "comment")
, tokens = pure (Comment PreDoc "comment")
}
it "works" $ do
associateLines
Expand Down Expand Up @@ -1114,7 +1114,7 @@ Baz
[ LinesWithComments
{ lwcLines =
Line { lineIndent = 0, tokens = (Token "Foo") :| [] } :|
[ Line { lineIndent = 2, tokens = pure (DocComment "Field") }
[ Line { lineIndent = 2, tokens = pure (Comment PreDoc "Field") }
, Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] }
]
, lwcComments =
Expand Down