From 322e26d994b05a9a22b8d405f64174a38951503b Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Tue, 19 Jan 2021 23:03:56 +0900 Subject: [PATCH 01/41] WIP: Comment parsing using module annotations --- ghcide/src/Development/IDE/GHC/Orphans.hs | 1 + plugins/hls-eval-plugin/hls-eval-plugin.cabal | 2 + .../src/Ide/Plugin/Eval/CodeLens.hs | 44 +++++++-- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 94 +++++++++++++++++++ .../src/Ide/Plugin/Eval/Types.hs | 25 +++++ stack-8.10.1.yaml | 1 + stack-8.6.4.yaml | 1 + stack-8.6.5.yaml | 1 + stack-8.8.2.yaml | 1 + stack-8.8.3.yaml | 1 + stack-8.8.4.yaml | 1 + stack.yaml | 1 + 12 files changed, 164 insertions(+), 9 deletions(-) create mode 100644 plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index e9a5e91538..be3c830794 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -22,6 +22,7 @@ import qualified StringBuffer as SB import Data.Text (Text) import Data.String (IsString(fromString)) import Retrie.ExactPrint (Annotated) +import Data.List (foldl') -- Orphan instances for types from the GHC API. diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index cc20233af8..745e81ac25 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -33,6 +33,7 @@ library Ide.Plugin.Eval.Parse.Option Ide.Plugin.Eval.Parse.Parser Ide.Plugin.Eval.Parse.Section + Ide.Plugin.Eval.Parse.Comments Ide.Plugin.Eval.Parse.Token Ide.Plugin.Eval.Types Ide.Plugin.Eval.Util @@ -54,6 +55,7 @@ library , haskell-lsp , haskell-lsp-types , hls-plugin-api + , megaparsec >= 0.9 , parser-combinators , pretty-simple , QuickCheck diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 6c50bc05c7..64123ff862 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -42,13 +43,13 @@ import Data.Aeson ( ) import Data.Char (isSpace) import Data.Either (isRight) -import qualified Data.HashMap.Strict as Map +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map.Strict as Map import Data.List ( dropWhileEnd, find, ) -import Data.Maybe ( - catMaybes, +import Data.Maybe (catMaybes, fromMaybe, ) import Data.String (IsString) @@ -57,7 +58,7 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import Data.Time (getCurrentTime) import Data.Typeable (Typeable) -import Development.IDE ( +import Development.IDE (fromNormalizedFilePath, GetParsedModuleWithComments(..), GetModSummary (..), GhcSession (..), HscEnvEq (envImportPaths, hscEnv), @@ -75,11 +76,12 @@ import Development.IDE ( toNormalizedUri, uriToFilePath', use_, + useWithStale_ ) import Development.IDE.Core.Preprocessor ( preprocessor, ) -import Development.IDE.GHC.Compat (HscEnv) +import Development.IDE.GHC.Compat (AnnotationComment(AnnBlockComment, AnnLineComment), srcSpanFile, GenLocated(L), ParsedModule(..), HscEnv) import DynamicLoading (initializePlugins) import GHC ( ExecOptions ( @@ -163,6 +165,7 @@ import Ide.Plugin.Eval.Parse.Section ( ) import Ide.Plugin.Eval.Parse.Token (tokensFrom) import Ide.Plugin.Eval.Types ( + Comments(..), Format (SingleLine), Loc, Located (Located), @@ -217,7 +220,7 @@ import Language.Haskell.LSP.Types ( WorkspaceEdit (WorkspaceEdit), ) import Language.Haskell.LSP.VFS (virtualFileText) -import Outputable ( +import Outputable (showSDocUnsafe, nest, ppr, showSDoc, @@ -230,6 +233,8 @@ import System.IO (hClose) import System.IO.Temp (withSystemTempFile) import Text.Read (readMaybe) import Util (OverridingBool (Never)) +import Development.IDE.GHC.Compat (SrcSpan(RealSrcSpan)) +import FastString (unpackFS) {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. @@ -242,14 +247,35 @@ codeLens lsp st plId CodeLensParams{_textDocument} = response $ do let TextDocumentIdentifier uri = _textDocument fp <- handleMaybe "uri" $ uriToFilePath' uri + let nfp = toNormalizedFilePath' fp dbg "fp" fp + (ParsedModule{..}, _posMap) <- liftIO $ + runAction "parsed" st $ useWithStale_ GetParsedModuleWithComments nfp + dbg "comments" $ showSDocUnsafe $ ppr $ snd pm_annotations + let comments = foldMap + ( foldMap (\case + L (RealSrcSpan real) bdy + | unpackFS (srcSpanFile real) == + fromNormalizedFilePath nfp -> + -- since Haddock parsing is off, + -- we can concentrate on these two + case bdy of + AnnLineComment cmt -> + mempty { lineComments = Map.singleton real cmt } + AnnBlockComment cmt -> + mempty { blockComments = Map.singleton real cmt } + _ -> mempty + _ -> mempty + ) + ) + $ snd pm_annotations + mdlText <- moduleText lsp uri {- Normalise CPP/LHS files/custom preprocessed files. Used to extract tests correctly from CPP and LHS (Bird-style). -} - session :: HscEnvEq <- - runGetSession st $ toNormalizedFilePath' fp + session :: HscEnvEq <- runGetSession st nfp Right (ppContent, _dflags) <- perf "preprocessor" $ @@ -415,7 +441,7 @@ runEvalCmd lsp st EvalParams{..} = (st, fp) tests - let workspaceEditsMap = Map.fromList [(_uri, List edits)] + let workspaceEditsMap = HashMap.fromList [(_uri, List edits)] let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing return (WorkspaceApplyEdit, ApplyWorkspaceEditParams workspaceEdits) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs new file mode 100644 index 0000000000..161b28faeb --- /dev/null +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE RecordWildCards #-} + +module Ide.Plugin.Eval.Parse.Comments where + +import Control.Arrow ((&&&), (>>>)) +import Control.Monad.Combinators +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Development.IDE.GHC.Compat +import Ide.Plugin.Eval.Types +import Text.Megaparsec (Parsec) +import Data.Void (Void) +import qualified Data.Char as C +import qualified Data.List as L +import qualified Text.Megaparsec as P +import qualified Data.Set as Set +import qualified Control.Applicative.Combinators.NonEmpty as NE + +parseSections :: + Comments -> Sections +parseSections Comments {..} = undefined + +groupLineComments :: + Map RealSrcSpan String -> [NonEmpty (RealSrcSpan, String)] +groupLineComments = + contiguousGroupOn (fst >>> srcSpanStartLine &&& srcSpanEndLine) + . Map.toList + +type Parser inputs = Parsec Void inputs + +-- >>> readPropLine $ dropLineComment "-- prop> foo" +-- Just (PropLine {runPropLine = "foo"}) + +dropLineComment + :: String -> String +dropLineComment = + L.dropWhile C.isSpace . + drop 2 . + L.dropWhile C.isSpace + +-- | Example line, with ">>>" stripped off +newtype ExampleLine = ExampleLine { getExampleLine :: String } + deriving (Show) + +exampleLinesP :: Parser [String] (NonEmpty ExampleLine) +exampleLinesP = NE.some exampleLineP + +exampleLineP :: Parser [String] ExampleLine +exampleLineP = P.token readExampleLine mempty + +propLineP :: Parser [String] PropLine +propLineP = P.token readPropLine mempty + +readExampleLine + :: String -> Maybe ExampleLine +readExampleLine ('>' : '>' : '>' : rest@(c : _)) + | c /= '>' = Just $ ExampleLine $ L.dropWhile C.isSpace rest +readExampleLine _ = Nothing + +-- | Prop line, with "prop>" stripped off +newtype PropLine = PropLine { runPropLine :: String } + deriving (Show) + +readPropLine + :: String -> Maybe PropLine +readPropLine ('p' : 'r' : 'o' : 'p' : '>' : rest@(c : _)) + | c /= '>' = Just $ PropLine $ L.dropWhile C.isSpace rest +readPropLine _ = Nothing + + +{- | +Given a sequence of tokens increasing in their starting position, +groups them into sublists consisting of contiguous tokens; +Two adjacent tokens are considered to be contiguous if + + * line number increases by 1, and + * they have same starting column. + +>>> contiguousGroupOn id [(1,2),(2,2),(3,4),(4,4),(5,4),(7,0),(8,0)] +NOW [(1,2) :| [(2,2)],(3,4) :| [(4,4),(5,4)],(7,0) :| [(8,0)]] +-} +contiguousGroupOn :: (a -> (Int, Int)) -> [a] -> [NonEmpty a] +contiguousGroupOn toLineCol = foldr step [] + where + step a [] = [pure a] + step a bss0@((b :| bs) : bss) + | let (aLine, aCol) = toLineCol a + , let (bLine, bCol) = toLineCol b + , aLine + 1 == bLine && aCol == bCol = + (a :| b : bs) : bss + | otherwise = pure a : bss0 diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index fe370566ec..f89d96cf0d 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -11,11 +11,13 @@ module Ide.Plugin.Eval.Types ( Format (..), Language (..), Section (..), + Sections(..), hasTests, hasPropertyTest, splitSections, Loc, Located (..), + Comments(..), unLoc, Txt, ) where @@ -26,6 +28,8 @@ import Data.List (partition) import Data.List.NonEmpty (NonEmpty) import Data.String (IsString (..)) import GHC.Generics (Generic) +import Data.Map.Strict (Map) +import Development.IDE.GHC.Compat (RealSrcSpan) -- | A thing with a location attached. data Located l a = Located {location :: l, located :: a} @@ -50,6 +54,14 @@ locate0 = locate . Located 0 type Txt = String +data Sections = + Sections + { setupSections :: [Section] + , lineSecions :: [Section] + , multilneSections :: [Section] + } + deriving (Show, Eq, Generic) + data Section = Section { sectionName :: Txt , sectionTests :: [Loc Test] @@ -73,6 +85,19 @@ data Test | Property {testline :: Txt, testOutput :: [Txt]} deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) +data Comments = + Comments + { lineComments :: Map RealSrcSpan String + , blockComments :: Map RealSrcSpan String + } + deriving (Show, Eq, Ord, Generic) + +instance Semigroup Comments where + Comments ls bs <> Comments ls' bs' = Comments (ls <> ls') (bs <> bs') + +instance Monoid Comments where + mempty = Comments mempty mempty + isProperty :: Test -> Bool isProperty (Property _ _) = True isProperty _ = False diff --git a/stack-8.10.1.yaml b/stack-8.10.1.yaml index cb1b8db061..2ce536d992 100644 --- a/stack-8.10.1.yaml +++ b/stack-8.10.1.yaml @@ -37,6 +37,7 @@ extra-deps: - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 - lsp-test-0.11.0.6 + - megaparsec-9.0.1 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 - opentelemetry-extra-0.6.1 diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index d9efc8cee2..b77c8434b9 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -60,6 +60,7 @@ extra-deps: - indexed-profunctors-0.1 - lens-4.18 - lsp-test-0.11.0.6 + - megaparsec-9.0.1 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 - opentelemetry-extra-0.6.1 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index e62ed4f925..9a2723ec64 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -59,6 +59,7 @@ extra-deps: - indexed-profunctors-0.1 - lens-4.18 - lsp-test-0.11.0.6 + - megaparsec-9.0.1 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 - opentelemetry-extra-0.6.1 diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index 264b74559a..50f8730ec3 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -54,6 +54,7 @@ extra-deps: - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 - lsp-test-0.11.0.6 + - megaparsec-9.0.1 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 - opentelemetry-extra-0.6.1 diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index 3f4491fbc9..42f3d14810 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -47,6 +47,7 @@ extra-deps: - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 - lsp-test-0.11.0.6 + - megaparsec-9.0.1 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 - opentelemetry-extra-0.6.1 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index ab3fb4e770..2c0d4a23e7 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -46,6 +46,7 @@ extra-deps: - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 - lsp-test-0.11.0.6 + - megaparsec-9.0.1 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 - opentelemetry-extra-0.6.1 diff --git a/stack.yaml b/stack.yaml index 87dad30bff..b7b84b7257 100644 --- a/stack.yaml +++ b/stack.yaml @@ -61,6 +61,7 @@ extra-deps: - indexed-profunctors-0.1 - lens-4.18 - lsp-test-0.11.0.6 + - megaparsec-9.0.1 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 - opentelemetry-extra-0.6.1 From e2f4b9d0303ac950b344036f9f2f1a1a38a61d35 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 21 Jan 2021 01:09:08 +0900 Subject: [PATCH 02/41] Line Comment parsers (wip) --- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 130 +++++++++++++----- 1 file changed, 94 insertions(+), 36 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index 161b28faeb..b461abec2e 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -1,23 +1,29 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} module Ide.Plugin.Eval.Parse.Comments where -import Control.Arrow ((&&&), (>>>)) -import Control.Monad.Combinators +import qualified Control.Applicative.Combinators.NonEmpty as NE +import Control.Arrow (second, (&&&), (>>>)) +import Control.Monad.Combinators () +import qualified Data.Char as C +import Data.Coerce (coerce) +import qualified Data.List as L import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Semigroup +import qualified Data.Set as Set +import Data.Void (Void) import Development.IDE.GHC.Compat import Ide.Plugin.Eval.Types -import Text.Megaparsec (Parsec) -import Data.Void (Void) -import qualified Data.Char as C -import qualified Data.List as L +import SrcLoc (mkRealSrcLoc, mkRealSrcSpan, realSrcSpanEnd, realSrcSpanStart) +import Text.Megaparsec import qualified Text.Megaparsec as P -import qualified Data.Set as Set -import qualified Control.Applicative.Combinators.NonEmpty as NE +import Text.Megaparsec.Char (char, space, space1) parseSections :: Comments -> Sections @@ -31,46 +37,98 @@ groupLineComments = type Parser inputs = Parsec Void inputs --- >>> readPropLine $ dropLineComment "-- prop> foo" --- Just (PropLine {runPropLine = "foo"}) +data LineCommentSection + = SingleProp RealSrcSpan PropLine + | Examples RealSrcSpan (NonEmpty ExampleLine) + | NormalCommentLines RealSrcSpan String + deriving (Show) -dropLineComment - :: String -> String +data CommentFlavour = Vanilla | HaddockNext | HaddockPrev | Named String + deriving (Read, Show, Eq, Ord) + +-- >>> parse lineCommentFlavour "" "-- $a a" +-- Right (Named "a") + +lineCommentFlavour :: Parser String CommentFlavour +lineCommentFlavour = + commentHeadP + -- N.B. Haddock assumes at most one space before modifiers: + *> space + *> P.option + Vanilla + ( HaddockNext <$ char '|' + <|> HaddockPrev <$ char '^' + <|> Named <$ char '$' + <* optional space + <*> P.takeWhile1P (Just "alphabet number") C.isAlphaNum + ) + +commentHeadP :: Parser String () +commentHeadP = + space *> chunk "--" + *> P.notFollowedBy (oneOf "!#$%&*.+=/<>?@\\~^-:|") + +lineCommentSectionsP :: + Parser [(RealSrcSpan, String)] [LineCommentSection] +lineCommentSectionsP = + many $ + toExamples <$> exampleLinesP + <|> uncurry SingleProp . second snd <$> propLineP + <|> uncurry NormalCommentLines <$> anySingle + +toExamples :: NonEmpty (RealSrcSpan, ExampleLine) -> LineCommentSection +toExamples lns = + Examples (convexHullSpan $ fst <$> lns) $ snd <$> lns + +convexHullSpan :: NonEmpty RealSrcSpan -> RealSrcSpan +convexHullSpan lns@(headSpan :| _) = + let aFile = srcSpanFile headSpan + (mbeg, mend) = + foldMap + ( (fmap (Just . Min) . mkRealSrcLoc aFile <$> srcSpanStartLine <*> srcSpanStartCol) + &&& (fmap (Just . Max) . mkRealSrcLoc aFile <$> srcSpanEndLine <*> srcSpanEndCol) + ) + lns + beg = maybe (realSrcSpanStart headSpan) coerce mbeg + end = maybe (realSrcSpanEnd headSpan) coerce mend + in mkRealSrcSpan beg end + +dropLineComment :: + String -> String dropLineComment = - L.dropWhile C.isSpace . - drop 2 . L.dropWhile C.isSpace + . drop 2 + . L.dropWhile C.isSpace --- | Example line, with ">>>" stripped off -newtype ExampleLine = ExampleLine { getExampleLine :: String } +-- | Example line, with @>>>@ stripped off +newtype ExampleLine = ExampleLine {getExampleLine :: String} deriving (Show) -exampleLinesP :: Parser [String] (NonEmpty ExampleLine) -exampleLinesP = NE.some exampleLineP +exampleLinesP :: Parser [(RealSrcSpan, String)] (NonEmpty (RealSrcSpan, ExampleLine)) +exampleLinesP = NE.some $ second snd <$> exampleLineP + +exampleLineP :: Parser [(RealSrcSpan, String)] (RealSrcSpan, (CommentFlavour, ExampleLine)) +exampleLineP = P.token (mapM $ parseMaybe exampleLineStrP) mempty -exampleLineP :: Parser [String] ExampleLine -exampleLineP = P.token readExampleLine mempty +propLineP :: Parser [(RealSrcSpan, String)] (RealSrcSpan, (CommentFlavour, PropLine)) +propLineP = P.token (mapM $ parseMaybe propLineStrP) mempty -propLineP :: Parser [String] PropLine -propLineP = P.token readPropLine mempty +exampleLineStrP :: Parser String (CommentFlavour, ExampleLine) +exampleLineStrP = + (,) <$> lineCommentFlavour + <* chunk ">>>" <* P.notFollowedBy (char '>') + <*> (ExampleLine <$> P.takeRest) -readExampleLine - :: String -> Maybe ExampleLine -readExampleLine ('>' : '>' : '>' : rest@(c : _)) - | c /= '>' = Just $ ExampleLine $ L.dropWhile C.isSpace rest -readExampleLine _ = Nothing +propLineStrP :: Parser String (CommentFlavour, PropLine) +propLineStrP = + (,) <$> lineCommentFlavour + <* chunk "prop>" <* P.notFollowedBy (char '>') + <*> (PropLine <$> P.takeRest) -- | Prop line, with "prop>" stripped off -newtype PropLine = PropLine { runPropLine :: String } +newtype PropLine = PropLine {runPropLine :: String} deriving (Show) -readPropLine - :: String -> Maybe PropLine -readPropLine ('p' : 'r' : 'o' : 'p' : '>' : rest@(c : _)) - | c /= '>' = Just $ PropLine $ L.dropWhile C.isSpace rest -readPropLine _ = Nothing - - {- | Given a sequence of tokens increasing in their starting position, groups them into sublists consisting of contiguous tokens; From 155ec6d0548fa7b849f0f356f8f550071ce3291b Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 21 Jan 2021 23:38:49 +0900 Subject: [PATCH 03/41] Line comment implemented (block comment not implemented) --- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 3 +- .../src/Ide/Plugin/Eval/CodeLens.hs | 425 ++++++++---------- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 217 +++++++-- .../src/Ide/Plugin/Eval/Parse/Section.hs | 141 ------ .../src/Ide/Plugin/Eval/Parse/Token.hs | 283 ------------ .../src/Ide/Plugin/Eval/Types.hs | 4 +- 6 files changed, 370 insertions(+), 703 deletions(-) delete mode 100644 plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Section.hs delete mode 100644 plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Token.hs diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index 745e81ac25..f5554184f7 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -32,9 +32,7 @@ library Ide.Plugin.Eval.GHC Ide.Plugin.Eval.Parse.Option Ide.Plugin.Eval.Parse.Parser - Ide.Plugin.Eval.Parse.Section Ide.Plugin.Eval.Parse.Comments - Ide.Plugin.Eval.Parse.Token Ide.Plugin.Eval.Types Ide.Plugin.Eval.Util @@ -45,6 +43,7 @@ library , deepseq , Diff , directory + , dlist , extra , filepath , ghc diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 178986f0b8..9db76b4b08 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -26,221 +26,209 @@ module Ide.Plugin.Eval.CodeLens ( import Control.Applicative (Alternative ((<|>))) import Control.Arrow (second) import qualified Control.Exception as E -import Control.Monad ( - void, - when, - ) +import Control.Monad + ( void, + when, + ) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Except ( - ExceptT (..), - runExceptT, - ) -import Data.Aeson ( - FromJSON, - ToJSON, - toJSON, - ) +import Control.Monad.Trans.Except + ( ExceptT (..), + ) +import Data.Aeson + ( FromJSON, + ToJSON, + toJSON, + ) import Data.Char (isSpace) import Data.Either (isRight) import qualified Data.HashMap.Strict as HashMap +import Data.List + ( dropWhileEnd, + find, + ) import qualified Data.Map.Strict as Map -import Data.List ( - dropWhileEnd, - find, - ) -import Data.Maybe (catMaybes, - fromMaybe, - ) +import Data.Maybe + ( catMaybes, + fromMaybe, + ) import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8) import Data.Time (getCurrentTime) import Data.Typeable (Typeable) -import Development.IDE (fromNormalizedFilePath, GetParsedModuleWithComments(..), - GetModSummary (..), - GhcSession (..), - HscEnvEq (envImportPaths, hscEnv), - IdeState, - List (List), - NormalizedFilePath, - Range (Range), - Uri, - evalGhcEnv, - hscEnvWithImportPaths, - runAction, - stringBufferToByteString, - textToStringBuffer, - toNormalizedFilePath', - toNormalizedUri, - uriToFilePath', - use_, - useWithStale_ - ) -import Development.IDE.Core.Preprocessor ( - preprocessor, - ) -import Development.IDE.GHC.Compat (AnnotationComment(AnnBlockComment, AnnLineComment), srcSpanFile, GenLocated(L), ParsedModule(..), HscEnv) +import Development.IDE + ( GetModSummary (..), + GetParsedModuleWithComments (..), + GhcSession (..), + HscEnvEq (envImportPaths), + IdeState, + List (List), + NormalizedFilePath, + Range (Range), + Uri, + evalGhcEnv, + fromNormalizedFilePath, + hscEnvWithImportPaths, + runAction, + textToStringBuffer, + toNormalizedFilePath', + toNormalizedUri, + uriToFilePath', + useWithStale_, + use_, + ) +import Development.IDE.GHC.Compat (AnnotationComment (AnnBlockComment, AnnLineComment), GenLocated (L), HscEnv, ParsedModule (..), SrcSpan (RealSrcSpan), srcSpanFile) import DynamicLoading (initializePlugins) -import GHC ( - ExecOptions ( - execLineNumber, - execSourceFile - ), - ExecResult (..), - GeneralFlag (..), - Ghc, - GhcLink (LinkInMemory), - GhcMode (CompManager), - GhcMonad (getSession), - HscTarget (HscInterpreted), - LoadHowMuch (LoadAllTargets), - ModSummary (ms_hspp_opts), - Module (moduleName), - SuccessFlag (Failed, Succeeded), - TcRnExprMode (..), - execOptions, - execStmt, - exprType, - getInteractiveDynFlags, - getSessionDynFlags, - isImport, - isStmt, - load, - runDecls, - setContext, - setInteractiveDynFlags, - setLogAction, - setSessionDynFlags, - setTargets, - typeKind, - ) +import FastString (unpackFS) +import GHC + ( ExecOptions + ( execLineNumber, + execSourceFile + ), + ExecResult (..), + GeneralFlag (..), + Ghc, + GhcLink (LinkInMemory), + GhcMode (CompManager), + GhcMonad (getSession), + HscTarget (HscInterpreted), + LoadHowMuch (LoadAllTargets), + ModSummary (ms_hspp_opts), + Module (moduleName), + SuccessFlag (Failed, Succeeded), + TcRnExprMode (..), + execOptions, + execStmt, + exprType, + getInteractiveDynFlags, + getSessionDynFlags, + isImport, + isStmt, + load, + runDecls, + setContext, + setInteractiveDynFlags, + setLogAction, + setSessionDynFlags, + setTargets, + typeKind, + ) import GHC.Generics (Generic) import qualified GHC.LanguageExtensions.Type as LangExt -import GhcPlugins ( - DynFlags (..), - defaultLogActionHPutStrDoc, - gopt_set, - gopt_unset, - interpWays, - targetPlatform, - updateWays, - wayGeneralFlags, - wayUnsetGeneralFlags, - xopt_set, - ) -import HscTypes ( - InteractiveImport (IIModule), - ModSummary (ms_mod), - Target (Target), - TargetId (TargetFile), - ) -import Ide.Plugin.Eval.Code ( - Statement, - asStatements, - evalExpr, - evalExtensions, - evalSetup, - propSetup, - resultRange, - testCheck, - testRanges, - ) -import Ide.Plugin.Eval.GHC ( - addExtension, - addImport, - addPackages, - hasPackage, - isExpr, - showDynFlags, - ) +import GhcPlugins + ( DynFlags (..), + defaultLogActionHPutStrDoc, + gopt_set, + gopt_unset, + interpWays, + targetPlatform, + updateWays, + wayGeneralFlags, + wayUnsetGeneralFlags, + xopt_set, + ) +import HscTypes + ( InteractiveImport (IIModule), + ModSummary (ms_mod), + Target (Target), + TargetId (TargetFile), + ) +import Ide.Plugin.Eval.Code + ( Statement, + asStatements, + evalExpr, + evalExtensions, + evalSetup, + propSetup, + resultRange, + testCheck, + testRanges, + ) +import Ide.Plugin.Eval.GHC + ( addExtension, + addImport, + addPackages, + hasPackage, + isExpr, + showDynFlags, + ) +import Ide.Plugin.Eval.Parse.Comments (commentsToSections, groupLineComments) import Ide.Plugin.Eval.Parse.Option (langOptions) -import Ide.Plugin.Eval.Parse.Section ( - Section ( - sectionFormat, - sectionTests - ), - allSections, - ) -import Ide.Plugin.Eval.Parse.Token (tokensFrom) -import Ide.Plugin.Eval.Types ( - Comments(..), - Format (SingleLine), - Loc, - Located (Located), - Test, - hasTests, - isProperty, - splitSections, - unLoc, - ) -import Ide.Plugin.Eval.Util ( - asS, - gStrictTry, - handleMaybe, - handleMaybeM, - isLiterate, - logWith, - response, - response', - timed, - ) +import Ide.Plugin.Eval.Types + ( Comments (..), + Format (SingleLine), + Loc, + Located (Located), + Section (..), + Sections (..), + Test, + isProperty, + unLoc, + ) +import Ide.Plugin.Eval.Util + ( asS, + gStrictTry, + handleMaybe, + handleMaybeM, + isLiterate, + logWith, + response, + response', + timed, + ) import Ide.PluginUtils (mkLspCommand) -import Ide.Types ( - CodeLensProvider, - CommandFunction, - CommandId, - PluginCommand (PluginCommand), - ) -import Language.Haskell.LSP.Core ( - LspFuncs ( - getVirtualFileFunc, - withIndefiniteProgress - ), - ProgressCancellable ( - Cancellable - ), - ) -import Language.Haskell.LSP.Types ( - ApplyWorkspaceEditParams ( - ApplyWorkspaceEditParams - ), - CodeLens (CodeLens), - CodeLensParams ( - CodeLensParams, - _textDocument - ), - Command (_arguments, _title), - Position (..), - ServerMethod ( - WorkspaceApplyEdit - ), - TextDocumentIdentifier (..), - TextEdit (TextEdit), - WorkspaceEdit (WorkspaceEdit), - ) +import Ide.Types + ( CodeLensProvider, + CommandFunction, + CommandId, + PluginCommand (PluginCommand), + ) +import Language.Haskell.LSP.Core + ( LspFuncs + ( getVirtualFileFunc, + withIndefiniteProgress + ), + ProgressCancellable + ( Cancellable + ), + ) +import Language.Haskell.LSP.Types + ( ApplyWorkspaceEditParams + ( ApplyWorkspaceEditParams + ), + CodeLens (CodeLens), + CodeLensParams + ( CodeLensParams, + _textDocument + ), + Command (_arguments, _title), + Position (..), + ServerMethod + ( WorkspaceApplyEdit + ), + TextDocumentIdentifier (..), + TextEdit (TextEdit), + WorkspaceEdit (WorkspaceEdit), + ) import Language.Haskell.LSP.VFS (virtualFileText) -import Outputable (showSDocUnsafe, - nest, - ppr, - showSDoc, - text, - ($$), - (<+>), - ) +import Outputable + ( nest, + ppr, + showSDoc, + text, + ($$), + (<+>), + ) import System.FilePath (takeFileName) import System.IO (hClose) import System.IO.Temp (withSystemTempFile) import Text.Read (readMaybe) import Util (OverridingBool (Never)) -import Development.IDE.GHC.Compat (SrcSpan(RealSrcSpan)) -import FastString (unpackFS) - {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. -} codeLens :: CodeLensProvider IdeState -codeLens lsp st plId CodeLensParams{_textDocument} = +codeLens _lsp st plId CodeLensParams{_textDocument} = let dbg = logWith st perf = timed dbg in perf "codeLens" $ @@ -251,7 +239,6 @@ codeLens lsp st plId CodeLensParams{_textDocument} = dbg "fp" fp (ParsedModule{..}, _posMap) <- liftIO $ runAction "parsed" st $ useWithStale_ GetParsedModuleWithComments nfp - dbg "comments" $ showSDocUnsafe $ ppr $ snd pm_annotations let comments = foldMap ( foldMap (\case L (RealSrcSpan real) bdy @@ -269,40 +256,19 @@ codeLens lsp st plId CodeLensParams{_textDocument} = ) ) $ snd pm_annotations - - mdlText <- moduleText lsp uri - - {- Normalise CPP/LHS files/custom preprocessed files. - Used to extract tests correctly from CPP and LHS (Bird-style). - -} - session :: HscEnvEq <- runGetSession st nfp - - Right (ppContent, _dflags) <- - perf "preprocessor" $ - liftIO $ - runExceptT $ - preprocessor (hscEnv session) fp (Just $ textToStringBuffer mdlText) - let text = - cleanSource (isLiterate fp) . decodeUtf8 $ - stringBufferToByteString - ppContent - -- dbg "PREPROCESSED CONTENT" text + dbg "comments" $ show comments + dbg "groups" $ groupLineComments $ lineComments comments -- Extract tests from source code - let Right (setups, nonSetups) = - (splitSections . filter hasTests <$>) - . allSections - . tokensFrom - . T.unpack - $ text - let tests = testsBySection nonSetups - + let Sections{..} = commentsToSections comments + tests = testsBySection nonSetups + nonSetups = lineSections ++ multilineSections cmd <- liftIO $ mkLspCommand plId evalCommandName "Evaluate=..." (Just []) let lenses = [ CodeLens testRange (Just cmd') Nothing | (section, test) <- tests , let (testRange, resultRange) = testRanges test - args = EvalParams (setups ++ [section]) _textDocument + args = EvalParams (setupSections ++ [section]) _textDocument cmd' = (cmd :: Command) { _arguments = Just (List [toJSON args]) @@ -320,7 +286,7 @@ codeLens lsp st plId CodeLensParams{_textDocument} = , "tests in" , show (length nonSetups) , "sections" - , show (length setups) + , show (length setupSections) , "setups" , show (length lenses) , "lenses." @@ -715,27 +681,6 @@ padPrefix :: IsString p => Format -> p padPrefix SingleLine = "-- " padPrefix _ = "" -{- -Normalise preprocessed source code (from a CPP/LHS or other processed file) so that tests are on the same lines as in the original source. - ->>> cleanSource True $ T.pack "#line 1 \nA comment\n> module X where" -"comment\nmodule X where\n" - ->>> cleanSource False $ T.pack "#1 \nmodule X where" -"module X where\n" --} -cleanSource :: Bool -> Text -> Text -cleanSource isLit = - T.unlines - . reverse - . (if isLit then map cleanBirdCode else id) - . takeWhile (\t -> T.null t || (T.head t /= '#')) - . reverse - . T.lines - -cleanBirdCode :: Text -> Text -cleanBirdCode = T.drop 2 - {- | Resulting @Text@ MUST NOT prefix each line with @--@ Such comment-related post-process will be taken place solely in 'evalGhciLikeCmd'. diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index b461abec2e..892c1776e6 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -1,24 +1,29 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} module Ide.Plugin.Eval.Parse.Comments where import qualified Control.Applicative.Combinators.NonEmpty as NE -import Control.Arrow (second, (&&&), (>>>)) +import Control.Arrow (first, second, (&&&), (>>>)) +import Control.Monad (guard, void) import Control.Monad.Combinators () import qualified Data.Char as C import Data.Coerce (coerce) +import qualified Data.DList as DL import qualified Data.List as L import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) import Data.Semigroup import qualified Data.Set as Set import Data.Void (Void) import Development.IDE.GHC.Compat +import GHC.Generics import Ide.Plugin.Eval.Types import SrcLoc (mkRealSrcLoc, mkRealSrcSpan, realSrcSpanEnd, realSrcSpanStart) import Text.Megaparsec @@ -32,28 +37,136 @@ parseSections Comments {..} = undefined groupLineComments :: Map RealSrcSpan String -> [NonEmpty (RealSrcSpan, String)] groupLineComments = - contiguousGroupOn (fst >>> srcSpanStartLine &&& srcSpanEndLine) + contiguousGroupOn (fst >>> srcSpanStartLine &&& srcSpanStartCol) . Map.toList type Parser inputs = Parsec Void inputs -data LineCommentSection - = SingleProp RealSrcSpan PropLine - | Examples RealSrcSpan (NonEmpty ExampleLine) - | NormalCommentLines RealSrcSpan String +-- | Prop line, with "prop>" stripped off +newtype PropLine = PropLine {getPropLine :: String} + deriving (Show) + +-- | Example line, with @>>>@ stripped off +newtype ExampleLine = ExampleLine {getExampleLine :: String} + deriving (Show) + +data LineCommentTest + = AProp + { lineCommentSectionSpan :: RealSrcSpan + , lineProp :: PropLine + , propResults :: [(RealSrcSpan, String)] + } + | AnExample + { lineCommentSectionSpan :: RealSrcSpan + , lineExamples :: NonEmpty ExampleLine + , exampleResults :: [(RealSrcSpan, String)] + } deriving (Show) data CommentFlavour = Vanilla | HaddockNext | HaddockPrev | Named String deriving (Read, Show, Eq, Ord) --- >>> parse lineCommentFlavour "" "-- $a a" --- Right (Named "a") +data CommentStyle = Line | Block + deriving (Read, Show, Eq, Ord, Generic) + +commentsToSections :: Comments -> Sections +commentsToSections Comments {..} = + let (lineSectionSeeds, lineSetupSeeds) = + foldMap + ( \lcs -> + case parseMaybe lineGroupP $ NE.toList lcs of + Nothing -> mempty + Just (mls, rs) -> + (maybe DL.empty DL.singleton mls, DL.fromList rs) + ) + $ groupLineComments + lineComments + (multilineSections, blockSetups) = ([], []) + lineSections = + map (uncurry linesToSection) $ + DL.toList lineSectionSeeds + lineSetups = linesToSection (Named "setup") $ DL.toList lineSetupSeeds + setupSections = lineSetups : blockSetups + in Sections {..} + +linesToSection :: + -- | Nothing if setup section + CommentFlavour -> + [LineCommentTest] -> + Section +linesToSection flav tests = + let sectionName + | Named name <- flav = name + | otherwise = "" + sectionLanguage = case flav of + HaddockNext -> Haddock + HaddockPrev -> Haddock + _ -> Plain + sectionTests = map fromLineTest tests + sectionFormat = SingleLine + in Section {..} + +fromLineTest :: LineCommentTest -> Loc Test +fromLineTest AProp {..} = + Located + (srcSpanStartLine lineCommentSectionSpan - 1) + Property + { testline = getPropLine lineProp + , testOutput = map snd propResults + } +fromLineTest AnExample {..} = + Located + (srcSpanStartLine lineCommentSectionSpan - 1) + Example + { testLines = getExampleLine <$> lineExamples + , testOutput = map snd exampleResults + } + +-- >>> parseMaybe + +{- | +Result: a tuple of ordinary line tests and setting sections. + +TODO: Haddock comment can adjacent to vanilla comment: + + @ + -- Vanilla comment + -- Another vanilla + -- | This parses as Haddock comment as GHC + @ + +This behaviour is not yet handled correctly in Eval Plugin; +but for future extension for this, we use a tuple here instead of 'Either'. +-} +lineGroupP :: + Parser + [(RealSrcSpan, String)] + (Maybe (CommentFlavour, [LineCommentTest]), [LineCommentTest]) +lineGroupP = do + (_, flav) <- + lookAhead $ + token (mapM $ parseMaybe $ lineCommentFlavour <* takeRest) mempty + case flav of + Named "setup" -> (Nothing,) <$> lineCommentSectionsP + flav -> (,mempty) . Just . (flav,) <$> lineCommentSectionsP + +-- >>> :set -XOverloadedStrings +-- >>> dummyLoc = mkRealSrcLoc "" 0 0 +-- >>> dummySpan = mkRealSrcSpan dummyLoc dummyLoc +-- >>> parseMaybe lineCommentSectionsP $ (dummySpan,) <$> ["-- | >>> unwords example", "-- \"Stale output\""] +-- Just [] + +-- >>> parseMaybe (lineCommentFlavour *> takeRest) "-- >>> a" +-- Just ">>> a" + +-- >>> parseMaybe (lineCommentFlavour *> takeRest) "-- | >>> a" +-- Just ">>> a" lineCommentFlavour :: Parser String CommentFlavour lineCommentFlavour = - commentHeadP + lineCommentHeadP -- N.B. Haddock assumes at most one space before modifiers: - *> space + *> optional (satisfy C.isSpace) *> P.option Vanilla ( HaddockNext <$ char '|' @@ -62,23 +175,55 @@ lineCommentFlavour = <* optional space <*> P.takeWhile1P (Just "alphabet number") C.isAlphaNum ) + <* space -commentHeadP :: Parser String () -commentHeadP = +lineCommentHeadP :: Parser String () +lineCommentHeadP = space *> chunk "--" *> P.notFollowedBy (oneOf "!#$%&*.+=/<>?@\\~^-:|") +{- $setup + >>> :set -XOverloadedStrings + >>> dummyLoc = mkRealSrcLoc "" 0 0 + >>> dummySpan = mkRealSrcSpan dummyLoc dummyLoc +-} + lineCommentSectionsP :: - Parser [(RealSrcSpan, String)] [LineCommentSection] -lineCommentSectionsP = - many $ - toExamples <$> exampleLinesP - <|> uncurry SingleProp . second snd <$> propLineP - <|> uncurry NormalCommentLines <$> anySingle + Parser [(RealSrcSpan, String)] [LineCommentTest] +lineCommentSectionsP = do + skipMany normalCommentP + lexemeLine $ + many $ + exampleLinesP + <|> uncurry AProp . second snd <$> propLineP <*> resultLinesP + <* skipMany normalCommentP + +lexemeLine :: Parser [(RealSrcSpan, String)] a -> Parser [(RealSrcSpan, String)] a +lexemeLine p = p <* skipMany normalCommentP + +resultLinesP :: Parser [(RealSrcSpan, String)] [(RealSrcSpan, String)] +resultLinesP = many nonEmptyCommentP + +emptyLineP :: Parser [(RealSrcSpan, String)] () +emptyLineP = + void $ + satisfy $ + isJust . parseMaybe (lineCommentHeadP *> space) . snd -toExamples :: NonEmpty (RealSrcSpan, ExampleLine) -> LineCommentSection -toExamples lns = - Examples (convexHullSpan $ fst <$> lns) $ snd <$> lns +normalCommentP :: Parser [(RealSrcSpan, String)] (RealSrcSpan, String) +normalCommentP = + P.token + (mapM $ \ln -> do + guard $ isNothing $ parseMaybe (void (try exampleLineStrP) <|> void propLineStrP) ln + pure $ dropWhile C.isSpace $ drop 2 ln + ) + mempty + +nonEmptyCommentP :: Parser [(RealSrcSpan, String)] (RealSrcSpan, String) +nonEmptyCommentP = do + (spn, str) <- normalCommentP + guard $ not $ null str + pure (spn, str) convexHullSpan :: NonEmpty RealSrcSpan -> RealSrcSpan convexHullSpan lns@(headSpan :| _) = @@ -100,35 +245,37 @@ dropLineComment = . drop 2 . L.dropWhile C.isSpace --- | Example line, with @>>>@ stripped off -newtype ExampleLine = ExampleLine {getExampleLine :: String} - deriving (Show) - -exampleLinesP :: Parser [(RealSrcSpan, String)] (NonEmpty (RealSrcSpan, ExampleLine)) -exampleLinesP = NE.some $ second snd <$> exampleLineP +exampleLinesP :: Parser [(RealSrcSpan, String)] LineCommentTest +exampleLinesP = + lexemeLine $ + uncurry AnExample . first convexHullSpan . NE.unzip + <$> NE.some (second snd <$> exampleLineP) + <*> resultLinesP exampleLineP :: Parser [(RealSrcSpan, String)] (RealSrcSpan, (CommentFlavour, ExampleLine)) -exampleLineP = P.token (mapM $ parseMaybe exampleLineStrP) mempty +exampleLineP = do + P.token (mapM $ parseMaybe exampleLineStrP) mempty propLineP :: Parser [(RealSrcSpan, String)] (RealSrcSpan, (CommentFlavour, PropLine)) propLineP = P.token (mapM $ parseMaybe propLineStrP) mempty +-- >>> either (error . errorBundlePretty) id $ parse exampleLineStrP "" "-- | >>> 12" +-- (HaddockNext,ExampleLine {getExampleLine = " 12"}) + exampleLineStrP :: Parser String (CommentFlavour, ExampleLine) exampleLineStrP = (,) <$> lineCommentFlavour - <* chunk ">>>" <* P.notFollowedBy (char '>') + <* chunk ">>>" + <* P.notFollowedBy (char '>') <*> (ExampleLine <$> P.takeRest) propLineStrP :: Parser String (CommentFlavour, PropLine) propLineStrP = (,) <$> lineCommentFlavour - <* chunk "prop>" <* P.notFollowedBy (char '>') + <* chunk "prop>" + <* P.notFollowedBy (char '>') <*> (PropLine <$> P.takeRest) --- | Prop line, with "prop>" stripped off -newtype PropLine = PropLine {runPropLine :: String} - deriving (Show) - {- | Given a sequence of tokens increasing in their starting position, groups them into sublists consisting of contiguous tokens; diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Section.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Section.hs deleted file mode 100644 index 403f393d22..0000000000 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Section.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# OPTIONS_GHC -Wwarn #-} -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} - --- |Parse a Section, a group of zero or more tests defined in a multiline comment or a sequence of one line comments. -module Ide.Plugin.Eval.Parse.Section ( - allSections, - validSections, - Section (..), -) where - -import qualified Control.Applicative.Combinators.NonEmpty as NE -import Control.Monad.Combinators ( - many, - optional, - some, - (<|>), - ) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (catMaybes, fromMaybe) -import Ide.Plugin.Eval.Parse.Parser ( - Parser, - runParser, - satisfy, - ) -import Ide.Plugin.Eval.Parse.Token ( - Token (BlockOpen, blockFormat, blockLanguage, blockName), - TokenS, - isBlockClose, - isBlockOpen, - isCodeLine, - isPropLine, - isStatement, - isTextLine, - unsafeContent, - ) -import Ide.Plugin.Eval.Types ( - Format (SingleLine), - Loc, - Located (Located, located, location), - Section (..), - Test (Example, Property), - hasTests, - unLoc, - ) - -type Tk = Loc TokenS - -validSections :: [Tk] -> Either String [Section] -validSections = (filter hasTests <$>) . allSections - -allSections :: [Tk] -> Either String [Section] -allSections = runParser sections - -{- ->>> import Ide.Plugin.Eval.Parse.Token ->>> import System.IO.Extra(readFileUTF8') ->>> testSource_ = runParser sections . tokensFrom ->>> testSource fp = testSource_ <$> readFileUTF8' fp - ->>> testSource "plugins/default/src/Ide/Plugin/Eval/Test/TestGHC.hs" -Right [Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [Located {location = 36, located = Property {testline = " \\(l::[Bool]) -> reverse (reverse l) == l", testOutput = []}}], sectionLanguage = Plain, sectionFormat = MultiLine},Section {sectionName = "", sectionTests = [Located {location = 40, located = Example {testLines = " :set -XScopedTypeVariables -XExplicitForAll" :| [" import qualified Test.QuickCheck as Q11"," runProp11 p = Q11.quickCheckWithResult Q11.stdArgs p >>= return . Q11.output"," prop11 = \\(l::[Int]) -> reverse (reverse l) == l"," runProp11 prop11"], testOutput = []}},Located {location = 46, located = Property {testline = " \\(l::[Int]) -> reverse (reverse l) == l", testOutput = []}}], sectionLanguage = Plain, sectionFormat = MultiLine},Section {sectionName = "", sectionTests = [Located {location = 50, located = Example {testLines = " t" :| [], testOutput = []}}], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [Located {location = 55, located = Example {testLines = " run $ runEval \"3+2\"" :| [], testOutput = []}}], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [Located {location = 125, located = Example {testLines = " isStmt \"\"" :| [], testOutput = ["stmt = let x =33;print x"]}}], sectionLanguage = Haddock, sectionFormat = MultiLine},Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = MultiLine},Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = SingleLine}] - ->>> testSource "test/testdata/eval/T11.hs" -Right [Section {sectionName = "", sectionTests = [Located {location = 2, located = Example {testLines = " :kind! a" :| [], testOutput = []}}], sectionLanguage = Plain, sectionFormat = SingleLine}] - ->>> testSource "test/testdata/eval/T12.hs" -Right [Section {sectionName = "", sectionTests = [Located {location = 6, located = Example {testLines = " type N = 1" :| [" type M = 40"," :kind N + M + 1"], testOutput = []}}], sectionLanguage = Plain, sectionFormat = SingleLine}] - ->>> testSource_ $ "{"++"-\n -" ++ "}" -Right [Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = MultiLine}] --} -sections :: Parser Tk [Section] -sections = - catMaybes <$> many (const Nothing <$> some code <|> Just <$> section) - -section :: Parser Tk Section -section = sectionBody >>= sectionEnd - -sectionBody :: Parser Tk Section -sectionBody = - ( \(unLoc -> BlockOpen{..}) ts -> - Section (fromMaybe "" blockName) (catMaybes ts) blockLanguage blockFormat - ) - <$> open <*> many (Just <$> example <|> Just <$> property <|> const Nothing <$> doc) - -sectionEnd :: Section -> Parser Tk Section -sectionEnd s - | sectionFormat s == SingleLine = optional code *> return s - | otherwise = close *> return s - --- section = do --- s <- --- maybe --- (Section "" [] Plain SingleLine) --- ( \(Located _ BlockOpen {..}) -> --- Section (fromMaybe "" blockName) [] blockLanguage blockFormat --- ) --- <$> optional open --- ts <- many (Just <$> example <|> Just <$> property <|> const Nothing <$> doc) --- optional close --- return $ s {sectionTests = catMaybes ts} - --- singleSection :: Parser Tk Section --- singleSection = (\ts -> Section "" (catMaybes ts) Plain SingleLine) <$> tests - --- tests :: Parser Tk [Maybe (Loc Test)] --- tests = some (Just <$> example <|> Just <$> property <|> const Nothing <$> doc) - -doc :: Parser Tk [Tk] -doc = some text - -example, property :: Parser Tk (Loc Test) -property = - ( \(Located l p) rs -> - Located l (Property (unsafeContent p) (unsafeContent . located <$> rs)) - ) - <$> prop - <*> many nonEmptyText -example = - ( \es rs -> - Located - (location (NE.head es)) - (Example (unsafeContent . located <$> es) (unsafeContent . located <$> rs)) - ) - <$> NE.some statement - <*> many nonEmptyText - -open, close, statement, nonEmptyText, text, prop, code :: Parser Tk Tk -statement = is isStatement -text = is isTextLine -prop = is isPropLine -open = is isBlockOpen -close = is isBlockClose -code = is isCodeLine -nonEmptyText = is (\l -> isTextLine l && not (null (unsafeContent l))) - -is :: (b -> Bool) -> Parser (Loc b) (Loc b) -is p = satisfy (p . unLoc) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Token.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Token.hs deleted file mode 100644 index 614ae02107..0000000000 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Token.hs +++ /dev/null @@ -1,283 +0,0 @@ -{-# OPTIONS_GHC -Wwarn #-} - --- | Parse source code into a list of line Tokens. -module Ide.Plugin.Eval.Parse.Token ( - Token(..), - TokenS, - tokensFrom, - unsafeContent, - isStatement, - isTextLine, - isPropLine, - isCodeLine, - isBlockOpen, - isBlockClose -) where - -import Control.Monad.Combinators (many, optional, skipManyTill, - (<|>)) -import Data.Functor (($>)) -import Data.List (foldl') -import Ide.Plugin.Eval.Parse.Parser (Parser, alphaNumChar, char, - letterChar, runParser, satisfy, - space, string, tillEnd) -import Ide.Plugin.Eval.Types (Format (..), Language (..), Loc, - Located (Located)) -import Maybes (fromJust, fromMaybe) - -type TParser = Parser Char (State, [TokenS]) - -data State = InCode | InSingleComment | InMultiComment deriving (Eq, Show) - -commentState :: Bool -> State -commentState True = InMultiComment -commentState False = InSingleComment - -type TokenS = Token String - -data Token s - = -- | Text, without prefix "(--)? >>>" - Statement s - | -- | Text, without prefix "(--)? prop>" - PropLine s - | -- | Text inside a comment - TextLine s - | -- | Line of code (outside comments) - CodeLine - | -- | Open of comment - BlockOpen {blockName :: Maybe s, blockLanguage :: Language, blockFormat :: Format} - | -- | Close of multi-line comment - BlockClose - deriving (Eq, Show) - -isStatement :: Token s -> Bool -isStatement (Statement _) = True -isStatement _ = False - -isTextLine :: Token s -> Bool -isTextLine (TextLine _) = True -isTextLine _ = False - -isPropLine :: Token s -> Bool -isPropLine (PropLine _) = True -isPropLine _ = False - -isCodeLine :: Token s -> Bool -isCodeLine CodeLine = True -isCodeLine _ = False - -isBlockOpen :: Token s -> Bool -isBlockOpen (BlockOpen _ _ _) = True -isBlockOpen _ = False - -isBlockClose :: Token s -> Bool -isBlockClose BlockClose = True -isBlockClose _ = False - -unsafeContent :: Token a -> a -unsafeContent = fromJust . contentOf - -contentOf :: Token a -> Maybe a -contentOf (Statement c) = Just c -contentOf (PropLine c) = Just c -contentOf (TextLine c) = Just c -contentOf _ = Nothing - -{- | Parse source code and return a list of located Tokens ->>> import Ide.Plugin.Eval.Types (unLoc) ->>> tks src = map unLoc . tokensFrom <$> readFile src - ->>> tks "test/testdata/eval/T1.hs" -[CodeLine,CodeLine,CodeLine,CodeLine,BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = SingleLine},Statement " unwords example",CodeLine,CodeLine] - ->>> tks "test/testdata/eval/TLanguageOptions.hs" -[BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = SingleLine},TextLine "Support for language options",CodeLine,CodeLine,CodeLine,CodeLine,BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = SingleLine},TextLine "Language options set in the module source (ScopedTypeVariables)",TextLine "also apply to tests so this works fine",Statement " f = (\\(c::Char) -> [c])",CodeLine,BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine},TextLine "Multiple options can be set with a single `:set`",TextLine "",Statement " :set -XMultiParamTypeClasses -XFlexibleInstances",Statement " class Z a b c",BlockClose,CodeLine,BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine},TextLine "",TextLine "",TextLine "Options apply only in the section where they are defined (unless they are in the setup section), so this will fail:",TextLine "",Statement " class L a b c",BlockClose,CodeLine,CodeLine,BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine},TextLine "",TextLine "Options apply to all tests in the same section after their declaration.",TextLine "",TextLine "Not set yet:",TextLine "",Statement " class D",TextLine "",TextLine "Now it works:",TextLine "",Statement ":set -XMultiParamTypeClasses",Statement " class C",TextLine "",TextLine "It still works",TextLine "",Statement " class F",BlockClose,CodeLine,BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine},TextLine "Wrong option names are reported.",Statement " :set -XWrong",BlockClose] - --} -tokensFrom :: String -> [Loc (Token String)] -tokensFrom = tokens . lines . filter (/= '\r') - -{- | ->>> tokens ["-- |$setup >>> 4+7","x=11"] -[Located {location = 0, located = BlockOpen {blockName = Just "setup", blockLanguage = Haddock, blockFormat = SingleLine}},Located {location = 0, located = Statement " 4+7"},Located {location = 1, located = CodeLine}] - ->>> tokens ["-- $start"] -[Located {location = 0, located = BlockOpen {blockName = Just "start", blockLanguage = Plain, blockFormat = SingleLine}},Located {location = 0, located = TextLine ""}] - ->>> tokens ["--","-- >>> 4+7"] -[Located {location = 0, located = BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = SingleLine}},Located {location = 0, located = TextLine ""},Located {location = 1, located = Statement " 4+7"}] - ->>> tokens ["-- |$setup 44","-- >>> 4+7"] -[Located {location = 0, located = BlockOpen {blockName = Just "setup", blockLanguage = Haddock, blockFormat = SingleLine}},Located {location = 0, located = TextLine "44"},Located {location = 1, located = Statement " 4+7"}] - ->>> tokens ["{"++"- |$doc",">>> 2+2","4","prop> x-x==0","--minus","-"++"}"] -[Located {location = 0, located = BlockOpen {blockName = Just "doc", blockLanguage = Haddock, blockFormat = MultiLine}},Located {location = 0, located = TextLine ""},Located {location = 1, located = Statement " 2+2"},Located {location = 2, located = TextLine "4"},Located {location = 3, located = PropLine " x-x==0"},Located {location = 4, located = TextLine "--minus"},Located {location = 5, located = BlockClose}] - -Multi lines, closed on following line: - ->>> tokens ["{"++"-","-"++"}"] -[Located {location = 0, located = BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine}},Located {location = 0, located = TextLine ""},Located {location = 1, located = BlockClose}] - ->>> tokens [" {"++"-","-"++"} "] -[Located {location = 0, located = BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine}},Located {location = 0, located = TextLine ""},Located {location = 1, located = BlockClose}] - ->>> tokens ["{"++"- SOME TEXT "," MORE -"++"}"] -[Located {location = 0, located = BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine}},Located {location = 0, located = TextLine "SOME TEXT "},Located {location = 1, located = BlockClose}] - -Multi lines, closed on the same line: - ->>> tokens $ ["{--}"] -[Located {location = 0, located = CodeLine}] - ->>> tokens $ [" {- IGNORED -} "] -[Located {location = 0, located = CodeLine}] - ->>> tokens ["{-# LANGUAGE TupleSections","#-}"] -[Located {location = 0, located = CodeLine},Located {location = 1, located = CodeLine}] - ->>> tokens [] -[] --} -tokens :: [String] -> [Loc TokenS] -tokens = concatMap (\(l, vs) -> map (Located l) vs) . zip [0 ..] . reverse . snd . foldl' next (InCode, []) - where - next (st, tokens) ln = case runParser (aline st) ln of - Right (st', tokens') -> (st', tokens' : tokens) - Left err -> error $ unwords ["Tokens.next failed to parse", ln, err] - --- | Parse a line of input -aline :: State -> TParser -aline InCode = optionStart <|> multi <|> singleOpen <|> codeLine -aline InSingleComment = optionStart <|> multi <|> commentLine False <|> codeLine -aline InMultiComment = multiClose <|> commentLine True - -multi :: TParser -multi = multiOpenClose <|> multiOpen - -codeLine :: TParser -codeLine = (InCode, [CodeLine]) <$ tillEnd - -{- | A multi line comment that starts and ends on the same line. - ->>> runParser multiOpenClose $ concat ["{","--","}"] -Right (InCode,[CodeLine]) - ->>> runParser multiOpenClose $ concat [" {","-| >>> IGNORED -","} "] -Right (InCode,[CodeLine]) --} -multiOpenClose :: TParser -multiOpenClose = (multiStart >> multiClose) $> (InCode, [CodeLine]) - -{-| Parses the opening of a multi line comment. ->>> runParser multiOpen $ "{"++"- $longSection this is also parsed" -Right (InMultiComment,[BlockOpen {blockName = Just "longSection", blockLanguage = Plain, blockFormat = MultiLine},TextLine "this is also parsed"]) - ->>> runParser multiOpen $ "{"++"- $longSection >>> 2+3" -Right (InMultiComment,[BlockOpen {blockName = Just "longSection", blockLanguage = Plain, blockFormat = MultiLine},Statement " 2+3"]) --} -multiOpen :: TParser -multiOpen = - ( \() (maybeLanguage, maybeName) tk -> - (InMultiComment, [BlockOpen maybeName (defLang maybeLanguage) MultiLine, tk]) - ) - <$> multiStart - <*> languageAndName - <*> commentRest - -{- | Parse the first line of a sequence of single line comments ->>> runParser singleOpen "-- |$doc >>>11" -Right (InSingleComment,[BlockOpen {blockName = Just "doc", blockLanguage = Haddock, blockFormat = SingleLine},Statement "11"]) --} -singleOpen :: TParser -singleOpen = - ( \() (maybeLanguage, maybeName) tk -> - (InSingleComment, [BlockOpen maybeName (defLang maybeLanguage) SingleLine, tk]) - ) - <$> singleStart - <*> languageAndName - <*> commentRest - -{- | Parse a line in a comment ->>> runParser (commentLine False) "x=11" -Left "No match" - ->>> runParser (commentLine False) "-- >>>11" -Right (InSingleComment,[Statement "11"]) - ->>> runParser (commentLine True) "-- >>>11" -Right (InMultiComment,[TextLine "-- >>>11"]) --} -commentLine :: Bool -> TParser -commentLine noPrefix = - (\tk -> (commentState noPrefix, [tk])) <$> (optLineStart noPrefix *> commentBody) - -commentRest :: Parser Char (Token [Char]) -commentRest = many space *> commentBody - -commentBody :: Parser Char (Token [Char]) -commentBody = stmt <|> prop <|> txt - where - txt = TextLine <$> tillEnd - stmt = Statement <$> (string ">>>" *> tillEnd) - prop = PropLine <$> (string "prop>" *> tillEnd) - --- | Remove comment line prefix, if needed -optLineStart :: Bool -> Parser Char () -optLineStart noPrefix - | noPrefix = pure () - | otherwise = singleStart - -singleStart :: Parser Char () -singleStart = (string "--" *> optional space) $> () - -multiStart :: Parser Char () -multiStart = sstring "{-" $> () - -{- Parse the close of a multi-line comment ->>> runParser multiClose $ "-"++"}" -Right (InCode,[BlockClose]) - ->>> runParser multiClose $ "-"++"} " -Right (InCode,[BlockClose]) - -As there is currently no way of handling tests in the final line of a multi line comment, it ignores anything that precedes the closing marker: - ->>> runParser multiClose $ "IGNORED -"++"} " -Right (InCode,[BlockClose]) --} -multiClose :: TParser -multiClose = skipManyTill (satisfy (const True)) (string "-}" *> many space) >> return (InCode, [BlockClose]) - -optionStart :: Parser Char (State, [Token s]) -optionStart = (string "{-#" *> tillEnd) $> (InCode, [CodeLine]) - -name :: Parser Char [Char] -name = (:) <$> letterChar <*> many (alphaNumChar <|> char '_') - -sstring :: String -> Parser Char [Char] -sstring s = many space *> string s *> many space - -{- | ->>>runParser languageAndName "|$" -Right (Just Haddock,Just "") - ->>>runParser languageAndName "|$start" -Right (Just Haddock,Just "start") - ->>>runParser languageAndName "| $start" -Right (Just Haddock,Just "start") - ->>>runParser languageAndName "^" -Right (Just Haddock,Nothing) - ->>>runParser languageAndName "$start" -Right (Nothing,Just "start") --} -languageAndName :: Parser Char (Maybe Language, Maybe String) -languageAndName = - (,) <$> optional ((char '|' <|> char '^') >> pure Haddock) - <*> optional - (char '$' *> (fromMaybe "" <$> optional name)) - -defLang :: Maybe Language -> Language -defLang = fromMaybe Plain diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index f89d96cf0d..6eb399d90d 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -57,8 +57,8 @@ type Txt = String data Sections = Sections { setupSections :: [Section] - , lineSecions :: [Section] - , multilneSections :: [Section] + , lineSections :: [Section] + , multilineSections :: [Section] } deriving (Show, Eq, Generic) From 032bc609fd01c59b3c32ea5f9f7a9c1214c35274 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 21 Jan 2021 23:50:05 +0900 Subject: [PATCH 04/41] Completely switches to Megaparsec --- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 1 - .../src/Ide/Plugin/Eval/Parse/Option.hs | 26 ++--- .../src/Ide/Plugin/Eval/Parse/Parser.hs | 98 ------------------- .../test/testdata/TLastLine.hs | 3 + 4 files changed, 16 insertions(+), 112 deletions(-) delete mode 100644 plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Parser.hs create mode 100644 plugins/hls-eval-plugin/test/testdata/TLastLine.hs diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index f5554184f7..a4605a108c 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -31,7 +31,6 @@ library Ide.Plugin.Eval.CodeLens Ide.Plugin.Eval.GHC Ide.Plugin.Eval.Parse.Option - Ide.Plugin.Eval.Parse.Parser Ide.Plugin.Eval.Parse.Comments Ide.Plugin.Eval.Types Ide.Plugin.Eval.Util diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Option.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Option.hs index ad75bb4c39..a76dfdeb22 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Option.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Option.hs @@ -6,13 +6,10 @@ module Ide.Plugin.Eval.Parse.Option ( ) where import Control.Monad.Combinators (many) -import Ide.Plugin.Eval.Parse.Parser ( - Parser, - letterChar, - runParser, - space, - string, - ) +import Text.Megaparsec.Char +import Text.Megaparsec +import Data.Void (Void) +import Control.Arrow (left) {- | >>> langOptions ":set -XBinaryLiterals -XOverloadedStrings " @@ -24,10 +21,13 @@ Right [] >>> langOptions "" Left "No match" -} -langOptions :: [Char] -> Either String [[Char]] -langOptions = runParser (many space *> languageOpts <* many space) +langOptions :: String -> Either String [String] +langOptions = + left errorBundlePretty + . parse (space *> languageOpts <* eof) "" --- >>> runParser languageOpts ":set -XBinaryLiterals -XOverloadedStrings" --- Right ["BinaryLiterals","OverloadedStrings"] -languageOpts :: Parser Char [[Char]] -languageOpts = string ":set" *> many (many space *> string "-X" *> many letterChar) +-- >>> parseMaybe languageOpts ":set -XBinaryLiterals -XOverloadedStrings" +-- Just ["BinaryLiterals","OverloadedStrings"] +languageOpts :: Parsec Void String [String] +languageOpts = string ":set" *> space1 + *> many (string "-X" *> many letterChar <* space) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Parser.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Parser.hs deleted file mode 100644 index a3d533d4e9..0000000000 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Parser.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} - --- |Simple List Parser, used for both line and test parsing. -module Ide.Plugin.Eval.Parse.Parser ( - Parser, - runParser, - satisfy, - alphaNumChar, - letterChar, - space, - string, - char, - tillEnd, -) where - -import Control.Applicative (Alternative) -import Control.Monad (MonadPlus, (>=>)) -import Control.Monad.Combinators ( - empty, - (<|>), - ) -import Data.Char ( - isAlphaNum, - isLetter, - ) -import Data.List (isPrefixOf) - -type CharParser = Parser Char - -{- $setup - >>> import Control.Monad.Combinators --} - -{- | ->>> runParser (string "aa" <|> string "bb") "bb" -Right "bb" - ->>> runParser (some (string "aa")) "aaaaaa" -Right ["aa","aa","aa"] --} -string :: String -> CharParser String -string t = Parser $ - \s -> if t `isPrefixOf` s then Just (t, drop (length t) s) else Nothing - -letterChar :: Parser Char Char -letterChar = satisfy isLetter - -alphaNumChar :: Parser Char Char -alphaNumChar = satisfy isAlphaNum - -space :: Parser Char Char -space = char ' ' - -{- | - >>> runParser (some $ char 'a') "aa" - Right "aa" --} -char :: Char -> CharParser Char -char ch = satisfy (== ch) - -{- | ->>> runParser tillEnd "abc\ndef" -Right "abc\ndef" --} -tillEnd :: Parser t [t] -tillEnd = Parser $ \s -> Just (s, []) - -satisfy :: (t -> Bool) -> Parser t t -satisfy f = Parser sel - where - sel [] = Nothing - sel (t : ts) - | f t = Just (t, ts) - | otherwise = Nothing - -newtype Parser t a = Parser {parse :: [t] -> Maybe (a, [t])} deriving (Functor) - -instance Applicative (Parser t) where - pure a = Parser (\s -> Just (a, s)) - (Parser p1) <*> (Parser p2) = - Parser (p1 >=> (\(f, s1) -> p2 s1 >>= \(a, s2) -> return (f a, s2))) - -instance Alternative (Parser t) where - empty = Parser (const Nothing) - p <|> q = Parser $ \s -> parse p s <|> parse q s - -instance Monad (Parser t) where - return = pure - (>>=) f g = Parser (parse f >=> (\(a, s') -> parse (g a) s')) - -instance MonadPlus (Parser t) - -runParser :: Show t => Parser t a -> [t] -> Either String a -runParser m s = case parse m s of - Just (res, []) -> Right res - Just (_, ts) -> - Left $ "Parser did not consume entire stream, left: " ++ show ts - Nothing -> Left "No match" diff --git a/plugins/hls-eval-plugin/test/testdata/TLastLine.hs b/plugins/hls-eval-plugin/test/testdata/TLastLine.hs new file mode 100644 index 0000000000..779fb1230a --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TLastLine.hs @@ -0,0 +1,3 @@ +module TLastLine where + +-- >>> take 3 [1..] \ No newline at end of file From abc37963f18375ed4a50fb73d71ad8a6d910b838 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Fri, 22 Jan 2021 01:24:50 +0900 Subject: [PATCH 05/41] T27 must be fixed --- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 1 + .../src/Ide/Plugin/Eval/CodeLens.hs | 13 ++- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 90 ++++++++++--------- .../src/Ide/Plugin/Eval/Types.hs | 5 +- 4 files changed, 63 insertions(+), 46 deletions(-) diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index a4605a108c..a341d06af4 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -53,6 +53,7 @@ library , haskell-lsp , haskell-lsp-types , hls-plugin-api + , lens , megaparsec >= 0.9 , parser-combinators , pretty-simple diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 9db76b4b08..571e308782 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -57,7 +57,7 @@ import qualified Data.Text as T import Data.Time (getCurrentTime) import Data.Typeable (Typeable) import Development.IDE - ( GetModSummary (..), + (realSrcSpanToRange, GetModSummary (..), GetParsedModuleWithComments (..), GhcSession (..), HscEnvEq (envImportPaths), @@ -224,6 +224,8 @@ import System.IO (hClose) import System.IO.Temp (withSystemTempFile) import Text.Read (readMaybe) import Util (OverridingBool (Never)) +import Development.IDE.Core.PositionMapping (toCurrentRange) + {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. -} @@ -237,20 +239,23 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = fp <- handleMaybe "uri" $ uriToFilePath' uri let nfp = toNormalizedFilePath' fp dbg "fp" fp - (ParsedModule{..}, _posMap) <- liftIO $ + (ParsedModule{..}, posMap) <- liftIO $ runAction "parsed" st $ useWithStale_ GetParsedModuleWithComments nfp let comments = foldMap ( foldMap (\case L (RealSrcSpan real) bdy | unpackFS (srcSpanFile real) == fromNormalizedFilePath nfp -> + let ran0 = realSrcSpanToRange real + curRan = fromMaybe ran0 $ toCurrentRange posMap ran0 + in -- since Haddock parsing is off, -- we can concentrate on these two case bdy of AnnLineComment cmt -> - mempty { lineComments = Map.singleton real cmt } + mempty { lineComments = Map.singleton curRan cmt } AnnBlockComment cmt -> - mempty { blockComments = Map.singleton real cmt } + mempty { blockComments = Map.singleton curRan cmt } _ -> mempty _ -> mempty ) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index 892c1776e6..48d3398896 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -8,6 +9,7 @@ module Ide.Plugin.Eval.Parse.Comments where import qualified Control.Applicative.Combinators.NonEmpty as NE import Control.Arrow (first, second, (&&&), (>>>)) +import Control.Lens (view, (^.)) import Control.Monad (guard, void) import Control.Monad.Combinators () import qualified Data.Char as C @@ -18,26 +20,31 @@ import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) +import Data.Maybe (isJust, isNothing) import Data.Semigroup -import qualified Data.Set as Set import Data.Void (Void) -import Development.IDE.GHC.Compat +import Development.IDE (Range) +import Development.IDE.Types.Location (Range (Range)) import GHC.Generics import Ide.Plugin.Eval.Types -import SrcLoc (mkRealSrcLoc, mkRealSrcSpan, realSrcSpanEnd, realSrcSpanStart) +import Language.Haskell.LSP.Types.Lens + ( character, + end, + line, + start, + ) import Text.Megaparsec import qualified Text.Megaparsec as P -import Text.Megaparsec.Char (char, space, space1) +import Text.Megaparsec.Char (char, space) parseSections :: Comments -> Sections parseSections Comments {..} = undefined groupLineComments :: - Map RealSrcSpan String -> [NonEmpty (RealSrcSpan, String)] + Map Range String -> [NonEmpty (Range, String)] groupLineComments = - contiguousGroupOn (fst >>> srcSpanStartLine &&& srcSpanStartCol) + contiguousGroupOn (fst >>> view start >>> view line &&& view character) . Map.toList type Parser inputs = Parsec Void inputs @@ -52,14 +59,14 @@ newtype ExampleLine = ExampleLine {getExampleLine :: String} data LineCommentTest = AProp - { lineCommentSectionSpan :: RealSrcSpan + { lineCommentSectionSpan :: Range , lineProp :: PropLine - , propResults :: [(RealSrcSpan, String)] + , propResults :: [(Range, String)] } | AnExample - { lineCommentSectionSpan :: RealSrcSpan + { lineCommentSectionSpan :: Range , lineExamples :: NonEmpty ExampleLine - , exampleResults :: [(RealSrcSpan, String)] + , exampleResults :: [(Range, String)] } deriving (Show) @@ -79,8 +86,7 @@ commentsToSections Comments {..} = Just (mls, rs) -> (maybe DL.empty DL.singleton mls, DL.fromList rs) ) - $ groupLineComments - lineComments + $ groupLineComments lineComments (multilineSections, blockSetups) = ([], []) lineSections = map (uncurry linesToSection) $ @@ -90,7 +96,6 @@ commentsToSections Comments {..} = in Sections {..} linesToSection :: - -- | Nothing if setup section CommentFlavour -> [LineCommentTest] -> Section @@ -109,20 +114,26 @@ linesToSection flav tests = fromLineTest :: LineCommentTest -> Loc Test fromLineTest AProp {..} = Located - (srcSpanStartLine lineCommentSectionSpan - 1) + (lineCommentSectionSpan ^. start . line) Property { testline = getPropLine lineProp , testOutput = map snd propResults } fromLineTest AnExample {..} = Located - (srcSpanStartLine lineCommentSectionSpan - 1) + (lineCommentSectionSpan ^. start . line) Example { testLines = getExampleLine <$> lineExamples , testOutput = map snd exampleResults } --- >>> parseMaybe +-- >>> :set -XOverloadedStrings +-- >>> import Language.Haskell.LSP.Types (Position(..)) +-- >>> dummyLoc = Position 0 0 +-- >>> dummySpan = Range dummyLoc dummyLoc +-- >>> import Control.Arrow +-- >>> parse lineCommentSectionsP "" [(dummySpan, "-- >>> 12"), (dummySpan, "--")] +-- Right [AnExample {lineCommentSectionSpan = Range {_start = Position {_line = 0, _character = 0}, _end = Position {_line = 0, _character = 0}}, lineExamples = ExampleLine {getExampleLine = " 12"} :| [], exampleResults = []}] {- | Result: a tuple of ordinary line tests and setting sections. @@ -140,7 +151,7 @@ but for future extension for this, we use a tuple here instead of 'Either'. -} lineGroupP :: Parser - [(RealSrcSpan, String)] + [(Range, String)] (Maybe (CommentFlavour, [LineCommentTest]), [LineCommentTest]) lineGroupP = do (_, flav) <- @@ -183,13 +194,13 @@ lineCommentHeadP = *> P.notFollowedBy (oneOf "!#$%&*.+=/<>?@\\~^-:|") {- $setup - >>> :set -XOverloadedStrings - >>> dummyLoc = mkRealSrcLoc "" 0 0 - >>> dummySpan = mkRealSrcSpan dummyLoc dummyLoc +>>> :set -XOverloadedStrings +>>> dummyLoc = mkRealSrcLoc "" 0 0 +>>> dummySpan = mkRealSrcSpan dummyLoc dummyLoc -} lineCommentSectionsP :: - Parser [(RealSrcSpan, String)] [LineCommentTest] + Parser [(Range, String)] [LineCommentTest] lineCommentSectionsP = do skipMany normalCommentP lexemeLine $ @@ -198,45 +209,44 @@ lineCommentSectionsP = do <|> uncurry AProp . second snd <$> propLineP <*> resultLinesP <* skipMany normalCommentP -lexemeLine :: Parser [(RealSrcSpan, String)] a -> Parser [(RealSrcSpan, String)] a +lexemeLine :: Parser [(Range, String)] a -> Parser [(Range, String)] a lexemeLine p = p <* skipMany normalCommentP -resultLinesP :: Parser [(RealSrcSpan, String)] [(RealSrcSpan, String)] +resultLinesP :: Parser [(Range, String)] [(Range, String)] resultLinesP = many nonEmptyCommentP -emptyLineP :: Parser [(RealSrcSpan, String)] () +emptyLineP :: Parser [(Range, String)] () emptyLineP = void $ satisfy $ isJust . parseMaybe (lineCommentHeadP *> space) . snd -normalCommentP :: Parser [(RealSrcSpan, String)] (RealSrcSpan, String) +normalCommentP :: Parser [(Range, String)] (Range, String) normalCommentP = P.token - (mapM $ \ln -> do + ( mapM $ \ln -> do guard $ isNothing $ parseMaybe (void (try exampleLineStrP) <|> void propLineStrP) ln pure $ dropWhile C.isSpace $ drop 2 ln ) mempty -nonEmptyCommentP :: Parser [(RealSrcSpan, String)] (RealSrcSpan, String) -nonEmptyCommentP = do +nonEmptyCommentP :: Parser [(Range, String)] (Range, String) +nonEmptyCommentP = try $ do (spn, str) <- normalCommentP guard $ not $ null str pure (spn, str) -convexHullSpan :: NonEmpty RealSrcSpan -> RealSrcSpan +convexHullSpan :: NonEmpty Range -> Range convexHullSpan lns@(headSpan :| _) = - let aFile = srcSpanFile headSpan - (mbeg, mend) = + let (mbeg, mend) = foldMap - ( (fmap (Just . Min) . mkRealSrcLoc aFile <$> srcSpanStartLine <*> srcSpanStartCol) - &&& (fmap (Just . Max) . mkRealSrcLoc aFile <$> srcSpanEndLine <*> srcSpanEndCol) + ( (Just . Min . view start) + &&& (Just . Max . view end) ) lns - beg = maybe (realSrcSpanStart headSpan) coerce mbeg - end = maybe (realSrcSpanEnd headSpan) coerce mend - in mkRealSrcSpan beg end + beg = maybe (headSpan ^. start) coerce mbeg + end_ = maybe (headSpan ^. end) coerce mend + in Range beg end_ dropLineComment :: String -> String @@ -245,18 +255,18 @@ dropLineComment = . drop 2 . L.dropWhile C.isSpace -exampleLinesP :: Parser [(RealSrcSpan, String)] LineCommentTest +exampleLinesP :: Parser [(Range, String)] LineCommentTest exampleLinesP = lexemeLine $ uncurry AnExample . first convexHullSpan . NE.unzip <$> NE.some (second snd <$> exampleLineP) <*> resultLinesP -exampleLineP :: Parser [(RealSrcSpan, String)] (RealSrcSpan, (CommentFlavour, ExampleLine)) +exampleLineP :: Parser [(Range, String)] (Range, (CommentFlavour, ExampleLine)) exampleLineP = do P.token (mapM $ parseMaybe exampleLineStrP) mempty -propLineP :: Parser [(RealSrcSpan, String)] (RealSrcSpan, (CommentFlavour, PropLine)) +propLineP :: Parser [(Range, String)] (Range, (CommentFlavour, PropLine)) propLineP = P.token (mapM $ parseMaybe propLineStrP) mempty -- >>> either (error . errorBundlePretty) id $ parse exampleLineStrP "" "-- | >>> 12" diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index 6eb399d90d..cf0ecc70c7 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -30,6 +30,7 @@ import Data.String (IsString (..)) import GHC.Generics (Generic) import Data.Map.Strict (Map) import Development.IDE.GHC.Compat (RealSrcSpan) +import Development.IDE (Range(Range)) -- | A thing with a location attached. data Located l a = Located {location :: l, located :: a} @@ -87,8 +88,8 @@ data Test data Comments = Comments - { lineComments :: Map RealSrcSpan String - , blockComments :: Map RealSrcSpan String + { lineComments :: Map Range String + , blockComments :: Map Range String } deriving (Show, Eq, Ord, Generic) From d6b0ad91a3c25f045c008c95ba54409032b50146 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Fri, 22 Jan 2021 20:42:22 +0900 Subject: [PATCH 06/41] We can always assume that comment starts with "--" with no space prepended --- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index 48d3398896..7ab56bf8b8 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -190,7 +190,7 @@ lineCommentFlavour = lineCommentHeadP :: Parser String () lineCommentHeadP = - space *> chunk "--" + chunk "--" *> P.notFollowedBy (oneOf "!#$%&*.+=/<>?@\\~^-:|") {- $setup From f035f37c29c047c913287f9ea1b06580d96a322a Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Fri, 22 Jan 2021 20:52:12 +0900 Subject: [PATCH 07/41] must be horizontal space, not ANY whitespace --- .../hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index 7ab56bf8b8..c36b3728d6 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -35,7 +35,7 @@ import Language.Haskell.LSP.Types.Lens ) import Text.Megaparsec import qualified Text.Megaparsec as P -import Text.Megaparsec.Char (char, space) +import Text.Megaparsec.Char (hspace, char) parseSections :: Comments -> Sections @@ -183,10 +183,10 @@ lineCommentFlavour = ( HaddockNext <$ char '|' <|> HaddockPrev <$ char '^' <|> Named <$ char '$' - <* optional space + <* optional hspace <*> P.takeWhile1P (Just "alphabet number") C.isAlphaNum ) - <* space + <* hspace lineCommentHeadP :: Parser String () lineCommentHeadP = @@ -219,7 +219,7 @@ emptyLineP :: Parser [(Range, String)] () emptyLineP = void $ satisfy $ - isJust . parseMaybe (lineCommentHeadP *> space) . snd + isJust . parseMaybe (lineCommentHeadP *> hspace) . snd normalCommentP :: Parser [(Range, String)] (Range, String) normalCommentP = From 3f25b178d576c3b8be59e76919a2340595f47d8c Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sat, 23 Jan 2021 02:00:41 +0900 Subject: [PATCH 08/41] Block parser (WIP) --- .../src/Ide/Plugin/Eval/CodeLens.hs | 30 +- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 440 ++++++++++++------ .../src/Ide/Plugin/Eval/Types.hs | 35 +- .../hls-eval-plugin/test/testdata/test.cabal | 2 + 4 files changed, 337 insertions(+), 170 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 571e308782..6ae392a235 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -155,16 +155,6 @@ import Ide.Plugin.Eval.GHC import Ide.Plugin.Eval.Parse.Comments (commentsToSections, groupLineComments) import Ide.Plugin.Eval.Parse.Option (langOptions) import Ide.Plugin.Eval.Types - ( Comments (..), - Format (SingleLine), - Loc, - Located (Located), - Section (..), - Sections (..), - Test, - isProperty, - unLoc, - ) import Ide.Plugin.Eval.Util ( asS, gStrictTry, @@ -225,6 +215,7 @@ import System.IO.Temp (withSystemTempFile) import Text.Read (readMaybe) import Util (OverridingBool (Never)) import Development.IDE.Core.PositionMapping (toCurrentRange) +import qualified Data.DList as DL {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. @@ -253,15 +244,24 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = -- we can concentrate on these two case bdy of AnnLineComment cmt -> - mempty { lineComments = Map.singleton curRan cmt } + mempty { lineComments = Map.singleton curRan (RawLineComment cmt) } AnnBlockComment cmt -> - mempty { blockComments = Map.singleton curRan cmt } + mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt } _ -> mempty _ -> mempty ) ) $ snd pm_annotations - dbg "comments" $ show comments + dbg "comments" $ show $ DL.toList $ + foldMap + (foldMap $ \(L a b) -> + case b of + AnnLineComment{} -> mempty + AnnBlockComment{} -> mempty + _ -> DL.singleton (a, b) + ) + $ snd pm_annotations + dbg "excluded comments" $ show comments dbg "groups" $ groupLineComments $ lineComments comments -- Extract tests from source code @@ -307,7 +307,9 @@ evalCommandName = "evalCommand" evalCommand :: PluginCommand IdeState evalCommand = PluginCommand evalCommandName "evaluate" runEvalCmd --- |Specify the test section to execute +-- | Specify the test section to execute +-- +-- >>> 12 data EvalParams = EvalParams { sections :: [Section] , module_ :: !TextDocumentIdentifier diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index c36b3728d6..cbd34ebc0b 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -1,30 +1,28 @@ -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} module Ide.Plugin.Eval.Parse.Comments where import qualified Control.Applicative.Combinators.NonEmpty as NE -import Control.Arrow (first, second, (&&&), (>>>)) +import Control.Arrow (first, (&&&), (>>>)) import Control.Lens (view, (^.)) import Control.Monad (guard, void) import Control.Monad.Combinators () import qualified Data.Char as C import Data.Coerce (coerce) import qualified Data.DList as DL -import qualified Data.List as L +import qualified Data.Foldable as F import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (isJust, isNothing) import Data.Semigroup import Data.Void (Void) import Development.IDE (Range) -import Development.IDE.Types.Location (Range (Range)) +import Development.IDE.Types.Location (Position (..), Range (Range)) import GHC.Generics import Ide.Plugin.Eval.Types import Language.Haskell.LSP.Types.Lens @@ -35,20 +33,40 @@ import Language.Haskell.LSP.Types.Lens ) import Text.Megaparsec import qualified Text.Megaparsec as P -import Text.Megaparsec.Char (hspace, char) +import Text.Megaparsec.Char + ( alphaNumChar, + char, + eol, + hspace, + letterChar, + ) -parseSections :: - Comments -> Sections -parseSections Comments {..} = undefined +{- | +We build parsers combining the following three kinds of them: -groupLineComments :: - Map Range String -> [NonEmpty (Range, String)] -groupLineComments = - contiguousGroupOn (fst >>> view start >>> view line &&& view character) - . Map.toList + * Line parser - paring a single line into an input, + works both for line- and block-comments. + A line should be a proper content of lines contained in comment: + doesn't include starting @--@ and @{\-@ and no ending @-\}@ + + * Line comment group parser: parses a contiguous group of + tuples of range and line comment into sections of line comments. + Each input MUST start with @--@. + * Block comment parser: Parsing entire block comment into sections. + Input must be surrounded by @{\-@ and @-\}@. +-} type Parser inputs = Parsec Void inputs +-- | Line parser +type LineParser = Parser String + +-- | Line comment group parser +type LineGroupParser = Parser [(Range, RawLineComment)] + +-- | Block comment parser +type BlockCommentParser = Parser String + -- | Prop line, with "prop>" stripped off newtype PropLine = PropLine {getPropLine :: String} deriving (Show) @@ -57,22 +75,24 @@ newtype PropLine = PropLine {getPropLine :: String} newtype ExampleLine = ExampleLine {getExampleLine :: String} deriving (Show) -data LineCommentTest +data TestComment = AProp { lineCommentSectionSpan :: Range , lineProp :: PropLine - , propResults :: [(Range, String)] + , propResults :: [String] } | AnExample { lineCommentSectionSpan :: Range , lineExamples :: NonEmpty ExampleLine - , exampleResults :: [(Range, String)] + , exampleResults :: [String] } deriving (Show) +-- | Classification of comments data CommentFlavour = Vanilla | HaddockNext | HaddockPrev | Named String deriving (Read, Show, Eq, Ord) +-- | Single line or block comments? data CommentStyle = Line | Block deriving (Read, Show, Eq, Ord, Generic) @@ -84,22 +104,52 @@ commentsToSections Comments {..} = case parseMaybe lineGroupP $ NE.toList lcs of Nothing -> mempty Just (mls, rs) -> - (maybe DL.empty DL.singleton mls, DL.fromList rs) + ( maybe DL.empty DL.singleton mls + , -- orders setup sections in ascending order + if null rs + then mempty + else + Map.singleton (fst $ NE.head lcs) $ + DL.singleton (Line, rs) + ) ) $ groupLineComments lineComments - (multilineSections, blockSetups) = ([], []) + (blockSeed, blockSetupSeeds) = + foldMap + ( \(ran, lcs) -> + case parseMaybe (blockCommentBP $ ran ^. start) $ getRawBlockComment lcs of + Nothing -> mempty + Just (Named "setup", grp) -> + -- orders setup sections in ascending order + ( mempty + , Map.singleton ran $ + DL.singleton (Block, grp) + ) + Just grp -> + ( DL.singleton grp + , mempty + ) + ) + $ Map.toList blockComments lineSections = - map (uncurry linesToSection) $ + map (uncurry $ testsToSection Line) $ DL.toList lineSectionSeeds - lineSetups = linesToSection (Named "setup") $ DL.toList lineSetupSeeds - setupSections = lineSetups : blockSetups + multilineSections = + map (uncurry $ testsToSection Block) $ + DL.toList blockSeed + setupSections = + map (uncurry (`testsToSection` Named "setup")) $ + DL.toList $ + F.fold $ + Map.unionWith (<>) lineSetupSeeds blockSetupSeeds in Sections {..} -linesToSection :: +testsToSection :: + CommentStyle -> CommentFlavour -> - [LineCommentTest] -> + [TestComment] -> Section -linesToSection flav tests = +testsToSection style flav tests = let sectionName | Named name <- flav = name | otherwise = "" @@ -107,33 +157,94 @@ linesToSection flav tests = HaddockNext -> Haddock HaddockPrev -> Haddock _ -> Plain - sectionTests = map fromLineTest tests - sectionFormat = SingleLine + sectionTests = map fromTestComment tests + sectionFormat = + case style of + Line -> SingleLine + Block -> MultiLine in Section {..} -fromLineTest :: LineCommentTest -> Loc Test -fromLineTest AProp {..} = +fromTestComment :: TestComment -> Loc Test +fromTestComment AProp {..} = Located (lineCommentSectionSpan ^. start . line) Property { testline = getPropLine lineProp - , testOutput = map snd propResults + , testOutput = propResults } -fromLineTest AnExample {..} = +fromTestComment AnExample {..} = Located (lineCommentSectionSpan ^. start . line) Example { testLines = getExampleLine <$> lineExamples - , testOutput = map snd exampleResults + , testOutput = exampleResults + } + +-- * Block comment parser + +-- >>> parseMaybe (blockCommentBP $ Position 0 0) "{- $setup\n>>> dummyPos = Position 0 0\n>>> dummyRange = Range dummyPos dummyPos\n-}" +-- Just (Named "setup",[AnExample {lineCommentSectionSpan = Range {_start = Position {_line = 1, _character = 0}, _end = Position {_line = 3, _character = 0}}, lineExamples = ExampleLine {getExampleLine = " dummyPos = Position 0 0"} :| [ExampleLine {getExampleLine = " dummyRange = Range dummyPos dummyPos"}], exampleResults = []}]) + +blockCommentBP :: + Position -> BlockCommentParser (CommentFlavour, [TestComment]) +blockCommentBP pos = do + updateParserState $ \st -> + st + { statePosState = + (statePosState st) + { pstateSourcePos = positionToSourcePos pos + } } + skipCount 2 anySingle -- "{-" + void $ optional $ char ' ' + flav <- commentFlavourP + hit <- skipNormalCommentBlock + if hit + then do + body <- many $ (blockExamples <|> blockProp) <* skipNormalCommentBlock + void takeRest -- just consume the rest + pure (flav, body) + else pure (Vanilla, []) + +skipNormalCommentBlock :: Parser String Bool +skipNormalCommentBlock = + skipManyTill (normalLineP Block) $ + False <$ try (optional (chunk "-}") *> eof) <|> True <$ lookAhead (propSymbol <|> exampleSymbol) + +eob :: BlockCommentParser () +eob = eof <|> try (optional (chunk "-}") *> eof) <|> void eol + +blockExamples, blockProp :: BlockCommentParser TestComment +blockExamples = do + (ran, examples) <- withRange $ NE.some $ exampleLineStrP Block + AnExample ran examples <$> resultBlockP +blockProp = do + (ran, prop) <- withRange $ propLineStrP Block + AProp ran prop <$> resultBlockP + +withRange :: (TraversableStream s, Stream s) => Parser s a -> Parser s (Range, a) +withRange p = do + beg <- sourcePosToPosition <$> getSourcePos + a <- p + fin <- sourcePosToPosition <$> getSourcePos + pure (Range beg fin, a) + +resultBlockP :: BlockCommentParser [String] +resultBlockP = many $ nonEmptyNormalLineP Block + +positionToSourcePos :: Position -> SourcePos +positionToSourcePos pos = + P.SourcePos + { sourceName = "" + , sourceLine = P.mkPos $ 1 + pos ^. line + , sourceColumn = P.mkPos $ 1 + pos ^. character + } --- >>> :set -XOverloadedStrings --- >>> import Language.Haskell.LSP.Types (Position(..)) --- >>> dummyLoc = Position 0 0 --- >>> dummySpan = Range dummyLoc dummyLoc --- >>> import Control.Arrow --- >>> parse lineCommentSectionsP "" [(dummySpan, "-- >>> 12"), (dummySpan, "--")] --- Right [AnExample {lineCommentSectionSpan = Range {_start = Position {_line = 0, _character = 0}, _end = Position {_line = 0, _character = 0}}, lineExamples = ExampleLine {getExampleLine = " 12"} :| [], exampleResults = []}] +sourcePosToPosition :: SourcePos -> Position +sourcePosToPosition SourcePos {..} = + Position (unPos sourceLine - 1) (unPos sourceColumn - 1) + +-- * Line Group Parser {- | Result: a tuple of ordinary line tests and setting sections. @@ -150,141 +261,145 @@ This behaviour is not yet handled correctly in Eval Plugin; but for future extension for this, we use a tuple here instead of 'Either'. -} lineGroupP :: - Parser - [(Range, String)] - (Maybe (CommentFlavour, [LineCommentTest]), [LineCommentTest]) + LineGroupParser + (Maybe (CommentFlavour, [TestComment]), [TestComment]) lineGroupP = do - (_, flav) <- - lookAhead $ - token (mapM $ parseMaybe $ lineCommentFlavour <* takeRest) mempty + (_, flav) <- lookAhead $ parseLine (commentFlavourP <* takeRest) case flav of Named "setup" -> (Nothing,) <$> lineCommentSectionsP flav -> (,mempty) . Just . (flav,) <$> lineCommentSectionsP --- >>> :set -XOverloadedStrings --- >>> dummyLoc = mkRealSrcLoc "" 0 0 --- >>> dummySpan = mkRealSrcSpan dummyLoc dummyLoc --- >>> parseMaybe lineCommentSectionsP $ (dummySpan,) <$> ["-- | >>> unwords example", "-- \"Stale output\""] --- Just [] - --- >>> parseMaybe (lineCommentFlavour *> takeRest) "-- >>> a" --- Just ">>> a" - --- >>> parseMaybe (lineCommentFlavour *> takeRest) "-- | >>> a" --- Just ">>> a" - -lineCommentFlavour :: Parser String CommentFlavour -lineCommentFlavour = - lineCommentHeadP - -- N.B. Haddock assumes at most one space before modifiers: - *> optional (satisfy C.isSpace) - *> P.option - Vanilla - ( HaddockNext <$ char '|' - <|> HaddockPrev <$ char '^' - <|> Named <$ char '$' - <* optional hspace - <*> P.takeWhile1P (Just "alphabet number") C.isAlphaNum - ) - <* hspace - -lineCommentHeadP :: Parser String () -lineCommentHeadP = - chunk "--" - *> P.notFollowedBy (oneOf "!#$%&*.+=/<>?@\\~^-:|") - {- $setup ->>> :set -XOverloadedStrings ->>> dummyLoc = mkRealSrcLoc "" 0 0 ->>> dummySpan = mkRealSrcSpan dummyLoc dummyLoc +>>> dummyPos = Position 0 0 +>>> dummyRange = Range dummyPos dummyPos -} -lineCommentSectionsP :: - Parser [(Range, String)] [LineCommentTest] -lineCommentSectionsP = do - skipMany normalCommentP - lexemeLine $ - many $ - exampleLinesP - <|> uncurry AProp . second snd <$> propLineP <*> resultLinesP - <* skipMany normalCommentP - -lexemeLine :: Parser [(Range, String)] a -> Parser [(Range, String)] a -lexemeLine p = p <* skipMany normalCommentP +-- >>> parse (lineGroupP <*eof) "" $ (dummyRange, ) . RawLineComment <$> ["-- a", "-- b"] +-- Variable not in scope: dummyRange :: Range + +commentFlavourP :: LineParser CommentFlavour +commentFlavourP = + P.option + Vanilla + ( HaddockNext <$ char '|' + <|> HaddockPrev <$ char '^' + <|> Named <$ char '$' + <* optional hspace + <*> ((:) <$> letterChar <*> P.many alphaNumChar) + ) + <* optional (char ' ') -resultLinesP :: Parser [(Range, String)] [(Range, String)] -resultLinesP = many nonEmptyCommentP +lineCommentHeadP :: LineParser () +lineCommentHeadP = do + -- and no operator symbol character follows. + void $ chunk "--" + skipMany $ char '-' + void $ optional $ char ' ' -emptyLineP :: Parser [(Range, String)] () -emptyLineP = - void $ - satisfy $ - isJust . parseMaybe (lineCommentHeadP *> hspace) . snd +lineCommentSectionsP :: + LineGroupParser [TestComment] +lineCommentSectionsP = do + skipMany normalLineCommentP + many $ + exampleLinesGP + <|> uncurry AProp <$> propLineGP <*> resultLinesP + <* skipMany normalLineCommentP -normalCommentP :: Parser [(Range, String)] (Range, String) -normalCommentP = - P.token - ( mapM $ \ln -> do - guard $ isNothing $ parseMaybe (void (try exampleLineStrP) <|> void propLineStrP) ln - pure $ dropWhile C.isSpace $ drop 2 ln - ) - mempty +lexemeLine :: LineGroupParser a -> LineGroupParser a +lexemeLine p = p <* skipMany normalLineCommentP -nonEmptyCommentP :: Parser [(Range, String)] (Range, String) -nonEmptyCommentP = try $ do - (spn, str) <- normalCommentP - guard $ not $ null str - pure (spn, str) +resultLinesP :: LineGroupParser [String] +resultLinesP = many nonEmptyLGP -convexHullSpan :: NonEmpty Range -> Range -convexHullSpan lns@(headSpan :| _) = - let (mbeg, mend) = - foldMap - ( (Just . Min . view start) - &&& (Just . Max . view end) - ) - lns - beg = maybe (headSpan ^. start) coerce mbeg - end_ = maybe (headSpan ^. end) coerce mend - in Range beg end_ +normalLineCommentP :: LineGroupParser (Range, String) +normalLineCommentP = + parseLine (commentFlavourP *> normalLineP Line) -dropLineComment :: - String -> String -dropLineComment = - L.dropWhile C.isSpace - . drop 2 - . L.dropWhile C.isSpace +nonEmptyLGP :: LineGroupParser String +nonEmptyLGP = try $ fmap snd $ parseLine $ commentFlavourP *> nonEmptyNormalLineP Line -exampleLinesP :: Parser [(Range, String)] LineCommentTest -exampleLinesP = +exampleLinesGP :: LineGroupParser TestComment +exampleLinesGP = lexemeLine $ uncurry AnExample . first convexHullSpan . NE.unzip - <$> NE.some (second snd <$> exampleLineP) + <$> NE.some exampleLineGP <*> resultLinesP -exampleLineP :: Parser [(Range, String)] (Range, (CommentFlavour, ExampleLine)) -exampleLineP = do - P.token (mapM $ parseMaybe exampleLineStrP) mempty +exampleLineGP :: LineGroupParser (Range, ExampleLine) +exampleLineGP = parseLine (commentFlavourP *> exampleLineStrP Line) + +propLineGP :: LineGroupParser (Range, PropLine) +propLineGP = parseLine (commentFlavourP *> propLineStrP Line) -propLineP :: Parser [(Range, String)] (Range, (CommentFlavour, PropLine)) -propLineP = P.token (mapM $ parseMaybe propLineStrP) mempty +{- | +Turning a line parser into line group parser consuming a single line comment. +Parses a sinlge line comment, skipping prefix "--[-*]" with optional one horizontal space. +fails if the input does not start with "--". + +__N.B.__ We don't strip comment flavours. --- >>> either (error . errorBundlePretty) id $ parse exampleLineStrP "" "-- | >>> 12" --- (HaddockNext,ExampleLine {getExampleLine = " 12"}) +>>> parseMaybe (parseLine $ takeRest) $ map (:[]) ["-- >>> A"] +Just [">>> A"] -exampleLineStrP :: Parser String (CommentFlavour, ExampleLine) -exampleLineStrP = - (,) <$> lineCommentFlavour - <* chunk ">>>" - <* P.notFollowedBy (char '>') - <*> (ExampleLine <$> P.takeRest) +>>> parseMaybe (parseLine $ takeRest) $ map (:[]) ["--- >>> A"] +Just [" >>> A"] -propLineStrP :: Parser String (CommentFlavour, PropLine) -propLineStrP = - (,) <$> lineCommentFlavour - <* chunk "prop>" - <* P.notFollowedBy (char '>') - <*> (PropLine <$> P.takeRest) +>>> parseMaybe (parseLine takeRest) $ map (:[]) [""] +Nothing +-} +parseLine :: + (Ord (f RawLineComment), Traversable f) => + LineParser a -> + Parser [f RawLineComment] (f a) +parseLine p = + P.token + (mapM $ parseMaybe (lineCommentHeadP *> p) . getRawLineComment) + mempty + +-- * Line Parsers + +-- | Non-empty normal line. +nonEmptyNormalLineP :: CommentStyle -> LineParser String +nonEmptyNormalLineP style = try $ do + ln <- normalLineP style + guard $ not $ all C.isSpace ln + pure ln + +{- | Normal line is a line neither a example nor prop. + Empty line is normal. +-} +normalLineP :: CommentStyle -> LineParser String +normalLineP style = do + notFollowedBy (try $ exampleSymbol <|> propSymbol) + consume style + +-- >>> parse (skipMany (consume Block)) "" "foo\nbar" +-- Right () +consume :: CommentStyle -> Parser String String +consume style = + case style of + Line -> takeRest + Block -> manyTill anySingle eob + +-- | Parses example test line. +exampleLineStrP :: CommentStyle -> LineParser ExampleLine +exampleLineStrP style = + exampleSymbol *> (ExampleLine <$> consume style) + +exampleSymbol :: Parser String () +exampleSymbol = chunk ">>>" *> P.notFollowedBy (char '>') + +propSymbol :: Parser String () +propSymbol = chunk "prop>" *> P.notFollowedBy (char '>') + +-- | Parses prop test line. +propLineStrP :: CommentStyle -> LineParser PropLine +propLineStrP style = + chunk "prop>" + *> P.notFollowedBy (char '>') + *> (PropLine <$> consume style) + +-- * Utilities {- | Given a sequence of tokens increasing in their starting position, @@ -307,3 +422,24 @@ contiguousGroupOn toLineCol = foldr step [] , aLine + 1 == bLine && aCol == bCol = (a :| b : bs) : bss | otherwise = pure a : bss0 + +convexHullSpan :: NonEmpty Range -> Range +convexHullSpan lns@(headSpan :| _) = + let (mbeg, mend) = + foldMap + ( (Just . Min . view start) + &&& (Just . Max . view end) + ) + lns + beg = maybe (headSpan ^. start) coerce mbeg + end_ = maybe (headSpan ^. end) coerce mend + in Range beg end_ + +{- | Given a map from ranges, divides them into subgroup + with contiguous line and columns. +-} +groupLineComments :: + Map Range a -> [NonEmpty (Range, a)] +groupLineComments = + contiguousGroupOn (fst >>> view start >>> view line &&& view character) + . Map.toList diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index cf0ecc70c7..d3a686a00d 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} @@ -18,6 +21,8 @@ module Ide.Plugin.Eval.Types ( Loc, Located (..), Comments(..), + RawBlockComment(..), + RawLineComment(..), unLoc, Txt, ) where @@ -29,8 +34,8 @@ import Data.List.NonEmpty (NonEmpty) import Data.String (IsString (..)) import GHC.Generics (Generic) import Data.Map.Strict (Map) -import Development.IDE.GHC.Compat (RealSrcSpan) -import Development.IDE (Range(Range)) +import Development.IDE (Range(..)) +import qualified Text.Megaparsec as P -- | A thing with a location attached. data Located l a = Located {location :: l, located :: a} @@ -88,11 +93,33 @@ data Test data Comments = Comments - { lineComments :: Map Range String - , blockComments :: Map Range String + { lineComments :: Map Range RawLineComment + , blockComments :: Map Range RawBlockComment } deriving (Show, Eq, Ord, Generic) +newtype RawBlockComment = RawBlockComment {getRawBlockComment :: String} + deriving (Show, Eq, Ord) + deriving newtype + ( IsString + , P.Stream + , P.TraversableStream + , P.VisualStream + , Semigroup + , Monoid + ) + +newtype RawLineComment = RawLineComment {getRawLineComment :: String} + deriving (Show, Eq, Ord) + deriving newtype + ( IsString + , P.Stream + , P.TraversableStream + , P.VisualStream + , Semigroup + , Monoid + ) + instance Semigroup Comments where Comments ls bs <> Comments ls' bs' = Comments (ls <> ls') (bs <> bs') diff --git a/plugins/hls-eval-plugin/test/testdata/test.cabal b/plugins/hls-eval-plugin/test/testdata/test.cabal index 2d57505ebe..49cb62e062 100644 --- a/plugins/hls-eval-plugin/test/testdata/test.cabal +++ b/plugins/hls-eval-plugin/test/testdata/test.cabal @@ -38,6 +38,7 @@ library T24 T25 T26 + T27 TMulti TPlainComment THaddock @@ -50,6 +51,7 @@ library TPrelude TCPP TLHS + TSetup Util build-depends: base >= 4.7 && < 5, QuickCheck From 1c0ca6279b9bd06eed08bf6379ee0c8546000364 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sat, 23 Jan 2021 02:42:27 +0900 Subject: [PATCH 09/41] We don't need whole range; position suffices --- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 69 +++++++------------ .../src/Ide/Plugin/Eval/Types.hs | 6 +- 2 files changed, 29 insertions(+), 46 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index cbd34ebc0b..0c421d8221 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -12,24 +12,20 @@ import Control.Lens (view, (^.)) import Control.Monad (guard, void) import Control.Monad.Combinators () import qualified Data.Char as C -import Data.Coerce (coerce) import qualified Data.DList as DL import qualified Data.Foldable as F import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Semigroup import Data.Void (Void) -import Development.IDE (Range) -import Development.IDE.Types.Location (Position (..), Range (Range)) +import Development.IDE (Position) +import Development.IDE.Types.Location (Position (..), Position (Position)) import GHC.Generics import Ide.Plugin.Eval.Types import Language.Haskell.LSP.Types.Lens ( character, - end, line, - start, ) import Text.Megaparsec import qualified Text.Megaparsec as P @@ -50,7 +46,7 @@ We build parsers combining the following three kinds of them: doesn't include starting @--@ and @{\-@ and no ending @-\}@ * Line comment group parser: parses a contiguous group of - tuples of range and line comment into sections of line comments. + tuples of position and line comment into sections of line comments. Each input MUST start with @--@. * Block comment parser: Parsing entire block comment into sections. @@ -62,7 +58,7 @@ type Parser inputs = Parsec Void inputs type LineParser = Parser String -- | Line comment group parser -type LineGroupParser = Parser [(Range, RawLineComment)] +type LineGroupParser = Parser [(Position, RawLineComment)] -- | Block comment parser type BlockCommentParser = Parser String @@ -77,12 +73,12 @@ newtype ExampleLine = ExampleLine {getExampleLine :: String} data TestComment = AProp - { lineCommentSectionSpan :: Range + { commentSectionStart :: Position , lineProp :: PropLine , propResults :: [String] } | AnExample - { lineCommentSectionSpan :: Range + { commentSectionStart :: Position , lineExamples :: NonEmpty ExampleLine , exampleResults :: [String] } @@ -117,7 +113,7 @@ commentsToSections Comments {..} = (blockSeed, blockSetupSeeds) = foldMap ( \(ran, lcs) -> - case parseMaybe (blockCommentBP $ ran ^. start) $ getRawBlockComment lcs of + case parseMaybe (blockCommentBP ran) $ getRawBlockComment lcs of Nothing -> mempty Just (Named "setup", grp) -> -- orders setup sections in ascending order @@ -167,14 +163,14 @@ testsToSection style flav tests = fromTestComment :: TestComment -> Loc Test fromTestComment AProp {..} = Located - (lineCommentSectionSpan ^. start . line) + (commentSectionStart ^. line) Property { testline = getPropLine lineProp , testOutput = propResults } fromTestComment AnExample {..} = Located - (lineCommentSectionSpan ^. start . line) + (commentSectionStart ^. line) Example { testLines = getExampleLine <$> lineExamples , testOutput = exampleResults @@ -182,8 +178,8 @@ fromTestComment AnExample {..} = -- * Block comment parser --- >>> parseMaybe (blockCommentBP $ Position 0 0) "{- $setup\n>>> dummyPos = Position 0 0\n>>> dummyRange = Range dummyPos dummyPos\n-}" --- Just (Named "setup",[AnExample {lineCommentSectionSpan = Range {_start = Position {_line = 1, _character = 0}, _end = Position {_line = 3, _character = 0}}, lineExamples = ExampleLine {getExampleLine = " dummyPos = Position 0 0"} :| [ExampleLine {getExampleLine = " dummyRange = Range dummyPos dummyPos"}], exampleResults = []}]) +-- >>> parseMaybe (blockCommentBP $ Position 0 0) "{- $setup\n>>> dummyPos = Position 0 0\n>>> dummyPosition = Position dummyPos dummyPos\n-}" +-- Just (Named "setup",[AnExample {commentSectionStart = Position {_start = Position {_line = 1, _character = 0}, _end = Position {_line = 3, _character = 0}}, lineExamples = ExampleLine {getExampleLine = " dummyPos = Position 0 0"} :| [ExampleLine {getExampleLine = " dummyPosition = Position dummyPos dummyPos"}], exampleResults = []}]) blockCommentBP :: Position -> BlockCommentParser (CommentFlavour, [TestComment]) @@ -216,18 +212,17 @@ eob = eof <|> try (optional (chunk "-}") *> eof) <|> void eol blockExamples, blockProp :: BlockCommentParser TestComment blockExamples = do - (ran, examples) <- withRange $ NE.some $ exampleLineStrP Block + (ran, examples) <- withPosition $ NE.some $ exampleLineStrP Block AnExample ran examples <$> resultBlockP blockProp = do - (ran, prop) <- withRange $ propLineStrP Block + (ran, prop) <- withPosition $ propLineStrP Block AProp ran prop <$> resultBlockP -withRange :: (TraversableStream s, Stream s) => Parser s a -> Parser s (Range, a) -withRange p = do +withPosition :: (TraversableStream s, Stream s) => Parser s a -> Parser s (Position, a) +withPosition p = do beg <- sourcePosToPosition <$> getSourcePos a <- p - fin <- sourcePosToPosition <$> getSourcePos - pure (Range beg fin, a) + pure (beg, a) resultBlockP :: BlockCommentParser [String] resultBlockP = many $ nonEmptyNormalLineP Block @@ -271,11 +266,11 @@ lineGroupP = do {- $setup >>> dummyPos = Position 0 0 ->>> dummyRange = Range dummyPos dummyPos +>>> dummyPosition = Position dummyPos dummyPos -} --- >>> parse (lineGroupP <*eof) "" $ (dummyRange, ) . RawLineComment <$> ["-- a", "-- b"] --- Variable not in scope: dummyRange :: Range +-- >>> parse (lineGroupP <*eof) "" $ (dummyPosition, ) . RawLineComment <$> ["-- a", "-- b"] +-- Variable not in scope: dummyPosition :: Position commentFlavourP :: LineParser CommentFlavour commentFlavourP = @@ -311,7 +306,7 @@ lexemeLine p = p <* skipMany normalLineCommentP resultLinesP :: LineGroupParser [String] resultLinesP = many nonEmptyLGP -normalLineCommentP :: LineGroupParser (Range, String) +normalLineCommentP :: LineGroupParser (Position, String) normalLineCommentP = parseLine (commentFlavourP *> normalLineP Line) @@ -321,14 +316,14 @@ nonEmptyLGP = try $ fmap snd $ parseLine $ commentFlavourP *> nonEmptyNormalLine exampleLinesGP :: LineGroupParser TestComment exampleLinesGP = lexemeLine $ - uncurry AnExample . first convexHullSpan . NE.unzip + uncurry AnExample . first NE.head . NE.unzip <$> NE.some exampleLineGP <*> resultLinesP -exampleLineGP :: LineGroupParser (Range, ExampleLine) +exampleLineGP :: LineGroupParser (Position, ExampleLine) exampleLineGP = parseLine (commentFlavourP *> exampleLineStrP Line) -propLineGP :: LineGroupParser (Range, PropLine) +propLineGP :: LineGroupParser (Position, PropLine) propLineGP = parseLine (commentFlavourP *> propLineStrP Line) {- | @@ -423,23 +418,11 @@ contiguousGroupOn toLineCol = foldr step [] (a :| b : bs) : bss | otherwise = pure a : bss0 -convexHullSpan :: NonEmpty Range -> Range -convexHullSpan lns@(headSpan :| _) = - let (mbeg, mend) = - foldMap - ( (Just . Min . view start) - &&& (Just . Max . view end) - ) - lns - beg = maybe (headSpan ^. start) coerce mbeg - end_ = maybe (headSpan ^. end) coerce mend - in Range beg end_ - -{- | Given a map from ranges, divides them into subgroup +{- | Given a map from positions, divides them into subgroup with contiguous line and columns. -} groupLineComments :: - Map Range a -> [NonEmpty (Range, a)] + Map Position a -> [NonEmpty (Position, a)] groupLineComments = - contiguousGroupOn (fst >>> view start >>> view line &&& view character) + contiguousGroupOn (fst >>> view line &&& view character) . Map.toList diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index d3a686a00d..835753a63b 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -34,7 +34,7 @@ import Data.List.NonEmpty (NonEmpty) import Data.String (IsString (..)) import GHC.Generics (Generic) import Data.Map.Strict (Map) -import Development.IDE (Range(..)) +import Development.IDE (Position(..)) import qualified Text.Megaparsec as P -- | A thing with a location attached. @@ -93,8 +93,8 @@ data Test data Comments = Comments - { lineComments :: Map Range RawLineComment - , blockComments :: Map Range RawBlockComment + { lineComments :: Map Position RawLineComment + , blockComments :: Map Position RawBlockComment } deriving (Show, Eq, Ord, Generic) From fce4e840228555a8f5d4e774c516c65bc674f103 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sat, 23 Jan 2021 02:48:13 +0900 Subject: [PATCH 10/41] Brutal parsing for block haddock comments --- .../src/Ide/Plugin/Eval/CodeLens.hs | 48 +++++++++++++++++-- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 22 +++++---- 2 files changed, 57 insertions(+), 13 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 6ae392a235..82f223b45e 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -77,11 +77,11 @@ import Development.IDE useWithStale_, use_, ) -import Development.IDE.GHC.Compat (AnnotationComment (AnnBlockComment, AnnLineComment), GenLocated (L), HscEnv, ParsedModule (..), SrcSpan (RealSrcSpan), srcSpanFile) +import Development.IDE.GHC.Compat (AnnotationComment(AnnDocCommentNext, AnnBlockComment, AnnLineComment), GenLocated (L), HscEnv, ParsedModule (..), SrcSpan (RealSrcSpan), srcSpanFile) import DynamicLoading (initializePlugins) import FastString (unpackFS) import GHC - ( ExecOptions + (AnnotationComment(AnnDocCommentNamed, AnnDocCommentPrev), ExecOptions ( execLineNumber, execSourceFile ), @@ -166,7 +166,7 @@ import Ide.Plugin.Eval.Util response', timed, ) -import Ide.PluginUtils (mkLspCommand) +import Ide.PluginUtils (extractRange, mkLspCommand) import Ide.Types ( CodeLensProvider, CommandFunction, @@ -216,6 +216,8 @@ import Text.Read (readMaybe) import Util (OverridingBool (Never)) import Development.IDE.Core.PositionMapping (toCurrentRange) import qualified Data.DList as DL +import Control.Lens ((+~), (&), (^.)) +import Language.Haskell.LSP.Types.Lens (character, start) {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. @@ -228,6 +230,7 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = response $ do let TextDocumentIdentifier uri = _textDocument fp <- handleMaybe "uri" $ uriToFilePath' uri + content <- moduleText _lsp uri let nfp = toNormalizedFilePath' fp dbg "fp" fp (ParsedModule{..}, posMap) <- liftIO $ @@ -239,14 +242,49 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = fromNormalizedFilePath nfp -> let ran0 = realSrcSpanToRange real curRan = fromMaybe ran0 $ toCurrentRange posMap ran0 + -- used to detect whether haddock comment is a line comment or not, in a brutal way + begin = curRan ^. start + isLine = + extractRange + (Range begin + $ begin & character +~ 1 + ) content + == "--" in -- since Haddock parsing is off, -- we can concentrate on these two case bdy of AnnLineComment cmt -> - mempty { lineComments = Map.singleton curRan (RawLineComment cmt) } + mempty { lineComments = Map.singleton begin (RawLineComment cmt) } AnnBlockComment cmt -> - mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt } + mempty { blockComments = Map.singleton begin $ RawBlockComment cmt } + AnnDocCommentNext txt + | isLine -> mempty + | otherwise -> + mempty { + blockComments = + Map.singleton begin + $ RawBlockComment $ + "{- | " <> txt <> "-}" + } + AnnDocCommentPrev txt + | isLine -> mempty + | otherwise -> + mempty { + blockComments = + Map.singleton begin + $ RawBlockComment $ + "{- ^ " <> txt <> "-}" + } + AnnDocCommentNamed txt + | isLine -> mempty + | otherwise -> + mempty { + blockComments = + Map.singleton begin + $ RawBlockComment $ + "{- $ " <> txt <> "-}" + } _ -> mempty _ -> mempty ) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index 0c421d8221..34afb55b20 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -178,8 +178,12 @@ fromTestComment AnExample {..} = -- * Block comment parser --- >>> parseMaybe (blockCommentBP $ Position 0 0) "{- $setup\n>>> dummyPos = Position 0 0\n>>> dummyPosition = Position dummyPos dummyPos\n-}" --- Just (Named "setup",[AnExample {commentSectionStart = Position {_start = Position {_line = 1, _character = 0}, _end = Position {_line = 3, _character = 0}}, lineExamples = ExampleLine {getExampleLine = " dummyPos = Position 0 0"} :| [ExampleLine {getExampleLine = " dummyPosition = Position dummyPos dummyPos"}], exampleResults = []}]) +{- $setup +>>> dummyPos = Position 0 0 +-} + +-- >>> parseMaybe (blockCommentBP $ dummyPos) "{- $setup\n>>> dummyPos = Position 0 0\n>>> dummyPosition = Position dummyPos dummyPos\n-}" +-- Just (Named "setup",[AnExample {commentSectionStart = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " dummyPos = Position 0 0"} :| [ExampleLine {getExampleLine = " dummyPosition = Position dummyPos dummyPos"}], exampleResults = []}]) blockCommentBP :: Position -> BlockCommentParser (CommentFlavour, [TestComment]) @@ -267,6 +271,8 @@ lineGroupP = do {- $setup >>> dummyPos = Position 0 0 >>> dummyPosition = Position dummyPos dummyPos +Couldn't match expected type ‘Int’ with actual type ‘Position’ +Couldn't match expected type ‘Int’ with actual type ‘Position’ -} -- >>> parse (lineGroupP <*eof) "" $ (dummyPosition, ) . RawLineComment <$> ["-- a", "-- b"] @@ -333,13 +339,15 @@ fails if the input does not start with "--". __N.B.__ We don't strip comment flavours. ->>> parseMaybe (parseLine $ takeRest) $ map (:[]) ["-- >>> A"] +>>> pck = (:[]).(:[]) . RawLineComment + +>>> parseMaybe (parseLine $ takeRest) $ pck "-- >>> A" Just [">>> A"] ->>> parseMaybe (parseLine $ takeRest) $ map (:[]) ["--- >>> A"] +>>> parseMaybe (parseLine $ takeRest) $ pck "--- >>> A" Just [" >>> A"] ->>> parseMaybe (parseLine takeRest) $ map (:[]) [""] +>>> parseMaybe (parseLine takeRest) $ pck "" Nothing -} parseLine :: @@ -368,8 +376,6 @@ normalLineP style = do notFollowedBy (try $ exampleSymbol <|> propSymbol) consume style --- >>> parse (skipMany (consume Block)) "" "foo\nbar" --- Right () consume :: CommentStyle -> Parser String String consume style = case style of @@ -405,7 +411,7 @@ Two adjacent tokens are considered to be contiguous if * they have same starting column. >>> contiguousGroupOn id [(1,2),(2,2),(3,4),(4,4),(5,4),(7,0),(8,0)] -NOW [(1,2) :| [(2,2)],(3,4) :| [(4,4),(5,4)],(7,0) :| [(8,0)]] +[(1,2) :| [(2,2)],(3,4) :| [(4,4),(5,4)],(7,0) :| [(8,0)]] -} contiguousGroupOn :: (a -> (Int, Int)) -> [a] -> [NonEmpty a] contiguousGroupOn toLineCol = foldr step [] From 2e64bbe0f11ba1694edd6185160aebd31d0fc93f Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sat, 23 Jan 2021 03:15:41 +0900 Subject: [PATCH 11/41] Brutal line parsing --- .../src/Ide/Plugin/Eval/CodeLens.hs | 33 +++++++++++++++---- 1 file changed, 27 insertions(+), 6 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 82f223b45e..1f1008a7eb 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -43,7 +45,7 @@ import Data.Char (isSpace) import Data.Either (isRight) import qualified Data.HashMap.Strict as HashMap import Data.List - ( dropWhileEnd, + (mapAccumL, dropWhileEnd, find, ) import qualified Data.Map.Strict as Map @@ -216,8 +218,8 @@ import Text.Read (readMaybe) import Util (OverridingBool (Never)) import Development.IDE.Core.PositionMapping (toCurrentRange) import qualified Data.DList as DL -import Control.Lens ((+~), (&), (^.)) -import Language.Haskell.LSP.Types.Lens (character, start) +import Control.Lens ((.~), (+~), (&), (^.)) +import Language.Haskell.LSP.Types.Lens (end, line, character, start) {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. @@ -244,6 +246,7 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = curRan = fromMaybe ran0 $ toCurrentRange posMap ran0 -- used to detect whether haddock comment is a line comment or not, in a brutal way begin = curRan ^. start + fin = curRan ^. end isLine = extractRange (Range begin @@ -259,7 +262,7 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = AnnBlockComment cmt -> mempty { blockComments = Map.singleton begin $ RawBlockComment cmt } AnnDocCommentNext txt - | isLine -> mempty + | isLine -> mimicLine '|' begin fin txt | otherwise -> mempty { blockComments = @@ -268,7 +271,7 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = "{- | " <> txt <> "-}" } AnnDocCommentPrev txt - | isLine -> mempty + | isLine -> mimicLine '^' begin fin txt | otherwise -> mempty { blockComments = @@ -277,7 +280,7 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = "{- ^ " <> txt <> "-}" } AnnDocCommentNamed txt - | isLine -> mempty + | isLine -> mimicLine '$' begin fin txt | otherwise -> mempty { blockComments = @@ -339,6 +342,24 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = where trivial (Range p p') = p == p' +mimicLine :: Char -> Position -> Position -> String -> Comments +mimicLine prefix beg fin content = + let prfx' = "-- " ++ [prefix, ' ' ] + (next, alls) = mapAccumL + ( \ !pos l -> + ( pos & line +~ 1 & character .~ 0 + , (pos, RawLineComment $ prfx' ++ l) + ) + ) + beg + $ lines content + pads = map ((, RawLineComment prfx') . flip Position 0) + [next^.line .. fin^.line] + in mempty + { lineComments = + Map.fromList $ alls ++ pads + } + evalCommandName :: CommandId evalCommandName = "evalCommand" From 53476b03be76e9f494a81ce84055df979dde90c6 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sat, 23 Jan 2021 03:28:55 +0900 Subject: [PATCH 12/41] unset Opt_Haddock --- ghcide/src/Development/IDE/Core/Rules.hs | 5 +- .../src/Ide/Plugin/Eval/CodeLens.hs | 67 ++----------------- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 6 -- 3 files changed, 11 insertions(+), 67 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 31fdf4d352..69f340886d 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -349,6 +349,9 @@ withOptHaddock = withOption Opt_Haddock withOption :: GeneralFlag -> ModSummary -> ModSummary withOption opt ms = ms{ms_hspp_opts= gopt_set (ms_hspp_opts ms) opt} +withoutOption :: GeneralFlag -> ModSummary -> ModSummary +withoutOption opt ms = ms{ms_hspp_opts= gopt_unset (ms_hspp_opts ms) opt} + -- | Given some normal parse errors (first) and some from Haddock (second), merge them. -- Ignore Haddock errors that are in both. Demote Haddock-only errors to warnings. mergeParseErrorsHaddock :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic] @@ -370,7 +373,7 @@ getParsedModuleWithCommentsRule = defineEarlyCutoff $ \GetParsedModuleWithCommen sess <- use_ GhcSession file opt <- getIdeOptions - let ms' = withOption Opt_KeepRawTokenStream ms + let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms liftIO $ getParsedModuleDefinition (hscEnv sess) opt file ms' diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 1f1008a7eb..9be1886461 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -45,7 +45,7 @@ import Data.Char (isSpace) import Data.Either (isRight) import qualified Data.HashMap.Strict as HashMap import Data.List - (mapAccumL, dropWhileEnd, + (dropWhileEnd, find, ) import qualified Data.Map.Strict as Map @@ -79,11 +79,11 @@ import Development.IDE useWithStale_, use_, ) -import Development.IDE.GHC.Compat (AnnotationComment(AnnDocCommentNext, AnnBlockComment, AnnLineComment), GenLocated (L), HscEnv, ParsedModule (..), SrcSpan (RealSrcSpan), srcSpanFile) +import Development.IDE.GHC.Compat (AnnotationComment(AnnBlockComment, AnnLineComment), GenLocated (L), HscEnv, ParsedModule (..), SrcSpan (RealSrcSpan), srcSpanFile) import DynamicLoading (initializePlugins) import FastString (unpackFS) import GHC - (AnnotationComment(AnnDocCommentNamed, AnnDocCommentPrev), ExecOptions + (ExecOptions ( execLineNumber, execSourceFile ), @@ -168,7 +168,7 @@ import Ide.Plugin.Eval.Util response', timed, ) -import Ide.PluginUtils (extractRange, mkLspCommand) +import Ide.PluginUtils (mkLspCommand) import Ide.Types ( CodeLensProvider, CommandFunction, @@ -218,8 +218,8 @@ import Text.Read (readMaybe) import Util (OverridingBool (Never)) import Development.IDE.Core.PositionMapping (toCurrentRange) import qualified Data.DList as DL -import Control.Lens ((.~), (+~), (&), (^.)) -import Language.Haskell.LSP.Types.Lens (end, line, character, start) +import Control.Lens ((^.)) +import Language.Haskell.LSP.Types.Lens (start) {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. @@ -232,7 +232,6 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = response $ do let TextDocumentIdentifier uri = _textDocument fp <- handleMaybe "uri" $ uriToFilePath' uri - content <- moduleText _lsp uri let nfp = toNormalizedFilePath' fp dbg "fp" fp (ParsedModule{..}, posMap) <- liftIO $ @@ -246,48 +245,14 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = curRan = fromMaybe ran0 $ toCurrentRange posMap ran0 -- used to detect whether haddock comment is a line comment or not, in a brutal way begin = curRan ^. start - fin = curRan ^. end - isLine = - extractRange - (Range begin - $ begin & character +~ 1 - ) content - == "--" in - -- since Haddock parsing is off, + -- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments', -- we can concentrate on these two case bdy of AnnLineComment cmt -> mempty { lineComments = Map.singleton begin (RawLineComment cmt) } AnnBlockComment cmt -> mempty { blockComments = Map.singleton begin $ RawBlockComment cmt } - AnnDocCommentNext txt - | isLine -> mimicLine '|' begin fin txt - | otherwise -> - mempty { - blockComments = - Map.singleton begin - $ RawBlockComment $ - "{- | " <> txt <> "-}" - } - AnnDocCommentPrev txt - | isLine -> mimicLine '^' begin fin txt - | otherwise -> - mempty { - blockComments = - Map.singleton begin - $ RawBlockComment $ - "{- ^ " <> txt <> "-}" - } - AnnDocCommentNamed txt - | isLine -> mimicLine '$' begin fin txt - | otherwise -> - mempty { - blockComments = - Map.singleton begin - $ RawBlockComment $ - "{- $ " <> txt <> "-}" - } _ -> mempty _ -> mempty ) @@ -342,24 +307,6 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = where trivial (Range p p') = p == p' -mimicLine :: Char -> Position -> Position -> String -> Comments -mimicLine prefix beg fin content = - let prfx' = "-- " ++ [prefix, ' ' ] - (next, alls) = mapAccumL - ( \ !pos l -> - ( pos & line +~ 1 & character .~ 0 - , (pos, RawLineComment $ prfx' ++ l) - ) - ) - beg - $ lines content - pads = map ((, RawLineComment prfx') . flip Position 0) - [next^.line .. fin^.line] - in mempty - { lineComments = - Map.fromList $ alls ++ pads - } - evalCommandName :: CommandId evalCommandName = "evalCommand" diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index 34afb55b20..0e7f84a6b5 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -268,12 +268,6 @@ lineGroupP = do Named "setup" -> (Nothing,) <$> lineCommentSectionsP flav -> (,mempty) . Just . (flav,) <$> lineCommentSectionsP -{- $setup ->>> dummyPos = Position 0 0 ->>> dummyPosition = Position dummyPos dummyPos -Couldn't match expected type ‘Int’ with actual type ‘Position’ -Couldn't match expected type ‘Int’ with actual type ‘Position’ --} -- >>> parse (lineGroupP <*eof) "" $ (dummyPosition, ) . RawLineComment <$> ["-- a", "-- b"] -- Variable not in scope: dummyPosition :: Position From 261e8a6a00965da36f17ba5c43830b9c66fb3fd7 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sat, 23 Jan 2021 03:30:21 +0900 Subject: [PATCH 13/41] Wrong debug messages --- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 9be1886461..c7c8fc8a27 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -258,7 +258,7 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = ) ) $ snd pm_annotations - dbg "comments" $ show $ DL.toList $ + dbg "excluded comments" $ show $ DL.toList $ foldMap (foldMap $ \(L a b) -> case b of @@ -267,7 +267,7 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = _ -> DL.singleton (a, b) ) $ snd pm_annotations - dbg "excluded comments" $ show comments + dbg "comments" $ show comments dbg "groups" $ groupLineComments $ lineComments comments -- Extract tests from source code From d4c1800bb5aad10916925f452cc9892507dd78a9 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sat, 23 Jan 2021 03:30:35 +0900 Subject: [PATCH 14/41] Redundant debug output --- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index c7c8fc8a27..492c87e6a9 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -268,7 +268,6 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = ) $ snd pm_annotations dbg "comments" $ show comments - dbg "groups" $ groupLineComments $ lineComments comments -- Extract tests from source code let Sections{..} = commentsToSections comments From abede6b7c58cd7f50b6d081c0484437671ed50ff Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sun, 24 Jan 2021 13:58:15 +0900 Subject: [PATCH 15/41] Hacks for indentation levels and LHS --- .../src/Ide/Plugin/Eval/CodeLens.hs | 7 +- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 102 +++++++++++++----- 2 files changed, 79 insertions(+), 30 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 492c87e6a9..29e73a1c6b 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -154,7 +152,7 @@ import Ide.Plugin.Eval.GHC isExpr, showDynFlags, ) -import Ide.Plugin.Eval.Parse.Comments (commentsToSections, groupLineComments) +import Ide.Plugin.Eval.Parse.Comments (commentsToSections) import Ide.Plugin.Eval.Parse.Option (langOptions) import Ide.Plugin.Eval.Types import Ide.Plugin.Eval.Util @@ -233,6 +231,7 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = let TextDocumentIdentifier uri = _textDocument fp <- handleMaybe "uri" $ uriToFilePath' uri let nfp = toNormalizedFilePath' fp + isLHS = isLiterate fp dbg "fp" fp (ParsedModule{..}, posMap) <- liftIO $ runAction "parsed" st $ useWithStale_ GetParsedModuleWithComments nfp @@ -270,7 +269,7 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = dbg "comments" $ show comments -- Extract tests from source code - let Sections{..} = commentsToSections comments + let Sections{..} = commentsToSections isLHS comments tests = testsBySection nonSetups nonSetups = lineSections ++ multilineSections cmd <- liftIO $ mkLspCommand plId evalCommandName "Evaluate=..." (Just []) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index 0e7f84a6b5..f59ebd3e8c 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -9,7 +9,7 @@ module Ide.Plugin.Eval.Parse.Comments where import qualified Control.Applicative.Combinators.NonEmpty as NE import Control.Arrow (first, (&&&), (>>>)) import Control.Lens (view, (^.)) -import Control.Monad (guard, void) +import Control.Monad (guard, void, when) import Control.Monad.Combinators () import qualified Data.Char as C import qualified Data.DList as DL @@ -20,7 +20,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Void (Void) import Development.IDE (Position) -import Development.IDE.Types.Location (Position (..), Position (Position)) +import Development.IDE.Types.Location (Position (..)) import GHC.Generics import Ide.Plugin.Eval.Types import Language.Haskell.LSP.Types.Lens @@ -92,8 +92,12 @@ data CommentFlavour = Vanilla | HaddockNext | HaddockPrev | Named String data CommentStyle = Line | Block deriving (Read, Show, Eq, Ord, Generic) -commentsToSections :: Comments -> Sections -commentsToSections Comments {..} = +commentsToSections :: + -- | True if it is literate Haskell + Bool -> + Comments -> + Sections +commentsToSections isLHS Comments {..} = let (lineSectionSeeds, lineSetupSeeds) = foldMap ( \lcs -> @@ -109,11 +113,23 @@ commentsToSections Comments {..} = DL.singleton (Line, rs) ) ) - $ groupLineComments lineComments + $ groupLineComments $ + Map.filterWithKey + -- FIXME: + -- To comply with the initial behaviour of + -- Extended Eval Plugin; + -- but it also rejects modules with + -- non-zero base indentation level! + ( \pos _ -> + if isLHS + then pos ^. character == 2 + else pos ^. character == 0 + ) + lineComments (blockSeed, blockSetupSeeds) = foldMap ( \(ran, lcs) -> - case parseMaybe (blockCommentBP ran) $ getRawBlockComment lcs of + case parseMaybe (blockCommentBP isLHS ran) $ getRawBlockComment lcs of Nothing -> mempty Just (Named "setup", grp) -> -- orders setup sections in ascending order @@ -126,6 +142,10 @@ commentsToSections Comments {..} = , mempty ) ) + -- It seems Extended Eval Plugin doesn't constraint + -- starting indentation level for block comments. + -- Rather, it constrains the indentation level /inside/ + -- block comment body. $ Map.toList blockComments lineSections = map (uncurry $ testsToSection Line) $ @@ -136,8 +156,8 @@ commentsToSections Comments {..} = setupSections = map (uncurry (`testsToSection` Named "setup")) $ DL.toList $ - F.fold $ - Map.unionWith (<>) lineSetupSeeds blockSetupSeeds + F.fold $ + Map.unionWith (<>) lineSetupSeeds blockSetupSeeds in Sections {..} testsToSection :: @@ -186,8 +206,11 @@ fromTestComment AnExample {..} = -- Just (Named "setup",[AnExample {commentSectionStart = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " dummyPos = Position 0 0"} :| [ExampleLine {getExampleLine = " dummyPosition = Position dummyPos dummyPos"}], exampleResults = []}]) blockCommentBP :: - Position -> BlockCommentParser (CommentFlavour, [TestComment]) -blockCommentBP pos = do + -- | True if Literate Haskell + Bool -> + Position -> + BlockCommentParser (CommentFlavour, [TestComment]) +blockCommentBP isLHS pos = do updateParserState $ \st -> st { statePosState = @@ -201,7 +224,7 @@ blockCommentBP pos = do hit <- skipNormalCommentBlock if hit then do - body <- many $ (blockExamples <|> blockProp) <* skipNormalCommentBlock + body <- many $ (blockExamples isLHS <|> blockProp isLHS) <* skipNormalCommentBlock void takeRest -- just consume the rest pure (flav, body) else pure (Vanilla, []) @@ -214,12 +237,16 @@ skipNormalCommentBlock = eob :: BlockCommentParser () eob = eof <|> try (optional (chunk "-}") *> eof) <|> void eol -blockExamples, blockProp :: BlockCommentParser TestComment -blockExamples = do - (ran, examples) <- withPosition $ NE.some $ exampleLineStrP Block +blockExamples + , blockProp :: + -- | True if Literate Haskell + Bool -> + BlockCommentParser TestComment +blockExamples isLHS = do + (ran, examples) <- withPosition $ NE.some $ exampleLineStrP isLHS Block AnExample ran examples <$> resultBlockP -blockProp = do - (ran, prop) <- withPosition $ propLineStrP Block +blockProp isLHS = do + (ran, prop) <- withPosition $ propLineStrP isLHS Block AProp ran prop <$> resultBlockP withPosition :: (TraversableStream s, Stream s) => Parser s a -> Parser s (Position, a) @@ -268,7 +295,6 @@ lineGroupP = do Named "setup" -> (Nothing,) <$> lineCommentSectionsP flav -> (,mempty) . Just . (flav,) <$> lineCommentSectionsP - -- >>> parse (lineGroupP <*eof) "" $ (dummyPosition, ) . RawLineComment <$> ["-- a", "-- b"] -- Variable not in scope: dummyPosition :: Position @@ -321,10 +347,14 @@ exampleLinesGP = <*> resultLinesP exampleLineGP :: LineGroupParser (Position, ExampleLine) -exampleLineGP = parseLine (commentFlavourP *> exampleLineStrP Line) +exampleLineGP = + -- In line-comments, indentation-level inside comment doesn't matter. + parseLine (commentFlavourP *> exampleLineStrP False Line) propLineGP :: LineGroupParser (Position, PropLine) -propLineGP = parseLine (commentFlavourP *> propLineStrP Line) +propLineGP = + -- In line-comments, indentation-level inside comment doesn't matter. + parseLine (commentFlavourP *> propLineStrP False Line) {- | Turning a line parser into line group parser consuming a single line comment. @@ -377,20 +407,40 @@ consume style = Block -> manyTill anySingle eob -- | Parses example test line. -exampleLineStrP :: CommentStyle -> LineParser ExampleLine -exampleLineStrP style = - exampleSymbol *> (ExampleLine <$> consume style) +exampleLineStrP :: + -- | True if Literate Haskell + Bool -> + CommentStyle -> + LineParser ExampleLine +exampleLineStrP isLHS style = + -- FIXME: To comply with existing Extended Eval Plugin Behaviour; + -- it must skip one space after a comment! + -- This prevents Eval Plugin from working on + -- modules with non-standard base indentation-level. + when (isLHS && style == Block) (void $ optional $ char ' ') + *> exampleSymbol + *> (ExampleLine <$> consume style) exampleSymbol :: Parser String () -exampleSymbol = chunk ">>>" *> P.notFollowedBy (char '>') +exampleSymbol = + chunk ">>>" *> P.notFollowedBy (char '>') propSymbol :: Parser String () propSymbol = chunk "prop>" *> P.notFollowedBy (char '>') -- | Parses prop test line. -propLineStrP :: CommentStyle -> LineParser PropLine -propLineStrP style = - chunk "prop>" +propLineStrP :: + -- | True if Literate HAskell + Bool -> + CommentStyle -> + LineParser PropLine +propLineStrP isLHS style = + -- FIXME: To comply with existing Extended Eval Plugin Behaviour; + -- it must skip one space after a comment! + -- This prevents Eval Plugin from working on + -- modules with non-standard base indentation-level. + when (isLHS && style == Block) (void $ optional $ char ' ') + *> chunk "prop>" *> P.notFollowedBy (char '>') *> (PropLine <$> consume style) From c9e5636cf9cdd01249aca4390201439d1ca4f6a0 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sun, 24 Jan 2021 14:43:00 +0900 Subject: [PATCH 16/41] Updates block comment logic in Literate Haskell --- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 54 +++++++++++++------ 1 file changed, 37 insertions(+), 17 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index f59ebd3e8c..687d56bf5f 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -200,10 +200,11 @@ fromTestComment AnExample {..} = {- $setup >>> dummyPos = Position 0 0 +>>> parseE p = either (error . errorBundlePretty) id . parse p "" -} --- >>> parseMaybe (blockCommentBP $ dummyPos) "{- $setup\n>>> dummyPos = Position 0 0\n>>> dummyPosition = Position dummyPos dummyPos\n-}" --- Just (Named "setup",[AnExample {commentSectionStart = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " dummyPos = Position 0 0"} :| [ExampleLine {getExampleLine = " dummyPosition = Position dummyPos dummyPos"}], exampleResults = []}]) +-- >>> parseE (blockCommentBP True dummyPos) "{- |\n >>> 5+5\n 11\n -}" +-- (HaddockNext,[AnExample {commentSectionStart = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " 5+5"} :| [], exampleResults = [" 11"]}]) blockCommentBP :: -- | True if Literate Haskell @@ -221,18 +222,32 @@ blockCommentBP isLHS pos = do skipCount 2 anySingle -- "{-" void $ optional $ char ' ' flav <- commentFlavourP - hit <- skipNormalCommentBlock + hit <- skipNormalCommentBlock isLHS if hit then do - body <- many $ (blockExamples isLHS <|> blockProp isLHS) <* skipNormalCommentBlock + body <- many $ (blockExamples isLHS <|> blockProp isLHS) + <* skipNormalCommentBlock isLHS void takeRest -- just consume the rest pure (flav, body) - else pure (Vanilla, []) + else pure (flav, []) -skipNormalCommentBlock :: Parser String Bool -skipNormalCommentBlock = - skipManyTill (normalLineP Block) $ - False <$ try (optional (chunk "-}") *> eof) <|> True <$ lookAhead (propSymbol <|> exampleSymbol) +skipNormalCommentBlock :: + -- | True if Literate Haskell + Bool -> + Parser String Bool +skipNormalCommentBlock isLHS = + skipManyTill (normalLineP isLHS Block) $ + False <$ try (optional (chunk "-}") *> eof) + <|> True <$ lookAhead (try $ testSymbol isLHS Block) + +testSymbol :: Bool -> CommentStyle -> Parser String () +testSymbol isLHS style = + -- FIXME: To comply with existing Extended Eval Plugin Behaviour; + -- it must skip one space after a comment! + -- This prevents Eval Plugin from working on + -- modules with non-standard base indentation-level. + when (isLHS && style == Block) (void $ count' 0 2 $ char ' ') + *> (exampleSymbol <|> propSymbol) eob :: BlockCommentParser () eob = eof <|> try (optional (chunk "-}") *> eof) <|> void eol @@ -334,7 +349,7 @@ resultLinesP = many nonEmptyLGP normalLineCommentP :: LineGroupParser (Position, String) normalLineCommentP = - parseLine (commentFlavourP *> normalLineP Line) + parseLine (commentFlavourP *> normalLineP False Line) nonEmptyLGP :: LineGroupParser String nonEmptyLGP = try $ fmap snd $ parseLine $ commentFlavourP *> nonEmptyNormalLineP Line @@ -388,16 +403,21 @@ parseLine p = -- | Non-empty normal line. nonEmptyNormalLineP :: CommentStyle -> LineParser String nonEmptyNormalLineP style = try $ do - ln <- normalLineP style + ln <- normalLineP False style guard $ not $ all C.isSpace ln pure ln {- | Normal line is a line neither a example nor prop. Empty line is normal. -} -normalLineP :: CommentStyle -> LineParser String -normalLineP style = do - notFollowedBy (try $ exampleSymbol <|> propSymbol) +normalLineP :: + -- | True if Literate Haskell + Bool -> + CommentStyle -> + LineParser String +normalLineP isLHS style = do + notFollowedBy + (try $ testSymbol isLHS style) consume style consume :: CommentStyle -> Parser String String @@ -412,12 +432,12 @@ exampleLineStrP :: Bool -> CommentStyle -> LineParser ExampleLine -exampleLineStrP isLHS style = +exampleLineStrP isLHS style = try $ -- FIXME: To comply with existing Extended Eval Plugin Behaviour; -- it must skip one space after a comment! -- This prevents Eval Plugin from working on -- modules with non-standard base indentation-level. - when (isLHS && style == Block) (void $ optional $ char ' ') + when (isLHS && style == Block) (void $ count' 0 2 $ char ' ') *> exampleSymbol *> (ExampleLine <$> consume style) @@ -439,7 +459,7 @@ propLineStrP isLHS style = -- it must skip one space after a comment! -- This prevents Eval Plugin from working on -- modules with non-standard base indentation-level. - when (isLHS && style == Block) (void $ optional $ char ' ') + when (isLHS && style == Block) (void $ count' 0 2 $ char ' ') *> chunk "prop>" *> P.notFollowedBy (char '>') *> (PropLine <$> consume style) From f698addb665b6baeaedc0c47b073306bc1c93d25 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sun, 24 Jan 2021 16:15:41 +0900 Subject: [PATCH 17/41] Updates doctests --- .../hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 29e73a1c6b..7427fcf7d1 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -428,21 +428,21 @@ runEvalCmd lsp st EvalParams{..} = {- >>> import Language.Haskell.LSP.Types(applyTextEdit) ->>> aTest s = let Right [sec] = allSections (tokensFrom s) in head. sectionTests $ sec +>>> aTest = Located 1 (Example (pure " 2 + 2") []) >>> mdl = "module Test where\n-- >>> 2+2" To avoid https://github.com/haskell/haskell-language-server/issues/1213, `addFinalReturn` adds, if necessary, a final empty line to the document before inserting the tests' results. ->>> let [e1,e2] = addFinalReturn mdl [asEdit (aTest mdl) ["4"]] in applyTextEdit e2 (applyTextEdit e1 mdl) +>>> let [e1,e2] = addFinalReturn mdl [asEdit aTest ["4"]] in applyTextEdit e2 (applyTextEdit e1 mdl) "module Test where\n-- >>> 2+2\n4\n" ->>> applyTextEdit (head $ addFinalReturn mdl [asEdit (aTest mdl) ["4"]]) mdl +>>> applyTextEdit (head $ addFinalReturn mdl [asEdit aTest ["4"]]) mdl "module Test where\n-- >>> 2+2\n" ->>> addFinalReturn mdl [asEdit (aTest mdl) ["4"]] +>>> addFinalReturn mdl [asEdit aTest ["4"]] [TextEdit {_range = Range {_start = Position {_line = 1, _character = 10}, _end = Position {_line = 1, _character = 10}}, _newText = "\n"},TextEdit {_range = Range {_start = Position {_line = 2, _character = 0}, _end = Position {_line = 2, _character = 0}}, _newText = "4\n"}] ->>> asEdit (aTest mdl) ["4"] +>>> asEdit aTest ["4"] TextEdit {_range = Range {_start = Position {_line = 2, _character = 0}, _end = Position {_line = 2, _character = 0}}, _newText = "4\n"} -} addFinalReturn :: Text -> [TextEdit] -> [TextEdit] @@ -545,7 +545,7 @@ A, possibly multi line, error is returned for a wrong declaration, directive or Unknown extension: "NonExistent" >>> cls C -Variable not in scope: cls :: t0 -> f0 +Variable not in scope: cls :: t0 -> () Data constructor not in scope: C >>> "A From d51457088b11002e7ddac8312cf9ceec05d71481 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sun, 24 Jan 2021 19:39:12 +0900 Subject: [PATCH 18/41] Allows doctest without newline at the end --- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 1 + .../src/Ide/Plugin/Eval/CodeLens.hs | 31 ++- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 212 +++++++++++------- .../src/Ide/Plugin/Eval/Types.hs | 28 ++- plugins/hls-eval-plugin/test/Eval.hs | 3 + .../test/testdata/TEndingMulti.hs | 6 + .../test/testdata/TEndingMulti.hs.expected | 9 + .../hls-eval-plugin/test/testdata/THaddock.hs | 4 +- .../test/testdata/THaddock.hs.expected | 4 +- .../hls-eval-plugin/test/testdata/TMulti.hs | 2 +- .../test/testdata/TMulti.hs.expected | 4 +- .../hls-eval-plugin/test/testdata/test.cabal | 1 + 12 files changed, 197 insertions(+), 108 deletions(-) create mode 100644 plugins/hls-eval-plugin/test/testdata/TEndingMulti.hs create mode 100644 plugins/hls-eval-plugin/test/testdata/TEndingMulti.hs.expected diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index a341d06af4..088115efa7 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -64,6 +64,7 @@ library , text , time , transformers + , mtl , unordered-containers ghc-options: -Wall -Wno-name-shadowing diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 7427fcf7d1..4f44c41dd1 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -216,8 +216,9 @@ import Text.Read (readMaybe) import Util (OverridingBool (Never)) import Development.IDE.Core.PositionMapping (toCurrentRange) import qualified Data.DList as DL -import Control.Lens ((^.)) -import Language.Haskell.LSP.Types.Lens (start) +import Control.Lens ((^.), (-~), view) +import Language.Haskell.LSP.Types.Lens (line, end, character) +import Data.Function ((&)) {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. @@ -242,16 +243,14 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = fromNormalizedFilePath nfp -> let ran0 = realSrcSpanToRange real curRan = fromMaybe ran0 $ toCurrentRange posMap ran0 - -- used to detect whether haddock comment is a line comment or not, in a brutal way - begin = curRan ^. start in -- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments', -- we can concentrate on these two case bdy of AnnLineComment cmt -> - mempty { lineComments = Map.singleton begin (RawLineComment cmt) } + mempty { lineComments = Map.singleton curRan (RawLineComment cmt) } AnnBlockComment cmt -> - mempty { blockComments = Map.singleton begin $ RawBlockComment cmt } + mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt } _ -> mempty _ -> mempty ) @@ -429,11 +428,12 @@ runEvalCmd lsp st EvalParams{..} = {- >>> import Language.Haskell.LSP.Types(applyTextEdit) >>> aTest = Located 1 (Example (pure " 2 + 2") []) +>>> ending = Position 1 10 >>> mdl = "module Test where\n-- >>> 2+2" To avoid https://github.com/haskell/haskell-language-server/issues/1213, `addFinalReturn` adds, if necessary, a final empty line to the document before inserting the tests' results. ->>> let [e1,e2] = addFinalReturn mdl [asEdit aTest ["4"]] in applyTextEdit e2 (applyTextEdit e1 mdl) +>>> let [e1,e2] = addFinalReturn mdl [asEdit aTest Line () ["4"]] in applyTextEdit e2 (applyTextEdit e1 mdl) "module Test where\n-- >>> 2+2\n4\n" >>> applyTextEdit (head $ addFinalReturn mdl [asEdit aTest ["4"]]) mdl @@ -492,7 +492,8 @@ runTests e@(_st, _) tests = do let checkedResult = testCheck (section, unLoc test) rs - let edit = asEdit test (map pad checkedResult) + let edit = asEdit (sectionFormat section) (sectionRange section) + test (map pad checkedResult) dbg "TEST EDIT" edit return edit @@ -504,8 +505,18 @@ runTests e@(_st, _) tests = do "Add QuickCheck to your cabal dependencies to run this test." runTest e df test = evals e df (asStatements test) -asEdit :: Loc Test -> [Text] -> TextEdit -asEdit test resultLines = TextEdit (resultRange test) (T.unlines resultLines) +asEdit :: Format -> Range -> Loc Test -> [Text] -> TextEdit +asEdit (MultiLine commRange) testRange test resultLines + -- A test in a block comment, ending with @-\}@ without newline in-between. + | testRange ^. end.line == commRange ^. end . line = + TextEdit + (Range + (view end testRange & character -~ 2) + (resultRange test ^. end) + ) + ("\n" <> T.unlines (resultLines <> ["-}"])) +asEdit _ _ test resultLines = + TextEdit (resultRange test) (T.unlines resultLines) {- The result of evaluating a test line can be: diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index 687d56bf5f..40c28b6171 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -1,31 +1,40 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} module Ide.Plugin.Eval.Parse.Comments where import qualified Control.Applicative.Combinators.NonEmpty as NE import Control.Arrow (first, (&&&), (>>>)) -import Control.Lens (view, (^.)) -import Control.Monad (guard, void, when) +import Control.Lens (lensField, lensRules, view, (.~), (^.)) +import Control.Lens.Extras (is) +import Control.Lens.TH (makeLensesWith, makePrisms, mappingNamer) +import Control.Monad (guard, join, void, when) import Control.Monad.Combinators () +import Control.Monad.Reader (ask) +import Control.Monad.Trans.Reader (Reader, runReader) import qualified Data.Char as C import qualified Data.DList as DL import qualified Data.Foldable as F +import Data.Function ((&)) import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Void (Void) -import Development.IDE (Position) +import Development.IDE (Position, Range (Range)) import Development.IDE.Types.Location (Position (..)) import GHC.Generics import Ide.Plugin.Eval.Types import Language.Haskell.LSP.Types.Lens ( character, + end, line, + start, ) import Text.Megaparsec import qualified Text.Megaparsec as P @@ -55,13 +64,23 @@ We build parsers combining the following three kinds of them: type Parser inputs = Parsec Void inputs -- | Line parser -type LineParser = Parser String +type LineParser a = forall m. Monad m => ParsecT Void String m a -- | Line comment group parser -type LineGroupParser = Parser [(Position, RawLineComment)] +type LineGroupParser = Parser [(Range, RawLineComment)] + +data BlockEnv = BlockEnv + { isLhs :: Bool + , blockRange :: Range + } + deriving (Read, Show, Eq, Ord) + +makeLensesWith + (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) + ''BlockEnv -- | Block comment parser -type BlockCommentParser = Parser String +type BlockCommentParser = ParsecT Void String (Reader BlockEnv) -- | Prop line, with "prop>" stripped off newtype PropLine = PropLine {getPropLine :: String} @@ -89,9 +108,11 @@ data CommentFlavour = Vanilla | HaddockNext | HaddockPrev | Named String deriving (Read, Show, Eq, Ord) -- | Single line or block comments? -data CommentStyle = Line | Block +data CommentStyle = Line | Block Range deriving (Read, Show, Eq, Ord, Generic) +makePrisms ''CommentStyle + commentsToSections :: -- | True if it is literate Haskell Bool -> @@ -101,17 +122,21 @@ commentsToSections isLHS Comments {..} = let (lineSectionSeeds, lineSetupSeeds) = foldMap ( \lcs -> - case parseMaybe lineGroupP $ NE.toList lcs of - Nothing -> mempty - Just (mls, rs) -> - ( maybe DL.empty DL.singleton mls - , -- orders setup sections in ascending order - if null rs - then mempty - else - Map.singleton (fst $ NE.head lcs) $ - DL.singleton (Line, rs) - ) + let theRan = + Range + (view start $ fst $ NE.head lcs) + (view end $ fst $ NE.last lcs) + in case parseMaybe lineGroupP $ NE.toList lcs of + Nothing -> mempty + Just (mls, rs) -> + ( maybe DL.empty DL.singleton ((theRan,) <$> mls) + , -- orders setup sections in ascending order + if null rs + then mempty + else + Map.singleton theRan $ + DL.singleton (Line, rs) + ) ) $ groupLineComments $ Map.filterWithKey @@ -122,23 +147,24 @@ commentsToSections isLHS Comments {..} = -- non-zero base indentation level! ( \pos _ -> if isLHS - then pos ^. character == 2 - else pos ^. character == 0 + then pos ^. start . character == 2 + else pos ^. start . character == 0 ) lineComments (blockSeed, blockSetupSeeds) = foldMap ( \(ran, lcs) -> - case parseMaybe (blockCommentBP isLHS ran) $ getRawBlockComment lcs of + case parseBlockMaybe isLHS ran blockCommentBP + $ getRawBlockComment lcs of Nothing -> mempty Just (Named "setup", grp) -> -- orders setup sections in ascending order ( mempty , Map.singleton ran $ - DL.singleton (Block, grp) + DL.singleton (Block ran, grp) ) Just grp -> - ( DL.singleton grp + ( DL.singleton (ran, grp) , mempty ) ) @@ -148,24 +174,53 @@ commentsToSections isLHS Comments {..} = -- block comment body. $ Map.toList blockComments lineSections = - map (uncurry $ testsToSection Line) $ + map (\(pos, (flav, cmd)) -> testsToSection Line flav pos cmd) $ DL.toList lineSectionSeeds multilineSections = - map (uncurry $ testsToSection Block) $ + map (\(ran, (flav, cmd)) -> testsToSection (Block ran) flav ran cmd) $ DL.toList blockSeed setupSections = - map (uncurry (`testsToSection` Named "setup")) $ - DL.toList $ + -- Setups doesn't need Dummy position + map + ( \(style, tests) -> + testsToSection + style + (Named "setup") + (join Range (Position 0 0)) -- Just dummy for setup sections + tests + ) + $ DL.toList $ F.fold $ Map.unionWith (<>) lineSetupSeeds blockSetupSeeds in Sections {..} +parseBlockMaybe :: Bool -> Range -> BlockCommentParser a -> String -> Maybe a +parseBlockMaybe isLhs blockRange p i = + case runReader (runParserT p' "" i) BlockEnv {..} of + Left {} -> Nothing + Right a -> Just a + where + p' = do + updateParserState $ \st -> + st + { statePosState = + (statePosState st) + { pstateSourcePos = positionToSourcePos $ blockRange ^. start + } + } + p + +type CommentRange = Range + +type SectionRange = Range + testsToSection :: CommentStyle -> CommentFlavour -> + SectionRange -> [TestComment] -> Section -testsToSection style flav tests = +testsToSection style flav sectionRange tests = let sectionName | Named name <- flav = name | otherwise = "" @@ -177,7 +232,7 @@ testsToSection style flav tests = sectionFormat = case style of Line -> SingleLine - Block -> MultiLine + Block ran -> MultiLine ran in Section {..} fromTestComment :: TestComment -> Loc Test @@ -208,70 +263,64 @@ fromTestComment AnExample {..} = blockCommentBP :: -- | True if Literate Haskell - Bool -> - Position -> BlockCommentParser (CommentFlavour, [TestComment]) -blockCommentBP isLHS pos = do - updateParserState $ \st -> - st - { statePosState = - (statePosState st) - { pstateSourcePos = positionToSourcePos pos - } - } +blockCommentBP = do skipCount 2 anySingle -- "{-" void $ optional $ char ' ' flav <- commentFlavourP - hit <- skipNormalCommentBlock isLHS + hit <- skipNormalCommentBlock if hit then do - body <- many $ (blockExamples isLHS <|> blockProp isLHS) - <* skipNormalCommentBlock isLHS + body <- + many $ + (blockExamples <|> blockProp) + <* skipNormalCommentBlock void takeRest -- just consume the rest pure (flav, body) else pure (flav, []) -skipNormalCommentBlock :: - -- | True if Literate Haskell - Bool -> - Parser String Bool -skipNormalCommentBlock isLHS = - skipManyTill (normalLineP isLHS Block) $ +skipNormalCommentBlock :: BlockCommentParser Bool +skipNormalCommentBlock = do + BlockEnv {..} <- ask + skipManyTill (normalLineP isLhs $ Block blockRange) $ False <$ try (optional (chunk "-}") *> eof) - <|> True <$ lookAhead (try $ testSymbol isLHS Block) + <|> True <$ lookAhead (try $ testSymbol isLhs $ Block blockRange) -testSymbol :: Bool -> CommentStyle -> Parser String () +testSymbol :: Bool -> CommentStyle -> LineParser () testSymbol isLHS style = -- FIXME: To comply with existing Extended Eval Plugin Behaviour; -- it must skip one space after a comment! -- This prevents Eval Plugin from working on -- modules with non-standard base indentation-level. - when (isLHS && style == Block) (void $ count' 0 2 $ char ' ') + when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') *> (exampleSymbol <|> propSymbol) -eob :: BlockCommentParser () +eob :: LineParser () eob = eof <|> try (optional (chunk "-}") *> eof) <|> void eol blockExamples , blockProp :: - -- | True if Literate Haskell - Bool -> BlockCommentParser TestComment -blockExamples isLHS = do - (ran, examples) <- withPosition $ NE.some $ exampleLineStrP isLHS Block +blockExamples = do + BlockEnv {..} <- ask + (ran, examples) <- withPosition $ NE.some $ exampleLineStrP isLhs $ Block blockRange AnExample ran examples <$> resultBlockP -blockProp isLHS = do - (ran, prop) <- withPosition $ propLineStrP isLHS Block +blockProp = do + BlockEnv {..} <- ask + (ran, prop) <- withPosition $ propLineStrP isLhs $ Block blockRange AProp ran prop <$> resultBlockP -withPosition :: (TraversableStream s, Stream s) => Parser s a -> Parser s (Position, a) +withPosition :: + (TraversableStream s, Stream s, Monad m, Ord v) => + ParsecT v s m a -> + ParsecT v s m (Position, a) withPosition p = do beg <- sourcePosToPosition <$> getSourcePos a <- p pure (beg, a) resultBlockP :: BlockCommentParser [String] -resultBlockP = many $ nonEmptyNormalLineP Block +resultBlockP = many $ nonEmptyNormalLineP . Block =<< view blockRangeL positionToSourcePos :: Position -> SourcePos positionToSourcePos pos = @@ -338,7 +387,7 @@ lineCommentSectionsP = do skipMany normalLineCommentP many $ exampleLinesGP - <|> uncurry AProp <$> propLineGP <*> resultLinesP + <|> uncurry (AProp . view start) <$> propLineGP <*> resultLinesP <* skipMany normalLineCommentP lexemeLine :: LineGroupParser a -> LineGroupParser a @@ -347,7 +396,7 @@ lexemeLine p = p <* skipMany normalLineCommentP resultLinesP :: LineGroupParser [String] resultLinesP = many nonEmptyLGP -normalLineCommentP :: LineGroupParser (Position, String) +normalLineCommentP :: LineGroupParser (Range, String) normalLineCommentP = parseLine (commentFlavourP *> normalLineP False Line) @@ -357,16 +406,16 @@ nonEmptyLGP = try $ fmap snd $ parseLine $ commentFlavourP *> nonEmptyNormalLine exampleLinesGP :: LineGroupParser TestComment exampleLinesGP = lexemeLine $ - uncurry AnExample . first NE.head . NE.unzip + uncurry AnExample . first (view start . NE.head) . NE.unzip <$> NE.some exampleLineGP <*> resultLinesP -exampleLineGP :: LineGroupParser (Position, ExampleLine) +exampleLineGP :: LineGroupParser (Range, ExampleLine) exampleLineGP = -- In line-comments, indentation-level inside comment doesn't matter. parseLine (commentFlavourP *> exampleLineStrP False Line) -propLineGP :: LineGroupParser (Position, PropLine) +propLineGP :: LineGroupParser (Range, PropLine) propLineGP = -- In line-comments, indentation-level inside comment doesn't matter. parseLine (commentFlavourP *> propLineStrP False Line) @@ -420,11 +469,11 @@ normalLineP isLHS style = do (try $ testSymbol isLHS style) consume style -consume :: CommentStyle -> Parser String String +consume :: CommentStyle -> LineParser String consume style = case style of Line -> takeRest - Block -> manyTill anySingle eob + Block {} -> manyTill anySingle eob -- | Parses example test line. exampleLineStrP :: @@ -432,20 +481,21 @@ exampleLineStrP :: Bool -> CommentStyle -> LineParser ExampleLine -exampleLineStrP isLHS style = try $ - -- FIXME: To comply with existing Extended Eval Plugin Behaviour; - -- it must skip one space after a comment! - -- This prevents Eval Plugin from working on - -- modules with non-standard base indentation-level. - when (isLHS && style == Block) (void $ count' 0 2 $ char ' ') - *> exampleSymbol - *> (ExampleLine <$> consume style) - -exampleSymbol :: Parser String () +exampleLineStrP isLHS style = + try $ + -- FIXME: To comply with existing Extended Eval Plugin Behaviour; + -- it must skip one space after a comment! + -- This prevents Eval Plugin from working on + -- modules with non-standard base indentation-level. + when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') + *> exampleSymbol + *> (ExampleLine <$> consume style) + +exampleSymbol :: LineParser () exampleSymbol = chunk ">>>" *> P.notFollowedBy (char '>') -propSymbol :: Parser String () +propSymbol :: LineParser () propSymbol = chunk "prop>" *> P.notFollowedBy (char '>') -- | Parses prop test line. @@ -459,7 +509,7 @@ propLineStrP isLHS style = -- it must skip one space after a comment! -- This prevents Eval Plugin from working on -- modules with non-standard base indentation-level. - when (isLHS && style == Block) (void $ count' 0 2 $ char ' ') + when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') *> chunk "prop>" *> P.notFollowedBy (char '>') *> (PropLine <$> consume style) @@ -492,7 +542,7 @@ contiguousGroupOn toLineCol = foldr step [] with contiguous line and columns. -} groupLineComments :: - Map Position a -> [NonEmpty (Position, a)] + Map Range a -> [NonEmpty (Range, a)] groupLineComments = - contiguousGroupOn (fst >>> view line &&& view character) + contiguousGroupOn (fst >>> view start >>> view line &&& view character) . Map.toList diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index 835753a63b..27b1dcd4e2 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -34,7 +34,7 @@ import Data.List.NonEmpty (NonEmpty) import Data.String (IsString (..)) import GHC.Generics (Generic) import Data.Map.Strict (Map) -import Development.IDE (Position(..)) +import Development.IDE (Range) import qualified Text.Megaparsec as P -- | A thing with a location attached. @@ -68,12 +68,14 @@ data Sections = } deriving (Show, Eq, Generic) -data Section = Section - { sectionName :: Txt - , sectionTests :: [Loc Test] - , sectionLanguage :: Language - , sectionFormat :: Format - } +data Section + = Section + { sectionName :: Txt + , sectionTests :: [Loc Test] + , sectionLanguage :: Language + , sectionFormat :: Format + , sectionRange :: Range + } deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) hasTests :: Section -> Bool @@ -93,8 +95,8 @@ data Test data Comments = Comments - { lineComments :: Map Position RawLineComment - , blockComments :: Map Position RawBlockComment + { lineComments :: Map Range RawLineComment + , blockComments :: Map Range RawBlockComment } deriving (Show, Eq, Ord, Generic) @@ -130,8 +132,12 @@ isProperty :: Test -> Bool isProperty (Property _ _) = True isProperty _ = False -data Format = SingleLine | MultiLine deriving (Eq, Show, Ord, Generic, FromJSON, ToJSON, NFData) - +data Format + = SingleLine + | -- | @Range@ is that of surrounding entire block comment, not section. + -- Used for detecting no-newline test commands. + MultiLine Range + deriving (Eq, Show, Ord, Generic, FromJSON, ToJSON, NFData) data Language = Plain | Haddock deriving (Eq, Show, Generic, Ord, FromJSON, ToJSON, NFData) data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine diff --git a/plugins/hls-eval-plugin/test/Eval.hs b/plugins/hls-eval-plugin/test/Eval.hs index f9218e70f0..0c813c642c 100644 --- a/plugins/hls-eval-plugin/test/Eval.hs +++ b/plugins/hls-eval-plugin/test/Eval.hs @@ -127,6 +127,9 @@ tests = , testCase "Multi line comments" $ goldenTest "TMulti.hs" + , testCase + "Multi line comments, with the last test line ends without newline" + $ goldenTest "TEndingMulti.hs" , testCase "Evaluate expressions in Plain comments in both single line and multi line format" $ goldenTest "TPlainComment.hs" diff --git a/plugins/hls-eval-plugin/test/testdata/TEndingMulti.hs b/plugins/hls-eval-plugin/test/testdata/TEndingMulti.hs new file mode 100644 index 0000000000..81d79f5464 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TEndingMulti.hs @@ -0,0 +1,6 @@ +module TEndingMulti where + +-- Now trailing doctest is allowed: + +{- >>> 42 +>>> 54-} diff --git a/plugins/hls-eval-plugin/test/testdata/TEndingMulti.hs.expected b/plugins/hls-eval-plugin/test/testdata/TEndingMulti.hs.expected new file mode 100644 index 0000000000..2e73d6d7d1 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TEndingMulti.hs.expected @@ -0,0 +1,9 @@ +module TEndingMulti where + +-- Now trailing doctest is allowed: + +{- >>> 42 +>>> 54 +42 +54 +-} diff --git a/plugins/hls-eval-plugin/test/testdata/THaddock.hs b/plugins/hls-eval-plugin/test/testdata/THaddock.hs index 1a3614f517..57cc5e70f8 100644 --- a/plugins/hls-eval-plugin/test/testdata/THaddock.hs +++ b/plugins/hls-eval-plugin/test/testdata/THaddock.hs @@ -1,8 +1,8 @@ {- | Tests in plain comments in both single line or multi line format, both forward and backward. Tests are ignored if: - * do not start on the first column - * are in multi line comments that open and close on the same line + * do not start on the first column (in Ordinary Haskell) + * do not start on the first or second column (in Literate Haskell) -} module THaddock () where diff --git a/plugins/hls-eval-plugin/test/testdata/THaddock.hs.expected b/plugins/hls-eval-plugin/test/testdata/THaddock.hs.expected index 22edc0fbaf..c7d0a6b5ef 100644 --- a/plugins/hls-eval-plugin/test/testdata/THaddock.hs.expected +++ b/plugins/hls-eval-plugin/test/testdata/THaddock.hs.expected @@ -1,8 +1,8 @@ {- | Tests in plain comments in both single line or multi line format, both forward and backward. Tests are ignored if: - * do not start on the first column - * are in multi line comments that open and close on the same line + * do not start on the first column (in Ordinary Haskell) + * do not start on the first or second column (in Literate Haskell) -} module THaddock () where diff --git a/plugins/hls-eval-plugin/test/testdata/TMulti.hs b/plugins/hls-eval-plugin/test/testdata/TMulti.hs index fb5eb2da80..22943dc240 100644 --- a/plugins/hls-eval-plugin/test/testdata/TMulti.hs +++ b/plugins/hls-eval-plugin/test/testdata/TMulti.hs @@ -15,7 +15,7 @@ module TMulti () where -- this should work fine if previous multi comment is parsed correctly -- >>> "a"++"b" - {-| >>> IGNORED -} + {-| >>> "NOT IGNORED" -} -- this should work fine if previous multi comment is parsed correctly -- >>> "a"++"b" diff --git a/plugins/hls-eval-plugin/test/testdata/TMulti.hs.expected b/plugins/hls-eval-plugin/test/testdata/TMulti.hs.expected index 13a8105eae..c029b9c0df 100644 --- a/plugins/hls-eval-plugin/test/testdata/TMulti.hs.expected +++ b/plugins/hls-eval-plugin/test/testdata/TMulti.hs.expected @@ -18,7 +18,9 @@ module TMulti () where -- >>> "a"++"b" -- "ab" - {-| >>> IGNORED -} + {-| >>> "NOT IGNORED" +"NOT IGNORED" +-} -- this should work fine if previous multi comment is parsed correctly -- >>> "a"++"b" diff --git a/plugins/hls-eval-plugin/test/testdata/test.cabal b/plugins/hls-eval-plugin/test/testdata/test.cabal index 49cb62e062..a1a92ee1cf 100644 --- a/plugins/hls-eval-plugin/test/testdata/test.cabal +++ b/plugins/hls-eval-plugin/test/testdata/test.cabal @@ -39,6 +39,7 @@ library T25 T26 T27 + TEndingMulti TMulti TPlainComment THaddock From f7bdb5466d94490799e17bcf813451bdcd30ce03 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sun, 24 Jan 2021 21:18:13 +0900 Subject: [PATCH 19/41] Precise handling of line ending --- .../src/Ide/Plugin/Eval/Code.hs | 27 +++-- .../src/Ide/Plugin/Eval/CodeLens.hs | 28 ++--- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 111 ++++++++++-------- .../src/Ide/Plugin/Eval/Types.hs | 86 +++++++------- 4 files changed, 130 insertions(+), 122 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs index 91208b71c1..35cc58fc5b 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs @@ -15,20 +15,21 @@ import GhcMonad (Ghc, GhcMonad, liftIO) import Ide.Plugin.Eval.Types ( Language (Plain), Loc, - Located (Located), Section (sectionLanguage), - Test (Example, Property, testOutput), + Test (..), Txt, locate, - locate0, + locate0, Located(..) ) import InteractiveEval (runDecls) import Unsafe.Coerce (unsafeCoerce) +import Control.Lens ((^.)) +import Language.Haskell.LSP.Types.Lens (start, line) -- | Return the ranges of the expression and result parts of the given test -testRanges :: Loc Test -> (Range, Range) -testRanges (Located line tst) = - let startLine = line +testRanges :: Test -> (Range, Range) +testRanges tst = + let startLine = testRange tst ^. start.line (exprLines, resultLines) = testLenghts tst resLine = startLine + exprLines in ( Range @@ -44,7 +45,7 @@ testRanges (Located line tst) = -} -- |The document range where the result of the test is defined -resultRange :: Loc Test -> Range +resultRange :: Test -> Range resultRange = snd . testRanges -- TODO: handle BLANKLINE @@ -66,18 +67,18 @@ testCheck (section, test) out | otherwise = showDiffs $ getDiff (map T.pack $ testOutput test) out testLenghts :: Test -> (Int, Int) -testLenghts (Example e r) = (NE.length e, length r) -testLenghts (Property _ r) = (1, length r) +testLenghts (Example e r _) = (NE.length e, length r) +testLenghts (Property _ r _) = (1, length r) -- |A one-line Haskell statement type Statement = Loc String -asStatements :: Loc Test -> [Statement] -asStatements lt = locate (asStmts <$> lt) +asStatements :: Test -> [Statement] +asStatements lt = locate $ Located (testRange lt ^. start.line) (asStmts lt) asStmts :: Test -> [Txt] -asStmts (Example e _) = NE.toList e -asStmts (Property t _) = +asStmts (Example e _ _) = NE.toList e +asStmts (Property t _ _) = ["prop11 = " ++ t, "(propEvaluation prop11 :: IO String)"] -- |Evaluate an expression (either a pure expression or an IO a) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 4f44c41dd1..6c080093f1 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -468,13 +468,13 @@ moduleText lsp uri = lsp (toNormalizedUri uri) -testsBySection :: [Section] -> [(Section, Loc Test)] +testsBySection :: [Section] -> [(Section, Test)] testsBySection sections = [(section, test) | section <- sections, test <- sectionTests section] type TEnv = (IdeState, String) -runTests :: TEnv -> [(Section, Loc Test)] -> Ghc [TextEdit] +runTests :: TEnv -> [(Section, Test)] -> Ghc [TextEdit] runTests e@(_st, _) tests = do df <- getInteractiveDynFlags evalSetup @@ -482,7 +482,7 @@ runTests e@(_st, _) tests = do mapM (processTest e df) tests where - processTest :: TEnv -> DynFlags -> (Section, Loc Test) -> Ghc TextEdit + processTest :: TEnv -> DynFlags -> (Section, Test) -> Ghc TextEdit processTest e@(st, fp) df (section, test) = do let dbg = logWith st let pad = pad_ $ (if isLiterate fp then ("> " `T.append`) else id) $ padPrefix (sectionFormat section) @@ -490,32 +490,32 @@ runTests e@(_st, _) tests = do rs <- runTest e df test dbg "TEST RESULTS" rs - let checkedResult = testCheck (section, unLoc test) rs + let checkedResult = testCheck (section, test) rs - let edit = asEdit (sectionFormat section) (sectionRange section) - test (map pad checkedResult) + let edit = asEdit (sectionFormat section) test (map pad checkedResult) dbg "TEST EDIT" edit return edit -- runTest :: String -> DynFlags -> Loc Test -> Ghc [Text] runTest _ df test - | not (hasQuickCheck df) && (isProperty . unLoc $ test) = + | not (hasQuickCheck df) && isProperty test = return $ singleLine "Add QuickCheck to your cabal dependencies to run this test." runTest e df test = evals e df (asStatements test) -asEdit :: Format -> Range -> Loc Test -> [Text] -> TextEdit -asEdit (MultiLine commRange) testRange test resultLines +asEdit :: Format -> Test -> [Text] -> TextEdit +asEdit (MultiLine commRange) test resultLines -- A test in a block comment, ending with @-\}@ without newline in-between. - | testRange ^. end.line == commRange ^. end . line = + | testRange test ^. end.line == commRange ^. end . line + = TextEdit (Range - (view end testRange & character -~ 2) + (view end (testRange test) & character -~ 2) (resultRange test ^. end) ) ("\n" <> T.unlines (resultLines <> ["-}"])) -asEdit _ _ test resultLines = +asEdit _ test resultLines = TextEdit (resultRange test) (T.unlines resultLines) {- @@ -649,8 +649,8 @@ runGetSession st nfp = -- GhcSessionDeps nfp -needsQuickCheck :: [(Section, Loc Test)] -> Bool -needsQuickCheck = any (isProperty . unLoc . snd) +needsQuickCheck :: [(Section, Test)] -> Bool +needsQuickCheck = any (isProperty . snd) hasQuickCheck :: DynFlags -> Bool hasQuickCheck df = hasPackage df "QuickCheck" diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index 40c28b6171..5e09216226 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -13,7 +13,7 @@ import Control.Arrow (first, (&&&), (>>>)) import Control.Lens (lensField, lensRules, view, (.~), (^.)) import Control.Lens.Extras (is) import Control.Lens.TH (makeLensesWith, makePrisms, mappingNamer) -import Control.Monad (guard, join, void, when) +import Control.Monad (guard, void, when) import Control.Monad.Combinators () import Control.Monad.Reader (ask) import Control.Monad.Trans.Reader (Reader, runReader) @@ -45,6 +45,7 @@ import Text.Megaparsec.Char hspace, letterChar, ) +import Data.Functor.Identity {- | We build parsers combining the following three kinds of them: @@ -92,12 +93,12 @@ newtype ExampleLine = ExampleLine {getExampleLine :: String} data TestComment = AProp - { commentSectionStart :: Position + { testCommentRange :: Range , lineProp :: PropLine , propResults :: [String] } | AnExample - { commentSectionStart :: Position + { testCommentRange :: Range , lineExamples :: NonEmpty ExampleLine , exampleResults :: [String] } @@ -154,8 +155,8 @@ commentsToSections isLHS Comments {..} = (blockSeed, blockSetupSeeds) = foldMap ( \(ran, lcs) -> - case parseBlockMaybe isLHS ran blockCommentBP - $ getRawBlockComment lcs of + case parseBlockMaybe isLHS ran blockCommentBP $ + getRawBlockComment lcs of Nothing -> mempty Just (Named "setup", grp) -> -- orders setup sections in ascending order @@ -174,10 +175,10 @@ commentsToSections isLHS Comments {..} = -- block comment body. $ Map.toList blockComments lineSections = - map (\(pos, (flav, cmd)) -> testsToSection Line flav pos cmd) $ + map (\(_, (flav, cmd)) -> testsToSection Line flav cmd) $ DL.toList lineSectionSeeds multilineSections = - map (\(ran, (flav, cmd)) -> testsToSection (Block ran) flav ran cmd) $ + map (\(ran, (flav, cmd)) -> testsToSection (Block ran) flav cmd) $ DL.toList blockSeed setupSections = -- Setups doesn't need Dummy position @@ -186,7 +187,6 @@ commentsToSections isLHS Comments {..} = testsToSection style (Named "setup") - (join Range (Position 0 0)) -- Just dummy for setup sections tests ) $ DL.toList $ @@ -217,10 +217,9 @@ type SectionRange = Range testsToSection :: CommentStyle -> CommentFlavour -> - SectionRange -> [TestComment] -> Section -testsToSection style flav sectionRange tests = +testsToSection style flav tests = let sectionName | Named name <- flav = name | otherwise = "" @@ -235,21 +234,19 @@ testsToSection style flav sectionRange tests = Block ran -> MultiLine ran in Section {..} -fromTestComment :: TestComment -> Loc Test +fromTestComment :: TestComment -> Test fromTestComment AProp {..} = - Located - (commentSectionStart ^. line) - Property - { testline = getPropLine lineProp - , testOutput = propResults - } + Property + { testline = getPropLine lineProp + , testOutput = propResults + , testRange = testCommentRange + } fromTestComment AnExample {..} = - Located - (commentSectionStart ^. line) - Example - { testLines = getExampleLine <$> lineExamples - , testOutput = exampleResults - } + Example + { testLines = getExampleLine <$> lineExamples + , testOutput = exampleResults + , testRange = testCommentRange + } -- * Block comment parser @@ -259,7 +256,7 @@ fromTestComment AnExample {..} = -} -- >>> parseE (blockCommentBP True dummyPos) "{- |\n >>> 5+5\n 11\n -}" --- (HaddockNext,[AnExample {commentSectionStart = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " 5+5"} :| [], exampleResults = [" 11"]}]) +-- (HaddockNext,[AnExample {testCommentRange = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " 5+5"} :| [], exampleResults = [" 11"]}]) blockCommentBP :: -- | True if Literate Haskell @@ -303,24 +300,28 @@ blockExamples BlockCommentParser TestComment blockExamples = do BlockEnv {..} <- ask - (ran, examples) <- withPosition $ NE.some $ exampleLineStrP isLhs $ Block blockRange + (ran, examples) <- withRange $ NE.some $ exampleLineStrP isLhs $ Block blockRange AnExample ran examples <$> resultBlockP blockProp = do BlockEnv {..} <- ask - (ran, prop) <- withPosition $ propLineStrP isLhs $ Block blockRange + (ran, Identity prop) <- withRange $ fmap Identity $ propLineStrP isLhs $ Block blockRange AProp ran prop <$> resultBlockP -withPosition :: - (TraversableStream s, Stream s, Monad m, Ord v) => - ParsecT v s m a -> - ParsecT v s m (Position, a) -withPosition p = do +withRange :: + (TraversableStream s, Stream s, Monad m, Ord v, Traversable t) => + ParsecT v s m (t (a, Position)) -> + ParsecT v s m (Range, t a) +withRange p = do beg <- sourcePosToPosition <$> getSourcePos - a <- p - pure (beg, a) + as <- p + let fin | null as = beg + | otherwise = snd $ last $ F.toList as + pure (Range beg fin, fst <$> as) resultBlockP :: BlockCommentParser [String] -resultBlockP = many $ nonEmptyNormalLineP . Block =<< view blockRangeL +resultBlockP = many $ + fmap fst . nonEmptyNormalLineP + . Block =<< view blockRangeL positionToSourcePos :: Position -> SourcePos positionToSourcePos pos = @@ -387,7 +388,7 @@ lineCommentSectionsP = do skipMany normalLineCommentP many $ exampleLinesGP - <|> uncurry (AProp . view start) <$> propLineGP <*> resultLinesP + <|> uncurry AProp <$> propLineGP <*> resultLinesP <* skipMany normalLineCommentP lexemeLine :: LineGroupParser a -> LineGroupParser a @@ -398,27 +399,32 @@ resultLinesP = many nonEmptyLGP normalLineCommentP :: LineGroupParser (Range, String) normalLineCommentP = - parseLine (commentFlavourP *> normalLineP False Line) + parseLine (fst <$ commentFlavourP <*> normalLineP False Line) nonEmptyLGP :: LineGroupParser String -nonEmptyLGP = try $ fmap snd $ parseLine $ commentFlavourP *> nonEmptyNormalLineP Line +nonEmptyLGP = try $ fmap snd $ parseLine $ + fst <$ commentFlavourP <*> nonEmptyNormalLineP Line exampleLinesGP :: LineGroupParser TestComment exampleLinesGP = lexemeLine $ - uncurry AnExample . first (view start . NE.head) . NE.unzip + uncurry AnExample . first convexHullRange . NE.unzip <$> NE.some exampleLineGP <*> resultLinesP +convexHullRange :: NonEmpty Range -> Range +convexHullRange nes = + Range (NE.head nes ^. start) (NE.last nes ^. end) + exampleLineGP :: LineGroupParser (Range, ExampleLine) exampleLineGP = -- In line-comments, indentation-level inside comment doesn't matter. - parseLine (commentFlavourP *> exampleLineStrP False Line) + parseLine (fst <$ commentFlavourP <*> exampleLineStrP False Line) propLineGP :: LineGroupParser (Range, PropLine) propLineGP = -- In line-comments, indentation-level inside comment doesn't matter. - parseLine (commentFlavourP *> propLineStrP False Line) + parseLine (fst <$ commentFlavourP <*> propLineStrP False Line) {- | Turning a line parser into line group parser consuming a single line comment. @@ -450,11 +456,11 @@ parseLine p = -- * Line Parsers -- | Non-empty normal line. -nonEmptyNormalLineP :: CommentStyle -> LineParser String +nonEmptyNormalLineP :: CommentStyle -> LineParser (String, Position) nonEmptyNormalLineP style = try $ do - ln <- normalLineP False style + (ln, pos) <- normalLineP False style guard $ not $ all C.isSpace ln - pure ln + pure (ln, pos) {- | Normal line is a line neither a example nor prop. Empty line is normal. @@ -463,24 +469,27 @@ normalLineP :: -- | True if Literate Haskell Bool -> CommentStyle -> - LineParser String + LineParser (String, Position) normalLineP isLHS style = do notFollowedBy (try $ testSymbol isLHS style) consume style -consume :: CommentStyle -> LineParser String +consume :: CommentStyle -> LineParser (String, Position) consume style = case style of - Line -> takeRest - Block {} -> manyTill anySingle eob + Line -> (,) <$> takeRest <*> getPosition + Block {} -> manyTill_ anySingle (getPosition <* eob) + +getPosition :: (Ord v, TraversableStream s) => ParsecT v s m Position +getPosition = sourcePosToPosition <$> getSourcePos -- | Parses example test line. exampleLineStrP :: -- | True if Literate Haskell Bool -> CommentStyle -> - LineParser ExampleLine + LineParser (ExampleLine, Position) exampleLineStrP isLHS style = try $ -- FIXME: To comply with existing Extended Eval Plugin Behaviour; @@ -489,7 +498,7 @@ exampleLineStrP isLHS style = -- modules with non-standard base indentation-level. when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') *> exampleSymbol - *> (ExampleLine <$> consume style) + *> (first ExampleLine <$> consume style) exampleSymbol :: LineParser () exampleSymbol = @@ -503,7 +512,7 @@ propLineStrP :: -- | True if Literate HAskell Bool -> CommentStyle -> - LineParser PropLine + LineParser (PropLine, Position) propLineStrP isLHS style = -- FIXME: To comply with existing Extended Eval Plugin Behaviour; -- it must skip one space after a comment! @@ -512,7 +521,7 @@ propLineStrP isLHS style = when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') *> chunk "prop>" *> P.notFollowedBy (char '>') - *> (PropLine <$> consume style) + *> (first PropLine <$> consume style) -- * Utilities diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index 27b1dcd4e2..324b028dbb 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -1,40 +1,41 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wwarn #-} -module Ide.Plugin.Eval.Types ( - locate, - locate0, - Test (..), - isProperty, - Format (..), - Language (..), - Section (..), - Sections(..), - hasTests, - hasPropertyTest, - splitSections, - Loc, - Located (..), - Comments(..), - RawBlockComment(..), - RawLineComment(..), - unLoc, - Txt, -) where +module Ide.Plugin.Eval.Types + ( locate, + locate0, + Test (..), + isProperty, + Format (..), + Language (..), + Section (..), + Sections (..), + hasTests, + hasPropertyTest, + splitSections, + Loc, + Located (..), + Comments (..), + RawBlockComment (..), + RawLineComment (..), + unLoc, + Txt, + ) +where import Control.DeepSeq (NFData (rnf), deepseq) import Data.Aeson (FromJSON, ToJSON) import Data.List (partition) import Data.List.NonEmpty (NonEmpty) -import Data.String (IsString (..)) -import GHC.Generics (Generic) import Data.Map.Strict (Map) +import Data.String (IsString (..)) import Development.IDE (Range) +import GHC.Generics (Generic) import qualified Text.Megaparsec as P -- | A thing with a location attached. @@ -60,44 +61,40 @@ locate0 = locate . Located 0 type Txt = String -data Sections = - Sections +data Sections = Sections { setupSections :: [Section] , lineSections :: [Section] , multilineSections :: [Section] } deriving (Show, Eq, Generic) -data Section - = Section - { sectionName :: Txt - , sectionTests :: [Loc Test] - , sectionLanguage :: Language - , sectionFormat :: Format - , sectionRange :: Range - } +data Section = Section + { sectionName :: Txt + , sectionTests :: [Test] + , sectionLanguage :: Language + , sectionFormat :: Format + } deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) hasTests :: Section -> Bool hasTests = not . null . sectionTests hasPropertyTest :: Section -> Bool -hasPropertyTest = any (isProperty . unLoc) . sectionTests +hasPropertyTest = any isProperty . sectionTests -- |Split setup and normal sections splitSections :: [Section] -> ([Section], [Section]) splitSections = partition ((== "setup") . sectionName) data Test - = Example {testLines :: NonEmpty Txt, testOutput :: [Txt]} - | Property {testline :: Txt, testOutput :: [Txt]} + = Example {testLines :: NonEmpty Txt, testOutput :: [Txt], testRange :: Range} + | Property {testline :: Txt, testOutput :: [Txt], testRange :: Range} deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) -data Comments = - Comments - { lineComments :: Map Range RawLineComment - , blockComments :: Map Range RawBlockComment - } +data Comments = Comments + { lineComments :: Map Range RawLineComment + , blockComments :: Map Range RawBlockComment + } deriving (Show, Eq, Ord, Generic) newtype RawBlockComment = RawBlockComment {getRawBlockComment :: String} @@ -129,7 +126,7 @@ instance Monoid Comments where mempty = Comments mempty mempty isProperty :: Test -> Bool -isProperty (Property _ _) = True +isProperty Property {} = True isProperty _ = False data Format @@ -138,6 +135,7 @@ data Format -- Used for detecting no-newline test commands. MultiLine Range deriving (Eq, Show, Ord, Generic, FromJSON, ToJSON, NFData) + data Language = Plain | Haddock deriving (Eq, Show, Generic, Ord, FromJSON, ToJSON, NFData) data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine From 044fec593d187ca513e9b512141e006d10ff5802 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sun, 24 Jan 2021 22:25:47 +0900 Subject: [PATCH 20/41] Corrects last-line block eval handling --- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 6c080093f1..d4844cf04a 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -511,7 +511,7 @@ asEdit (MultiLine commRange) test resultLines = TextEdit (Range - (view end (testRange test) & character -~ 2) + (testRange test ^. end) (resultRange test ^. end) ) ("\n" <> T.unlines (resultLines <> ["-}"])) From 6525bbcf5b0af6bd3a0c3bcfb78af497d50d6d02 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sun, 24 Jan 2021 22:32:53 +0900 Subject: [PATCH 21/41] Makes normal line parsing LHS sensitive --- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 32 +++++++++++++------ 1 file changed, 22 insertions(+), 10 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index 5e09216226..30707d6dc5 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -21,6 +21,7 @@ import qualified Data.Char as C import qualified Data.DList as DL import qualified Data.Foldable as F import Data.Function ((&)) +import Data.Functor.Identity import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) @@ -45,7 +46,6 @@ import Text.Megaparsec.Char hspace, letterChar, ) -import Data.Functor.Identity {- | We build parsers combining the following three kinds of them: @@ -314,14 +314,17 @@ withRange :: withRange p = do beg <- sourcePosToPosition <$> getSourcePos as <- p - let fin | null as = beg + let fin + | null as = beg | otherwise = snd $ last $ F.toList as pure (Range beg fin, fst <$> as) resultBlockP :: BlockCommentParser [String] -resultBlockP = many $ - fmap fst . nonEmptyNormalLineP - . Block =<< view blockRangeL +resultBlockP = do + BlockEnv {..} <- ask + many $ + fmap fst . nonEmptyNormalLineP isLhs $ + Block blockRange positionToSourcePos :: Position -> SourcePos positionToSourcePos pos = @@ -402,8 +405,11 @@ normalLineCommentP = parseLine (fst <$ commentFlavourP <*> normalLineP False Line) nonEmptyLGP :: LineGroupParser String -nonEmptyLGP = try $ fmap snd $ parseLine $ - fst <$ commentFlavourP <*> nonEmptyNormalLineP Line +nonEmptyLGP = + try $ + fmap snd $ + parseLine $ + fst <$ commentFlavourP <*> nonEmptyNormalLineP False Line exampleLinesGP :: LineGroupParser TestComment exampleLinesGP = @@ -456,9 +462,13 @@ parseLine p = -- * Line Parsers -- | Non-empty normal line. -nonEmptyNormalLineP :: CommentStyle -> LineParser (String, Position) -nonEmptyNormalLineP style = try $ do - (ln, pos) <- normalLineP False style +nonEmptyNormalLineP :: + -- | True if Literate Haskell + Bool -> + CommentStyle -> + LineParser (String, Position) +nonEmptyNormalLineP isLHS style = try $ do + (ln, pos) <- normalLineP isLHS style guard $ not $ all C.isSpace ln pure (ln, pos) @@ -473,6 +483,8 @@ normalLineP :: normalLineP isLHS style = do notFollowedBy (try $ testSymbol isLHS style) + when (isLHS && is _Block style) $ + void $ count' 0 2 $ char ' ' consume style consume :: CommentStyle -> LineParser (String, Position) From f0bbd708512e5c98b2c35c549e4f0fd811542651 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Mon, 25 Jan 2021 00:10:46 +0900 Subject: [PATCH 22/41] Removes outdated note on block comments in a single line --- plugins/hls-eval-plugin/test/testdata/TMulti.hs | 2 -- plugins/hls-eval-plugin/test/testdata/TMulti.hs.expected | 2 -- 2 files changed, 4 deletions(-) diff --git a/plugins/hls-eval-plugin/test/testdata/TMulti.hs b/plugins/hls-eval-plugin/test/testdata/TMulti.hs index 22943dc240..35ea1f9bd8 100644 --- a/plugins/hls-eval-plugin/test/testdata/TMulti.hs +++ b/plugins/hls-eval-plugin/test/testdata/TMulti.hs @@ -1,6 +1,4 @@ {- | Multi line comments are parsed correctly. - - Note that if they open and close on a single line, their content is ignored. -} module TMulti () where diff --git a/plugins/hls-eval-plugin/test/testdata/TMulti.hs.expected b/plugins/hls-eval-plugin/test/testdata/TMulti.hs.expected index c029b9c0df..458239a81a 100644 --- a/plugins/hls-eval-plugin/test/testdata/TMulti.hs.expected +++ b/plugins/hls-eval-plugin/test/testdata/TMulti.hs.expected @@ -1,6 +1,4 @@ {- | Multi line comments are parsed correctly. - - Note that if they open and close on a single line, their content is ignored. -} module TMulti () where From b167c3dcb3c2eac80459ea235d4ac91d057fe43d Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Mon, 25 Jan 2021 00:16:04 +0900 Subject: [PATCH 23/41] Wait a moment before executing each code lenses --- plugins/hls-eval-plugin/test/Eval.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/plugins/hls-eval-plugin/test/Eval.hs b/plugins/hls-eval-plugin/test/Eval.hs index 0c813c642c..eb34af44d4 100644 --- a/plugins/hls-eval-plugin/test/Eval.hs +++ b/plugins/hls-eval-plugin/test/Eval.hs @@ -50,6 +50,7 @@ import Test.Tasty.HUnit ( testCase, (@?=), ) +import System.Time.Extra (sleep) tests :: TestTree tests = @@ -178,8 +179,10 @@ goldenTestBy fltr input = runSession hlsCommand fullCaps evalPath $ do codeLenses <- reverse <$> getCodeLensesBy fltr doc -- liftIO $ print codeLenses - -- Execute sequentially - mapM_ executeCmd $ [c | CodeLens{_command = Just c} <- codeLenses] + -- Execute sequentially, waiting for a moment to + -- avoid mis-insertion due to staled location info. + mapM_ (\cmd -> liftIO (sleep 0.5) *> executeCmd cmd) + [c | CodeLens{_command = Just c} <- codeLenses] edited <- replaceUnicodeQuotes <$> documentContents doc -- liftIO $ T.putStrLn edited From dc30f8ffc21ecc47176d3c9d127d744244b3e3aa Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Mon, 25 Jan 2021 10:02:46 +0900 Subject: [PATCH 24/41] Sorting tests in order --- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index d4844cf04a..121dc83e65 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -269,7 +269,7 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = -- Extract tests from source code let Sections{..} = commentsToSections isLHS comments - tests = testsBySection nonSetups + tests = sortOn (testRange . snd) $ testsBySection nonSetups nonSetups = lineSections ++ multilineSections cmd <- liftIO $ mkLspCommand plId evalCommandName "Evaluate=..." (Just []) let lenses = From 1d2a1ad45c81518c6de17603cc6a72274719cabb Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Mon, 25 Jan 2021 10:03:47 +0900 Subject: [PATCH 25/41] Sorts lenses in order --- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs | 2 +- plugins/hls-eval-plugin/test/Eval.hs | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 121dc83e65..7485a0094c 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -44,7 +44,7 @@ import Data.Either (isRight) import qualified Data.HashMap.Strict as HashMap import Data.List (dropWhileEnd, - find, + find, sortOn ) import qualified Data.Map.Strict as Map import Data.Maybe diff --git a/plugins/hls-eval-plugin/test/Eval.hs b/plugins/hls-eval-plugin/test/Eval.hs index eb34af44d4..581cf2b90f 100644 --- a/plugins/hls-eval-plugin/test/Eval.hs +++ b/plugins/hls-eval-plugin/test/Eval.hs @@ -50,7 +50,6 @@ import Test.Tasty.HUnit ( testCase, (@?=), ) -import System.Time.Extra (sleep) tests :: TestTree tests = @@ -181,7 +180,7 @@ goldenTestBy fltr input = runSession hlsCommand fullCaps evalPath $ do -- Execute sequentially, waiting for a moment to -- avoid mis-insertion due to staled location info. - mapM_ (\cmd -> liftIO (sleep 0.5) *> executeCmd cmd) + mapM_ executeCommand [c | CodeLens{_command = Just c} <- codeLenses] edited <- replaceUnicodeQuotes <$> documentContents doc From 4fcea608b4bf8ca5357da3a1d093536e9673b650 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Mon, 25 Jan 2021 10:40:30 +0900 Subject: [PATCH 26/41] Reverted to use executCmd --- plugins/hls-eval-plugin/test/Eval.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-eval-plugin/test/Eval.hs b/plugins/hls-eval-plugin/test/Eval.hs index 581cf2b90f..e8f4ca4079 100644 --- a/plugins/hls-eval-plugin/test/Eval.hs +++ b/plugins/hls-eval-plugin/test/Eval.hs @@ -180,7 +180,7 @@ goldenTestBy fltr input = runSession hlsCommand fullCaps evalPath $ do -- Execute sequentially, waiting for a moment to -- avoid mis-insertion due to staled location info. - mapM_ executeCommand + mapM_ executeCmd [c | CodeLens{_command = Just c} <- codeLenses] edited <- replaceUnicodeQuotes <$> documentContents doc From 64bc51c80448a94743be5737db6c8ded96b45ec6 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Mon, 25 Jan 2021 11:16:39 +0900 Subject: [PATCH 27/41] Changes sorting logic --- .../src/Ide/Plugin/Eval/CodeLens.hs | 12 +++++------- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 14 ++++++++------ .../hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs | 5 ++--- plugins/hls-eval-plugin/test/Eval.hs | 2 +- 4 files changed, 16 insertions(+), 17 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 7485a0094c..af73bea8a3 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -44,7 +44,7 @@ import Data.Either (isRight) import qualified Data.HashMap.Strict as HashMap import Data.List (dropWhileEnd, - find, sortOn + find ) import qualified Data.Map.Strict as Map import Data.Maybe @@ -216,9 +216,8 @@ import Text.Read (readMaybe) import Util (OverridingBool (Never)) import Development.IDE.Core.PositionMapping (toCurrentRange) import qualified Data.DList as DL -import Control.Lens ((^.), (-~), view) -import Language.Haskell.LSP.Types.Lens (line, end, character) -import Data.Function ((&)) +import Control.Lens ((^.)) +import Language.Haskell.LSP.Types.Lens (line, end) {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. @@ -269,8 +268,7 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = -- Extract tests from source code let Sections{..} = commentsToSections isLHS comments - tests = sortOn (testRange . snd) $ testsBySection nonSetups - nonSetups = lineSections ++ multilineSections + tests = testsBySection nonSetupSections cmd <- liftIO $ mkLspCommand plId evalCommandName "Evaluate=..." (Just []) let lenses = [ CodeLens testRange (Just cmd') Nothing @@ -292,7 +290,7 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = unwords [ show (length tests) , "tests in" - , show (length nonSetups) + , show (length nonSetupSections) , "sections" , show (length setupSections) , "setups" diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index 30707d6dc5..9c39bdbbfe 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -46,6 +46,7 @@ import Text.Megaparsec.Char hspace, letterChar, ) +import Data.Functor ((<&>)) {- | We build parsers combining the following three kinds of them: @@ -130,7 +131,7 @@ commentsToSections isLHS Comments {..} = in case parseMaybe lineGroupP $ NE.toList lcs of Nothing -> mempty Just (mls, rs) -> - ( maybe DL.empty DL.singleton ((theRan,) <$> mls) + ( maybe mempty (uncurry Map.singleton) ((theRan,) <$> mls) , -- orders setup sections in ascending order if null rs then mempty @@ -165,7 +166,7 @@ commentsToSections isLHS Comments {..} = DL.singleton (Block ran, grp) ) Just grp -> - ( DL.singleton (ran, grp) + ( Map.singleton ran grp , mempty ) ) @@ -175,11 +176,11 @@ commentsToSections isLHS Comments {..} = -- block comment body. $ Map.toList blockComments lineSections = - map (\(_, (flav, cmd)) -> testsToSection Line flav cmd) $ - DL.toList lineSectionSeeds + lineSectionSeeds <&> uncurry (testsToSection Line) multilineSections = - map (\(ran, (flav, cmd)) -> testsToSection (Block ran) flav cmd) $ - DL.toList blockSeed + Map.mapWithKey + (uncurry . testsToSection . Block) + blockSeed setupSections = -- Setups doesn't need Dummy position map @@ -192,6 +193,7 @@ commentsToSections isLHS Comments {..} = $ DL.toList $ F.fold $ Map.unionWith (<>) lineSetupSeeds blockSetupSeeds + nonSetupSections = F.toList $ lineSections `Map.union` multilineSections in Sections {..} parseBlockMaybe :: Bool -> Range -> BlockCommentParser a -> String -> Maybe a diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index 324b028dbb..b02fd8ec18 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -62,9 +62,8 @@ locate0 = locate . Located 0 type Txt = String data Sections = Sections - { setupSections :: [Section] - , lineSections :: [Section] - , multilineSections :: [Section] + { nonSetupSections :: [Section] + , setupSections :: [Section] } deriving (Show, Eq, Generic) diff --git a/plugins/hls-eval-plugin/test/Eval.hs b/plugins/hls-eval-plugin/test/Eval.hs index e8f4ca4079..8997731109 100644 --- a/plugins/hls-eval-plugin/test/Eval.hs +++ b/plugins/hls-eval-plugin/test/Eval.hs @@ -155,7 +155,7 @@ tests = liftIO $ do let mdl = "TLastLine.hs" -- Write the test file, to make sure that it has no final line return - writeFile (evalPath mdl) $ "module TLastLine where\n\n-- >>> take 3 [1..]" + writeFile (evalPath mdl) "module TLastLine where\n\n-- >>> take 3 [1..]" goldenTest mdl #if __GLASGOW_HASKELL__ >= 808 , testCase "CPP support" $ goldenTest "TCPP.hs" From 3adb01f79dd59b165a371aafdfc66cb6dc9a3a4e Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Mon, 25 Jan 2021 12:19:44 +0900 Subject: [PATCH 28/41] Fixes test case: trailing space --- plugins/hls-eval-plugin/test/testdata/TMulti.hs.expected | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-eval-plugin/test/testdata/TMulti.hs.expected b/plugins/hls-eval-plugin/test/testdata/TMulti.hs.expected index 458239a81a..7c35e06d12 100644 --- a/plugins/hls-eval-plugin/test/testdata/TMulti.hs.expected +++ b/plugins/hls-eval-plugin/test/testdata/TMulti.hs.expected @@ -16,7 +16,7 @@ module TMulti () where -- >>> "a"++"b" -- "ab" - {-| >>> "NOT IGNORED" + {-| >>> "NOT IGNORED" "NOT IGNORED" -} From 4d33ce24d1e22dad700d1c943fd128de2ffd2db8 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Mon, 25 Jan 2021 12:27:55 +0900 Subject: [PATCH 29/41] Dummy commit to re-invoke CI From c63b370e4dde4a43e1fe32b9967ff21a14f021b1 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Mon, 25 Jan 2021 13:53:04 +0900 Subject: [PATCH 30/41] expect fail CPP Eval on Windows --- plugins/hls-eval-plugin/test/Eval.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/plugins/hls-eval-plugin/test/Eval.hs b/plugins/hls-eval-plugin/test/Eval.hs index 8997731109..843e78894d 100644 --- a/plugins/hls-eval-plugin/test/Eval.hs +++ b/plugins/hls-eval-plugin/test/Eval.hs @@ -158,7 +158,11 @@ tests = writeFile (evalPath mdl) "module TLastLine where\n\n-- >>> take 3 [1..]" goldenTest mdl #if __GLASGOW_HASKELL__ >= 808 - , testCase "CPP support" $ goldenTest "TCPP.hs" + , +#if mingw32_HOST_OS + expectFailBeause "CPP eval on Windows fails for some reasons" $ +#endif + testCase "CPP support" $ goldenTest "TCPP.hs" , testCase "Literate Haskell Bird Style" $ goldenTest "TLHS.lhs" #endif -- , testCase "Literate Haskell LaTeX Style" $ goldenTest "TLHSLateX.lhs" From 83cb1ef496eb6367232793380e6501607f918c4c Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Mon, 25 Jan 2021 14:05:07 +0900 Subject: [PATCH 31/41] Corrects typo --- plugins/hls-eval-plugin/test/Eval.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-eval-plugin/test/Eval.hs b/plugins/hls-eval-plugin/test/Eval.hs index 843e78894d..2cbdb3e2dc 100644 --- a/plugins/hls-eval-plugin/test/Eval.hs +++ b/plugins/hls-eval-plugin/test/Eval.hs @@ -160,7 +160,7 @@ tests = #if __GLASGOW_HASKELL__ >= 808 , #if mingw32_HOST_OS - expectFailBeause "CPP eval on Windows fails for some reasons" $ + expectFailBecause "CPP eval on Windows fails for some reasons" $ #endif testCase "CPP support" $ goldenTest "TCPP.hs" , testCase "Literate Haskell Bird Style" $ goldenTest "TLHS.lhs" From 5f4a5a64406fe0dda58c0776b6a7261ec335854c Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Tue, 26 Jan 2021 23:43:55 +0900 Subject: [PATCH 32/41] Test for #1258 --- plugins/hls-eval-plugin/test/Eval.hs | 3 +++ plugins/hls-eval-plugin/test/testdata/TUNPACK.hs | 14 ++++++++++++++ .../test/testdata/TUNPACK.hs.expected | 15 +++++++++++++++ 3 files changed, 32 insertions(+) create mode 100644 plugins/hls-eval-plugin/test/testdata/TUNPACK.hs create mode 100644 plugins/hls-eval-plugin/test/testdata/TUNPACK.hs.expected diff --git a/plugins/hls-eval-plugin/test/Eval.hs b/plugins/hls-eval-plugin/test/Eval.hs index 2cbdb3e2dc..3b77ac4a81 100644 --- a/plugins/hls-eval-plugin/test/Eval.hs +++ b/plugins/hls-eval-plugin/test/Eval.hs @@ -150,6 +150,9 @@ tests = , testCase "Prelude has no special treatment, it is imported as stated in the module" $ goldenTest "TPrelude.hs" + , testCase + "Don't panic on {-# UNPACK #-} pragma" + $ goldenTest "TUNPACK.hs" , testCase "Test on last line insert results correctly" $ do runSession hlsCommand fullCaps evalPath $ liftIO $ do diff --git a/plugins/hls-eval-plugin/test/testdata/TUNPACK.hs b/plugins/hls-eval-plugin/test/testdata/TUNPACK.hs new file mode 100644 index 0000000000..a282378728 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TUNPACK.hs @@ -0,0 +1,14 @@ +{- | Multi line comments are parsed correctly. +-} +module TUNPACK (THStatus(..)) where + +type ByteString = String +type BSEndo = ByteString -> ByteString +type BSEndoList = [ByteString] -> [ByteString] + +data THStatus = THStatus + {-# UNPACK #-} !Int -- running total byte count + BSEndoList -- previously parsed lines + BSEndo -- bytestrings to be prepended + +-- >>> "Yay! UNPACK pragma didn't do bad things!" diff --git a/plugins/hls-eval-plugin/test/testdata/TUNPACK.hs.expected b/plugins/hls-eval-plugin/test/testdata/TUNPACK.hs.expected new file mode 100644 index 0000000000..851ce19da5 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TUNPACK.hs.expected @@ -0,0 +1,15 @@ +{- | Multi line comments are parsed correctly. +-} +module TUNPACK (THStatus(..)) where + +type ByteString = String +type BSEndo = ByteString -> ByteString +type BSEndoList = [ByteString] -> [ByteString] + +data THStatus = THStatus + {-# UNPACK #-} !Int -- running total byte count + BSEndoList -- previously parsed lines + BSEndo -- bytestrings to be prepended + +-- >>> "Yay! UNPACK pragma didn't do bad things!" +-- "Yay! UNPACK pragma didn't do bad things!" From 547ff270a2f47ce6f79f9430931869d1fa4537c6 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Tue, 26 Jan 2021 23:45:37 +0900 Subject: [PATCH 33/41] Corrects test header --- plugins/hls-eval-plugin/test/testdata/TUNPACK.hs | 3 +-- plugins/hls-eval-plugin/test/testdata/TUNPACK.hs.expected | 3 +-- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/plugins/hls-eval-plugin/test/testdata/TUNPACK.hs b/plugins/hls-eval-plugin/test/testdata/TUNPACK.hs index a282378728..a16a07ef1a 100644 --- a/plugins/hls-eval-plugin/test/testdata/TUNPACK.hs +++ b/plugins/hls-eval-plugin/test/testdata/TUNPACK.hs @@ -1,5 +1,4 @@ -{- | Multi line comments are parsed correctly. --} +{- | Won't panic on UNPACKs -} module TUNPACK (THStatus(..)) where type ByteString = String diff --git a/plugins/hls-eval-plugin/test/testdata/TUNPACK.hs.expected b/plugins/hls-eval-plugin/test/testdata/TUNPACK.hs.expected index 851ce19da5..407202f20f 100644 --- a/plugins/hls-eval-plugin/test/testdata/TUNPACK.hs.expected +++ b/plugins/hls-eval-plugin/test/testdata/TUNPACK.hs.expected @@ -1,5 +1,4 @@ -{- | Multi line comments are parsed correctly. --} +{- | Won't panic on UNPACKs -} module TUNPACK (THStatus(..)) where type ByteString = String From 7e1648c92476334f2b9b7adb70c0ee5fa45d9ea7 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 28 Jan 2021 01:25:05 +0900 Subject: [PATCH 34/41] Ad-hoc treatment for ending brace in nested comment block --- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 7 ++++++- plugins/hls-eval-plugin/test/Eval.hs | 3 +++ plugins/hls-eval-plugin/test/testdata/TNested.hs | 7 +++++++ .../hls-eval-plugin/test/testdata/TNested.hs.expected | 9 +++++++++ plugins/hls-eval-plugin/test/testdata/test.cabal | 1 + 5 files changed, 26 insertions(+), 1 deletion(-) create mode 100644 plugins/hls-eval-plugin/test/testdata/TNested.hs create mode 100644 plugins/hls-eval-plugin/test/testdata/TNested.hs.expected diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index 9c39bdbbfe..a314b20295 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} @@ -47,6 +48,7 @@ import Text.Megaparsec.Char letterChar, ) import Data.Functor ((<&>)) +import qualified Data.Text as T {- | We build parsers combining the following three kinds of them: @@ -471,7 +473,10 @@ nonEmptyNormalLineP :: LineParser (String, Position) nonEmptyNormalLineP isLHS style = try $ do (ln, pos) <- normalLineP isLHS style - guard $ not $ all C.isSpace ln + guard $ + case style of + Block{} -> T.strip (T.pack ln) `notElem` ["{-", "-}", ""] + _ -> not $ all C.isSpace ln pure (ln, pos) {- | Normal line is a line neither a example nor prop. diff --git a/plugins/hls-eval-plugin/test/Eval.hs b/plugins/hls-eval-plugin/test/Eval.hs index 3b77ac4a81..bca79c04b3 100644 --- a/plugins/hls-eval-plugin/test/Eval.hs +++ b/plugins/hls-eval-plugin/test/Eval.hs @@ -153,6 +153,9 @@ tests = , testCase "Don't panic on {-# UNPACK #-} pragma" $ goldenTest "TUNPACK.hs" + , testCase + "Can handle eval inside nested comment properly" + $ goldenTest "TNested.hs" , testCase "Test on last line insert results correctly" $ do runSession hlsCommand fullCaps evalPath $ liftIO $ do diff --git a/plugins/hls-eval-plugin/test/testdata/TNested.hs b/plugins/hls-eval-plugin/test/testdata/TNested.hs new file mode 100644 index 0000000000..b1edb87385 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TNested.hs @@ -0,0 +1,7 @@ +module TNseted () where +{- +>>> 54 +{- +>>> 42 +-} +-} diff --git a/plugins/hls-eval-plugin/test/testdata/TNested.hs.expected b/plugins/hls-eval-plugin/test/testdata/TNested.hs.expected new file mode 100644 index 0000000000..8b18866db1 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TNested.hs.expected @@ -0,0 +1,9 @@ +module TNseted () where +{- +>>> 54 +54 +{- +>>> 42 +42 +-} +-} diff --git a/plugins/hls-eval-plugin/test/testdata/test.cabal b/plugins/hls-eval-plugin/test/testdata/test.cabal index a1a92ee1cf..9a9c5104ab 100644 --- a/plugins/hls-eval-plugin/test/testdata/test.cabal +++ b/plugins/hls-eval-plugin/test/testdata/test.cabal @@ -54,6 +54,7 @@ library TLHS TSetup Util + TNested build-depends: base >= 4.7 && < 5, QuickCheck default-language: Haskell2010 From 1decd413cec3cea1c0dfa71f995f22998f047bcf Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 28 Jan 2021 12:58:29 +0900 Subject: [PATCH 35/41] `goldenTest` function from Eval plugin doesn't support multiple tests in the same block but in separate group --- plugins/hls-eval-plugin/test/testdata/TNested.hs | 6 ++++++ plugins/hls-eval-plugin/test/testdata/TNested.hs.expected | 6 ++++++ 2 files changed, 12 insertions(+) diff --git a/plugins/hls-eval-plugin/test/testdata/TNested.hs b/plugins/hls-eval-plugin/test/testdata/TNested.hs index b1edb87385..7acd11f5bc 100644 --- a/plugins/hls-eval-plugin/test/testdata/TNested.hs +++ b/plugins/hls-eval-plugin/test/testdata/TNested.hs @@ -2,6 +2,12 @@ module TNseted () where {- >>> 54 {- +Nested +-} +-} + +{- +{- >>> 42 -} -} diff --git a/plugins/hls-eval-plugin/test/testdata/TNested.hs.expected b/plugins/hls-eval-plugin/test/testdata/TNested.hs.expected index 8b18866db1..86369f01c1 100644 --- a/plugins/hls-eval-plugin/test/testdata/TNested.hs.expected +++ b/plugins/hls-eval-plugin/test/testdata/TNested.hs.expected @@ -3,6 +3,12 @@ module TNseted () where >>> 54 54 {- +Nested +-} +-} + +{- +{- >>> 42 42 -} From 255d6fbb37978f34611f4e49029dea289033d791 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Thu, 28 Jan 2021 18:13:02 +0900 Subject: [PATCH 36/41] Dummy commit to rerun CI From 557fdd68f7b0d3aa4ee9f90b5516c09e1ba3e999 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sun, 31 Jan 2021 01:51:08 +0900 Subject: [PATCH 37/41] Stop using CPP and use `knownBrokenForGhcVersions` and `knownBrokenOnWindows` --- plugins/hls-eval-plugin/test/Eval.hs | 14 ++++++-------- test/utils/Test/Hls/Util.hs | 7 +++++++ 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/plugins/hls-eval-plugin/test/Eval.hs b/plugins/hls-eval-plugin/test/Eval.hs index bca79c04b3..5ba27d1197 100644 --- a/plugins/hls-eval-plugin/test/Eval.hs +++ b/plugins/hls-eval-plugin/test/Eval.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -37,7 +36,7 @@ import System.FilePath ( (<.>), (), ) -import Test.Hls.Util (hlsCommand) +import Test.Hls.Util (hlsCommand, GhcVersion (GHC84, GHC86), knownBrokenForGhcVersions, knownBrokenOnWindows) import Test.Tasty ( TestTree, testGroup, @@ -163,15 +162,14 @@ tests = -- Write the test file, to make sure that it has no final line return writeFile (evalPath mdl) "module TLastLine where\n\n-- >>> take 3 [1..]" goldenTest mdl -#if __GLASGOW_HASKELL__ >= 808 - , -#if mingw32_HOST_OS - expectFailBecause "CPP eval on Windows fails for some reasons" $ -#endif + , knownBrokenForGhcVersions [GHC84, GHC86] + "Preprocessor known to fail on GHC <= 8.6" + $ testGroup "with preprocessors" + [ knownBrokenOnWindows "CPP eval on Windows fails for some reasons" $ testCase "CPP support" $ goldenTest "TCPP.hs" , testCase "Literate Haskell Bird Style" $ goldenTest "TLHS.lhs" -#endif -- , testCase "Literate Haskell LaTeX Style" $ goldenTest "TLHSLateX.lhs" + ] ] goldenTest :: FilePath -> IO () diff --git a/test/utils/Test/Hls/Util.hs b/test/utils/Test/Hls/Util.hs index 066cddae98..f39d7cf684 100644 --- a/test/utils/Test/Hls/Util.hs +++ b/test/utils/Test/Hls/Util.hs @@ -20,6 +20,7 @@ module Test.Hls.Util , inspectCodeAction , inspectCommand , inspectDiagnostic + , knownBrokenOnWindows , knownBrokenForGhcVersions , logFilePath , setupBuildToolFiles @@ -61,6 +62,7 @@ import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFailBecaus import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) import Text.Blaze.Renderer.String (renderMarkup) import Text.Blaze.Internal hiding (null) +import System.Info.Extra (isWindows) codeActionSupportCaps :: C.ClientCapabilities codeActionSupportCaps = def { C._textDocument = Just textDocumentCaps } @@ -116,6 +118,11 @@ ghcVersion = GHC86 ghcVersion = GHC84 #endif +knownBrokenOnWindows :: String -> TestTree -> TestTree +knownBrokenOnWindows reason + | isWindows = expectFailBecause reason + | otherwise = id + knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree knownBrokenForGhcVersions vers reason | ghcVersion `elem` vers = expectFailBecause reason From 5b90f4343e24d16c51c6fcfcbc72fa5d95dd0659 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sun, 31 Jan 2021 14:13:20 +0900 Subject: [PATCH 38/41] Nested `expectedFailure` didn't work as expected --- plugins/hls-eval-plugin/test/Eval.hs | 11 +++++---- test/utils/Test/Hls/Util.hs | 34 +++++++++++++++++++++++++++- 2 files changed, 39 insertions(+), 6 deletions(-) diff --git a/plugins/hls-eval-plugin/test/Eval.hs b/plugins/hls-eval-plugin/test/Eval.hs index 5ba27d1197..4e6b65e2ec 100644 --- a/plugins/hls-eval-plugin/test/Eval.hs +++ b/plugins/hls-eval-plugin/test/Eval.hs @@ -36,7 +36,7 @@ import System.FilePath ( (<.>), (), ) -import Test.Hls.Util (hlsCommand, GhcVersion (GHC84, GHC86), knownBrokenForGhcVersions, knownBrokenOnWindows) +import Test.Hls.Util (hlsCommand, GhcVersion (GHC84, GHC86), knownBrokenForGhcVersions, knownBrokenInEnv, EnvSpec (HostOS, GhcVer), OS (Windows)) import Test.Tasty ( TestTree, testGroup, @@ -162,12 +162,13 @@ tests = -- Write the test file, to make sure that it has no final line return writeFile (evalPath mdl) "module TLastLine where\n\n-- >>> take 3 [1..]" goldenTest mdl + , testGroup "with preprocessors" + [ knownBrokenInEnv [HostOS Windows, GhcVer GHC84, GhcVer GHC86] + "CPP eval on Windows and/or GHC <= 8.6 fails for some reasons" $ + testCase "CPP support" $ goldenTest "TCPP.hs" , knownBrokenForGhcVersions [GHC84, GHC86] "Preprocessor known to fail on GHC <= 8.6" - $ testGroup "with preprocessors" - [ knownBrokenOnWindows "CPP eval on Windows fails for some reasons" $ - testCase "CPP support" $ goldenTest "TCPP.hs" - , testCase "Literate Haskell Bird Style" $ goldenTest "TLHS.lhs" + $ testCase "Literate Haskell Bird Style" $ goldenTest "TLHS.lhs" -- , testCase "Literate Haskell LaTeX Style" $ goldenTest "TLHSLateX.lhs" ] ] diff --git a/test/utils/Test/Hls/Util.hs b/test/utils/Test/Hls/Util.hs index f39d7cf684..2e27cc3cd5 100644 --- a/test/utils/Test/Hls/Util.hs +++ b/test/utils/Test/Hls/Util.hs @@ -13,15 +13,19 @@ module Test.Hls.Util , fromCommand , getHspecFormattedConfig , ghcVersion, GhcVersion(..) + , hostOS, OS(..) + , matchesCurrentEnv, EnvSpec(..) , hlsCommand , hlsCommandExamplePlugin , hlsCommandVomit , ignoreForGhcVersions + , ignoreInEnv , inspectCodeAction , inspectCommand , inspectDiagnostic , knownBrokenOnWindows , knownBrokenForGhcVersions + , knownBrokenInEnv , logFilePath , setupBuildToolFiles , SymbolLocation @@ -62,7 +66,7 @@ import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFailBecaus import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) import Text.Blaze.Renderer.String (renderMarkup) import Text.Blaze.Internal hiding (null) -import System.Info.Extra (isWindows) +import System.Info.Extra (isWindows, isMac) codeActionSupportCaps :: C.ClientCapabilities codeActionSupportCaps = def { C._textDocument = Just textDocumentCaps } @@ -118,6 +122,28 @@ ghcVersion = GHC86 ghcVersion = GHC84 #endif +data EnvSpec = HostOS OS | GhcVer GhcVersion + deriving (Show, Eq) + +matchesCurrentEnv :: EnvSpec -> Bool +matchesCurrentEnv (HostOS os) = hostOS == os +matchesCurrentEnv (GhcVer ver) = ghcVersion == ver + +data OS = Windows | MacOS | Linux + deriving (Show, Eq) + +hostOS :: OS +hostOS + | isWindows = Windows + | isMac = MacOS + | otherwise = Linux + +-- | Mark as broken if /any/ of environmental spec mathces the current environment. +knownBrokenInEnv :: [EnvSpec] -> String -> TestTree -> TestTree +knownBrokenInEnv envSpecs reason + | any matchesCurrentEnv envSpecs = expectFailBecause reason + | otherwise = id + knownBrokenOnWindows :: String -> TestTree -> TestTree knownBrokenOnWindows reason | isWindows = expectFailBecause reason @@ -128,6 +154,12 @@ knownBrokenForGhcVersions vers reason | ghcVersion `elem` vers = expectFailBecause reason | otherwise = id +-- | IgnroeTest if /any/ of environmental spec mathces the current environment. +ignoreInEnv :: [EnvSpec] -> String -> TestTree -> TestTree +ignoreInEnv envSpecs reason + | any matchesCurrentEnv envSpecs = ignoreTestBecause reason + | otherwise = id + ignoreForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree ignoreForGhcVersions vers reason | ghcVersion `elem` vers = ignoreTestBecause reason From 66cdc32ed2dfc73e4ea98e6da4e814f1ba0e083f Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sun, 31 Jan 2021 14:24:16 +0900 Subject: [PATCH 39/41] Abolishes `Parser` type synonym --- .../hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index a314b20295..b77d2b7bc9 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -50,7 +50,7 @@ import Text.Megaparsec.Char import Data.Functor ((<&>)) import qualified Data.Text as T -{- | +{- We build parsers combining the following three kinds of them: * Line parser - paring a single line into an input, @@ -65,13 +65,12 @@ We build parsers combining the following three kinds of them: * Block comment parser: Parsing entire block comment into sections. Input must be surrounded by @{\-@ and @-\}@. -} -type Parser inputs = Parsec Void inputs -- | Line parser type LineParser a = forall m. Monad m => ParsecT Void String m a -- | Line comment group parser -type LineGroupParser = Parser [(Range, RawLineComment)] +type LineGroupParser = Parsec Void [(Range, RawLineComment)] data BlockEnv = BlockEnv { isLhs :: Bool @@ -457,7 +456,7 @@ Nothing parseLine :: (Ord (f RawLineComment), Traversable f) => LineParser a -> - Parser [f RawLineComment] (f a) + Parsec Void [f RawLineComment] (f a) parseLine p = P.token (mapM $ parseMaybe (lineCommentHeadP *> p) . getRawLineComment) From 90c86ce29da3919763d8b44d1d5873b63f6fbe07 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sun, 31 Jan 2021 14:26:02 +0900 Subject: [PATCH 40/41] Removes unneccesary comment evals --- .../src/Ide/Plugin/Eval/CodeLens.hs | 22 ------------------- 1 file changed, 22 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index af73bea8a3..c9fe8e7393 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -309,8 +309,6 @@ evalCommand :: PluginCommand IdeState evalCommand = PluginCommand evalCommandName "evaluate" runEvalCmd -- | Specify the test section to execute --- --- >>> 12 data EvalParams = EvalParams { sections :: [Section] , module_ :: !TextDocumentIdentifier @@ -423,26 +421,6 @@ runEvalCmd lsp st EvalParams{..} = withIndefiniteProgress lsp "Evaluating" Cancellable $ response' cmd -{- ->>> import Language.Haskell.LSP.Types(applyTextEdit) ->>> aTest = Located 1 (Example (pure " 2 + 2") []) ->>> ending = Position 1 10 ->>> mdl = "module Test where\n-- >>> 2+2" - -To avoid https://github.com/haskell/haskell-language-server/issues/1213, `addFinalReturn` adds, if necessary, a final empty line to the document before inserting the tests' results. - ->>> let [e1,e2] = addFinalReturn mdl [asEdit aTest Line () ["4"]] in applyTextEdit e2 (applyTextEdit e1 mdl) -"module Test where\n-- >>> 2+2\n4\n" - ->>> applyTextEdit (head $ addFinalReturn mdl [asEdit aTest ["4"]]) mdl -"module Test where\n-- >>> 2+2\n" - ->>> addFinalReturn mdl [asEdit aTest ["4"]] -[TextEdit {_range = Range {_start = Position {_line = 1, _character = 10}, _end = Position {_line = 1, _character = 10}}, _newText = "\n"},TextEdit {_range = Range {_start = Position {_line = 2, _character = 0}, _end = Position {_line = 2, _character = 0}}, _newText = "4\n"}] - ->>> asEdit aTest ["4"] -TextEdit {_range = Range {_start = Position {_line = 2, _character = 0}, _end = Position {_line = 2, _character = 0}}, _newText = "4\n"} --} addFinalReturn :: Text -> [TextEdit] -> [TextEdit] addFinalReturn mdlText edits | not (null edits) && not (T.null mdlText) && T.last mdlText /= '\n' = From 0e689e34c82a0cbdafebb83388ad9b01065f6d22 Mon Sep 17 00:00:00 2001 From: Hiromi ISHII Date: Sun, 31 Jan 2021 14:28:15 +0900 Subject: [PATCH 41/41] Skip failed curentRange resolution --- .../hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index c9fe8e7393..29f3d3900b 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -236,13 +236,14 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = (ParsedModule{..}, posMap) <- liftIO $ runAction "parsed" st $ useWithStale_ GetParsedModuleWithComments nfp let comments = foldMap - ( foldMap (\case + ( foldMap $ \case L (RealSrcSpan real) bdy | unpackFS (srcSpanFile real) == - fromNormalizedFilePath nfp -> - let ran0 = realSrcSpanToRange real - curRan = fromMaybe ran0 $ toCurrentRange posMap ran0 - in + fromNormalizedFilePath nfp + , let ran0 = realSrcSpanToRange real + , Just curRan <- toCurrentRange posMap ran0 + -> + -- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments', -- we can concentrate on these two case bdy of @@ -252,7 +253,6 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt } _ -> mempty _ -> mempty - ) ) $ snd pm_annotations dbg "excluded comments" $ show $ DL.toList $