diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/hls-eval-plugin.cabal b/hls-eval-plugin.cabal new file mode 100644 --- /dev/null +++ b/hls-eval-plugin.cabal @@ -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 diff --git a/src/Ide/Plugin/Eval.hs b/src/Ide/Plugin/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Eval.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wwarn #-} + +{- | +A plugin inspired by: + +* the REPLoid feature of + +* 's Examples and Properties + +* + +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] + } diff --git a/src/Ide/Plugin/Eval/Code.hs b/src/Ide/Plugin/Eval/Code.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Eval/Code.hs @@ -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 + ] diff --git a/src/Ide/Plugin/Eval/CodeLens.hs b/src/Ide/Plugin/Eval/CodeLens.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Eval/CodeLens.hs @@ -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 , 's Examples and Properties and . + +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","--"] +-} +pad_ :: Text -> Text -> Text +pad_ prefix = (prefix `T.append`) . convertBlank + +convertBlank :: Text -> Text +convertBlank x + | T.null x = "" + | 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 diff --git a/src/Ide/Plugin/Eval/GHC.hs b/src/Ide/Plugin/Eval/GHC.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Eval/GHC.hs @@ -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 "") 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 ": cannot satisfy -package extra\n (use -v for more information)" + +>>> hasPackageTst "QuickCheck" +Left ": 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 ": cannot satisfy -package QuickCheck\n (use -v for more information)" + +>>> addPackagesTest ["base","notThere"] +Left ": 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 diff --git a/src/Ide/Plugin/Eval/Parse/Option.hs b/src/Ide/Plugin/Eval/Parse/Option.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Eval/Parse/Option.hs @@ -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)) diff --git a/src/Ide/Plugin/Eval/Parse/Parser.hs b/src/Ide/Plugin/Eval/Parse/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Eval/Parse/Parser.hs @@ -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" diff --git a/src/Ide/Plugin/Eval/Parse/Section.hs b/src/Ide/Plugin/Eval/Parse/Section.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Eval/Parse/Section.hs @@ -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) diff --git a/src/Ide/Plugin/Eval/Parse/Token.hs b/src/Ide/Plugin/Eval/Parse/Token.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Eval/Parse/Token.hs @@ -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 diff --git a/src/Ide/Plugin/Eval/Types.hs b/src/Ide/Plugin/Eval/Types.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Eval/Types.hs @@ -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 diff --git a/src/Ide/Plugin/Eval/Util.hs b/src/Ide/Plugin/Eval/Util.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Eval/Util.hs @@ -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