Extended Eval Plugin (additional changes)

Author: tittoassini

haskell-language-server.cabal

@@ -154,13 +154,12 @@ executable haskell-language-server
     , time
     , transformers
     , unordered-containers
-    -- , ghc-exactprint
     , parser-combinators
     , pretty-simple
-    , Diff == 0.4.*
-    -- , ghc-paths
+    , Diff
     , QuickCheck
 
+
   if flag(agpl)
     build-depends: brittany
     other-modules: Ide.Plugin.Brittany

plugins/default/src/Ide/Plugin/Eval/CodeLens.hs

@@ -10,9 +10,9 @@ module Ide.Plugin.Eval.GHC (
     hasPackage,
     addPackages,
     modifyFlags,
-    gStrictTry,
 ) where
 
+import Control.DeepSeq (NFData, ($!!))
 import Control.Exception (SomeException)
 import Data.List (isPrefixOf)
 import Development.IDE.GHC.Error ()
@@ -43,7 +43,7 @@ import GhcPlugins (
     xopt_set,
  )
 import HscTypes (InteractiveContext (ic_dflags))
-import Ide.Plugin.Eval.Util (asS)
+import Ide.Plugin.Eval.Util (asS, gStrictTry)
 import qualified Lexer as Lexer
 import Module (UnitId (DefiniteUnitId))
 import Outputable (
@@ -60,11 +60,11 @@ import SrcLoc (mkRealSrcLoc)
 import StringBuffer (stringToStringBuffer)
 
 {- $setup
- >>> import GHC
- >>> import GHC.Paths
- >>> run act = runGhc (Just libdir) (getSessionDynFlags >>= act)
- >>> libdir
- "/Users/titto/.stack/programs/x86_64-osx/ghc-8.10.2/lib/ghc-8.10.2"
+>>> import GHC
+>>> import GHC.Paths
+>>> run act = runGhc (Just libdir) (getSessionDynFlags >>= act)
+>>> libdir
+"/Users/titto/.stack/programs/x86_64-osx/ghc-8.10.2/lib/ghc-8.10.2"
 -}
 
 {- | Returns true if string is an expression
@@ -200,10 +200,3 @@ instance Show DynFlags where
 
 vList :: [String] -> SDoc
 vList = vcat . map text
-
-gStrictTry :: ExceptionMonad m => m b -> m (Either String b)
-gStrictTry op =
-    gcatch
-        -- gStrictTry op = MC.catch
-        (op >>= \v -> return $! Right $! v)
-        (\(err :: SomeException) -> return $! Left $! show $! err)

plugins/default/src/Ide/Plugin/Eval/GHC.hs

@@ -1,79 +1,95 @@
--- |Parse a Section, a group of zero or more tests defined in a multiline comment or a sequence of one line comments.
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE RecordWildCards           #-}
-{-# LANGUAGE ViewPatterns              #-}
 {-# OPTIONS_GHC -Wwarn #-}
 {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
 
-module Ide.Plugin.Eval.Parse.Section
-  ( allSections,
+-- |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
+) 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)
+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 fp = runParser sections . tokensFrom <$> readFileUTF8' fp
+>>> 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 = [], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [Located {location = 5, located = Example {testLines = " :set -XTupleSections -XFlexibleInstances" :| [" (\"a\",) \"b\""], testOutput = []}}], sectionLanguage = Plain, sectionFormat = MultiLine},Section {sectionName = "", sectionTests = [Located {location = 10, located = Example {testLines = " (\"a\",) \"b\"" :| [], testOutput = []}}], sectionLanguage = Plain, sectionFormat = MultiLine},Section {sectionName = "", sectionTests = [Located {location = 15, located = Example {testLines = " :set -XWrong" :| [], testOutput = []}}], sectionLanguage = Plain, sectionFormat = MultiLine}]
+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 = "setup", sectionTests = [Located {location = 3, located = Example {testLines = " let a = 11" :| [" let z = 33"], testOutput = []}}], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "setup", sectionTests = [Located {location = 9, located = Example {testLines = " let x=11" :| [" let y=22"], testOutput = []}}], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [Located {location = 12, located = Example {testLines = " x+y+z" :| [], testOutput = []}}], sectionLanguage = Haddock, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [Located {location = 14, located = Example {testLines = " \"A\"" :| [], testOutput = ["\"A\""]}}], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [Located {location = 18, located = Example {testLines = " x=33" :| [" y=18"," x+y"], testOutput = ["51"]}}], sectionLanguage = Plain, sectionFormat = MultiLine},Section {sectionName = "", sectionTests = [Located {location = 25, located = Example {testLines = " let x=11" :| [" y = 22"], testOutput = []}},Located {location = 28, located = Example {testLines = " x+y" :| [" x-y"], testOutput = []}},Located {location = 31, located = Example {testLines = " x+1+m" :| [], testOutput = ["Variable not in scope: m :: Integer"]}}], sectionLanguage = Plain, sectionFormat = MultiLine},Section {sectionName = "", sectionTests = [Located {location = 35, located = Example {testLines = " \"" :| [], testOutput = ["lexical error in string/character literal at end of input"]}}], sectionLanguage = Plain, sectionFormat = SingleLine},Section {sectionName = "", sectionTests = [Located {location = 39, located = Example {testLines = " \"abc\"" :| [], testOutput = ["\"abc\""]}}], sectionLanguage = Plain, sectionFormat = MultiLine},Section {sectionName = "", sectionTests = [Located {location = 46, located = Example {testLines = " print \"ABC\"" :| [], testOutput = ["()"]}}], sectionLanguage = Plain, sectionFormat = MultiLine},Section {sectionName = "", sectionTests = [Located {location = 55, located = Example {testLines = " import System.IO" :| [" import GHC.IO.Handle"," hSetEncoding stdout utf8 >> hSetEncoding stderr utf8"], testOutput = ["()"]}},Located {location = 64, located = Example {testLines = " import Data.ByteString" :| [" Data.ByteString.pack \"\20908\29916\""], testOutput = ["Couldn't match type \8216Char\8217 with \8216Word8\8217","Expected type: [Word8]","  Actual type: [Char]"]}}], sectionLanguage = Plain, sectionFormat = MultiLine},Section {sectionName = "", sectionTests = [Located {location = 73, located = Example {testLines = " :set -XFlexibleInstances" :| [], testOutput = []}},Located {location = 75, located = Example {testLines = " 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)"," asPrint (print \"GG\")"," asPrint \"GG\""], testOutput = []}}], sectionLanguage = Plain, sectionFormat = MultiLine}]
+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)
-
+    catMaybes <$> many (const Nothing <$> some code <|> Just <$> section)
 
 section :: Parser Tk Section
 section = sectionBody >>= sectionEnd
 
 sectionBody :: Parser Tk Section
 sectionBody =
-  do
-    ( \(unLoc -> BlockOpen {..}) ts ->
+    ( \(unLoc -> BlockOpen{..}) ts ->
         Section (fromMaybe "" blockName) (catMaybes ts) blockLanguage blockFormat
-      )
-    <$> open <*> many (Just <$> example <|> Just <$> property <|> const Nothing <$> doc)
+    )
+        <$> 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
+    | sectionFormat s == SingleLine = optional code *> return s
+    | otherwise = close *> return s
 
 -- section = do
 --   s <-
@@ -98,19 +114,19 @@ 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
+    ( \(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
+    ( \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

plugins/default/src/Ide/Plugin/Eval/Parse/Section.hs

@@ -71,13 +71,15 @@ 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/T11.hs"
-[BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = SingleLine},TextLine "Support for language options ",CodeLine,CodeLine,BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine},TextLine "Multiple options can be set with a single `:set` ",TextLine "",Statement " :set -XTupleSections -XFlexibleInstances",Statement " (\"a\",) \"b\"",BlockClose,CodeLine,BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine},TextLine "Options apply only in the section where they are defined (unless they are in the setup section).",Statement " (\"a\",) \"b\"",BlockClose,CodeLine,CodeLine,BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine},TextLine "Wrong option names are reported.",Statement " :set -XWrong",BlockClose]
+>>> 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
@@ -104,8 +106,8 @@ tokensFrom = tokens . lines
 >>> tokens ["{-# LANGUAGE TupleSections","#-}"]
 [Located {location = 0, located = CodeLine},Located {location = 1, located = CodeLine}]
 
-  -- FIX
-  >>> tokens ["{"++"--"++"}"]
+>>> length $ tokens ["{"++"--"++"}"]
+2
 
 >>> tokens []
 []
@@ -215,26 +217,30 @@ multiStart :: Parser Char ()
 multiStart = string "{-" *> optional space *> return ()
 
 multiClose :: TParser
-multiClose = string "-}" >> return (InCode, [BlockClose])
+multiClose = many space *> string "-}" >> return (InCode, [BlockClose])
 
 optionStart :: Parser Char (State, [Token s])
 optionStart = string "{-#" *> tillEnd *> return (InCode, [CodeLine])
 
 name :: Parser Char [Char]
 name = (:) <$> letterChar <*> many (alphaNumChar <|> char '_')
 
--- |
--- >>>runParser languageAndName "|$"
--- Right (Just Haddock,Just "")
---
--- >>>runParser languageAndName "|$start"
--- Right (Just Haddock,Just "start")
---
--- >>>runParser languageAndName "^"
--- Right (Just Haddock,Nothing)
---
--- >>>runParser languageAndName "$start"
--- Right (Nothing,Just "start")
+{- |
+>>>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)

plugins/default/src/Ide/Plugin/Eval/Parse/Token.hs

@@ -59,31 +59,34 @@ All tests in the same comment sections are executed together.
 This is very convenient to execute multiple tests on the same function, as in this example:
 
 >>> double 0
+0
 
 >>> double 11
+22
 
 >>> double 22
+44
 -}
 double :: Num a => a -> a
-double n = n*2
+double n = n * 2
 
--- A section prefixed with '$setup' has a special meaning, its code is executed before any other test.
+-- You can define a '$setup' section, whose code is executed before any other test.
 
--- $setup
--- >>> x = 11
--- >>> y = 22
+{- $setup
+ >>> x = 11
+ >>> y = 22
+-}
 
 -- 'x' and 'y' are available in any test:
 -- >>> (x,y)
 -- (11,22)
 
-
 {- |
 Haddock comments, like this one, constitute the external module's documentation.
 
-Theirs tests are part of the module functions' definitions and their results are not supposed to change.
+Their tests are part of the module functions' definitions and their results are not supposed to change.
 
-So, whenever tests in Haddock comments are refreshed their current result is compared with the previous one and differences are displayed.
+So, whenever tests in Haddock comments are refreshed, their current result is compared with the previous one and differences are displayed.
 
 If by mistake we change the definition of 'evens', we get a warning:
 
@@ -146,8 +149,8 @@ prop> \(l::[Int]) -> reverse (reverse l) == l
 +++ OK, passed 100 tests.
 
 prop> \(l::[Bool]) -> reverse l == l
-*** Failed! Falsified (after 5 tests and 2 shrinks):
-[True,False]
+*** Failed! Falsified (after 11 tests and 3 shrinks):
+[False,True]
 
 And finally expressions:
 
@@ -206,7 +209,7 @@ You could, for example, use the pretty-simple package:
 
 >>> import Text.Pretty.Simple
 >>> pShowNoColor [1..3]
-"[ 1\n, 2\n, 3\n] "
+"[ 1\n, 2\n, 3\n]"
 
 But what we get is just a String.
 
@@ -226,17 +229,3 @@ To 'print' it properly, we can exploit the fact that the output of an error is d
 , 3
 ]
 -}
-
-{-
-Tip: prop> can be customised.
-
-propEvaluation is the function used to evaluate a property, it can be redefined (e.g. to use something different than QuickCheck):
-
-prop> \(l::[Bool]) -> reverse (reverse l) == l
-+++ OK, passed 100 tests.
-
->>> propEvaluation p = return "Your property is a joke and it miserably failed!"
-
-prop> \(l::[Bool]) -> reverse (reverse l) == l
-"Your property is a joke and it miserably failed!"
--}

plugins/default/src/Ide/Plugin/Eval/Tutorial.hs

@@ -1,52 +1,42 @@
-{-# OPTIONS_GHC -Wwarn #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveFunctor  #-}
-{-# LANGUAGE DeriveGeneric  #-}
-module Ide.Plugin.Eval.Types
-  ( locate
-  , locate0
-  , Test(..)
-  , isProperty
-  , Format(..)
-  , Language(..)
-  , Section(..)
-  , hasTests
-  , hasPropertyTest
-  , splitSections
-  -- , ExpectedResult
-  -- , ExpectedLine(..)
-  -- , LineChunk(..)
-  , Loc
-  , Located(..)
-  , unLoc
-  , Txt
-  )
-where
-import           Data.Aeson         (FromJSON, ToJSON)
-import           Data.String
-import           GHC.Generics       (Generic)
--- import           Ide.Plugin.Eval.Location
-import           Control.DeepSeq    (NFData)
-import           Control.DeepSeq    (NFData (rnf), deepseq)
-import           Data.List          (partition)
-import           Data.List.NonEmpty (NonEmpty)
--- import           Data.String        (String)
+{-# 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)
+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
 
--- type Located = LocatedAt Location
-
--- location :: LocatedAt l a -> l
--- location (Located l _) = l
-
-instance (NFData l,NFData a) => NFData (Located l a) where
-  rnf (Located loc a) = loc `deepseq` a `deepseq` ()
+instance (NFData l, NFData a) => NFData (Located l a) where
+    rnf (Located loc a) = loc `deepseq` a `deepseq` ()
 
 type Loc = Located Line
 
@@ -60,13 +50,13 @@ 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)
+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
@@ -78,29 +68,27 @@ hasPropertyTest = any (isProperty . unLoc) . sectionTests
 splitSections :: [Section] -> ([Section], [Section])
 splitSections = partition ((== "setup") . sectionName)
 
-data Test 
-  = Example {testLines::(NonEmpty Txt),testOutput:: [Txt]} 
-  | Property {testline::Txt,testOutput::[Txt]}
---data Test line = Example (NonEmpty line) [line] | Property line [line]
-  deriving (Eq, Show, Generic, FromJSON, ToJSON,NFData)
+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
-
+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 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)
+    deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData)
 
 instance IsString ExpectedLine where
-  fromString = ExpectedLine . return . LineChunk
+    fromString = ExpectedLine . return . LineChunk
 
 data LineChunk = LineChunk String | WildCardChunk
-  deriving (Eq, Show, Generic, FromJSON, ToJSON,NFData)
+    deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData)
 
 instance IsString LineChunk where
-  fromString = LineChunk
+    fromString = LineChunk

plugins/default/src/Ide/Plugin/Eval/Types.hs

@@ -1,18 +1,22 @@
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 -- |Debug utilities
 module Ide.Plugin.Eval.Util (
     asS,
-    debug,
     timed,
     isLiterate,
     handleMaybe,
     handleMaybeM,
     response,
     response',
+    gStrictTry,
+    dbg,
 ) where
 
+import Control.Monad (join)
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except (
@@ -30,6 +34,9 @@ import Development.IDE (
     ideLogger,
     logPriority,
  )
+import Exception (ExceptionMonad, SomeException (..), evaluate, gcatch)
+import GHC.Exts (toList)
+import GHC.Stack (srcLocStartCol, srcLocStartLine, srcLocFile, HasCallStack, callStack)
 import Language.Haskell.LSP.Types (
     ErrorCode (InternalError),
     ResponseError (ResponseError),
@@ -54,11 +61,20 @@ timed out name op = do
     _ <- out name (showDuration secs)
     return r
 
-debug :: MonadIO m => T.Text -> IdeState -> T.Text -> T.Text -> m ()
-debug mdlName state key val =
+dbg :: (HasCallStack, MonadIO m, Show a1, Show a2) => IdeState -> a1 -> a2 -> m ()
+dbg state key val =
     liftIO . logPriority (ideLogger state) logLevel $
         T.unwords
-            [T.concat [mdlName, T.pack ":", key], val]
+            [T.pack dbgPos, asT key, asT val]
+  where
+    dbgPos =
+        let stk = toList callStack
+            pr pos = concat [srcLocFile pos, ":", show . srcLocStartLine $ pos, ":", show . srcLocStartCol $ pos]
+            -- pr = show
+         in if null stk then "" else pr . snd . head $ stk
+
+    asT :: Show a => a -> T.Text
+    asT = T.pack . show
 
 logLevel :: Priority
 logLevel = Info -- Debug
@@ -72,16 +88,28 @@ 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 :: 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 <- runExceptT act
-    case res of
+    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

plugins/default/src/Ide/Plugin/Eval/Util.hs

@@ -13,6 +13,7 @@ ghc-options:
 
 extra-deps:
   - aeson-1.5.2.0
+  - apply-refact-0.8.2.1
   - ansi-terminal-0.10.3
   - base-compat-0.10.5
   - github: bubba/brittany
@@ -21,49 +22,52 @@ extra-deps:
   - 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.1.0.0@rev:1
+  - fourmolu-0.3.0.0
   - fuzzy-0.1.0.0
   # - ghcide-0.1.0
   - ghc-check-0.5.0.1
-  - ghc-exactprint-0.6.2
-  - ghc-lib-parser-8.10.2.20200808
+  - 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
   - haddock-api-2.22.0@rev:1
   - haddock-library-1.8.0
   - haskell-lsp-0.22.0.0
   - haskell-lsp-types-0.22.0.0
   - hie-bios-0.7.1
+  - hlint-3.2
   - HsYAML-0.2.1.0@rev:1
   - HsYAML-aeson-0.2.0.0@rev:2
+  - implicit-hie-cradle-0.3.0.0
+  - implicit-hie-0.1.2.3
   - indexed-profunctors-0.1
   - lens-4.18
-  - lsp-test-0.11.0.5
+  - lsp-test-0.11.0.6
   - monad-dijkstra-0.1.1.2
   - opentelemetry-0.4.2
   - optics-core-0.2
   - optparse-applicative-0.15.1.0
-  - ormolu-0.1.2.0
+  - ormolu-0.1.4.1
   - parser-combinators-1.2.1
   - primitive-0.7.1.0
-  - refinery-0.1.0.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.11.0.3
+  - 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
-  - implicit-hie-cradle-0.2.0.1
-  - implicit-hie-0.1.1.0
   - Diff-0.4.0@sha256:b5cfbeed498f555a18774ffd549bbeff7a24bdfe5984154dcfc9f4328a3c2847,1275
 
 flags:

stack-8.6.5.yaml

@@ -1,5 +1,4 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -12,6 +11,7 @@ import Control.Applicative.Combinators (
  )
 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 (
     anyMessage,
@@ -39,7 +39,7 @@ import System.FilePath (
     (<.>),
     (</>),
  )
-import Test.Hls.Util (hieCommand)
+import Test.Hls.Util (hlsCommand)
 import Test.Tasty (
     TestTree,
     testGroup,
@@ -58,36 +58,30 @@ tests =
     testGroup
         "eval"
         [ testCase "Produces Evaluate code lenses" $
-            runSession hieCommand fullCaps evalPath $ 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" $
-            runSession hieCommand fullCaps evalPath $ 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" $
-            runSession hieCommand fullCaps evalPath $ do
+            runSession hlsCommand fullCaps evalPath $ do
                 doc <- openDoc "T1.hs" "haskell"
                 lenses <- getCodeLenses doc
-                liftIO $
-                    map _range lenses
-                        @?= [Range (Position 4 0) (Position 5 0)]
-        , testCase "Multi-line expressions have a multi-line range" $
-            runSession hieCommand fullCaps evalPath $ do
+                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 <- getCodeLenses doc
-                liftIO $
-                    map _range lenses
-                        @?= [Range (Position 3 0) (Position 5 0)]
-        , testCase "Executed expressions range covers only the expression" $
-            runSession hieCommand fullCaps evalPath $ do
+                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 <- getCodeLenses doc
-                liftIO $
-                    map _range lenses
-                        @?= [Range (Position 4 0) (Position 5 0)]
+                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"
@@ -103,25 +97,25 @@ tests =
         , 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 "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"
+        , 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 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" $
@@ -163,23 +157,27 @@ goldenTest = goldenTestBy id
  Compare results with the contents of corresponding '.expected' file (and creates it, if missing)
 -}
 goldenTestBy :: ([CodeLens] -> [CodeLens]) -> FilePath -> IO ()
-goldenTestBy filter input = runSession hieCommand fullCaps evalPath $ do
+goldenTestBy filter input = runSession hlsCommand fullCaps evalPath $ do
     doc <- openDoc input "haskell"
 
     -- Execute lenses backwards, to avoid affecting their position in the source file
     codeLenses <- reverse . filter <$> getCodeLenses doc
     mapM_ executeCommand $ [c | CodeLens{_command = Just c} <- codeLenses]
     _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message
-    edited <- documentContents doc
+    edited <- replaceUnicodeQuotes <$> documentContents doc
+
+    let expectedFile = evalPath </> input <.> "expected"
 
-    let expected = evalPath </> input <.> "expected"
     liftIO $ do
         -- Write expected file if missing
-        missingExpected <- not <$> doesFileExist expected
-        when missingExpected $ T.writeFile expected edited
+        missingExpected <- not <$> doesFileExist expectedFile
+        when missingExpected $ T.writeFile expectedFile edited
+
+    expected <- liftIO $ T.readFile expectedFile
+    liftIO $ edited @?= expected
 
-        expected <- T.readFile expected
-        edited @?= expected
+replaceUnicodeQuotes :: T.Text -> T.Text
+replaceUnicodeQuotes = T.replace "‘" "'" . T.replace "’" "'"
 
 evalPath :: FilePath
 evalPath = "test/testdata/eval"

test/functional/Eval.hs

@@ -1,4 +1,4 @@
 module T11 where
 
 -- >>> :kind! a
--- Not in scope: type variable ‘a’
+-- Not in scope: type variable 'a'

test/testdata/eval/T11.hs.expected

@@ -1,4 +1,4 @@
 module T13 where
 
 -- >>> :kind a
--- Not in scope: type variable ‘a’
+-- Not in scope: type variable 'a'

test/testdata/eval/T13.hs.expected

@@ -1,4 +1,4 @@
 module T17 where
 
 -- >>> :type  +no 42
--- parse error on input ‘+’
+-- parse error on input '+'

test/testdata/eval/T17.hs.expected

@@ -5,7 +5,7 @@ module T8 where
 -- Variable not in scope: noFunctionWithThisName
 
 -- >>> "a" + "bc"
--- No instance for (Num [Char]) arising from a use of ‘+’
+-- No instance for (Num [Char]) arising from a use of '+'
 
 -- >>> "
 -- lexical error in string/character literal at end of input

test/testdata/eval/T8.hs.expected

@@ -20,7 +20,7 @@ module TAllComments where
 twice :: [a] -> [a]
 twice a = a ++ a
 {- ^ Also in backward Haddock comments
- >>> twice "ABC"
+>>> twice "ABC"
 -}
 
 -- Ignored as it doesn't start on the first column.

test/testdata/eval/TAllComments.hs

@@ -23,7 +23,8 @@ module TAllComments where
 twice :: [a] -> [a]
 twice a = a ++ a
 {- ^ Also in backward Haddock comments
- >>> twice "ABC"
+>>> twice "ABC"
+"ABCABC"
 -}
 
 -- Ignored as it doesn't start on the first column.

test/testdata/eval/TAllComments.hs.expected

@@ -11,7 +11,7 @@ build-type:          Simple
 cabal-version:       >=1.10
 
 library
-  exposed-modules:     T1, T2, T3, T4, T5, T6, T7, T8, T9, T10, T11, T12, T13, T14
+  exposed-modules:     T1, T2, T3, T4, T5, T6, T7, T8, T9, T10, T11, T12, T13, T14, TAllComments, Util
   build-depends:       base >= 4.7 && < 5, QuickCheck
   default-language:    Haskell2010
   ghc-options:         -Wall -fwarn-unused-imports