{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Dhall.Docs.Comment
( parseComments
, CommentParseError(..)
, DhallDocsText
, parseSingleDhallDocsComment
, unDhallDocsText
) where
import Control.Applicative (many, some, (<|>))
import Data.Functor (void)
import Data.List.NonEmpty (NonEmpty (..), (<|))
import Data.Text (Text)
import Dhall.Docs.Util
import Dhall.Parser (Parser (..))
import Text.Megaparsec (SourcePos, (<?>))
import qualified Data.Either
import qualified Data.Foldable
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Maybe as Maybe
import qualified Data.Text
import qualified Dhall.Parser.Expression as Expression
import qualified Dhall.Parser.Token as Token
import qualified Text.Megaparsec
import qualified Text.Megaparsec.Pos as Megaparsec.Pos
data CommentType = DhallDocsComment | MarkedComment | RawComment
type ListOfSingleLineComments = NonEmpty (SourcePos, Text)
data DhallComment (a :: CommentType)
= BlockComment Text
| SingleLineComments ListOfSingleLineComments
deriving Show
newtype DhallDocsText = DhallDocsText Text
deriving Show
unDhallDocsText :: DhallDocsText -> Text
unDhallDocsText (DhallDocsText t) = t
lineCommentParser :: Parser (NonEmpty (DhallComment 'RawComment))
lineCommentParser = do
(l : ls) <- some singleLine
pure $ NonEmpty.map SingleLineComments $ groupComments (l :| ls)
where
groupComments :: ListOfSingleLineComments -> NonEmpty ListOfSingleLineComments
groupComments ls = case NonEmpty.nonEmpty remaining of
Nothing -> g :| []
Just l -> g <| groupComments l
where
lineNumber = Megaparsec.Pos.unPos . Megaparsec.Pos.sourceLine
(g, remaining) = removeSubseq ls
removeSubseq :: ListOfSingleLineComments -> (ListOfSingleLineComments, [(SourcePos, Text)])
removeSubseq (x :| []) = (x :| [], [])
removeSubseq (x@(xPos, _) :| ys@(y@(yPos, _) : rest))
| lineNumber yPos - lineNumber xPos == 1
= let (subSeq, r) = removeSubseq (y :| rest) in (x <| subSeq, r)
| otherwise = (x :| [], ys)
singleLine = do
sourcePos <- Expression.getSourcePos
commentLine <- Token.lineComment
whitespace
pure (sourcePos, commentLine)
whitespace :: Parser ()
whitespace = Text.Megaparsec.skipMany (Text.Megaparsec.choice
[ void (Text.Megaparsec.takeWhile1P Nothing predicate)
, void (Token.text "\r\n")
] <?> "whitespace")
where
predicate c = c == ' ' || c == '\t' || c == '\n'
blockCommentParser :: Parser (DhallComment 'RawComment)
blockCommentParser = do
c <- Token.blockComment
whitespace
pure $ BlockComment c
parseComments :: String -> Text -> [DhallComment 'RawComment]
parseComments delta text = case result of
Left err -> error ("An error has occurred while parsing comments:\n "
<> Text.Megaparsec.errorBundlePretty err)
Right comments -> comments
where
parser = do
comments <- many $ do
whitespace
lineCommentParser <|> ((:| []) <$> blockCommentParser)
Text.Megaparsec.eof
pure $ concatMap NonEmpty.toList comments
result = Text.Megaparsec.parse (unParser parser) delta text
data CommentParseError
= MissingNewlineOnBlockComment
| BadSingleLineCommentsAlignment
| BadPrefixesOnSingleLineComments
| SeveralSubseqDhallDocsComments
deriving Show
parseMarkedComment :: DhallComment 'RawComment -> Maybe (DhallComment 'MarkedComment)
parseMarkedComment (BlockComment comment)
| "{-|" `Data.Text.isPrefixOf` comment = Just $ BlockComment comment
| otherwise = Nothing
parseMarkedComment (SingleLineComments ls)
| any (("--|" `Data.Text.isPrefixOf`) . snd) ls = Just (SingleLineComments ls)
| otherwise = Nothing
parseDhallDocsComment :: DhallComment 'MarkedComment -> Either CommentParseError (DhallComment 'DhallDocsComment)
parseDhallDocsComment (BlockComment comment) =
if any (`Data.Text.isPrefixOf` comment) ["{-|\n", "{-|\r\n"] then Right $ BlockComment comment
else Left MissingNewlineOnBlockComment
parseDhallDocsComment (SingleLineComments lineComments) =
fmap SingleLineComments $ checkAlignment lineComments >>= checkAmountOfMarkers >>= checkPrefixes
where
sourceCol = Text.Megaparsec.unPos . Text.Megaparsec.sourceColumn
checkAmountOfMarkers :: ListOfSingleLineComments -> Either CommentParseError ListOfSingleLineComments
checkAmountOfMarkers ls =
if numberOfMarkers > 1 then Left SeveralSubseqDhallDocsComments
else case newLines of
[] -> fileAnIssue "checkAmountOfMarkers failed with newLines = []"
l : remainder -> Right $ l :| remainder
where
commentLines = NonEmpty.toList ls
numberOfMarkers = length $ filter (Data.Text.isPrefixOf "--|" . snd) commentLines
(_, newLines) = break (Data.Text.isPrefixOf "--|" . snd) commentLines
checkAlignment :: ListOfSingleLineComments -> Either CommentParseError ListOfSingleLineComments
checkAlignment ls@((first, _) :| rest)
| all ((== sourceCol first) . sourceCol . fst) rest = Right ls
| otherwise = Left BadSingleLineCommentsAlignment
checkPrefixes :: ListOfSingleLineComments -> Either CommentParseError ListOfSingleLineComments
checkPrefixes ls@((_, first) :| rest)
| "--| " `Data.Text.isPrefixOf` first && all (p . snd) rest
= Right ls
| otherwise = Left BadPrefixesOnSingleLineComments
where
p t = Data.Text.isPrefixOf "-- " t || (Data.Text.compareLength t 2 == EQ && "--" == t)
parseDhallDocsText :: DhallComment 'DhallDocsComment -> DhallDocsText
parseDhallDocsText (BlockComment blockComment) =
case Data.Text.stripSuffix "-}" joinedText of
Nothing -> fileAnIssue ("Obtained 'Nothing' on extractText.stripSuffix with text: \"" <> joinedText <> "\"")
Just e -> DhallDocsText e
where
joinedText = Data.Text.strip $ Data.Text.unlines reIndentedLines
(_ : commentLines) = Data.Text.lines blockComment
leadingSpaces = Data.Text.takeWhile isSpace
where
isSpace t = t == ' ' || t == '\t'
nonEmptyCommentLines = filter (not . Data.Text.null) commentLines
commonIndentation = Data.Text.length $
case map leadingSpaces nonEmptyCommentLines of
l : ls -> Data.Foldable.foldl' sharedPrefix l ls
[] -> ""
where
sharedPrefix ab ac =
case Data.Text.commonPrefixes ab ac of
Just (a, _, _) -> a
Nothing -> ""
reIndentedLines = map (Data.Text.drop commonIndentation) commentLines
parseDhallDocsText (SingleLineComments (fmap snd -> (first :| rest))) =
DhallDocsText $ Data.Text.unlines $ firstLine : map cleanRest rest
where
debugLines = Data.Text.unlines (first : rest)
firstLine = case Data.Text.stripPrefix "--| " first of
Nothing -> fileAnIssue $
"Error strippping \"--| \" prefix on parseDhallDocsText. " <>
"All comment lines are here:\n" <> debugLines
Just s -> s
cleanRest l = case Data.Text.stripPrefix "-- " l <|> Data.Text.stripPrefix "--" l of
Nothing -> fileAnIssue $
"Error strippping \"-- \" prefix on parseDhallDocsText. " <>
"All comment lines are here:\n" <> debugLines
Just s -> s
parseSingleDhallDocsComment :: String -> Text -> Maybe (Either [CommentParseError] DhallDocsText)
parseSingleDhallDocsComment delta text = do
let rawComments = parseComments delta text
let markedComments = Maybe.mapMaybe parseMarkedComment rawComments
let (errors_, dhallDocsComments) = Data.Either.partitionEithers $ map parseDhallDocsComment markedComments
let errors =
if length dhallDocsComments >= 2 then
SeveralSubseqDhallDocsComments : errors_
else
errors_
case (errors, dhallDocsComments) of
([] , []) -> Nothing
(_:_, _) -> Just $ Left errors
(_ , [a]) -> Just $ Right $ parseDhallDocsText a
(_ , _) -> fileAnIssue "Returned more than one comment at parseSingleDhallDocsComment"