hls-eval-plugin (empty) → 0.1.0.0
raw patch · 12 files changed
+2178/−0 lines, 12 filesdep +Diffdep +QuickCheckdep +aeson
Dependencies added: Diff, QuickCheck, aeson, base, containers, deepseq, directory, extra, filepath, ghc, ghc-boot-th, ghc-paths, ghcide, hashable, haskell-lsp, haskell-lsp-types, hls-plugin-api, parser-combinators, pretty-simple, safe-exceptions, shake, temporary, text, time, transformers, unordered-containers
Files
- LICENSE +201/−0
- hls-eval-plugin.cabal +66/−0
- src/Ide/Plugin/Eval.hs +34/−0
- src/Ide/Plugin/Eval/Code.hs +126/−0
- src/Ide/Plugin/Eval/CodeLens.hs +782/−0
- src/Ide/Plugin/Eval/GHC.hs +204/−0
- src/Ide/Plugin/Eval/Parse/Option.hs +33/−0
- src/Ide/Plugin/Eval/Parse/Parser.hs +98/−0
- src/Ide/Plugin/Eval/Parse/Section.hs +141/−0
- src/Ide/Plugin/Eval/Parse/Token.hs +283/−0
- src/Ide/Plugin/Eval/Types.hs +94/−0
- src/Ide/Plugin/Eval/Util.hs +116/−0
+ LICENSE view
@@ -0,0 +1,201 @@+ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ hls-eval-plugin.cabal view
@@ -0,0 +1,66 @@+cabal-version: 2.2+name: hls-eval-plugin+version: 0.1.0.0+synopsis: Eval plugin for Haskell Language Server+description: Please see Haskell Language Server Readme (https://github.com/haskell/haskell-language-server#readme)+category: Development+license: Apache-2.0+license-file: LICENSE+author: https://github.com/haskell/haskell-language-server/contributors+maintainer: https://github.com/haskell/haskell-language-server/contributors+build-type: Simple+extra-source-files: LICENSE++flag pedantic+ description: Enable -Werror+ default: False+ manual: True++library+ exposed-modules: Ide.Plugin.Eval+ hs-source-dirs: src+ other-modules:+ Ide.Plugin.Eval.Code+ Ide.Plugin.Eval.CodeLens+ Ide.Plugin.Eval.GHC+ 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+ , containers+ , deepseq+ , Diff+ , directory+ , extra+ , filepath+ , ghc+ , ghc-boot-th+ , ghc-paths+ , ghcide+ , hashable+ , haskell-lsp+ , haskell-lsp-types+ , hls-plugin-api+ , parser-combinators+ , pretty-simple+ , QuickCheck+ , safe-exceptions+ , shake+ , temporary+ , text+ , time+ , transformers+ , unordered-containers++ ghc-options: -Wall -Wno-name-shadowing++ if flag(pedantic)+ ghc-options: -Werror++ default-language: Haskell2010
+ src/Ide/Plugin/Eval.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wwarn #-}++{- |+A plugin inspired by:++* the REPLoid feature of <https://github.com/jyp/dante Dante>++* <https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744 Haddock>'s Examples and Properties++* <https://hackage.haskell.org/package/doctest Doctest>++See the "Ide.Plugin.Eval.Tutorial" module for a full introduction to the plugin functionality.+-}+module Ide.Plugin.Eval (+ descriptor,+) where++import Development.IDE (IdeState)+import qualified Ide.Plugin.Eval.CodeLens as CL+import Ide.Types (+ PluginDescriptor (..),+ PluginId,+ defaultPluginDescriptor,+ )++-- |Plugin descriptor+descriptor :: PluginId -> PluginDescriptor IdeState+descriptor plId =+ (defaultPluginDescriptor plId)+ { pluginCodeLensProvider = Just CL.codeLens+ , pluginCommands = [CL.evalCommand]+ }
+ src/Ide/Plugin/Eval/Code.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-}++-- | Expression execution+module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalExtensions, evalSetup, evalExpr, propSetup, testCheck, asStatements) where++import Data.Algorithm.Diff (Diff, PolyDiff (..), getDiff)+import qualified Data.List.NonEmpty as NE+import Data.String (IsString)+import qualified Data.Text as T+import Development.IDE.Types.Location (Position (..), Range (..))+import GHC (compileExpr)+import GHC.LanguageExtensions.Type (Extension (..))+import GhcMonad (Ghc, GhcMonad, liftIO)+import Ide.Plugin.Eval.Types (+ Language (Plain),+ Loc,+ Located (Located),+ Section (sectionLanguage),+ Test (Example, Property, testOutput),+ Txt,+ locate,+ locate0,+ )+import InteractiveEval (runDecls)+import Unsafe.Coerce (unsafeCoerce)++-- | 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+ (exprLines, resultLines) = testLenghts tst+ resLine = startLine + exprLines+ in ( Range+ (Position startLine 0)+ --(Position (startLine + exprLines + resultLines) 0),+ (Position resLine 0)+ , Range (Position resLine 0) (Position (resLine + resultLines) 0)+ )++{- |The document range where a test is defined+ testRange :: Loc Test -> Range+ testRange = fst . testRanges+-}++-- |The document range where the result of the test is defined+resultRange :: Loc Test -> Range+resultRange = snd . testRanges++-- TODO: handle BLANKLINE+{-+>>> showDiffs $ getDiff ["abc","def","ghi","end"] ["abc","def","Z","ZZ","end"]+["abc","def","WAS ghi","NOW Z","NOW ZZ","end"]+-}+showDiffs :: (Semigroup a, IsString a) => [Diff a] -> [a]+showDiffs = map showDiff++showDiff :: (Semigroup a, IsString a) => Diff a -> a+showDiff (First w) = "WAS " <> w+showDiff (Second w) = "NOW " <> w+showDiff (Both w _) = w++testCheck :: (Section, Test) -> [T.Text] -> [T.Text]+testCheck (section, test) out+ | null (testOutput test) || sectionLanguage section == Plain = 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)++-- |A one-line Haskell statement+type Statement = Loc String++asStatements :: Loc Test -> [Statement]+asStatements lt = locate (asStmts <$> lt)++asStmts :: Test -> [Txt]+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)+evalExpr :: GhcMonad m => [Char] -> m String+evalExpr e = do+ res <- compileExpr $ "asPrint (" ++ e ++ ")"+ liftIO (unsafeCoerce res :: IO String)++-- |GHC extensions required for expression evaluation+evalExtensions :: [Extension]+evalExtensions =+ [ OverlappingInstances+ , UndecidableInstances+ , FlexibleInstances+ , IncoherentInstances+ , TupleSections+ ]++-- |GHC declarations required for expression evaluation+evalSetup :: Ghc ()+evalSetup =+ mapM_+ runDecls+ [ "class Print f where asPrint :: f -> IO String"+ , "instance Show a => Print (IO a) where asPrint io = io >>= return . show"+ , "instance Show a => Print a where asPrint a = return (show a)"+ ]++{- |GHC declarations required to execute test properties++Example:++prop> \(l::[Bool]) -> reverse (reverse l) == l++++ OK, passed 100 tests.++prop> \(l::[Bool]) -> reverse l == l+*** Failed! Falsified (after 6 tests and 2 shrinks):+[True,False]+-}+propSetup :: [Loc [Char]]+propSetup =+ locate0+ [ ":set -XScopedTypeVariables -XExplicitForAll"+ , "import qualified Test.QuickCheck as Q11"+ , "propEvaluation p = Q11.quickCheckWithResult Q11.stdArgs p >>= error . Q11.output" -- uses `error` to get a multi-line display+ ]
+ src/Ide/Plugin/Eval/CodeLens.hs view
@@ -0,0 +1,782 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++{- |+A plugin inspired by the REPLoid feature of <https://github.com/jyp/dante Dante>, <https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744 Haddock>'s Examples and Properties and <https://hackage.haskell.org/package/doctest Doctest>.++For a full example see the "Ide.Plugin.Eval.Tutorial" module.+-}+module Ide.Plugin.Eval.CodeLens (+ codeLens,+ evalCommand,+) where++import Control.Applicative (Alternative ((<|>)))+import Control.Arrow (second)+import qualified Control.Exception as E+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 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 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 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 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 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.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 Language.Haskell.LSP.VFS (virtualFileText)+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))++{- | 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} =+ let dbg = logWith st+ perf = timed dbg+ in perf "codeLens" $+ response $ do+ let TextDocumentIdentifier uri = _textDocument+ fp <- handleMaybe "uri" $ uriToFilePath' uri+ 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++ 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++ -- Extract tests from source code+ let Right (setups, nonSetups) =+ (splitSections . filter hasTests <$>)+ . allSections+ . tokensFrom+ . T.unpack+ $ text+ let tests = testsBySection nonSetups++ 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+ cmd' =+ (cmd :: Command)+ { _arguments = Just (List [toJSON args])+ , _title =+ if trivial resultRange+ then "Evaluate..."+ else "Refresh..."+ }+ ]++ perf "tests" $+ dbg "Tests" $+ unwords+ [ show (length tests)+ , "tests in"+ , show (length nonSetups)+ , "sections"+ , show (length setups)+ , "setups"+ , show (length lenses)+ , "lenses."+ ]++ return $ List lenses+ where+ trivial (Range p p') = p == p'++evalCommandName :: CommandId+evalCommandName = "evalCommand"++evalCommand :: PluginCommand IdeState+evalCommand = PluginCommand evalCommandName "evaluate" runEvalCmd++-- |Specify the test section to execute+data EvalParams = EvalParams+ { sections :: [Section]+ , module_ :: !TextDocumentIdentifier+ }+ deriving (Eq, Show, Generic, FromJSON, ToJSON)++runEvalCmd :: CommandFunction IdeState EvalParams+runEvalCmd lsp st EvalParams{..} =+ let dbg = logWith st+ perf = timed dbg+ cmd = do+ let tests = testsBySection sections++ let TextDocumentIdentifier{_uri} = module_+ fp <- handleMaybe "uri" $ uriToFilePath' _uri+ let nfp = toNormalizedFilePath' fp+ mdlText <- moduleText lsp _uri++ session <- runGetSession st nfp++ (ms, _) <-+ liftIO $+ runAction "runEvalCmd.getModSummary" st $+ use_ GetModSummary nfp++ now <- liftIO getCurrentTime++ let modName = moduleName $ ms_mod ms+ thisModuleTarget =+ Target+ (TargetFile fp Nothing)+ False+ (Just (textToStringBuffer mdlText, now))++ -- Setup environment for evaluation+ hscEnv' <- withSystemTempFile (takeFileName fp) $ \logFilename logHandle -> ExceptT . (either Left id <$>) . gStrictTry . evalGhcEnv (hscEnvWithImportPaths session) $ do+ env <- getSession++ -- Install the module pragmas and options+ df <- liftIO $ setupDynFlagsForGHCiLike env $ ms_hspp_opts ms++ let impPaths = fromMaybe (importPaths df) (envImportPaths session)+ -- Restore the cradle import paths+ df <- return df{importPaths = impPaths}++ -- Set the modified flags in the session+ _lp <- setSessionDynFlags df++ -- property tests need QuickCheck+ when (needsQuickCheck tests) $ void $ addPackages ["QuickCheck"]+ dbg "QUICKCHECK NEEDS" $ needsQuickCheck tests+ dbg "QUICKCHECK HAS" $ hasQuickCheck df++ -- copy the package state to the interactive DynFlags+ idflags <- getInteractiveDynFlags+ df <- getSessionDynFlags+ setInteractiveDynFlags $+ (foldl xopt_set idflags evalExtensions)+ { pkgState =+ pkgState+ df+ , pkgDatabase =+ pkgDatabase+ df+ , packageFlags =+ packageFlags+ df+ , useColor = Never+ , canUseColor = False+ }++ -- set up a custom log action+ setLogAction $ \_df _wr _sev _span _style _doc ->+ defaultLogActionHPutStrDoc _df logHandle _doc _style++ -- Load the module with its current content (as the saved module might not be up to date)+ -- BUG: this fails for files that requires preprocessors (e.g. CPP) for ghc < 8.8+ -- see https://gitlab.haskell.org/ghc/ghc/-/issues/17066+ -- and https://hackage.haskell.org/package/ghc-8.10.1/docs/GHC.html#v:TargetFile+ eSetTarget <- gStrictTry $ setTargets [thisModuleTarget]+ dbg "setTarget" eSetTarget++ -- load the module in the interactive environment+ loadResult <- perf "loadModule" $ load LoadAllTargets+ dbg "LOAD RESULT" $ asS loadResult+ case loadResult of+ Failed -> liftIO $ do+ hClose logHandle+ err <- readFile logFilename+ dbg "load ERR" err+ return $ Left err+ Succeeded -> do+ -- Evaluation takes place 'inside' the module+ setContext [IIModule modName]+ Right <$> getSession++ edits <-+ perf "edits" $+ liftIO $+ evalGhcEnv hscEnv' $+ runTests+ (st, fp)+ tests++ let workspaceEditsMap = Map.fromList [(_uri, List edits)]+ let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing++ return (WorkspaceApplyEdit, ApplyWorkspaceEditParams workspaceEdits)+ in perf "evalCmd" $+ withIndefiniteProgress lsp "Evaluating" Cancellable $+ response' cmd++moduleText :: (IsString e, MonadIO m) => LspFuncs c -> Uri -> ExceptT e m Text+moduleText lsp uri =+ handleMaybeM "mdlText" $+ liftIO $+ (virtualFileText <$>)+ <$> getVirtualFileFunc+ lsp+ (toNormalizedUri uri)++testsBySection :: [Section] -> [(Section, Loc Test)]+testsBySection sections =+ [(section, test) | section <- sections, test <- sectionTests section]++type TEnv = (IdeState, String)++runTests :: TEnv -> [(Section, Loc Test)] -> Ghc [TextEdit]+runTests e@(_st, _) tests = do+ df <- getInteractiveDynFlags+ evalSetup+ when (hasQuickCheck df && needsQuickCheck tests) $ void $ evals e df propSetup++ mapM (processTest e df) tests+ where+ processTest :: TEnv -> DynFlags -> (Section, Loc 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)++ rs <- runTest e df test+ dbg "TEST RESULTS" rs++ let checkedResult = testCheck (section, unLoc test) rs++ let edit = TextEdit (resultRange test) (T.unlines . 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) =+ return $+ singleLine+ "Add QuickCheck to your cabal dependencies to run this test."+ runTest e df test = evals e df (asStatements test)++{-+The result of evaluating a test line can be:+* a value+* nothing+* a (possibly multiline) error message++A value is returned for a correct expression.++Either a pure value:+>>> 'h' :"askell"+"haskell"++Or an 'IO a' (output on stdout/stderr is ignored):+>>> print "OK" >> return "ABC"+"ABC"++Nothing is returned for a correct directive:++>>>:set -XFlexibleInstances+>>> import Data.Maybe++Nothing is returned for a correct declaration (let..,x=, data, class)++>>> let x = 11+>>> y = 22+>>> data B = T | F+>>> class C a++Nothing is returned for an empty line:++>>>++A, possibly multi line, error is returned for a wrong declaration, directive or value or an exception thrown by the evaluated code:++>>>:set -XNonExistent+Unknown extension: "NonExistent"++>>> cls C+Variable not in scope: cls :: t0 -> f0+Data constructor not in scope: C++>>> "A+lexical error in string/character literal at end of input++>>> 3 `div` 0+divide by zero++>>> error "Something went wrong\nbad times" :: E.SomeException+Something went wrong+bad times++Or for a value that does not have a Show instance and can therefore not be displayed:+>>> data V = V+>>> V+No instance for (Show V)+-}+evals :: TEnv -> DynFlags -> [Statement] -> Ghc [Text]+evals (st, fp) df stmts = do+ er <- gStrictTry $ mapM eval stmts+ return $ case er of+ Left err -> errorLines err+ Right rs -> concat . catMaybes $ rs+ where+ dbg = logWith st+ eval :: Statement -> Ghc (Maybe [Text])+ eval (Located l stmt)+ | -- A :set -XLanguageOption directive+ isRight (langOptions stmt) =+ either+ (return . Just . errorLines)+ ( \es -> do+ dbg "{:SET" es+ ndf <- getInteractiveDynFlags+ dbg "pre set" $ showDynFlags ndf+ mapM_ addExtension es+ ndf <- getInteractiveDynFlags+ dbg "post set" $ showDynFlags ndf+ return Nothing+ )+ $ ghcOptions stmt+ | -- A type/kind command+ Just (cmd, arg) <- parseGhciLikeCmd $ T.pack stmt =+ evalGhciLikeCmd cmd arg+ | -- An expression+ isExpr df stmt =+ do+ dbg "{EXPR" stmt+ eres <- gStrictTry $ evalExpr stmt+ dbg "RES ->" eres+ let res = case eres of+ Left err -> errorLines err+ Right rs -> [T.pack rs]+ dbg "EXPR} ->" res+ return . Just $ res+ | -- A statement+ isStmt df stmt =+ do+ dbg "{STMT " stmt+ res <- exec stmt l+ r <- case res of+ ExecComplete (Left err) _ -> return . Just . errorLines . show $ err+ ExecComplete (Right _) _ -> return Nothing+ ExecBreak{} ->+ return . Just . singleLine $ "breakpoints are not supported"+ dbg "STMT} -> " r+ return r+ | -- An import+ isImport df stmt =+ do+ dbg "{IMPORT " stmt+ _ <- addImport stmt+ return Nothing+ | -- A declaration+ otherwise =+ do+ dbg "{DECL " stmt+ void $ runDecls stmt+ return Nothing+ exec stmt l =+ let opts = execOptions{execSourceFile = fp, execLineNumber = l}+ in execStmt stmt opts++runGetSession :: MonadIO m => IdeState -> NormalizedFilePath -> m HscEnvEq+runGetSession st nfp =+ liftIO $+ runAction "getSession" st $+ use_+ GhcSession+ -- GhcSessionDeps+ nfp++needsQuickCheck :: [(Section, Loc Test)] -> Bool+needsQuickCheck = any (isProperty . unLoc . snd)++hasQuickCheck :: DynFlags -> Bool+hasQuickCheck df = hasPackage df "QuickCheck"++singleLine :: String -> [Text]+singleLine s = [T.pack s]++{- |+ Convert error messages to a list of text lines+ Remove unnecessary information.+-}+errorLines :: String -> [Text]+errorLines =+ map (\e -> fromMaybe e (T.stripSuffix "arising from a use of ‘asPrint’" e))+ . dropWhileEnd T.null+ . takeWhile (not . ("CallStack" `T.isPrefixOf`))+ . T.lines+ . T.pack++{-+Check that extensions actually exists.++>>> ghcOptions ":set -XLambdaCase"+Right [LambdaCase]+>>> ghcOptions ":set -XLambdaCase -XNotRight"+Left "Unknown extension: \"NotRight\""+-}+ghcOptions :: [Char] -> Either String [LangExt.Extension]+ghcOptions = either Left (mapM chk) . langOptions+ where+ chk o =+ maybe+ (Left $ unwords ["Unknown extension:", show o])+ Right+ (readMaybe o :: Maybe LangExt.Extension)++{- |+>>> map (pad_ (T.pack "--")) (map T.pack ["2+2",""])+["--2+2","--<BLANKLINE>"]+-}+pad_ :: Text -> Text -> Text+pad_ prefix = (prefix `T.append`) . convertBlank++convertBlank :: Text -> Text+convertBlank x+ | T.null x = "<BLANKLINE>"+ | otherwise = x++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'.+-}+type GHCiLikeCmd = DynFlags -> Text -> Ghc (Maybe Text)++-- Should we use some sort of trie here?+ghciLikeCommands :: [(Text, GHCiLikeCmd)]+ghciLikeCommands =+ [("kind", doKindCmd False), ("kind!", doKindCmd True), ("type", doTypeCmd)]++evalGhciLikeCmd :: Text -> Text -> Ghc (Maybe [Text])+evalGhciLikeCmd cmd arg = do+ df <- getSessionDynFlags+ case lookup cmd ghciLikeCommands+ <|> snd+ <$> find (T.isPrefixOf cmd . fst) ghciLikeCommands of+ Just hndler ->+ fmap+ T.lines+ <$> hndler df arg+ _ -> E.throw $ GhciLikeCmdNotImplemented cmd arg++doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text)+doKindCmd False df arg = do+ let input = T.strip arg+ (_, kind) <- typeKind False $ T.unpack input+ let kindText = text (T.unpack input) <+> "::" <+> ppr kind+ pure $ Just $ T.pack (showSDoc df kindText)+doKindCmd True df arg = do+ let input = T.strip arg+ (ty, kind) <- typeKind True $ T.unpack input+ let kindDoc = text (T.unpack input) <+> "::" <+> ppr kind+ tyDoc = "=" <+> ppr ty+ pure $ Just $ T.pack (showSDoc df $ kindDoc $$ tyDoc)++doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text)+doTypeCmd dflags arg = do+ let (emod, expr) = parseExprMode arg+ ty <- exprType emod $ T.unpack expr+ let rawType = T.strip $ T.pack $ showSDoc dflags $ ppr ty+ broken = T.any (\c -> c == '\r' || c == '\n') rawType+ pure $+ Just $+ if broken+ then+ T.pack $+ showSDoc dflags $+ text (T.unpack expr)+ $$ nest 2 ("::" <+> ppr ty)+ else expr <> " :: " <> rawType <> "\n"++parseExprMode :: Text -> (TcRnExprMode, T.Text)+parseExprMode rawArg = case T.break isSpace rawArg of+ ("+v", rest) -> (TM_NoInst, T.strip rest)+ ("+d", rest) -> (TM_Default, T.strip rest)+ _ -> (TM_Inst, rawArg)++data GhciLikeCmdException = GhciLikeCmdNotImplemented+ { ghciCmdName :: Text+ , ghciCmdArg :: Text+ }+ deriving (Typeable)++instance Show GhciLikeCmdException where+ showsPrec _ GhciLikeCmdNotImplemented{..} =+ showString "unknown command '"+ . showString (T.unpack ghciCmdName)+ . showChar '\''++instance E.Exception GhciLikeCmdException++{-+>>> parseGhciLikeCmd (T.pack ":kind! N + M + 1")+Just ("kind!","N + M + 1")+>>> parseGhciLikeCmd (T.pack ":kind a")+Just ("kind","a")+-}+parseGhciLikeCmd :: Text -> Maybe (Text, Text)+parseGhciLikeCmd input = do+ (':', rest) <- T.uncons $ T.stripStart input+ pure $ second T.strip $ T.break isSpace rest++setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags+setupDynFlagsForGHCiLike env dflags = do+ let dflags3 =+ dflags+ { hscTarget = HscInterpreted+ , ghcMode = CompManager+ , ghcLink = LinkInMemory+ }+ platform = targetPlatform dflags3+ dflags3a = updateWays $ dflags3{ways = interpWays}+ dflags3b =+ foldl gopt_set dflags3a $+ concatMap (wayGeneralFlags platform) interpWays+ dflags3c =+ foldl gopt_unset dflags3b $+ concatMap (wayUnsetGeneralFlags platform) interpWays+ dflags4 =+ dflags3c+ `gopt_set` Opt_ImplicitImportQualified+ `gopt_set` Opt_IgnoreOptimChanges+ `gopt_set` Opt_IgnoreHpcChanges+ `gopt_unset` Opt_DiagnosticsShowCaret+ initializePlugins env dflags4
+ src/Ide/Plugin/Eval/GHC.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-unused-imports -Wno-orphans #-}++-- |GHC API utilities+module Ide.Plugin.Eval.GHC (+ isExpr,+ addExtension,+ addImport,+ hasPackage,+ addPackages,+ modifyFlags,+ showDynFlags,+) where++import Data.List (isPrefixOf)+import Data.Maybe (mapMaybe)+import Development.IDE.GHC.Compat+import qualified EnumSet+import GHC.LanguageExtensions.Type (Extension (..))+import GhcMonad (modifySession)+import GhcPlugins (DefUnitId (..), InstalledUnitId (..), fsLit, hsc_IC)+import HscTypes (InteractiveContext (ic_dflags))+import Ide.Plugin.Eval.Util (asS, gStrictTry)+import qualified Lexer+import Module (UnitId (DefiniteUnitId))+import Outputable (+ Outputable (ppr),+ SDoc,+ showSDocUnsafe,+ text,+ vcat,+ (<+>),+ )+import qualified Parser+import SrcLoc (mkRealSrcLoc)+import StringBuffer (stringToStringBuffer)++{- $setup+>>> import GHC+>>> import GHC.Paths+>>> run act = runGhc (Just libdir) (getInteractiveDynFlags >>= act)+>>> libdir+"/Users/titto/.ghcup/ghc/8.8.4/lib/ghc-8.8.4"+-}++{- | Returns true if string is an expression++>>> isExprTst e df = return (isExpr df e)+>>> run $ isExprTst "3"+True++>>> run $ isExprTst "(x+y)"+True++>>> run $ isExprTst "import Data.Maybe"+False++>>> run $ isExprTst "three=3"+False+-}+isExpr :: DynFlags -> String -> Bool+isExpr df stmt = case parseThing Parser.parseExpression df stmt of+ Lexer.POk _ _ -> True+ Lexer.PFailed{} -> False++parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing+parseThing parser dflags stmt = do+ let buf = stringToStringBuffer stmt+ loc = mkRealSrcLoc (fsLit "<interactive>") 1 1++ Lexer.unP parser (Lexer.mkPState dflags buf loc)++{- | True if specified package is present in DynFlags++-- >>> hasPackageTst pkg = run $ \df -> return (hasPackage df pkg)+>>> hasPackageTst pkg = run $ \_ -> addPackages [pkg] >>= return . either Left (\df -> Right (hasPackage df pkg))++>>> hasPackageTst "base"+Right True++>>> hasPackageTst "ghc"+Right True++>>> hasPackageTst "extra"+Left "<command line>: cannot satisfy -package extra\n (use -v for more information)"++>>> hasPackageTst "QuickCheck"+Left "<command line>: cannot satisfy -package QuickCheck\n (use -v for more information)"+-}+hasPackage :: DynFlags -> String -> Bool+hasPackage df = hasPackage_ (packageFlags df)++hasPackage_ :: [PackageFlag] -> [Char] -> Bool+hasPackage_ pkgFlags name = any (name `isPrefixOf`) (pkgNames_ pkgFlags)++{- |+>>> run (return . pkgNames)+[]+-}+pkgNames :: DynFlags -> [String]+pkgNames = pkgNames_ . packageFlags++pkgNames_ :: [PackageFlag] -> [String]+pkgNames_ =+ mapMaybe+ ( \case+ ExposePackage _ (PackageArg n) _ -> Just n+ ExposePackage _ (UnitIdArg (DefiniteUnitId n)) _ -> Just $ asS n+ _ -> Nothing+ )++{- | Expose a list of packages.+>>> addPackagesTest pkgs = run (\_ -> (packageFlags <$>) <$> addPackages pkgs)++>>> addPackagesTest []+Right []++>>> addPackagesTest ["base","base","array"]+Right [-package base{package base True ([])},-package array{package array True ([])}]++>>> addPackagesTest ["Cabal"]+Right [-package Cabal{package Cabal True ([])}]++>>> addPackagesTest ["QuickCheck"]+Left "<command line>: cannot satisfy -package QuickCheck\n (use -v for more information)"++>>> addPackagesTest ["base","notThere"]+Left "<command line>: cannot satisfy -package notThere\n (use -v for more information)"++prop> \(x::Int) -> x + x == 2 * x++++ OK, passed 100 tests.+-}+addPackages :: [String] -> Ghc (Either String DynFlags)+addPackages pkgNames = gStrictTry $+ modifyFlags $ \df ->+ df{packageFlags = foldr (\pkgName pf -> if hasPackage_ pf pkgName then pf else expose pkgName : pf) (packageFlags df) pkgNames}+ where+ expose name = ExposePackage ("-package " ++ name) (PackageArg name) (ModRenaming True [])++modifyFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m DynFlags+modifyFlags f = do+ df <- getSessionDynFlags+ _ <- setSessionDynFlags (f df)+ getSessionDynFlags++-- modifyFlags f = do+-- modifyDynFlags f+-- getSessionDynFlags++{- | Add import to evaluation context++>>> run $ \_ -> addImport "import Data.Maybe"+Could not find module ‘Data.Maybe’+Use -v (or `:set -v` in ghci) to see a list of the files searched for.++>>> run $ \df -> addPackages ["base"] >> addImport "import Data.Maybe"+[import Data.Maybe]++>>> run $ \df -> addPackages ["base"] >> addImport "import qualified Data.Maybe as M"+[import qualified Data.Maybe as M]+-}+addImport :: GhcMonad m => String -> m [InteractiveImport]+addImport i = do+ ctx <- getContext+ -- dbgO "CONTEXT" ctx+ idecl <- parseImportDecl i+ setContext $ IIDecl idecl : ctx+ -- ctx' <- getContext+ -- dbg "CONTEXT'" ctx'+ getContext++{- | Add extension to interactive evaluation session+>>> import GHC.LanguageExtensions.Type(Extension(..))+>>> run $ \_ -> addExtension DeriveGeneric+()+-}+addExtension :: GhcMonad m => Extension -> m ()+addExtension ext =+ modifySession $ \hsc -> hsc{hsc_IC = setExtension (hsc_IC hsc) ext}++setExtension :: InteractiveContext -> Extension -> InteractiveContext+setExtension ic ext = ic{ic_dflags = xopt_set (ic_dflags ic) ext}++deriving instance Read Extension++-- Partial display of DynFlags contents, for testing purposes+showDynFlags :: DynFlags -> String+showDynFlags df =+ showSDocUnsafe . vcat . map (\(n, d) -> text (n ++ ": ") <+> d) $+ [ ("extensions", ppr . extensions $ df)+ , ("extensionFlags", ppr . EnumSet.toList . extensionFlags $ df)+ , ("importPaths", vList $ importPaths df)+ , -- , ("includePaths", text . show $ includePaths df)+ -- ("packageEnv", ppr $ packageEnv df)+ ("pkgNames", vcat . map text $ pkgNames df)+ , ("packageFlags", vcat . map ppr $ packageFlags df)+ -- ,("pkgDatabase",(map) (ppr . installedPackageId) . pkgDatabase $ df)+ -- ("pkgDatabase", text . show <$> pkgDatabase $ df)+ ]++vList :: [String] -> SDoc+vList = vcat . map text
+ src/Ide/Plugin/Eval/Parse/Option.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -Wwarn #-}++-- | GHC language options parser+module Ide.Plugin.Eval.Parse.Option (+ langOptions,+) where++import Control.Monad.Combinators (many)+import Ide.Plugin.Eval.Parse.Parser (+ Parser,+ letterChar,+ runParser,+ space,+ string,+ )++{- |+>>> langOptions ":set -XBinaryLiterals -XOverloadedStrings "+Right ["BinaryLiterals","OverloadedStrings"]++>>> langOptions ":set"+Right []++>>> langOptions ""+Left "No match"+-}+langOptions :: [Char] -> Either String [[Char]]+langOptions = runParser (many space *> languageOpts <* many space)++-- >>> runParser languageOpts ":set -XBinaryLiterals -XOverloadedStrings"+-- Right ["BinaryLiterals","OverloadedStrings"]+languageOpts :: Parser Char [[Char]]+languageOpts = string ":set" *> many (many space *> string "-X" *> (many letterChar))
+ src/Ide/Plugin/Eval/Parse/Parser.hs view
@@ -0,0 +1,98 @@+{-# 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 view
@@ -0,0 +1,141 @@+{-# 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 view
@@ -0,0 +1,283 @@+{-# 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
@@ -0,0 +1,94 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# OPTIONS_GHC -Wwarn #-}++module Ide.Plugin.Eval.Types (+ locate,+ locate0,+ Test (..),+ isProperty,+ Format (..),+ Language (..),+ Section (..),+ hasTests,+ hasPropertyTest,+ splitSections,+ Loc,+ Located (..),+ 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)++-- | A thing with a location attached.+data Located l a = Located {location :: l, located :: a}+ deriving (Eq, Show, Ord, Functor, Generic, FromJSON, ToJSON)++-- | Discard location information.+unLoc :: Located l a -> a+unLoc (Located _ a) = a++instance (NFData l, NFData a) => NFData (Located l a) where+ rnf (Located loc a) = loc `deepseq` a `deepseq` ()++type Loc = Located Line++type Line = Int++locate :: Loc [a] -> [Loc a]+locate (Located l tst) = zipWith Located [l ..] tst++locate0 :: [a] -> [Loc a]+locate0 = locate . Located 0++type Txt = String++data Section = Section+ { sectionName :: Txt+ , sectionTests :: [Loc 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++-- |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]}+ deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData)++isProperty :: Test -> Bool+isProperty (Property _ _) = True+isProperty _ = False++data Format = SingleLine | MultiLine 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+ deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData)++instance IsString ExpectedLine where+ fromString = ExpectedLine . return . LineChunk++data LineChunk = LineChunk String | WildCardChunk+ deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData)++instance IsString LineChunk where+ fromString = LineChunk
+ src/Ide/Plugin/Eval/Util.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- |Debug utilities+module Ide.Plugin.Eval.Util (+ asS,+ timed,+ isLiterate,+ handleMaybe,+ handleMaybeM,+ response,+ response',+ gStrictTry,+ logWith,+) where++import Control.Monad (join)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (+ ExceptT (..),+ runExceptT,+ throwE,+ )+import Data.Aeson (Value (Null))+import Data.Bifunctor (first)+import Data.String (IsString (fromString))+import qualified Data.Text as T+import Development.IDE (+ IdeState,+ Priority (..),+ ideLogger,+ logPriority,+ )+import Exception (ExceptionMonad, SomeException (..), evaluate, gcatch)+import GHC.Exts (toList)+import GHC.Stack (HasCallStack, callStack, srcLocFile, srcLocStartCol, srcLocStartLine)+import Language.Haskell.LSP.Types (+ ErrorCode (InternalError),+ ResponseError (ResponseError),+ )+import Outputable (+ Outputable (ppr),+ ppr,+ showSDocUnsafe,+ )+import System.FilePath (takeExtension)+import System.Time.Extra (+ duration,+ showDuration,+ )++asS :: Outputable a => a -> String+asS = showSDocUnsafe . ppr++timed :: MonadIO m => (t -> String -> m a) -> t -> m b -> m b+timed out name op = do+ (secs, r) <- duration op+ _ <- out name (showDuration secs)+ return r++-- |Log using hie logger, reports source position of logging statement+logWith :: (HasCallStack, MonadIO m, Show a1, Show a2) => IdeState -> a1 -> a2 -> m ()+logWith state key val =+ liftIO . logPriority (ideLogger state) logLevel $+ T.unwords+ [T.pack logWithPos, asT key, asT val]+ where+ logWithPos =+ let stk = toList callStack+ pr pos = concat [srcLocFile pos, ":", show . srcLocStartLine $ pos, ":", show . srcLocStartCol $ pos]+ in if null stk then "" else pr . snd . head $ stk++ asT :: Show a => a -> T.Text+ asT = T.pack . show++-- | Set to Info to see extensive debug info in hie log, set to Debug in production+logLevel :: Priority+logLevel = Debug -- Info++isLiterate :: FilePath -> Bool+isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"]++handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b+handleMaybe msg = maybe (throwE msg) return++handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b+handleMaybeM msg act = maybe (throwE msg) return =<< lift act++response :: Functor f => ExceptT String f c -> f (Either ResponseError c)+response =+ fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing))+ . runExceptT++response' :: ExceptT String IO a -> IO (Either ResponseError Value, Maybe a)+response' act = do+ res <- gStrictTry $ runExceptT act+ case join res of+ Left e ->+ return+ (Left (ResponseError InternalError (fromString e) Nothing), Nothing)+ Right a -> return (Right Null, Just a)++gStrictTry :: ExceptionMonad m => m b -> m (Either String b)+gStrictTry op =+ gcatch+ (op >>= fmap Right . gevaluate)+ showErr++gevaluate :: MonadIO m => a -> m a+gevaluate = liftIO . evaluate++showErr :: Monad m => SomeException -> m (Either String b)+showErr = return . Left . show