diff --git a/.circleci/config.yml b/.circleci/config.yml index 89ddb3b5dd..53038c4933 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -36,8 +36,8 @@ defaults: &defaults - run: name: Build (we need the exe for tests) + # need j1, else ghc-lib-parser triggers OOM command: stack -j 1 --stack-yaml=${STACK_FILE} install - # need j1, else ghc-lib-parser triggers OOM no_output_timeout: 30m - run: @@ -63,6 +63,14 @@ defaults: &defaults command: echo "ghcide tests disabled until they got fixed, see https://github.com/mpickering/ghcide/issues/25" no_output_timeout: 120m + - run: + name: Setup stack eval hie.html + command: cp test/testdata/eval/hie-stack.yaml test/testdata/eval/hie.yaml + + - run: + name: Setup stack eval stack.html + command: grep '^resolver:\|^compiler:' stack-build.txt > test/testdata/eval/stack.yaml + - run: name: Test haskell-language-server func-test suite # Tasty by default will run all the tests in parallel. Which should diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index a948d6e55f..e5ee7e62bb 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -7,76 +7,76 @@ jobs: strategy: fail-fast: false matrix: - ghc: ['8.10.2', '8.10.1', '8.8.4', '8.8.3', '8.8.2', '8.6.5', '8.6.4'] + ghc: ["8.10.2", "8.10.1", "8.8.4", "8.8.3", "8.8.2", "8.6.5", "8.6.4"] os: [ubuntu-latest, macOS-latest, windows-latest] exclude: - os: windows-latest - ghc: '8.10.2' # broken due to https://gitlab.haskell.org/ghc/ghc/-/issues/18550 + ghc: "8.10.2" # broken due to https://gitlab.haskell.org/ghc/ghc/-/issues/18550 - os: windows-latest - ghc: '8.8.4' # also fails due to segfault :( + ghc: "8.8.4" # also fails due to segfault :( - os: windows-latest - ghc: '8.8.3' # fails due to segfault + ghc: "8.8.3" # fails due to segfault - os: windows-latest - ghc: '8.8.2' # fails due to error with Cabal + ghc: "8.8.2" # fails due to error with Cabal include: - os: windows-latest - ghc: '8.10.2.2' # only available for windows and choco + ghc: "8.10.2.2" # only available for windows and choco steps: - - uses: actions/checkout@v2 - with: - submodules: true - - uses: actions/setup-haskell@v1 - with: - ghc-version: ${{ matrix.ghc }} - cabal-version: '3.2' - enable-stack: true + - uses: actions/checkout@v2 + with: + submodules: true + - uses: actions/setup-haskell@v1 + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: "3.2" + enable-stack: true - - name: Cache Cabal - uses: actions/cache@v2 - env: - cache-name: cache-cabal - with: - path: ~/.cabal/ - key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} - restore-keys: | - ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}- - ${{ runner.os }}-${{ matrix.ghc }}-build- - ${{ runner.os }}-${{ matrix.ghc }} + - name: Cache Cabal + uses: actions/cache@v2 + env: + cache-name: cache-cabal + with: + path: ~/.cabal/ + key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} + restore-keys: | + ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}- + ${{ runner.os }}-${{ matrix.ghc }}-build- + ${{ runner.os }}-${{ matrix.ghc }} - - run: cabal update + - run: cabal update - # Need this to work around filepath length limits in Windows - - name: Shorten binary names - shell: bash - run: | - sed -i.bak -e 's/haskell-language-server/hls/g' \ - -e 's/haskell_language_server/hls/g' \ - haskell-language-server.cabal - sed -i.bak -e 's/Paths_haskell_language_server/Paths_hls/g' \ - src/**/*.hs exe/*.hs + # Need this to work around filepath length limits in Windows + - name: Shorten binary names + shell: bash + run: | + sed -i.bak -e 's/haskell-language-server/hls/g' \ + -e 's/haskell_language_server/hls/g' \ + haskell-language-server.cabal + sed -i.bak -e 's/Paths_haskell_language_server/Paths_hls/g' \ + src/**/*.hs exe/*.hs - - name: Build - shell: bash - # Retry it three times to workaround compiler segfaults in windows - run: cabal build || cabal build || cabal build + - name: Build + shell: bash + # Retry it three times to workaround compiler segfaults in windows + run: cabal build || cabal build || cabal build - - name: Test func-test suite - shell: bash - env: - HLS_TEST_EXE: hls - HLS_WRAPPER_TEST_EXE: hls-wrapper - # run the tests without parallelism, otherwise tasty will attempt to run - # all functional test cases simultaneously which causes way too many hls - # instances to be spun up for the poor github actions runner to handle - run: cabal test func-test --test-options="-j1 --rerun-update" || cabal test func-test --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test func-test --test-options="-j1 --rerun" + - name: Test func-test suite + shell: bash + env: + HLS_TEST_EXE: hls + HLS_WRAPPER_TEST_EXE: hls-wrapper + # run the tests without parallelism, otherwise tasty will attempt to run + # all functional test cases simultaneously which causes way too many hls + # instances to be spun up for the poor github actions runner to handle + run: cabal test func-test --test-options="-j1 --rerun-update" || cabal test func-test --test-options="-j1 --rerun --rerun-update" || cabal test func-test --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test func-test --test-options="-j1 --rerun" - - name: Test wrapper-test suite - shell: bash - env: - HLS_TEST_EXE: hls - HLS_WRAPPER_TEST_EXE: hls-wrapper - # run the tests without parallelism, otherwise tasty will attempt to run - # all functional test cases simultaneously which causes way too many hls - # instances to be spun up for the poor github actions runner to handle - run: cabal test wrapper-test --test-options="-j1" || cabal test wrapper-test --test-options="-j1" || cabal test wrapper-test --test-options="-j1" + - name: Test wrapper-test suite + shell: bash + env: + HLS_TEST_EXE: hls + HLS_WRAPPER_TEST_EXE: hls-wrapper + # run the tests without parallelism, otherwise tasty will attempt to run + # all functional test cases simultaneously which causes way too many hls + # instances to be spun up for the poor github actions runner to handle + run: cabal test wrapper-test --test-options="-j1" || cabal test wrapper-test --test-options="-j1" || cabal test wrapper-test --test-options="-j1" diff --git a/exe/Main.hs b/exe/Main.hs index d3da416661..bac9b40924 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -8,10 +8,10 @@ import Ide.Arguments (Arguments (..), LspArguments (..), getArguments) import Ide.Main (defaultMain) import Plugins - +import Main.Utf8 (withUtf8) main :: IO () -main = do +main = withUtf8 $ do args <- getArguments "haskell-language-server" let withExamples = diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 1a41727cd1..ea9517f08e 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -157,7 +157,16 @@ common example-plugins common eval if flag(eval) || flag(all-plugins) hs-source-dirs: plugins/default/src - other-modules: Ide.Plugin.Eval + other-modules: Ide.Plugin.Eval + 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: cpp-options: -Deval @@ -289,6 +298,12 @@ executable haskell-language-server , time , transformers , unordered-containers + , parser-combinators + , pretty-simple + , Diff + , QuickCheck + , ghc-paths + , with-utf8 include-dirs: include default-language: Haskell2010 @@ -425,3 +440,7 @@ test-suite wrapper-test hs-source-dirs: test/wrapper main-is: Main.hs ghc-options: -Wall + + + + diff --git a/plugins/default/src/Ide/Plugin/Eval.hs b/plugins/default/src/Ide/Plugin/Eval.hs index 791a018db8..a7cd179d85 100644 --- a/plugins/default/src/Ide/Plugin/Eval.hs +++ b/plugins/default/src/Ide/Plugin/Eval.hs @@ -1,423 +1,33 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wwarn #-} --- | A plugin inspired by the REPLoid feature of Dante[1] which allows --- to evaluate code in comment prompts and splice the results right below: --- --- > example :: [String] --- > example = ["This is an example", "of", "interactive", "evaluation"] --- > --- > -- >>> intercalate " " example --- > -- "This is an example of interactive evaluation" --- > -- --- --- [1] - https://github.com/jyp/dante -module Ide.Plugin.Eval where +{- | +A plugin inspired by: -import Control.Applicative (Alternative ((<|>))) -import Control.Arrow (second) -import Control.DeepSeq (NFData, deepseq) -import qualified Control.Exception as E -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Class (MonadTrans (lift)) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE) -import Data.Aeson (FromJSON, ToJSON, Value (Null), - toJSON) -import Data.Bifunctor (Bifunctor (first)) -import Data.Char (isSpace) -import qualified Data.HashMap.Strict as Map -import Data.List (find) -import Data.Maybe (fromMaybe, catMaybes) -import Data.String (IsString (fromString)) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (getCurrentTime) -import Development.IDE -import Development.IDE.GHC.Compat (DynFlags(importPaths), ExecResult (..), - GeneralFlag (Opt_IgnoreHpcChanges, Opt_IgnoreOptimChanges, Opt_ImplicitImportQualified), - Ghc, GhcLink (LinkInMemory), - GhcMode (CompManager), - HscTarget (HscInterpreted), - LoadHowMuch (LoadAllTargets), - SuccessFlag (..), - TcRnExprMode (..), execLineNumber, - execOptions, execSourceFile, - execStmt, exprType, getContext, - getInteractiveDynFlags, getSession, - getSessionDynFlags, ghcLink, - ghcMode, hscTarget, isImport, - isStmt, load, moduleName, - packageFlags, parseImportDecl, - pkgDatabase, pkgState, runDecls, - setContext, setInteractiveDynFlags, - setLogAction, setSessionDynFlags, - setTargets, simpleImportDecl, - typeKind, ways) -import DynamicLoading (initializePlugins) -import GHC.Generics (Generic) -import GhcMonad (modifySession) -import GhcPlugins (targetPlatform, defaultLogActionHPutStrDoc, - gopt_set, gopt_unset, interpWays, - updateWays, wayGeneralFlags, - wayUnsetGeneralFlags) -import HscTypes -import Ide.Plugin -import Ide.Types -import Language.Haskell.LSP.Core -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.VFS (virtualFileText) -import Outputable (nest, ppr, showSDoc, text, ($$), - (<+>)) -import PrelNames (pRELUDE) -import System.FilePath -import System.IO (hClose) -import System.IO.Temp -import Type.Reflection (Typeable) +* the REPLoid feature of -descriptor :: PluginId -> PluginDescriptor -descriptor plId = - (defaultPluginDescriptor plId) - { pluginCodeLensProvider = Just provider, - pluginCommands = [evalCommand] - } - -extractMatches :: Maybe Text -> [([(Text, Int)], Range)] -extractMatches = goSearch 0 . maybe [] T.lines - where - checkMatch = T.stripPrefix "-- >>> " - looksLikeSplice l - | Just l' <- T.stripPrefix "--" l = - not (" >>>" `T.isPrefixOf` l') - | otherwise = - False - - goSearch _ [] = [] - goSearch line (l : ll) - | Just match <- checkMatch l = - goAcc (line + 1) [(match, line)] ll - | otherwise = - goSearch (line + 1) ll - - goAcc line acc [] = [(reverse acc, Range p p)] where p = Position line 0 - goAcc line acc (l : ll) - | Just match <- checkMatch l = - goAcc (line + 1) ([(match, line)] <> acc) ll - | otherwise = - (reverse acc, r) : goSearch (line + 1) ll - where - r = Range p p' - p = Position line 0 - p' = Position (line + spliceLength) 0 - spliceLines = takeWhile looksLikeSplice (l : ll) - -- Don't include the last line if it's an empty comment. - -- Do this to preserve spacing between consecutive splices - isEmptyComment = (== "--") - spliceLength = case spliceLines of - [] -> 0 - ls | isEmptyComment (last ls) -> length ls - 1 - | otherwise -> length ls - -provider :: CodeLensProvider -provider lsp _state plId CodeLensParams {_textDocument} = response $ do - let TextDocumentIdentifier uri = _textDocument - contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri uri - let text = virtualFileText <$> contents - let matches = extractMatches text - - cmd <- liftIO $ mkLspCommand plId evalCommandName "Evaluate..." (Just []) - - let lenses = - [ CodeLens range (Just cmd') Nothing - | (m, r) <- matches, - let (_, startLine) = head m - (endLineContents, endLine) = last m - range = Range start end - start = Position startLine 0 - end = Position endLine (T.length endLineContents) - args = EvalParams m r _textDocument, - let cmd' = - (cmd :: Command) - { _arguments = Just (List [toJSON args]), - _title = if trivial r then "Evaluate..." else "Refresh..." - } - ] - - return $ List lenses - where - trivial (Range p p') = p == p' - -evalCommandName :: CommandId -evalCommandName = "evalCommand" - -evalCommand :: PluginCommand -evalCommand = - PluginCommand evalCommandName "evaluate" runEvalCmd - -data EvalParams = EvalParams - { statements :: [(Text, Int)], - editTarget :: !Range, - module_ :: !TextDocumentIdentifier - } - deriving (Eq, Show, Generic, FromJSON, ToJSON) - -runEvalCmd :: CommandFunction EvalParams -runEvalCmd lsp state EvalParams {..} = withIndefiniteProgress lsp "Eval" Cancellable $ response' $ do - let TextDocumentIdentifier {_uri} = module_ - fp <- handleMaybe "uri" $ uriToFilePath' _uri - contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri _uri - text <- handleMaybe "contents" $ virtualFileText <$> contents - - session <- - liftIO $ - runAction "runEvalCmd.ghcSession" state $ - use_ GhcSession $ - toNormalizedFilePath' $ - fp - - (ms, _) <- - liftIO $ - runAction "runEvalCmd.getModSummary" state $ - use_ GetModSummary $ - toNormalizedFilePath' $ - fp - - now <- liftIO getCurrentTime - - let tmp = withSystemTempFile (takeFileName fp) - - tmp $ \temp _h -> tmp $ \tempLog hLog -> do - liftIO $ hClose _h - let modName = moduleName $ ms_mod ms - thisModuleTarget = Target (TargetFile fp Nothing) False (Just (textToStringBuffer text, now)) - - hscEnv' <- ExceptT $ - evalGhcEnv (hscEnv session) $ do - env <- getSession - -- Install the module pragmas and options - df <- liftIO $ setupDynFlagsForGHCiLike env $ ms_hspp_opts ms - -- Restore the cradle import paths - df <- return df{importPaths = fromMaybe (importPaths df) $ envImportPaths session} - -- Set the modified flags in the session - _lp <- setSessionDynFlags df - - -- copy the package state to the interactive DynFlags - idflags <- getInteractiveDynFlags - df <- getSessionDynFlags - setInteractiveDynFlags - idflags - { pkgState = pkgState df, - pkgDatabase = pkgDatabase df, - packageFlags = packageFlags df - } - - -- set up a custom log action - setLogAction $ \_df _wr _sev _span _style _doc -> - defaultLogActionHPutStrDoc _df hLog _doc _style - - -- load the module in the interactive environment - setTargets [thisModuleTarget] - loadResult <- load LoadAllTargets - case loadResult of - Failed -> liftIO $ do - hClose hLog - Left <$> readFile tempLog - Succeeded -> do - setContext [IIDecl (simpleImportDecl $ moduleName pRELUDE), IIModule modName] - Right <$> getSession - - df <- liftIO $ evalGhcEnv hscEnv' getSessionDynFlags - let eval (stmt, l) - | Just (cmd, arg) <- parseGhciLikeCmd $ T.pack stmt - = evalGhciLikeCmd cmd arg - | isStmt df stmt = do - -- set up a custom interactive print function - liftIO $ writeFile temp "" - ctxt <- getContext - setContext [IIDecl (simpleImportDecl $ moduleName pRELUDE)] - let printFun = "let ghcideCustomShow x = Prelude.writeFile " <> show temp <> " (Prelude.show x)" - interactivePrint <- - execStmt printFun execOptions >>= \case - ExecComplete (Right [interactivePrint]) _ -> pure interactivePrint - _ -> error "internal error binding print function" - modifySession $ \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) interactivePrint} - setContext ctxt +* 's Examples and Properties - let opts = - execOptions - { execSourceFile = fp, - execLineNumber = l - } - res <- execStmt stmt opts - case res of - ExecComplete (Left err) _ -> return $ Just $ T.pack $ pad $ show err - ExecComplete (Right _) _ -> do - out <- liftIO $ pad <$> readFile temp - -- Important to take the length in order to read the file eagerly - return $! if length out == 0 then Nothing else Just (T.pack out) - ExecBreak {} -> return $ Just $ T.pack $ pad "breakpoints are not supported" +* - | isImport df stmt = do - ctxt <- getContext - idecl <- parseImportDecl stmt - setContext $ IIDecl idecl : ctxt - return Nothing - | otherwise = do - void $ runDecls stmt - return Nothing +See the "Ide.Plugin.Eval.Tutorial" module for a full introduction to the plugin functionality. +-} +module Ide.Plugin.Eval ( + descriptor, +) where - edits <- - liftIO - $ (either (\e -> [Just . T.pack . pad $ e]) id <$>) - $ strictTry - $ evalGhcEnv hscEnv' - $ traverse (eval . first T.unpack) statements +import qualified Ide.Plugin.Eval.CodeLens as CL +import Ide.Types ( + PluginDescriptor (..), + PluginId, + defaultPluginDescriptor, + ) - - let workspaceEditsMap = Map.fromList [(_uri, List [evalEdit])] - workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing - evalEdit = TextEdit editTarget (T.intercalate "\n" $ catMaybes edits) - - return (WorkspaceApplyEdit, ApplyWorkspaceEditParams workspaceEdits) - --- | 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.unlines . map ("-- " <>) . 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 :: Text -> Maybe (Text, Text) -parseGhciLikeCmd input = do - (':', rest) <- T.uncons $ T.stripStart input - pure $ second T.strip $ T.break isSpace rest - -strictTry :: NFData b => IO b -> IO (Either String b) -strictTry op = E.catch - (op >>= \v -> return $! Right $! deepseq v v) - (\(err :: E.SomeException) -> return $! Left $ show err) - -pad :: String -> String -pad = unlines . map ("-- " <>) . lines - -------------------------------------------------------------------------------- - -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 :: ExceptT String IO a -> IO (Either ResponseError a) -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 <- runExceptT act - case res of - Left e -> - return (Left (ResponseError InternalError (fromString e) Nothing), Nothing) - Right a -> return (Right Null, Just a) - -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 - initializePlugins env dflags4 +-- |Plugin descriptor +descriptor :: PluginId -> PluginDescriptor +descriptor plId = + (defaultPluginDescriptor plId) + { pluginCodeLensProvider = Just CL.codeLens + , pluginCommands = [CL.evalCommand] + } diff --git a/plugins/default/src/Ide/Plugin/Eval/Code.hs b/plugins/default/src/Ide/Plugin/Eval/Code.hs new file mode 100644 index 0000000000..91208b71c1 --- /dev/null +++ b/plugins/default/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/plugins/default/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/default/src/Ide/Plugin/Eval/CodeLens.hs new file mode 100644 index 0000000000..f69271e23e --- /dev/null +++ b/plugins/default/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 (mkLspCommand) +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.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 +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 +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 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/plugins/default/src/Ide/Plugin/Eval/GHC.hs b/plugins/default/src/Ide/Plugin/Eval/GHC.hs new file mode 100644 index 0000000000..522b7e8551 --- /dev/null +++ b/plugins/default/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/plugins/default/src/Ide/Plugin/Eval/Parse/Option.hs b/plugins/default/src/Ide/Plugin/Eval/Parse/Option.hs new file mode 100644 index 0000000000..aea08f01df --- /dev/null +++ b/plugins/default/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/plugins/default/src/Ide/Plugin/Eval/Parse/Parser.hs b/plugins/default/src/Ide/Plugin/Eval/Parse/Parser.hs new file mode 100644 index 0000000000..a3d533d4e9 --- /dev/null +++ b/plugins/default/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/plugins/default/src/Ide/Plugin/Eval/Parse/Section.hs b/plugins/default/src/Ide/Plugin/Eval/Parse/Section.hs new file mode 100644 index 0000000000..403f393d22 --- /dev/null +++ b/plugins/default/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/plugins/default/src/Ide/Plugin/Eval/Parse/Token.hs b/plugins/default/src/Ide/Plugin/Eval/Parse/Token.hs new file mode 100644 index 0000000000..8bb8a6ef3e --- /dev/null +++ b/plugins/default/src/Ide/Plugin/Eval/Parse/Token.hs @@ -0,0 +1,271 @@ +{-# 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 (skipManyTill, many, optional, (<|>)) +import Data.List (foldl') +import Ide.Plugin.Eval.Parse.Parser (satisfy, Parser, alphaNumChar, char, + letterChar, runParser, space, + string, tillEnd) +import Ide.Plugin.Eval.Types (Format (..), Language (..), Loc, + Located (Located)) +import Maybes (fromJust, fromMaybe) +import Data.Functor ( ($>) ) + +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 + +{- | +>>> tokens ["-- |$setup >>> 4+7","x=11"] +[Located {location = 0, located = BlockOpen {blockName = Just "setup", blockLanguage = Haddock, blockFormat = SingleLine}},Located {location = 0, located = Statement " 4+7"},Located {location = 1, located = CodeLine}] + +>>> tokens ["-- $start"] +[Located {location = 0, located = BlockOpen {blockName = Just "start", blockLanguage = Plain, blockFormat = SingleLine}},Located {location = 0, located = TextLine ""}] + +>>> tokens ["--","-- >>> 4+7"] +[Located {location = 0, located = BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = SingleLine}},Located {location = 0, located = TextLine ""},Located {location = 1, located = Statement " 4+7"}] + +>>> tokens ["-- |$setup 44","-- >>> 4+7"] +[Located {location = 0, located = BlockOpen {blockName = Just "setup", blockLanguage = Haddock, blockFormat = SingleLine}},Located {location = 0, located = TextLine "44"},Located {location = 1, located = Statement " 4+7"}] + +>>> tokens ["{"++"- |$doc",">>> 2+2","4","prop> x-x==0","--minus","-"++"}"] +[Located {location = 0, located = BlockOpen {blockName = Just "doc", blockLanguage = Haddock, blockFormat = MultiLine}},Located {location = 0, located = TextLine ""},Located {location = 1, located = Statement " 2+2"},Located {location = 2, located = TextLine "4"},Located {location = 3, located = PropLine " x-x==0"},Located {location = 4, located = TextLine "--minus"},Located {location = 5, located = BlockClose}] + +Multi lines, closed on following line: + +>>> tokens ["{"++"-","-"++"}"] +[Located {location = 0, located = BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine}},Located {location = 0, located = TextLine ""},Located {location = 1, located = BlockClose}] + +>>> tokens [" {"++"-","-"++"} "] +[Located {location = 0, located = BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine}},Located {location = 0, located = TextLine ""},Located {location = 1, located = BlockClose}] + +>>> tokens ["{"++"- SOME TEXT "," MORE -"++"}"] +[Located {location = 0, located = BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine}},Located {location = 0, located = TextLine "SOME TEXT "},Located {location = 1, located = BlockClose}] + +Multi lines, closed on the same line: + +>>> tokens $ ["{--}"] +[Located {location = 0, located = CodeLine}] + +>>> tokens $ [" {- IGNORED -} "] +[Located {location = 0, located = CodeLine}] + +>>> tokens ["{-# LANGUAGE TupleSections","#-}"] +[Located {location = 0, located = CodeLine},Located {location = 1, located = CodeLine}] + +>>> tokens [] +[] +-} +tokens :: [String] -> [Loc TokenS] +tokens = concatMap (\(l, vs) -> map (Located l) vs) . zip [0 ..] . reverse . snd . foldl' next (InCode, []) + where + next (st, tokens) ln = case runParser (aline st) ln of + Right (st', tokens') -> (st', tokens' : tokens) + Left err -> error $ unwords ["Tokens.next failed to parse", ln, err] + +-- | Parse a line of input +aline :: State -> TParser +aline InCode = optionStart <|> multi <|> singleOpen <|> codeLine +aline InSingleComment = optionStart <|> multi <|> commentLine False <|> codeLine +aline InMultiComment = multiClose <|> commentLine True + +multi :: TParser +multi = multiOpenClose <|> multiOpen + +codeLine :: TParser +codeLine = (InCode, [CodeLine]) <$ tillEnd + +{- | A multi line comment that starts and ends on the same line. + +>>> runParser multiOpenClose $ concat ["{","--","}"] +Right (InCode,[CodeLine]) + +>>> runParser multiOpenClose $ concat [" {","-| >>> IGNORED -","} "] +Right (InCode,[CodeLine]) +-} +multiOpenClose :: TParser +multiOpenClose = (multiStart >> multiClose) $> (InCode, [CodeLine]) + +{-| Parses the opening of a multi line comment. +>>> runParser multiOpen $ "{"++"- $longSection this is also parsed" +Right (InMultiComment,[BlockOpen {blockName = Just "longSection", blockLanguage = Plain, blockFormat = MultiLine},TextLine "this is also parsed"]) + +>>> runParser multiOpen $ "{"++"- $longSection >>> 2+3" +Right (InMultiComment,[BlockOpen {blockName = Just "longSection", blockLanguage = Plain, blockFormat = MultiLine},Statement " 2+3"]) +-} +multiOpen :: TParser +multiOpen = + ( \() (maybeLanguage, maybeName) tk -> + (InMultiComment, [BlockOpen maybeName (defLang maybeLanguage) MultiLine, tk]) + ) + <$> multiStart + <*> languageAndName + <*> commentRest + +{- | Parse the first line of a sequence of single line comments +>>> runParser singleOpen "-- |$doc >>>11" +Right (InSingleComment,[BlockOpen {blockName = Just "doc", blockLanguage = Haddock, blockFormat = SingleLine},Statement "11"]) +-} +singleOpen :: TParser +singleOpen = + ( \() (maybeLanguage, maybeName) tk -> + (InSingleComment, [BlockOpen maybeName (defLang maybeLanguage) SingleLine, tk]) + ) + <$> singleStart + <*> languageAndName + <*> commentRest + +{- | Parse a line in a comment +>>> runParser (commentLine False) "x=11" +Left "No match" + +>>> runParser (commentLine False) "-- >>>11" +Right (InSingleComment,[Statement "11"]) + +>>> runParser (commentLine True) "-- >>>11" +Right (InMultiComment,[TextLine "-- >>>11"]) +-} +commentLine :: Bool -> TParser +commentLine noPrefix = + (\tk -> (commentState noPrefix, [tk])) <$> (optLineStart noPrefix *> commentBody) + +commentRest :: Parser Char (Token [Char]) +commentRest = many space *> commentBody + +commentBody :: Parser Char (Token [Char]) +commentBody = stmt <|> prop <|> txt + where + txt = TextLine <$> tillEnd + stmt = Statement <$> (string ">>>" *> tillEnd) + prop = PropLine <$> (string "prop>" *> tillEnd) + +-- | Remove comment line prefix, if needed +optLineStart :: Bool -> Parser Char () +optLineStart noPrefix + | noPrefix = pure () + | otherwise = singleStart + +singleStart :: Parser Char () +singleStart = (string "--" *> optional space) $> () + +multiStart :: Parser Char () +multiStart = sstring "{-" $> () + +{- Parse the close of a multi-line comment +>>> runParser multiClose $ "-"++"}" +Right (InCode,[BlockClose]) + +>>> runParser multiClose $ "-"++"} " +Right (InCode,[BlockClose]) + +As there is currently no way of handling tests in the final line of a multi line comment, it ignores anything that precedes the closing marker: + +>>> runParser multiClose $ "IGNORED -"++"} " +Right (InCode,[BlockClose]) +-} +multiClose :: TParser +multiClose = skipManyTill (satisfy (const True)) (string "-}" *> many space) >> return (InCode, [BlockClose]) + +optionStart :: Parser Char (State, [Token s]) +optionStart = (string "{-#" *> tillEnd) $> (InCode, [CodeLine]) + +name :: Parser Char [Char] +name = (:) <$> letterChar <*> many (alphaNumChar <|> char '_') + +sstring :: String -> Parser Char [Char] +sstring s = many space *> string s *> many space + +{- | +>>>runParser languageAndName "|$" +Right (Just Haddock,Just "") + +>>>runParser languageAndName "|$start" +Right (Just Haddock,Just "start") + +>>>runParser languageAndName "| $start" +Right (Just Haddock,Just "start") + +>>>runParser languageAndName "^" +Right (Just Haddock,Nothing) + +>>>runParser languageAndName "$start" +Right (Nothing,Just "start") +-} +languageAndName :: Parser Char (Maybe Language, Maybe String) +languageAndName = + (,) <$> optional ((char '|' <|> char '^') >> pure Haddock) + <*> optional + (char '$' *> (fromMaybe "" <$> optional name)) + +defLang :: Maybe Language -> Language +defLang = fromMaybe Plain diff --git a/plugins/default/src/Ide/Plugin/Eval/Tutorial.hs b/plugins/default/src/Ide/Plugin/Eval/Tutorial.hs new file mode 100644 index 0000000000..d152eedae5 --- /dev/null +++ b/plugins/default/src/Ide/Plugin/Eval/Tutorial.hs @@ -0,0 +1,246 @@ +{- | +The Eval plugin evaluates code in comments. + +This is mainly useful to: + +* quickly evaluate small code fragments + +* test and document functions + +Every line of code to be evaluated is introduced by __>>>__. + +A quick calculation: + +>>> 2**4.5/pi +7.202530529256849 + +A little test for the `double` function: + +>>> double 11 +22 + +You execute a test by clicking on the /Evaluate/ or /Refresh/ (if the test has been run previously) code lens that appears above it. + +All tests in the same comment are executed together. + +Tests can appear in all kind of comments: plain or Haddock (forward of backwards), single line or multiple line. + +Both plain Haskell and Literate Haskell (Bird-style only) source files are supported. + +A test can be composed of multiple lines: + +>>> "AB" ++ "CD" +>>> "CD" ++ "AB" +"ABCD" +"CDAB" + +In general, a test is a sequence of: + +* imports + +* directives + +* statements + +* expressions + +* properties + +in no particular order, with every line introduced by __>>>__ (or __prop>__ in the case of properties). + += Test Components + +== Imports + +>>> import Data.List +>>> import GHC.TypeNats + +From any package in scope but currently NOT from modules in the same source directory. + +== Language Extensions + +>>> :set -XScopedTypeVariables -XStandaloneDeriving -XDataKinds -XTypeOperators -XExplicitNamespaces + +=== Statements and Declarations + +Function declarations (optionally introduced by /let/): + +>>> let tuple x = (x,x) +>>> let one=1;two=2 +>>> triple x = (x,x,x) + +Any other declaration: + +>>> data TertiumDatur = Truly | Falsely | Other deriving Show +>>> class Display a where display :: a -> String +>>> instance Display TertiumDatur where display = show + +Definitions are available to following tests in the __same__ comment. + +If you want definitions to be available to all tests in the module, define a setup section: + +@ +-- $setup +-- >>> eleven = 11 +@ + +/eleven/ is now available to any test. + +== Type and Kind directives + +>>> :type Truly +Truly :: TertiumDatur + +>>> :kind TertiumDatur +TertiumDatur :: * + +>>> :type 3 +3 :: forall p. Num p => p + +>>> :type +d 3 +3 :: Integer + +>>> type N = 1 +>>> type M = 40 +>>> :kind! N + M + 1 +N + M + 1 :: Nat += 42 + +== Expressions + +>>> tuple 2 +>>> triple 3 +>>> display Other +(2,2) +(3,3,3) +"Other" + +IO expressions can also be evaluated but their output to stdout/stderr is NOT captured: + +>>> print "foo" +() + +== Properties + +prop> \(l::[Int]) -> reverse (reverse l) == l ++++ OK, passed 100 tests. + += Haddock vs Plain Comments + +There is a conceptual difference between Haddock and plain comments. + +Haddock comments constitute the external module's documentation while plain comments are internal documentation meant to explain how the code works (api vs implementation). + +This conceptual difference is reflected in the way tests results are refreshed by the Eval plugin. + +Tests in plain comments are refreshed by overwriting the previous result. + +On the contrary, when tests in Haddock comments are refreshed their current result is compared with the previous one and differences are displayed. + +Say for example that we have defined a test on the `thrice` function, defined as: + +>>> thrice = (*3) + +If by mistake at a later time we change its definition to: + +>>> thrice = (*2) + +When we refresh its test we get a warning: + +>>> thrice 11 +WAS 33 +NOW 22 + +== Tip: Multiline Output + +By default, the output of every expression is returned as a single line. + +This is a problem if you want, for example, to pretty print a value (in this case using the package): + +>>> import Text.Pretty.Simple +>>> pShowNoColor [1..3] +"[ 1\n, 2\n, 3\n]" + +We could try to print the pretty-print output, but stdout is not captured so we get just a (): + +>>> print $ pShowNoColor [1..7] +() + +To display it properly, we can exploit the fact that the output of an error is displayed as a multi-line text: + +>>> import qualified Data.Text.Lazy as TL +>>> import Text.Pretty.Simple +>>> prettyPrint v = error (TL.unpack $ pShowNoColor v) :: IO String +>>> prettyPrint [1..3] +[ 1 +, 2 +, 3 +] + += Differences with doctest + +Though the Eval plugin functionality is quite similar to that of , some doctest features are not supported. + +== Capturing Stdout + +Only the value of the expression is spliced in, not its output: + +>>> print "foo" +() + +== Pattern Matching + +The arbitrary content matcher __...__ is unsupported. + +== Missing lambda abstractions in property tests + +Variables are not automatically introduced: + +prop> reverse (reverse l) == (l::[Int]) +Variable not in scope: l :: [Int] +Variable not in scope: l :: [Int] + +This works: + +prop> \(l::[Int]) -> reverse (reverse l) == l ++++ OK, passed 100 tests. + +== Multiline Expressions + +@ + >>> :{ + let + x = 1 + y = 2 + in x + y + multiline + :} +@ +-} +module Ide.Plugin.Eval.Tutorial ( + double, +) where + +{- | Double a number + +An example of a simple test suite for a function (all tests are executed together). + +>>> double 1 +2 + +>>> double 11 +22 + +>>> double 22 +44 +-} +double :: Num a => a -> a +double n = n * 2 + +{- ORMOLU_DISABLE -} +-- $setup +-- >>> x = 11; +-- >>> y = 22 + +-- >>> (x,y) +-- (11,22) + diff --git a/plugins/default/src/Ide/Plugin/Eval/Types.hs b/plugins/default/src/Ide/Plugin/Eval/Types.hs new file mode 100644 index 0000000000..fe370566ec --- /dev/null +++ b/plugins/default/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/plugins/default/src/Ide/Plugin/Eval/Util.hs b/plugins/default/src/Ide/Plugin/Eval/Util.hs new file mode 100644 index 0000000000..e44a86e242 --- /dev/null +++ b/plugins/default/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 diff --git a/src/Ide/Version.hs b/src/Ide/Version.hs index 61b45fe3fa..9617284f09 100644 --- a/src/Ide/Version.hs +++ b/src/Ide/Version.hs @@ -7,8 +7,8 @@ -- and the current project's version module Ide.Version where -import Development.GitRev (gitCommitCount) -import Options.Applicative.Simple (simpleVersion) +import Development.GitRev (gitCommitCount) +import Options.Applicative.Simple (simpleVersion) import qualified Paths_haskell_language_server as Meta import System.Info import Data.Version @@ -18,6 +18,7 @@ import System.Process import System.Exit import Text.ParserCombinators.ReadP +-- >>> hlsVersion hlsVersion :: String hlsVersion = let commitCount = $gitCommitCount @@ -76,4 +77,3 @@ findVersionOf tool = consumeParser :: ReadP a -> String -> Maybe a consumeParser p input = listToMaybe $ map fst . filter (null . snd) $ readP_to_S p input - diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index fab0cb0a9a..105957a4a4 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -2,79 +2,82 @@ resolver: lts-14.27 # Last 8.6.5 compiler: ghc-8.6.4 packages: -- . -- ./ghcide/hie-compat -- ./ghcide/ -- ./hls-plugin-api -- ./plugins/tactics -- ./plugins/hls-hlint-plugin -- ./plugins/hls-explicit-imports-plugin -- ./plugins/hls-retrie-plugin + - . + - ./ghcide/hie-compat + - ./ghcide/ + - ./hls-plugin-api + - ./plugins/tactics + - ./plugins/hls-hlint-plugin + - ./plugins/hls-explicit-imports-plugin + - ./plugins/hls-retrie-plugin ghc-options: "$everything": -haddock extra-deps: -- aeson-1.5.2.0 -- apply-refact-0.8.2.1 -- ansi-terminal-0.10.3 -- base-compat-0.10.5 -- brittany-0.13.1.0 -- butcher-1.3.3.1 -- Cabal-3.0.2.0 -- cabal-plan-0.6.2.0 -- clock-0.7.2 -- Diff-0.4.0 -- extra-1.7.3 -- floskell-0.10.4 -- fourmolu-0.3.0.0 -- fuzzy-0.1.0.0 -# - ghcide-0.1.0 -- ghc-check-0.5.0.1 -- ghc-events-0.13.0 -- ghc-exactprint-0.6.3.2 -- ghc-lib-8.10.2.20200916 -- ghc-lib-parser-8.10.2.20200916 -- ghc-lib-parser-ex-8.10.0.16 -- ghc-source-gen-0.4.0.0 -- ghc-trace-events-0.1.2.1 -- haddock-api-2.22.0@rev:1 -- haddock-library-1.8.0 -- hashable-1.3.0.0 -- haskell-lsp-0.22.0.0 -- haskell-lsp-types-0.22.0.0 -- heapsize-0.3.0 -- hie-bios-0.7.1 -- hlint-3.2.3 -- HsYAML-0.2.1.0@rev:1 -- HsYAML-aeson-0.2.0.0@rev:2 -- implicit-hie-cradle-0.3.0.2 -- implicit-hie-0.1.2.5 -- indexed-profunctors-0.1 -- lens-4.18 -- lsp-test-0.11.0.6 -- monad-dijkstra-0.1.1.2 -- opentelemetry-0.6.1 -- opentelemetry-extra-0.6.1 -- optics-core-0.2 -- optparse-applicative-0.15.1.0 -- ormolu-0.1.4.1 -- parser-combinators-1.2.1 -- primitive-0.7.1.0 -- refinery-0.3.0.0 -- regex-base-0.94.0.0 -- regex-pcre-builtin-0.95.1.1.8.43 -- regex-tdfa-1.3.1.0 -- retrie-0.1.1.1 -- semialign-1.1 -# - github: wz1000/shake -# commit: fb3859dca2e54d1bbb2c873e68ed225fa179fbef -- stylish-haskell-0.12.2.0 -- tasty-rerun-1.1.17 -- temporary-1.2.1.1 -- these-1.1.1.1 -- type-equality-1 -- topograph-1 + - aeson-1.5.2.0 + - apply-refact-0.8.2.1 + - ansi-terminal-0.10.3 + - base-compat-0.10.5 + - brittany-0.13.1.0 + - butcher-1.3.3.1 + - Cabal-3.0.2.0 + - cabal-plan-0.6.2.0 + - clock-0.7.2 + - Diff-0.4.0 + - extra-1.7.3 + - floskell-0.10.4 + - fourmolu-0.3.0.0 + - fuzzy-0.1.0.0 + # - ghcide-0.1.0 + - ghc-check-0.5.0.1 + - ghc-events-0.13.0 + - ghc-exactprint-0.6.3.2 + - ghc-lib-8.10.2.20200916 + - ghc-lib-parser-8.10.2.20200916 + - ghc-lib-parser-ex-8.10.0.16 + - ghc-source-gen-0.4.0.0 + - ghc-trace-events-0.1.2.1 + - haddock-api-2.22.0@rev:1 + - haddock-library-1.8.0 + - hashable-1.3.0.0 + - haskell-lsp-0.22.0.0 + - haskell-lsp-types-0.22.0.0 + - heapsize-0.3.0 + - hie-bios-0.7.1 + - hlint-3.2.3 + - HsYAML-0.2.1.0@rev:1 + - HsYAML-aeson-0.2.0.0@rev:2 + - implicit-hie-cradle-0.3.0.2 + - implicit-hie-0.1.2.5 + - indexed-profunctors-0.1 + - lens-4.18 + - lsp-test-0.11.0.6 + - monad-dijkstra-0.1.1.2 + - opentelemetry-0.6.1 + - opentelemetry-extra-0.6.1 + - optics-core-0.2 + - optparse-applicative-0.15.1.0 + - ormolu-0.1.4.1 + - parser-combinators-1.2.1 + - primitive-0.7.1.0 + - refinery-0.3.0.0 + - regex-base-0.94.0.0 + - regex-pcre-builtin-0.95.1.1.8.43 + - regex-tdfa-1.3.1.0 + - retrie-0.1.1.1 + - semialign-1.1 + # - github: wz1000/shake + # commit: fb3859dca2e54d1bbb2c873e68ed225fa179fbef + - stylish-haskell-0.12.2.0 + - tasty-rerun-1.1.17 + - temporary-1.2.1.1 + - these-1.1.1.1 + - type-equality-1 + - topograph-1 + - with-utf8-1.0.2.1@sha256:95c02fffa643ddbeb092359802a512007c3e644cd509809f4716ad54592c437b,3057 + - th-env-0.1.0.2@sha256:d8f1f37f42a8f1a22404d7d0579528af18f5dac7232cca6bdbd5117c115a0ad5,1370 + flags: haskell-language-server: @@ -85,6 +88,6 @@ flags: # allow-newer: true nix: - packages: [ icu libcxx zlib ] + packages: [icu libcxx zlib] concurrent-tests: false diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 871bb4a844..09006220e6 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -1,79 +1,82 @@ resolver: lts-14.27 # Last 8.6.5 packages: -- . -- ./ghcide/hie-compat -- ./ghcide/ -- ./hls-plugin-api -- ./plugins/tactics -- ./plugins/hls-hlint-plugin -- ./plugins/hls-explicit-imports-plugin -- ./plugins/hls-retrie-plugin + - . + - ./ghcide/hie-compat + - ./ghcide/ + - ./hls-plugin-api + - ./plugins/tactics + - ./plugins/hls-hlint-plugin + - ./plugins/hls-explicit-imports-plugin + - ./plugins/hls-retrie-plugin ghc-options: "$everything": -haddock extra-deps: -- aeson-1.5.2.0 -- apply-refact-0.8.2.1 -- ansi-terminal-0.10.3 -- base-compat-0.10.5 -- brittany-0.13.1.0 -- butcher-1.3.3.1 -- Cabal-3.0.2.0 -- cabal-plan-0.6.2.0 -- clock-0.7.2 -- Diff-0.4.0 -- extra-1.7.3 -- floskell-0.10.4 -- fourmolu-0.3.0.0 -- fuzzy-0.1.0.0 -# - ghcide-0.1.0 -- ghc-check-0.5.0.1 -- ghc-events-0.13.0 -- ghc-exactprint-0.6.3.2 -- ghc-lib-8.10.2.20200916 -- ghc-lib-parser-8.10.2.20200916 -- ghc-lib-parser-ex-8.10.0.16 -- ghc-source-gen-0.4.0.0 -- ghc-trace-events-0.1.2.1 -- haddock-api-2.22.0@rev:1 -- haddock-library-1.8.0 -- hashable-1.3.0.0 -- haskell-lsp-0.22.0.0 -- haskell-lsp-types-0.22.0.0 -- heapsize-0.3.0 -- hie-bios-0.7.1 -- hlint-3.2.3 -- HsYAML-0.2.1.0@rev:1 -- HsYAML-aeson-0.2.0.0@rev:2 -- implicit-hie-cradle-0.3.0.2 -- implicit-hie-0.1.2.5 -- indexed-profunctors-0.1 -- lens-4.18 -- lsp-test-0.11.0.6 -- monad-dijkstra-0.1.1.2 -- opentelemetry-0.6.1 -- opentelemetry-extra-0.6.1 -- optics-core-0.2 -- optparse-applicative-0.15.1.0 -- ormolu-0.1.4.1 -- parser-combinators-1.2.1 -- primitive-0.7.1.0 -- refinery-0.3.0.0 -- regex-base-0.94.0.0 -- regex-pcre-builtin-0.95.1.1.8.43 -- regex-tdfa-1.3.1.0 -- retrie-0.1.1.1 -- semialign-1.1 -# - github: wz1000/shake -# commit: fb3859dca2e54d1bbb2c873e68ed225fa179fbef -- stylish-haskell-0.12.2.0 -- tasty-rerun-1.1.17 -- temporary-1.2.1.1 -- these-1.1.1.1 -- type-equality-1 -- topograph-1 + - aeson-1.5.2.0 + - apply-refact-0.8.2.1 + - ansi-terminal-0.10.3 + - base-compat-0.10.5 + - brittany-0.13.1.0 + - butcher-1.3.3.1 + - Cabal-3.0.2.0 + - cabal-plan-0.6.2.0 + - clock-0.7.2 + - Diff-0.4.0 + - extra-1.7.3 + - floskell-0.10.4 + - fourmolu-0.3.0.0 + - fuzzy-0.1.0.0 + # - ghcide-0.1.0 + - ghc-check-0.5.0.1 + - ghc-events-0.13.0 + - ghc-exactprint-0.6.3.2 + - ghc-lib-8.10.2.20200916 + - ghc-lib-parser-8.10.2.20200916 + - ghc-lib-parser-ex-8.10.0.16 + - ghc-source-gen-0.4.0.0 + - ghc-trace-events-0.1.2.1 + - haddock-api-2.22.0@rev:1 + - haddock-library-1.8.0 + - hashable-1.3.0.0 + - haskell-lsp-0.22.0.0 + - haskell-lsp-types-0.22.0.0 + - heapsize-0.3.0 + - hie-bios-0.7.1 + - hlint-3.2.3 + - HsYAML-0.2.1.0@rev:1 + - HsYAML-aeson-0.2.0.0@rev:2 + - implicit-hie-cradle-0.3.0.2 + - implicit-hie-0.1.2.5 + - indexed-profunctors-0.1 + - lens-4.18 + - lsp-test-0.11.0.6 + - monad-dijkstra-0.1.1.2 + - opentelemetry-0.6.1 + - opentelemetry-extra-0.6.1 + - optics-core-0.2 + - optparse-applicative-0.15.1.0 + - ormolu-0.1.4.1 + - parser-combinators-1.2.1 + - primitive-0.7.1.0 + - refinery-0.3.0.0 + - regex-base-0.94.0.0 + - regex-pcre-builtin-0.95.1.1.8.43 + - regex-tdfa-1.3.1.0 + - retrie-0.1.1.1 + - semialign-1.1 + # - github: wz1000/shake + # commit: fb3859dca2e54d1bbb2c873e68ed225fa179fbef + - stylish-haskell-0.12.2.0 + - tasty-rerun-1.1.17 + - temporary-1.2.1.1 + - these-1.1.1.1 + - type-equality-1 + - topograph-1 + - with-utf8-1.0.2.1@sha256:95c02fffa643ddbeb092359802a512007c3e644cd509809f4716ad54592c437b,3057 + - th-env-0.1.0.2@sha256:d8f1f37f42a8f1a22404d7d0579528af18f5dac7232cca6bdbd5117c115a0ad5,1370 + flags: haskell-language-server: @@ -84,6 +87,6 @@ flags: # allow-newer: true nix: - packages: [ icu libcxx zlib ] + packages: [icu libcxx zlib] concurrent-tests: false diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index bfa19aa1df..e61d580023 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -1,64 +1,66 @@ resolver: lts-15.3 # Last 8.8.2 packages: -- . -- ./ghcide/hie-compat -- ./ghcide/ -- ./hls-plugin-api -- ./plugins/tactics -- ./plugins/hls-hlint-plugin -- ./plugins/hls-explicit-imports-plugin -- ./plugins/hls-retrie-plugin + - . + - ./ghcide/hie-compat + - ./ghcide/ + - ./hls-plugin-api + - ./plugins/tactics + - ./plugins/hls-hlint-plugin + - ./plugins/hls-explicit-imports-plugin + - ./plugins/hls-retrie-plugin ghc-options: "$everything": -haddock extra-deps: -- aeson-1.5.2.0 -- apply-refact-0.8.2.1 -- brittany-0.13.1.0 -- butcher-1.3.3.2 -- bytestring-trie-0.2.5.0 -- clock-0.7.2 -- constrained-dynamic-0.1.0.0 -- extra-1.7.3 -- floskell-0.10.4 -- fourmolu-0.3.0.0 -# - ghcide-0.6.0 -- ghc-check-0.5.0.1 -- ghc-events-0.13.0 -- ghc-exactprint-0.6.3.2 -- ghc-lib-8.10.2.20200916 -- ghc-lib-parser-8.10.2.20200916 -- ghc-lib-parser-ex-8.10.0.16 -- ghc-trace-events-0.1.2.1 -- haddock-library-1.8.0 -- haskell-lsp-0.22.0.0 -- haskell-lsp-types-0.22.0.0 -- haskell-src-exts-1.21.1 -- heapsize-0.3.0 -- hie-bios-0.7.1 -- hlint-3.2.3 -- hoogle-5.0.17.11 -- hsimport-0.11.0 -- HsYAML-0.2.1.0@rev:1 -- HsYAML-aeson-0.2.0.0@rev:2 -- ilist-0.3.1.0 -- implicit-hie-cradle-0.3.0.2 -- implicit-hie-0.1.2.5 -- lsp-test-0.11.0.6 -- monad-dijkstra-0.1.1.2 -- opentelemetry-0.6.1 -- opentelemetry-extra-0.6.1 -- ormolu-0.1.4.1 -- refinery-0.3.0.0 -- retrie-0.1.1.1 -- semigroups-0.18.5 -# - github: wz1000/shake -# commit: fb3859dca2e54d1bbb2c873e68ed225fa179fbef -- stylish-haskell-0.12.2.0 -- temporary-1.2.1.1 -- these-1.1.1.1 + - aeson-1.5.2.0 + - apply-refact-0.8.2.1 + - brittany-0.13.1.0 + - butcher-1.3.3.2 + - bytestring-trie-0.2.5.0 + - clock-0.7.2 + - constrained-dynamic-0.1.0.0 + - extra-1.7.3 + - floskell-0.10.4 + - fourmolu-0.3.0.0 + # - ghcide-0.6.0 + - ghc-check-0.5.0.1 + - ghc-events-0.13.0 + - ghc-exactprint-0.6.3.2 + - ghc-lib-8.10.2.20200916 + - ghc-lib-parser-8.10.2.20200916 + - ghc-lib-parser-ex-8.10.0.16 + - ghc-trace-events-0.1.2.1 + - haddock-library-1.8.0 + - haskell-lsp-0.22.0.0 + - haskell-lsp-types-0.22.0.0 + - haskell-src-exts-1.21.1 + - heapsize-0.3.0 + - hie-bios-0.7.1 + - hlint-3.2.3 + - hoogle-5.0.17.11 + - hsimport-0.11.0 + - HsYAML-0.2.1.0@rev:1 + - HsYAML-aeson-0.2.0.0@rev:2 + - ilist-0.3.1.0 + - implicit-hie-cradle-0.3.0.2 + - implicit-hie-0.1.2.5 + - lsp-test-0.11.0.6 + - monad-dijkstra-0.1.1.2 + - opentelemetry-0.6.1 + - opentelemetry-extra-0.6.1 + - ormolu-0.1.4.1 + - refinery-0.3.0.0 + - retrie-0.1.1.1 + - semigroups-0.18.5 + # - github: wz1000/shake + # commit: fb3859dca2e54d1bbb2c873e68ed225fa179fbef + - stylish-haskell-0.12.2.0 + - temporary-1.2.1.1 + - these-1.1.1.1 + - with-utf8-1.0.2.1@sha256:95c02fffa643ddbeb092359802a512007c3e644cd509809f4716ad54592c437b,3057 + - th-env-0.1.0.2@sha256:d8f1f37f42a8f1a22404d7d0579528af18f5dac7232cca6bdbd5117c115a0ad5,1370 flags: haskell-language-server: @@ -69,6 +71,6 @@ flags: # allow-newer: true nix: - packages: [ icu libcxx zlib ] + packages: [icu libcxx zlib] concurrent-tests: false diff --git a/stack.yaml b/stack.yaml index d7842be85a..4251c90a99 100644 --- a/stack.yaml +++ b/stack.yaml @@ -84,6 +84,6 @@ flags: # allow-newer: true nix: - packages: [ icu libcxx zlib ] + packages: [icu libcxx zlib] concurrent-tests: false diff --git a/test/functional/Eval.hs b/test/functional/Eval.hs index 78762599e4..8e0b6aa679 100644 --- a/test/functional/Eval.hs +++ b/test/functional/Eval.hs @@ -1,116 +1,211 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module Eval - ( tests - ) -where - -import Control.Applicative.Combinators (skipManyTill) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types (ApplyWorkspaceEditRequest, CodeLens (CodeLens, _command, _range), - Command (_title), - Position (..), Range (..)) -import System.FilePath -import Test.Hls.Util -import Test.Tasty -import Test.Tasty.ExpectedFailure (expectFailBecause) -import Test.Tasty.HUnit +module Eval ( + tests, +) where + +import Control.Applicative.Combinators ( + skipManyTill, + ) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Language.Haskell.LSP.Test ( + Session, + anyMessage, + documentContents, + executeCommand, + fullCaps, + getCodeLenses, + message, + openDoc, + runSession, + ) +import Language.Haskell.LSP.Types ( + ApplyWorkspaceEditRequest, + CodeLens (CodeLens, _command, _range), + Command (Command, _title), + Position (..), + Range (..), + TextDocumentIdentifier, + ) +import System.Directory (doesFileExist) +import System.FilePath ( + (<.>), + (), + ) +import Test.Hls.Util (hlsCommand) +import Test.Tasty ( + TestTree, + testGroup, + ) +import Test.Tasty.ExpectedFailure ( + expectFailBecause, + ignoreTestBecause, + ) +import Test.Tasty.HUnit ( + testCase, + (@?=), + ) tests :: TestTree -tests = testGroup - "eval" - [ testCase "Produces Evaluate code lenses" $ do - runSession hlsCommand fullCaps evalPath $ do - doc <- openDoc "T1.hs" "haskell" - lenses <- getCodeLenses doc - liftIO $ map (fmap _title . _command) lenses @?= [Just "Evaluate..."] - , testCase "Produces Refresh code lenses" $ do - runSession hlsCommand fullCaps evalPath $ do - doc <- openDoc "T2.hs" "haskell" - lenses <- getCodeLenses doc - liftIO $ map (fmap _title . _command) lenses @?= [Just "Refresh..."] - , testCase "Code lenses have ranges" $ do - runSession hlsCommand fullCaps evalPath $ do - doc <- openDoc "T1.hs" "haskell" - lenses <- getCodeLenses doc - liftIO $ map _range lenses @?= [Range (Position 4 0) (Position 4 15)] - , testCase "Multi-line expressions have a multi-line range" $ do - runSession hlsCommand fullCaps evalPath $ do - doc <- openDoc "T3.hs" "haskell" - lenses <- getCodeLenses doc - liftIO $ map _range lenses @?= [Range (Position 3 0) (Position 4 15)] - , testCase "Executed expressions range covers only the expression" $ do - runSession hlsCommand fullCaps evalPath $ do - doc <- openDoc "T2.hs" "haskell" - lenses <- getCodeLenses doc - liftIO $ map _range lenses @?= [Range (Position 4 0) (Position 4 15)] - , testCase "Evaluation of expressions" $ goldenTest "T1.hs" - , testCase "Reevaluation of expressions" $ goldenTest "T2.hs" - , testCase "Evaluation of expressions w/ imports" $ goldenTest "T3.hs" - , testCase "Evaluation of expressions w/ lets" $ goldenTest "T4.hs" - , testCase "Refresh an evaluation" $ goldenTest "T5.hs" - , testCase "Refresh an evaluation w/ lets" $ goldenTest "T6.hs" - , testCase "Refresh a multiline evaluation" $ goldenTest "T7.hs" - , testCase "Evaluate incorrect expressions" $ goldenTest "T8.hs" - , testCase "Applies file LANGUAGE extensions" $ goldenTest "T9.hs" - , testCase "Evaluate a type with :kind!" $ goldenTest "T10.hs" - , testCase "Reports an error for an incorrect type with :kind!" - $ goldenTest "T11.hs" - , testCase "Shows a kind with :kind" $ goldenTest "T12.hs" - , testCase "Reports an error for an incorrect type with :kind" - $ goldenTest "T13.hs" - , testCase "Returns a fully-instantiated type for :type" - $ goldenTest "T14.hs" - , testCase "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" - $ goldenTest "T15.hs" - , testCase "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" - $ goldenTest "T16.hs" - , testCase ":type reports an error when given with unknown +x option" - $ goldenTest "T17.hs" - , testCase "Reports an error when given with unknown command" - $ goldenTest "T18.hs" - , testCase "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt" - $ goldenTest "T19.hs" - , expectFailBecause "known issue - see a note in P.R. #361" - $ testCase ":type +d reflects the `default' declaration of the module" - $ goldenTest "T20.hs" - , testCase ":type handles a multilined result properly" - $ goldenTest "T21.hs" - , testCase ":t behaves exactly the same as :type" - $ goldenTest "T22.hs" - , testCase ":type does \"dovetails\" for short identifiers" - $ goldenTest "T23.hs" - , testCase ":kind! treats a multilined result properly" - $ goldenTest "T24.hs" - , testCase ":kind treats a multilined result properly" - $ goldenTest "T25.hs" - , testCase "local imports" - $ goldenTest "T26.hs" - , testCase "Preserves one empty comment line after prompt" - $ goldenTest "T27.hs" - ] +tests = + testGroup + "eval" + [ testCase "Produces Evaluate code lenses" $ + runSession hlsCommand fullCaps evalPath $ do + doc <- openDoc "T1.hs" "haskell" + lenses <- getEvalCodeLenses doc + liftIO $ map (fmap _title . _command) lenses @?= [Just "Evaluate..."] + , testCase "Produces Refresh code lenses" $ + runSession hlsCommand fullCaps evalPath $ do + doc <- openDoc "T2.hs" "haskell" + lenses <- getEvalCodeLenses doc + liftIO $ map (fmap _title . _command) lenses @?= [Just "Refresh..."] + , testCase "Code lenses have ranges" $ + runSession hlsCommand fullCaps evalPath $ do + doc <- openDoc "T1.hs" "haskell" + lenses <- getEvalCodeLenses doc + liftIO $ map _range lenses @?= [Range (Position 4 0) (Position 5 0)] + , testCase "Multi-line expressions have a multi-line range" $ do + runSession hlsCommand fullCaps evalPath $ do + doc <- openDoc "T3.hs" "haskell" + lenses <- getEvalCodeLenses doc + liftIO $ map _range lenses @?= [Range (Position 3 0) (Position 5 0)] + , testCase "Executed expressions range covers only the expression" $ do + runSession hlsCommand fullCaps evalPath $ do + doc <- openDoc "T2.hs" "haskell" + lenses <- getEvalCodeLenses doc + liftIO $ map _range lenses @?= [Range (Position 4 0) (Position 5 0)] + , testCase "Evaluation of expressions" $ goldenTest "T1.hs" + , testCase "Reevaluation of expressions" $ goldenTest "T2.hs" + , testCase "Evaluation of expressions w/ imports" $ goldenTest "T3.hs" + , testCase "Evaluation of expressions w/ lets" $ goldenTest "T4.hs" + , testCase "Refresh an evaluation" $ goldenTest "T5.hs" + , testCase "Refresh an evaluation w/ lets" $ goldenTest "T6.hs" + , testCase "Refresh a multiline evaluation" $ goldenTest "T7.hs" + , testCase "Semantic and Lexical errors are reported" $ goldenTest "T8.hs" + , testCase "Applies file LANGUAGE extensions" $ goldenTest "T9.hs" + , testCase "Evaluate a type with :kind!" $ goldenTest "T10.hs" + , testCase "Reports an error for an incorrect type with :kind!" $ + goldenTest "T11.hs" + , testCase "Shows a kind with :kind" $ goldenTest "T12.hs" + , testCase "Reports an error for an incorrect type with :kind" $ + goldenTest "T13.hs" + , testCase "Returns a fully-instantiated type for :type" $ + goldenTest "T14.hs" + , testCase "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" $ + goldenTest "T15.hs" + , testCase "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" $ + goldenTest "T16.hs" + , testCase ":type reports an error when given with unknown +x option" $ + goldenTest "T17.hs" + , testCase "Reports an error when given with unknown command" $ + goldenTest "T18.hs" + , testCase "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt" $ + goldenTest "T19.hs" + , expectFailBecause "known issue - see a note in P.R. #361" $ + testCase ":type +d reflects the `default' declaration of the module" $ + goldenTest "T20.hs" + , testCase ":type handles a multilined result properly" $ + goldenTest "T21.hs" + , testCase ":t behaves exactly the same as :type" $ + goldenTest "T22.hs" + , testCase ":type does \"dovetails\" for short identifiers" $ + goldenTest "T23.hs" + , testCase ":kind! treats a multilined result properly" $ + goldenTest "T24.hs" + , testCase ":kind treats a multilined result properly" $ + goldenTest "T25.hs" + , testCase "local imports" $ + goldenTest "T26.hs" + , testCase "Preserves one empty comment line after prompt" $ + goldenTest "T27.hs" + , testCase + "Multi line comments" + $ goldenTest "TMulti.hs" + , testCase + "Evaluate expressions in Plain comments in both single line and multi line format" + $ goldenTest "TPlainComment.hs" + , testCase + "Evaluate expressions in Haddock comments in both single line and multi line format" + $ goldenTest "THaddock.hs" + , testCase "Compare results (for Haddock tests only)" $ + goldenTest "TCompare.hs" + , testCase "Local Modules imports are accessible in a test" $ + goldenTest "TLocalImport.hs" + , -- , testCase "Local Modules can be imported in a test" $ goldenTest "TLocalImportInTest.hs" + ignoreTestBecause "Unexplained but minor issue" $ + testCase "Setting language option TupleSections" $ + goldenTest "TLanguageOptionsTupleSections.hs" + , testCase "IO expressions are supported, stdout/stderr output is ignored" $ + goldenTest "TIO.hs" + , testCase "Property checking" $ goldenTest "TProperty.hs" + , testCase + "Prelude has no special treatment, it is imported as stated in the module" + $ goldenTest "TPrelude.hs" +#if __GLASGOW_HASKELL__ >= 808 + , testCase "CPP support" $ goldenTest "TCPP.hs" + , testCase "Literate Haskell Bird Style" $ goldenTest "TLHS.lhs" +#endif + -- , testCase "Literate Haskell LaTeX Style" $ goldenTest "TLHSLateX.lhs" + ] goldenTest :: FilePath -> IO () -goldenTest input = - runSession hlsCommand fullCaps evalPath $ do - doc <- openDoc input "haskell" - [CodeLens { _command = Just c }] <- getCodeLenses doc - executeCommand c - _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message +goldenTest = goldenTestBy isEvalTest + +{- |Execute all CodeLens accepted by 'filter' + Compare results with the contents of corresponding '.expected' file (and creates it, if missing) +-} +goldenTestBy :: (CodeLens -> Bool) -> FilePath -> IO () +goldenTestBy f input = runSession hlsCommand fullCaps evalPath $ do + doc <- openDoc input "haskell" + + -- Execute lenses backwards, to avoid affecting their position in the source file + codeLenses <- reverse <$> getCodeLensesBy f doc + -- liftIO $ print codeLenses + + -- Execute sequentially + mapM_ executeCmd $ [c | CodeLens{_command = Just c} <- codeLenses] + edited <- replaceUnicodeQuotes <$> documentContents doc - expected <- fmap replaceUnicodeQuotes $ - liftIO $ T.readFile $ evalPath input <.> "expected" + -- liftIO $ T.putStrLn edited + + let expectedFile = evalPath input <.> "expected" + + liftIO $ do + -- Write expected file if missing + missingExpected <- not <$> doesFileExist expectedFile + when missingExpected $ T.writeFile expectedFile edited + + expected <- liftIO $ T.readFile expectedFile liftIO $ edited @?= expected +getEvalCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] +getEvalCodeLenses = getCodeLensesBy isEvalTest -replaceUnicodeQuotes :: T.Text -> T.Text -replaceUnicodeQuotes = T.replace "‘" "`" . T.replace "’" "'" +getCodeLensesBy :: (CodeLens -> Bool) -> TextDocumentIdentifier -> Session [CodeLens] +getCodeLensesBy f doc = filter f <$> getCodeLenses doc +-- Execute command and wait for result +executeCmd :: Command -> Session () +executeCmd cmd = do + executeCommand cmd + _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + -- liftIO $ print _resp + return () + +-- Execute only Eval tests to avoid interference from other plugins (e.g ghcide:typesignature.add) +isEvalTest :: CodeLens -> Bool +isEvalTest (CodeLens _ (Just (Command _ cmd _)) _) + | ":eval:" `T.isInfixOf` cmd = True +isEvalTest _ = False + +replaceUnicodeQuotes :: T.Text -> T.Text +replaceUnicodeQuotes = T.replace "‘" "'" . T.replace "’" "'" evalPath :: FilePath evalPath = "test/testdata/eval" diff --git a/test/functional/Main.hs b/test/functional/Main.hs index fb393aa944..de8f136797 100644 --- a/test/functional/Main.hs +++ b/test/functional/Main.hs @@ -1,59 +1,59 @@ module Main where -import Test.Tasty -import Test.Tasty.Runners ( listingTests - , consoleTestReporter - ) -import Test.Tasty.Ingredients.Rerun -import Test.Tasty.Runners.AntXML - -import Command -import Config -import Completion -import Deferred -import Definition -import Diagnostic -import Eval -import Format -import FunctionalBadProject -import FunctionalCodeAction -import FunctionalLiquid -import HieBios -import Highlight -import Progress -import Reference -import Rename -import Symbol -import Tactic -import TypeDefinition -import ModuleName +import Command +import Completion +import Config +import Deferred +import Definition +import Diagnostic +import Eval +import Format +import FunctionalBadProject +import FunctionalCodeAction +import FunctionalLiquid +import HieBios +import Highlight +import ModuleName +import Progress +import Reference +import Rename +import Symbol +import Tactic +import Test.Tasty +import Test.Tasty.Ingredients.Rerun +import Test.Tasty.Runners ( + consoleTestReporter, + listingTests, + ) +import Test.Tasty.Runners.AntXML +import TypeDefinition main :: IO () main = -- ingredient: xml runner writes json file of test results (https://github.com/ocharles/tasty-ant-xml/blob/master/Test/Tasty/Runners/AntXML.hs) -- rerunningTests allow rerun of failed tests (https://github.com/ocharles/tasty-rerun/blob/master/src/Test/Tasty/Ingredients/Rerun.hs) - defaultMainWithIngredients - [antXMLRunner, rerunningTests [listingTests, consoleTestReporter]] - $ testGroup - "haskell-language-server" - [ Command.tests - , Completion.tests - , Config.tests - , Deferred.tests - , Definition.tests - , Diagnostic.tests - , Eval.tests - , Format.tests - , FunctionalBadProject.tests - , FunctionalCodeAction.tests - , FunctionalLiquid.tests - , HieBios.tests - , Highlight.tests - , ModuleName.tests - , Progress.tests - , Reference.tests - , Rename.tests - , Symbol.tests - , Tactic.tests - , TypeDefinition.tests - ] + defaultMainWithIngredients + [antXMLRunner, rerunningTests [listingTests, consoleTestReporter]] + $ testGroup + "haskell-language-server" + [ Command.tests + , Completion.tests + , Config.tests + , Deferred.tests + , Definition.tests + , Diagnostic.tests + , Eval.tests + , Format.tests + , FunctionalBadProject.tests + , FunctionalCodeAction.tests + , FunctionalLiquid.tests + , HieBios.tests + , Highlight.tests + , ModuleName.tests + , Progress.tests + , Reference.tests + , Rename.tests + , Symbol.tests + , Tactic.tests + , TypeDefinition.tests + ] diff --git a/test/testdata/eval/T11.hs.expected b/test/testdata/eval/T11.hs.expected index fac41da1cd..c3651ba3cc 100644 --- a/test/testdata/eval/T11.hs.expected +++ b/test/testdata/eval/T11.hs.expected @@ -1,4 +1,4 @@ module T11 where -- >>> :kind! a --- Not in scope: type variable ‘a’ +-- Not in scope: type variable 'a' diff --git a/test/testdata/eval/T13.hs.expected b/test/testdata/eval/T13.hs.expected index c76a2af295..ef4643037e 100644 --- a/test/testdata/eval/T13.hs.expected +++ b/test/testdata/eval/T13.hs.expected @@ -1,4 +1,4 @@ module T13 where -- >>> :kind a --- Not in scope: type variable ‘a’ +-- Not in scope: type variable 'a' diff --git a/test/testdata/eval/T17.hs.expected b/test/testdata/eval/T17.hs.expected index 14e2aa74a1..fd0bce327f 100644 --- a/test/testdata/eval/T17.hs.expected +++ b/test/testdata/eval/T17.hs.expected @@ -1,4 +1,4 @@ module T17 where -- >>> :type +no 42 --- parse error on input ‘+’ +-- parse error on input '+' diff --git a/test/testdata/eval/T4.hs b/test/testdata/eval/T4.hs index 72c88ed1d4..96a43e5f60 100644 --- a/test/testdata/eval/T4.hs +++ b/test/testdata/eval/T4.hs @@ -1,8 +1,9 @@ module T4 where -import Data.List (unwords) +import Data.List (unwords) -- >>> let evaluation = " evaluation" -- >>> unwords example ++ evaluation example :: [String] example = ["This","is","an","example","of"] + diff --git a/test/testdata/eval/T4.hs.expected b/test/testdata/eval/T4.hs.expected index 4b56dbf392..53bb845392 100644 --- a/test/testdata/eval/T4.hs.expected +++ b/test/testdata/eval/T4.hs.expected @@ -1,9 +1,10 @@ module T4 where -import Data.List (unwords) +import Data.List (unwords) -- >>> let evaluation = " evaluation" -- >>> unwords example ++ evaluation -- "This is an example of evaluation" example :: [String] example = ["This","is","an","example","of"] + diff --git a/test/testdata/eval/T8.hs b/test/testdata/eval/T8.hs index c71bd73f19..a0188670b0 100644 --- a/test/testdata/eval/T8.hs +++ b/test/testdata/eval/T8.hs @@ -1,3 +1,10 @@ +-- Semantic and Lexical errors are reported module T8 where -- >>> noFunctionWithThisName + +-- >>> "a" + "bc" + +-- >>> " + +-- >>> 3 `div` 0 diff --git a/test/testdata/eval/T8.hs.expected b/test/testdata/eval/T8.hs.expected index 5ec1150adf..1a42fecfdf 100644 --- a/test/testdata/eval/T8.hs.expected +++ b/test/testdata/eval/T8.hs.expected @@ -1,4 +1,14 @@ +-- Semantic and Lexical errors are reported module T8 where -- >>> noFunctionWithThisName -- Variable not in scope: noFunctionWithThisName + +-- >>> "a" + "bc" +-- No instance for (Num [Char]) arising from a use of '+' + +-- >>> " +-- lexical error in string/character literal at end of input + +-- >>> 3 `div` 0 +-- divide by zero diff --git a/test/testdata/eval/TCPP.hs b/test/testdata/eval/TCPP.hs new file mode 100644 index 0000000000..efed8edacf --- /dev/null +++ b/test/testdata/eval/TCPP.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module TCPP where + +-- >>> y +y :: Integer +y = 11 + +#define ALL + +#ifdef ALL +-- >>> 3+y +#else +-- >>> 5+y +#endif + +-- >>> 2+y diff --git a/test/testdata/eval/TCPP.hs.expected b/test/testdata/eval/TCPP.hs.expected new file mode 100644 index 0000000000..1c35954861 --- /dev/null +++ b/test/testdata/eval/TCPP.hs.expected @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module TCPP where + +-- >>> y +-- 11 +y :: Integer +y = 11 + +#define ALL + +#ifdef ALL +-- >>> 3+y +-- 14 +#else +-- >>> 5+y +#endif + +-- >>> 2+y +-- 13 diff --git a/test/testdata/eval/TCompare.hs b/test/testdata/eval/TCompare.hs new file mode 100644 index 0000000000..2be9f94426 --- /dev/null +++ b/test/testdata/eval/TCompare.hs @@ -0,0 +1,12 @@ +module TCompare where + +-- In plain comments, the previous result of an evaluation is simply replaced + +-- >>> 2+2 +-- 5 + +-- In Haddock comments, the previous result of an evaluation is compared with the new one +-- and difference are displayed + +-- | >>> 2+2 +-- 5 diff --git a/test/testdata/eval/TCompare.hs.expected b/test/testdata/eval/TCompare.hs.expected new file mode 100644 index 0000000000..9b2f5301cc --- /dev/null +++ b/test/testdata/eval/TCompare.hs.expected @@ -0,0 +1,13 @@ +module TCompare where + +-- In plain comments, the previous result of an evaluation is simply replaced + +-- >>> 2+2 +-- 4 + +-- In Haddock comments, the previous result of an evaluation is compared with the new one +-- and difference are displayed + +-- | >>> 2+2 +-- WAS 5 +-- NOW 4 diff --git a/test/testdata/eval/THaddock.hs b/test/testdata/eval/THaddock.hs new file mode 100644 index 0000000000..1a3614f517 --- /dev/null +++ b/test/testdata/eval/THaddock.hs @@ -0,0 +1,35 @@ +{- | +Tests in plain comments in both single line or multi line format, both forward and backward. +Tests are ignored if: + * do not start on the first column + * are in multi line comments that open and close on the same line +-} +module THaddock () where + +{- ORMOLU_DISABLE -} + +-- | Single line comment +-- >>> "a"++"b" + +{- | Multi line comment + +>>> "b"++"c" +-} + +double a = a + a +-- ^ Single line backward comments +-- >>> double 11 + +twice :: [a] -> [a] +twice a = a ++ a +{- ^ Multi-line backward comments +>>> twice "ABC" +-} + +{- | >>> 2+five + + ^-- This works, as it starts at the first column after the header. + + >>> IGNORED as it does not start on the first column +-} +five = 5 diff --git a/test/testdata/eval/THaddock.hs.expected b/test/testdata/eval/THaddock.hs.expected new file mode 100644 index 0000000000..22edc0fbaf --- /dev/null +++ b/test/testdata/eval/THaddock.hs.expected @@ -0,0 +1,40 @@ +{- | +Tests in plain comments in both single line or multi line format, both forward and backward. +Tests are ignored if: + * do not start on the first column + * are in multi line comments that open and close on the same line +-} +module THaddock () where + +{- ORMOLU_DISABLE -} + +-- | Single line comment +-- >>> "a"++"b" +-- "ab" + +{- | Multi line comment + +>>> "b"++"c" +"bc" +-} + +double a = a + a +-- ^ Single line backward comments +-- >>> double 11 +-- 22 + +twice :: [a] -> [a] +twice a = a ++ a +{- ^ Multi-line backward comments +>>> twice "ABC" +"ABCABC" +-} + +{- | >>> 2+five +7 + + ^-- This works, as it starts at the first column after the header. + + >>> IGNORED as it does not start on the first column +-} +five = 5 diff --git a/test/testdata/eval/TIO.hs b/test/testdata/eval/TIO.hs new file mode 100644 index 0000000000..7f984892df --- /dev/null +++ b/test/testdata/eval/TIO.hs @@ -0,0 +1,9 @@ +-- IO expressions are supported, stdout/stderr output is ignored +module TIO where + +{- +Does not capture stdout, returns value. + +>>> print "ABC" >> return "XYZ" +"XYZ" +-} diff --git a/test/testdata/eval/TIO.hs.expected b/test/testdata/eval/TIO.hs.expected new file mode 100644 index 0000000000..7f984892df --- /dev/null +++ b/test/testdata/eval/TIO.hs.expected @@ -0,0 +1,9 @@ +-- IO expressions are supported, stdout/stderr output is ignored +module TIO where + +{- +Does not capture stdout, returns value. + +>>> print "ABC" >> return "XYZ" +"XYZ" +-} diff --git a/test/testdata/eval/TLHS.lhs b/test/testdata/eval/TLHS.lhs new file mode 100644 index 0000000000..4572772384 --- /dev/null +++ b/test/testdata/eval/TLHS.lhs @@ -0,0 +1,22 @@ +An example LHS + +> {-# LANGUAGE OverloadedStrings #-} + +> module TLHS where + +More comments, here. + +> -- | >>> 2+2 + +> -- | >>> x+a + +> {- | +> >>> 5+5 +> 11 +> -} +> x :: Integer +> x = 3 + +> a :: Integer +> a = 11 + diff --git a/test/testdata/eval/TLHS.lhs.expected b/test/testdata/eval/TLHS.lhs.expected new file mode 100644 index 0000000000..f62ad893e2 --- /dev/null +++ b/test/testdata/eval/TLHS.lhs.expected @@ -0,0 +1,25 @@ +An example LHS + +> {-# LANGUAGE OverloadedStrings #-} + +> module TLHS where + +More comments, here. + +> -- | >>> 2+2 +> -- 4 + +> -- | >>> x+a +> -- 14 + +> {- | +> >>> 5+5 +> WAS 11 +> NOW 10 +> -} +> x :: Integer +> x = 3 + +> a :: Integer +> a = 11 + diff --git a/test/testdata/eval/TLHSLaTeX.lhs b/test/testdata/eval/TLHSLaTeX.lhs new file mode 100644 index 0000000000..39d12d4caf --- /dev/null +++ b/test/testdata/eval/TLHSLaTeX.lhs @@ -0,0 +1,16 @@ +\documentstyle{article} + +\begin{document} + +\section{Introduction} + +This is a trivial program that prints the first 20 factorials. + +\begin{code} +module TLHSLaTeX where + +-- >>> prod +prod = [ (n, product [1..n]) | n <- [1..3]] +\end{code} + +\end{document} diff --git a/test/testdata/eval/TLHSLateX.lhs.expected b/test/testdata/eval/TLHSLateX.lhs.expected new file mode 100644 index 0000000000..be1b15feb7 --- /dev/null +++ b/test/testdata/eval/TLHSLateX.lhs.expected @@ -0,0 +1,17 @@ +\documentstyle{article} + +\begin{document} + +\section{Introduction} + +This is a trivial program that prints the first 20 factorials. + +\begin{code} +module TLHSLaTeX where + +-- >>> prod +-- [(1,1),(2,2),(3,6)] +prod = [ (n, product [1..n]) | n <- [1..3]] +\end{code} + +\end{document} diff --git a/test/testdata/eval/TLanguageOptions.hs b/test/testdata/eval/TLanguageOptions.hs new file mode 100644 index 0000000000..864d6c47de --- /dev/null +++ b/test/testdata/eval/TLanguageOptions.hs @@ -0,0 +1,43 @@ +-- Support for language options + +{-# LANGUAGE ScopedTypeVariables #-} +module TLanguageOptions where + +-- Language options set in the module source (ScopedTypeVariables) +-- also apply to tests so this works fine +-- >>> f = (\(c::Char) -> [c]) + +{- Multiple options can be set with a single `:set` + +>>> :set -XMultiParamTypeClasses -XFlexibleInstances +>>> class Z a b c +-} + +{- + +Options apply only in the section where they are defined (unless they are in the setup section), so this will fail: + +>>> class L a b c +-} + + +{- +Options apply to all tests in the same section after their declaration. + +Not set yet: + +>>> class D + +Now it works: + +>>>:set -XMultiParamTypeClasses +>>> class C + +It still works + +>>> class F +-} + +{- Wrong option names are reported. +>>> :set -XWrong +-} diff --git a/test/testdata/eval/TLanguageOptions.hs.expected b/test/testdata/eval/TLanguageOptions.hs.expected new file mode 100644 index 0000000000..43df24ac13 --- /dev/null +++ b/test/testdata/eval/TLanguageOptions.hs.expected @@ -0,0 +1,52 @@ +-- Support for language options + +{-# LANGUAGE ScopedTypeVariables #-} +module TLanguageOptions where + +-- Language options set in the module source (ScopedTypeVariables) +-- also apply to tests so this works fine +-- >>> f = (\(c::Char) -> [c]) + +{- Multiple options can be set with a single `:set` + +>>> :set -XMultiParamTypeClasses -XFlexibleInstances +>>> class Z a b c +-} + +{- + +Options apply only in the section where they are defined (unless they are in the setup section), so this will fail: + +>>> class L a b c +Too many parameters for class ‘L’ +(Enable MultiParamTypeClasses to allow multi-parameter classes) +-} + + +{- +Options apply to all tests in the same section after their declaration. + +Not set yet: + +>>> class D +No parameters for class ‘D’ +(Enable MultiParamTypeClasses to allow no-parameter classes) +No parameters for class ‘D’ +(Enable MultiParamTypeClasses to allow no-parameter classes) +No parameters for class ‘D’ +(Enable MultiParamTypeClasses to allow no-parameter classes) + +Now it works: + +>>>:set -XMultiParamTypeClasses +>>> class C + +It still works + +>>> class F +-} + +{- Wrong option names are reported. +>>> :set -XWrong +Unknown extension: "Wrong" +-} diff --git a/test/testdata/eval/TLanguageOptionsTupleSections.hs b/test/testdata/eval/TLanguageOptionsTupleSections.hs new file mode 100644 index 0000000000..800f1fa525 --- /dev/null +++ b/test/testdata/eval/TLanguageOptionsTupleSections.hs @@ -0,0 +1,9 @@ +-- This works fine: {-# LANGUAGE TupleSections #-} +module TLanguageOptionsTupleSection where + +-- Why oh why is this not working? +-- What is special about TupleSections? +-- >>> :set -XTupleSections +-- >>> ("a",) "b" +-- ("a","b") + diff --git a/test/testdata/eval/TLanguageOptionsTupleSections.hs.expected b/test/testdata/eval/TLanguageOptionsTupleSections.hs.expected new file mode 100644 index 0000000000..2262df9109 --- /dev/null +++ b/test/testdata/eval/TLanguageOptionsTupleSections.hs.expected @@ -0,0 +1,8 @@ +-- This works fine: {-# LANGUAGE TupleSections #-} +module TLanguageOptionsTupleSection where + +-- Why oh why is this not working? +-- What is special about TupleSections? +-- >>> :set -XTupleSections +-- >>> ("a",) "b" +-- ("a","b") \ No newline at end of file diff --git a/test/testdata/eval/TLocalImport.hs b/test/testdata/eval/TLocalImport.hs new file mode 100644 index 0000000000..38d2d0bcc0 --- /dev/null +++ b/test/testdata/eval/TLocalImport.hs @@ -0,0 +1,5 @@ +module TLocalImport where + +import qualified Util + +-- >>> Util.tst 11 11 diff --git a/test/testdata/eval/TLocalImport.hs.expected b/test/testdata/eval/TLocalImport.hs.expected new file mode 100644 index 0000000000..b01851afb4 --- /dev/null +++ b/test/testdata/eval/TLocalImport.hs.expected @@ -0,0 +1,6 @@ +module TLocalImport where + +import qualified Util + +-- >>> Util.tst 11 11 +-- True diff --git a/test/testdata/eval/TLocalImportInTest.hs b/test/testdata/eval/TLocalImportInTest.hs new file mode 100644 index 0000000000..55a692bd0c --- /dev/null +++ b/test/testdata/eval/TLocalImportInTest.hs @@ -0,0 +1,4 @@ +module TLocalImportInTest where + +-- >>> import qualified Util +-- >>> Util.a diff --git a/test/testdata/eval/TLocalImportInTest.hs.expected b/test/testdata/eval/TLocalImportInTest.hs.expected new file mode 100644 index 0000000000..7f4d68cbf3 --- /dev/null +++ b/test/testdata/eval/TLocalImportInTest.hs.expected @@ -0,0 +1,5 @@ +module TLocalImportInTest where + +-- >>> import qualified Util +-- >>> Util.a +-- 'a' diff --git a/test/testdata/eval/TMulti.hs b/test/testdata/eval/TMulti.hs new file mode 100644 index 0000000000..fb5eb2da80 --- /dev/null +++ b/test/testdata/eval/TMulti.hs @@ -0,0 +1,21 @@ +{- | Multi line comments are parsed correctly. + + Note that if they open and close on a single line, their content is ignored. +-} +module TMulti () where + +{- ORMOLU_DISABLE -} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" + + {- >>> 3+3 + -} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" + + {-| >>> IGNORED -} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" diff --git a/test/testdata/eval/TMulti.hs.expected b/test/testdata/eval/TMulti.hs.expected new file mode 100644 index 0000000000..13a8105eae --- /dev/null +++ b/test/testdata/eval/TMulti.hs.expected @@ -0,0 +1,25 @@ +{- | Multi line comments are parsed correctly. + + Note that if they open and close on a single line, their content is ignored. +-} +module TMulti () where + +{- ORMOLU_DISABLE -} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" +-- "ab" + + {- >>> 3+3 +6 + -} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" +-- "ab" + + {-| >>> IGNORED -} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" +-- "ab" diff --git a/test/testdata/eval/TPlainComment.hs b/test/testdata/eval/TPlainComment.hs new file mode 100644 index 0000000000..4951f76874 --- /dev/null +++ b/test/testdata/eval/TPlainComment.hs @@ -0,0 +1,25 @@ +{- | +Tests in plain comments in both single line or multi line format. +Tests are ignored if: + * do not start on the first column + * are in multi line comments that open and close on the same line +-} +module TPlain where + +{- ORMOLU_DISABLE -} + +-- Single line comment +-- >>> "a"++"b" + +{- Multi line comment + +>>> "b"++"c" +-} + +{- >>> 2+five + + ^-- This works, as it starts at the first column after the header. + + >>> IGNORED as it does not start on the first column +-} +five = 5 diff --git a/test/testdata/eval/TPlainComment.hs.expected b/test/testdata/eval/TPlainComment.hs.expected new file mode 100644 index 0000000000..49333aaf4f --- /dev/null +++ b/test/testdata/eval/TPlainComment.hs.expected @@ -0,0 +1,28 @@ +{- | +Tests in plain comments in both single line or multi line format. +Tests are ignored if: + * do not start on the first column + * are in multi line comments that open and close on the same line +-} +module TPlain where + +{- ORMOLU_DISABLE -} + +-- Single line comment +-- >>> "a"++"b" +-- "ab" + +{- Multi line comment + +>>> "b"++"c" +"bc" +-} + +{- >>> 2+five +7 + + ^-- This works, as it starts at the first column after the header. + + >>> IGNORED as it does not start on the first column +-} +five = 5 diff --git a/test/testdata/eval/TPrelude.hs b/test/testdata/eval/TPrelude.hs new file mode 100644 index 0000000000..2c573325b0 --- /dev/null +++ b/test/testdata/eval/TPrelude.hs @@ -0,0 +1,10 @@ +-- Prelude has no special treatment, it is imported as stated in the module. +module TPrelude where + +import Prelude hiding (foldr) + +-- >>> foldr (+) 10 [2,3,5] +foldr :: (a -> z -> z) -> z -> [a] -> z +foldr f z bs = + (foldl (\g a -> g . f a) id bs) z + diff --git a/test/testdata/eval/TPrelude.hs.expected b/test/testdata/eval/TPrelude.hs.expected new file mode 100644 index 0000000000..850ac987dd --- /dev/null +++ b/test/testdata/eval/TPrelude.hs.expected @@ -0,0 +1,11 @@ +-- Prelude has no special treatment, it is imported as stated in the module. +module TPrelude where + +import Prelude hiding (foldr) + +-- >>> foldr (+) 10 [2,3,5] +-- 20 +foldr :: (a -> z -> z) -> z -> [a] -> z +foldr f z bs = + (foldl (\g a -> g . f a) id bs) z + diff --git a/test/testdata/eval/TProperty.hs b/test/testdata/eval/TProperty.hs new file mode 100644 index 0000000000..8a1bb166bf --- /dev/null +++ b/test/testdata/eval/TProperty.hs @@ -0,0 +1,5 @@ +-- Support for property checking +module TProperty where + +-- prop> \(l::[Bool]) -> reverse (reverse l) == l + diff --git a/test/testdata/eval/TProperty.hs.expected b/test/testdata/eval/TProperty.hs.expected new file mode 100644 index 0000000000..28336f1e29 --- /dev/null +++ b/test/testdata/eval/TProperty.hs.expected @@ -0,0 +1,6 @@ +-- Support for property checking +module TProperty where + +-- prop> \(l::[Bool]) -> reverse (reverse l) == l +-- +++ OK, passed 100 tests. + diff --git a/test/testdata/eval/TSectionEval.hs b/test/testdata/eval/TSectionEval.hs new file mode 100644 index 0000000000..9d0226d9ae --- /dev/null +++ b/test/testdata/eval/TSectionEval.hs @@ -0,0 +1,15 @@ +-- Tests in the same document section are executed together +module TSectionEval where + +{- +>>> 1+1 + +>>> 2+2 +-} + +{- +>>> 3+3 + +>>> 4+4 +-} + diff --git a/test/testdata/eval/TSectionEval.hs.expected b/test/testdata/eval/TSectionEval.hs.expected new file mode 100644 index 0000000000..30f3756b76 --- /dev/null +++ b/test/testdata/eval/TSectionEval.hs.expected @@ -0,0 +1,17 @@ +-- Tests in the same document section are executed together +module TSectionEval where + +{- +>>> 1+1 +2 + +>>> 2+2 +4 +-} + +{- +>>> 3+3 + +>>> 4+4 +-} + diff --git a/test/testdata/eval/TSetup.hs b/test/testdata/eval/TSetup.hs new file mode 100644 index 0000000000..e29c3dd7fa --- /dev/null +++ b/test/testdata/eval/TSetup.hs @@ -0,0 +1,10 @@ +-- The setup section is executed before any other test +module TSetup where + +-- $setup +-- >>> x=11 +-- >>> y=22 + +-- >>> x+y + +-- >>> x*y diff --git a/test/testdata/eval/TSetup.hs.expected b/test/testdata/eval/TSetup.hs.expected new file mode 100644 index 0000000000..12d3ccf966 --- /dev/null +++ b/test/testdata/eval/TSetup.hs.expected @@ -0,0 +1,12 @@ +-- The setup section is executed before any other test +module TSetup where + +-- $setup +-- >>> x=11 +-- >>> y=22 + +-- >>> x+y +-- 33 + +-- >>> x*y +-- 242 diff --git a/test/testdata/eval/Util.hs b/test/testdata/eval/Util.hs new file mode 100644 index 0000000000..a0191ea783 --- /dev/null +++ b/test/testdata/eval/Util.hs @@ -0,0 +1,13 @@ +-- Used for testing local imports +module Util + ( tst + , a + , b + ) +where + +tst a b = a == b + +a = 'a' + +b = 'b' diff --git a/test/testdata/eval/cabal.project b/test/testdata/eval/cabal.project new file mode 100644 index 0000000000..e6fdbadb43 --- /dev/null +++ b/test/testdata/eval/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/test/testdata/eval/hie-cabal.yaml b/test/testdata/eval/hie-cabal.yaml new file mode 100644 index 0000000000..7251e586cd --- /dev/null +++ b/test/testdata/eval/hie-cabal.yaml @@ -0,0 +1,4 @@ +cradle: + cabal: + - path: "././" + component: "lib:test" diff --git a/test/testdata/eval/hie-stack.yaml b/test/testdata/eval/hie-stack.yaml new file mode 100644 index 0000000000..59c739536a --- /dev/null +++ b/test/testdata/eval/hie-stack.yaml @@ -0,0 +1,4 @@ +cradle: + stack: + - path: "././" + component: "test:lib" diff --git a/test/testdata/eval/hie.yaml b/test/testdata/eval/hie.yaml index 66e96b9b28..7251e586cd 100644 --- a/test/testdata/eval/hie.yaml +++ b/test/testdata/eval/hie.yaml @@ -1,29 +1,4 @@ cradle: - direct: - arguments: - - "T1" - - "T2" - - "T3" - - "T4" - - "T5" - - "T6" - - "T7" - - "T8" - - "T9" - - "T10" - - "T11" - - "T12" - - "T13" - - "T14" - - "T15" - - "T16" - - "T17" - - "T18" - - "T19" - - "T20" - - "T21" - - "T22" - - "T23" - - "T24" - - "T25" - - "T26" + cabal: + - path: "././" + component: "lib:test" diff --git a/test/testdata/eval/stack.yaml b/test/testdata/eval/stack.yaml new file mode 100644 index 0000000000..ca2bb68516 --- /dev/null +++ b/test/testdata/eval/stack.yaml @@ -0,0 +1,4 @@ +resolver: lts-14.27 # Last 8.6.5 + +packages: + - . diff --git a/test/testdata/eval/test.cabal b/test/testdata/eval/test.cabal index fbc943a651..2d57505ebe 100644 --- a/test/testdata/eval/test.cabal +++ b/test/testdata/eval/test.cabal @@ -11,7 +11,48 @@ build-type: Simple cabal-version: >=1.10 library - exposed-modules: T1, T2, T3, T4 - build-depends: base >= 4.7 && < 5 + exposed-modules: + T1 + T2 + T3 + T4 + T5 + T6 + T7 + T8 + T9 + T10 + T11 + T12 + T13 + T14 + T15 + T16 + T17 + T18 + T19 + T20 + T21 + T22 + T23 + T24 + T25 + T26 + TMulti + TPlainComment + THaddock + TCompare + TLocalImport + TLocalImportInTest + TLanguageOptionsTupleSections + TIO + TProperty + TPrelude + TCPP + TLHS + Util + + build-depends: base >= 4.7 && < 5, QuickCheck default-language: Haskell2010 ghc-options: -Wall -fwarn-unused-imports +