hls-eval-plugin 0.1.0.5 → 0.2.0.0
raw patch · 12 files changed
+947/−843 lines, 12 filesdep +dlistdep +lensdep +megaparsecdep ~ghcidedep ~hls-plugin-api
Dependencies added: dlist, lens, megaparsec, mtl
Dependency ranges changed: ghcide, hls-plugin-api
Files
- README.md +2/−2
- demo.gif binary
- hls-eval-plugin.cabal +13/−8
- src/Ide/Plugin/Eval/Code.hs +14/−13
- src/Ide/Plugin/Eval/CodeLens.hs +252/−247
- src/Ide/Plugin/Eval/Parse/Comments.hs +575/−0
- src/Ide/Plugin/Eval/Parse/Option.hs +13/−13
- src/Ide/Plugin/Eval/Parse/Parser.hs +0/−98
- src/Ide/Plugin/Eval/Parse/Section.hs +0/−141
- src/Ide/Plugin/Eval/Parse/Token.hs +0/−298
- src/Ide/Plugin/Eval/Types.hs +78/−22
- src/Ide/Plugin/Eval/Util.hs +0/−1
README.md view
@@ -27,7 +27,7 @@ # Demo -+ # Test Structure @@ -72,7 +72,7 @@ -- 22 ``` -Both plain Haskell and Literate Haskell (Bird-style only) source files are supported.+Modules that use CPP and Literate Haskell (Bird-style only) modules are also supported (for GHC >= 8.8). # Test Components
− demo.gif
binary file changed (190013 → absent bytes)
hls-eval-plugin.cabal view
@@ -1,7 +1,10 @@ cabal-version: 2.2 name: hls-eval-plugin-version: 0.1.0.5+version: 0.2.0.0 synopsis: Eval plugin for Haskell Language Server+description:+ Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>+ category: Development bug-reports: https://github.com/haskell/haskell-language-server/issues license: Apache-2.0@@ -14,8 +17,8 @@ build-type: Simple extra-source-files:+ LICENSE README.md- demo.gif flag pedantic description: Enable -Werror@@ -33,30 +36,32 @@ Ide.Plugin.Eval.Code Ide.Plugin.Eval.CodeLens Ide.Plugin.Eval.GHC+ Ide.Plugin.Eval.Parse.Comments Ide.Plugin.Eval.Parse.Option- Ide.Plugin.Eval.Parse.Parser- Ide.Plugin.Eval.Parse.Section- Ide.Plugin.Eval.Parse.Token Ide.Plugin.Eval.Types Ide.Plugin.Eval.Util build-depends: , aeson- , base >=4.12 && <5+ , base >=4.12 && <5 , containers , deepseq , Diff , directory+ , dlist , extra , filepath , ghc , ghc-boot-th , ghc-paths- , ghcide+ , ghcide >=0.7.3.0 , hashable , haskell-lsp , haskell-lsp-types- , hls-plugin-api+ , hls-plugin-api >=0.7+ , lens+ , megaparsec >=0.9+ , mtl , parser-combinators , pretty-simple , QuickCheck
src/Ide/Plugin/Eval/Code.hs view
@@ -15,20 +15,21 @@ 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 @@ -} -- |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 @@ | 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)
src/Ide/Plugin/Eval/CodeLens.hs view
@@ -1,10 +1,10 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}@@ -26,257 +26,255 @@ 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 Map-import Data.List (- dropWhileEnd,- find,- )-import Data.Maybe (- catMaybes,- fromMaybe,- )+import qualified Data.HashMap.Strict as HashMap+import Data.List+ (dropWhileEnd,+ find+ )+import qualified Data.Map.Strict as Map+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 (- GetModSummary (..),- GhcSession (..),- HscEnvEq (envImportPaths, hscEnv),- IdeState,- List (List),- NormalizedFilePath,- Range (Range),- Uri,- evalGhcEnv,- hscEnvWithImportPaths,- runAction,- stringBufferToByteString,- textToStringBuffer,- toNormalizedFilePath',- toNormalizedUri,- uriToFilePath',- use_,- )-import Development.IDE.Core.Preprocessor (- preprocessor,- )-import Development.IDE.GHC.Compat (HscEnv)+import Development.IDE+ (realSrcSpanToRange, 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) 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 (- 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+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),- 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 (- 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.Core.PositionMapping (toCurrentRange)+import qualified Data.DList as DL+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. -} 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" $ response $ do let TextDocumentIdentifier uri = _textDocument fp <- handleMaybe "uri" $ uriToFilePath' uri+ let nfp = toNormalizedFilePath' fp+ isLHS = isLiterate fp dbg "fp" fp- 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+ (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+ , Just curRan <- toCurrentRange posMap ran0+ -> - 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+ -- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments',+ -- we can concentrate on these two+ case bdy of+ AnnLineComment cmt ->+ mempty { lineComments = Map.singleton curRan (RawLineComment cmt) }+ AnnBlockComment cmt ->+ mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt }+ _ -> mempty+ _ -> mempty+ )+ $ snd pm_annotations+ dbg "excluded comments" $ show $ DL.toList $+ foldMap+ (foldMap $ \(L a b) ->+ case b of+ AnnLineComment{} -> mempty+ AnnBlockComment{} -> mempty+ _ -> DL.singleton (a, b)+ )+ $ snd pm_annotations+ dbg "comments" $ show 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 isLHS comments+ tests = testsBySection nonSetupSections 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])@@ -292,9 +290,9 @@ unwords [ show (length tests) , "tests in"- , show (length nonSetups)+ , show (length nonSetupSections) , "sections"- , show (length setups)+ , show (length setupSections) , "setups" , show (length lenses) , "lenses."@@ -310,7 +308,7 @@ evalCommand :: PluginCommand IdeState evalCommand = PluginCommand evalCommandName "evaluate" runEvalCmd --- |Specify the test section to execute+-- | Specify the test section to execute data EvalParams = EvalParams { sections :: [Section] , module_ :: !TextDocumentIdentifier@@ -415,7 +413,7 @@ (st, fp) tests - let workspaceEditsMap = Map.fromList [(_uri, List edits)]+ let workspaceEditsMap = HashMap.fromList [(_uri, List $ addFinalReturn mdlText edits)] let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing return (WorkspaceApplyEdit, ApplyWorkspaceEditParams workspaceEdits)@@ -423,6 +421,20 @@ withIndefiniteProgress lsp "Evaluating" Cancellable $ response' cmd +addFinalReturn :: Text -> [TextEdit] -> [TextEdit]+addFinalReturn mdlText edits+ | not (null edits) && not (T.null mdlText) && T.last mdlText /= '\n' =+ finalReturn mdlText : edits+ | otherwise = edits++finalReturn :: Text -> TextEdit+finalReturn txt =+ let ls = T.lines txt+ l = length ls -1+ c = T.length . last $ ls+ p = Position l c+ in TextEdit (Range p p) "\n"+ moduleText :: (IsString e, MonadIO m) => LspFuncs c -> Uri -> ExceptT e m Text moduleText lsp uri = handleMaybeM "mdlText" $@@ -432,13 +444,13 @@ 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@@ -446,7 +458,7 @@ 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)@@ -454,20 +466,34 @@ rs <- runTest e df test dbg "TEST RESULTS" rs - let checkedResult = testCheck (section, unLoc test) rs+ let checkedResult = testCheck (section, test) rs - let edit = TextEdit (resultRange test) (T.unlines . 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 -> Test -> [Text] -> TextEdit+asEdit (MultiLine commRange) test resultLines+ -- A test in a block comment, ending with @-\}@ without newline in-between.+ | testRange test ^. end.line == commRange ^. end . line+ =+ TextEdit+ (Range+ (testRange test ^. end)+ (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: * a value@@ -506,7 +532,7 @@ 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@@ -599,8 +625,8 @@ -- 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"@@ -652,27 +678,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
+ src/Ide/Plugin/Eval/Parse/Comments.hs view
@@ -0,0 +1,575 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# 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 (lensField, lensRules, view, (.~), (^.))+import Control.Lens.Extras (is)+import Control.Lens.TH (makeLensesWith, makePrisms, mappingNamer)+import Control.Monad (guard, 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.Functor.Identity+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, 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+import Text.Megaparsec.Char+ ( alphaNumChar,+ char,+ eol,+ hspace,+ letterChar,+ )+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,+ 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 position 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 @-\}@.+-}++-- | Line parser+type LineParser a = forall m. Monad m => ParsecT Void String m a++-- | Line comment group parser+type LineGroupParser = Parsec Void [(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 = ParsecT Void String (Reader BlockEnv)++-- | 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 TestComment+ = AProp+ { testCommentRange :: Range+ , lineProp :: PropLine+ , propResults :: [String]+ }+ | AnExample+ { testCommentRange :: Range+ , lineExamples :: NonEmpty ExampleLine+ , 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 Range+ deriving (Read, Show, Eq, Ord, Generic)++makePrisms ''CommentStyle++commentsToSections ::+ -- | True if it is literate Haskell+ Bool ->+ Comments ->+ Sections+commentsToSections isLHS Comments {..} =+ let (lineSectionSeeds, lineSetupSeeds) =+ foldMap+ ( \lcs ->+ 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 mempty (uncurry Map.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+ -- 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 ^. start . character == 2+ else pos ^. start . character == 0+ )+ lineComments+ (blockSeed, blockSetupSeeds) =+ foldMap+ ( \(ran, lcs) ->+ 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 ran, grp)+ )+ Just grp ->+ ( Map.singleton ran grp+ , 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 =+ lineSectionSeeds <&> uncurry (testsToSection Line)+ multilineSections =+ Map.mapWithKey+ (uncurry . testsToSection . Block)+ blockSeed+ setupSections =+ -- Setups doesn't need Dummy position+ map+ ( \(style, tests) ->+ testsToSection+ style+ (Named "setup")+ tests+ )+ $ 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+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 ->+ [TestComment] ->+ Section+testsToSection style flav tests =+ let sectionName+ | Named name <- flav = name+ | otherwise = ""+ sectionLanguage = case flav of+ HaddockNext -> Haddock+ HaddockPrev -> Haddock+ _ -> Plain+ sectionTests = map fromTestComment tests+ sectionFormat =+ case style of+ Line -> SingleLine+ Block ran -> MultiLine ran+ in Section {..}++fromTestComment :: TestComment -> Test+fromTestComment AProp {..} =+ Property+ { testline = getPropLine lineProp+ , testOutput = propResults+ , testRange = testCommentRange+ }+fromTestComment AnExample {..} =+ Example+ { testLines = getExampleLine <$> lineExamples+ , testOutput = exampleResults+ , testRange = testCommentRange+ }++-- * Block comment parser++{- $setup+>>> dummyPos = Position 0 0+>>> parseE p = either (error . errorBundlePretty) id . parse p ""+-}++-- >>> parseE (blockCommentBP True dummyPos) "{- |\n >>> 5+5\n 11\n -}"+-- (HaddockNext,[AnExample {testCommentRange = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " 5+5"} :| [], exampleResults = [" 11"]}])++blockCommentBP ::+ -- | True if Literate Haskell+ BlockCommentParser (CommentFlavour, [TestComment])+blockCommentBP = do+ 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 (flav, [])++skipNormalCommentBlock :: BlockCommentParser Bool+skipNormalCommentBlock = do+ BlockEnv {..} <- ask+ skipManyTill (normalLineP isLhs $ Block blockRange) $+ False <$ try (optional (chunk "-}") *> eof)+ <|> True <$ lookAhead (try $ testSymbol isLhs $ Block blockRange)++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 && is _Block style) (void $ count' 0 2 $ char ' ')+ *> (exampleSymbol <|> propSymbol)++eob :: LineParser ()+eob = eof <|> try (optional (chunk "-}") *> eof) <|> void eol++blockExamples+ , blockProp ::+ BlockCommentParser TestComment+blockExamples = do+ BlockEnv {..} <- ask+ (ran, examples) <- withRange $ NE.some $ exampleLineStrP isLhs $ Block blockRange+ AnExample ran examples <$> resultBlockP+blockProp = do+ BlockEnv {..} <- ask+ (ran, Identity prop) <- withRange $ fmap Identity $ propLineStrP isLhs $ Block blockRange+ AProp ran prop <$> resultBlockP++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+ as <- p+ let fin+ | null as = beg+ | otherwise = snd $ last $ F.toList as+ pure (Range beg fin, fst <$> as)++resultBlockP :: BlockCommentParser [String]+resultBlockP = do+ BlockEnv {..} <- ask+ many $+ fmap fst . nonEmptyNormalLineP isLhs $+ Block blockRange++positionToSourcePos :: Position -> SourcePos+positionToSourcePos pos =+ P.SourcePos+ { sourceName = "<block comment>"+ , sourceLine = P.mkPos $ 1 + pos ^. line+ , sourceColumn = P.mkPos $ 1 + pos ^. character+ }++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.++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 ::+ LineGroupParser+ (Maybe (CommentFlavour, [TestComment]), [TestComment])+lineGroupP = do+ (_, flav) <- lookAhead $ parseLine (commentFlavourP <* takeRest)+ case flav of+ Named "setup" -> (Nothing,) <$> lineCommentSectionsP+ flav -> (,mempty) . Just . (flav,) <$> lineCommentSectionsP++-- >>> parse (lineGroupP <*eof) "" $ (dummyPosition, ) . RawLineComment <$> ["-- a", "-- b"]+-- Variable not in scope: dummyPosition :: Position++commentFlavourP :: LineParser CommentFlavour+commentFlavourP =+ P.option+ Vanilla+ ( HaddockNext <$ char '|'+ <|> HaddockPrev <$ char '^'+ <|> Named <$ char '$'+ <* optional hspace+ <*> ((:) <$> letterChar <*> P.many alphaNumChar)+ )+ <* optional (char ' ')++lineCommentHeadP :: LineParser ()+lineCommentHeadP = do+ -- and no operator symbol character follows.+ void $ chunk "--"+ skipMany $ char '-'+ void $ optional $ char ' '++lineCommentSectionsP ::+ LineGroupParser [TestComment]+lineCommentSectionsP = do+ skipMany normalLineCommentP+ many $+ exampleLinesGP+ <|> uncurry AProp <$> propLineGP <*> resultLinesP+ <* skipMany normalLineCommentP++lexemeLine :: LineGroupParser a -> LineGroupParser a+lexemeLine p = p <* skipMany normalLineCommentP++resultLinesP :: LineGroupParser [String]+resultLinesP = many nonEmptyLGP++normalLineCommentP :: LineGroupParser (Range, String)+normalLineCommentP =+ parseLine (fst <$ commentFlavourP <*> normalLineP False Line)++nonEmptyLGP :: LineGroupParser String+nonEmptyLGP =+ try $+ fmap snd $+ parseLine $+ fst <$ commentFlavourP <*> nonEmptyNormalLineP False Line++exampleLinesGP :: LineGroupParser TestComment+exampleLinesGP =+ lexemeLine $+ 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 (fst <$ commentFlavourP <*> exampleLineStrP False Line)++propLineGP :: LineGroupParser (Range, PropLine)+propLineGP =+ -- In line-comments, indentation-level inside comment doesn't matter.+ parseLine (fst <$ commentFlavourP <*> propLineStrP False Line)++{- |+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.++>>> pck = (:[]).(:[]) . RawLineComment++>>> parseMaybe (parseLine $ takeRest) $ pck "-- >>> A"+Just [">>> A"]++>>> parseMaybe (parseLine $ takeRest) $ pck "--- >>> A"+Just [" >>> A"]++>>> parseMaybe (parseLine takeRest) $ pck ""+Nothing+-}+parseLine ::+ (Ord (f RawLineComment), Traversable f) =>+ LineParser a ->+ Parsec Void [f RawLineComment] (f a)+parseLine p =+ P.token+ (mapM $ parseMaybe (lineCommentHeadP *> p) . getRawLineComment)+ mempty++-- * Line Parsers++-- | Non-empty normal line.+nonEmptyNormalLineP ::+ -- | True if Literate Haskell+ Bool ->+ CommentStyle ->+ LineParser (String, Position)+nonEmptyNormalLineP isLHS style = try $ do+ (ln, pos) <- normalLineP isLHS style+ 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.+ Empty line is normal.+-}+normalLineP ::+ -- | True if Literate Haskell+ Bool ->+ CommentStyle ->+ LineParser (String, Position)+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)+consume style =+ case style of+ 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, Position)+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+ *> (first ExampleLine <$> consume style)++exampleSymbol :: LineParser ()+exampleSymbol =+ chunk ">>>" *> P.notFollowedBy (char '>')++propSymbol :: LineParser ()+propSymbol = chunk "prop>" *> P.notFollowedBy (char '>')++-- | Parses prop test line.+propLineStrP ::+ -- | True if Literate HAskell+ Bool ->+ CommentStyle ->+ LineParser (PropLine, Position)+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 && is _Block style) (void $ count' 0 2 $ char ' ')+ *> chunk "prop>"+ *> P.notFollowedBy (char '>')+ *> (first PropLine <$> consume style)++-- * Utilities++{- |+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)]+[(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++{- | Given a map from positions, 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
src/Ide/Plugin/Eval/Parse/Option.hs view
@@ -6,13 +6,10 @@ ) 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 @@ >>> 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)
− src/Ide/Plugin/Eval/Parse/Parser.hs
@@ -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"
− src/Ide/Plugin/Eval/Parse/Section.hs
@@ -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)
− src/Ide/Plugin/Eval/Parse/Token.hs
@@ -1,298 +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
src/Ide/Plugin/Eval/Types.hs view
@@ -1,31 +1,42 @@ {-# 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 (..),- hasTests,- hasPropertyTest,- splitSections,- Loc,- Located (..),- 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.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. data Located l a = Located {location :: l, located :: a}@@ -50,9 +61,15 @@ type Txt = String +data Sections = Sections+ { nonSetupSections :: [Section]+ , setupSections :: [Section]+ }+ deriving (Show, Eq, Generic)+ data Section = Section { sectionName :: Txt- , sectionTests :: [Loc Test]+ , sectionTests :: [Test] , sectionLanguage :: Language , sectionFormat :: Format }@@ -62,22 +79,61 @@ 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+ }+ 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')++instance Monoid Comments where+ mempty = Comments mempty mempty+ isProperty :: Test -> Bool-isProperty (Property _ _) = True+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)
src/Ide/Plugin/Eval/Util.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_GHC -Wno-orphans #-}