Skip to content

Commit 9be46df

Browse files
tittoassinitittoassini
committed
Extended Eval Plugin (additional changes)
1 parent 9848239 commit 9be46df

17 files changed

+414
-405
lines changed

‎haskell-language-server.cabal

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -154,13 +154,12 @@ executable haskell-language-server
154154
, time
155155
, transformers
156156
, unordered-containers
157-
-- , ghc-exactprint
158157
, parser-combinators
159158
, pretty-simple
160-
, Diff == 0.4.*
161-
-- , ghc-paths
159+
, Diff
162160
, QuickCheck
163161

162+
164163
if flag(agpl)
165164
build-depends: brittany
166165
other-modules: Ide.Plugin.Brittany

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

Lines changed: 160 additions & 173 deletions
Large diffs are not rendered by default.

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

Lines changed: 7 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -10,9 +10,9 @@ module Ide.Plugin.Eval.GHC (
1010
hasPackage,
1111
addPackages,
1212
modifyFlags,
13-
gStrictTry,
1413
) where
1514

15+
import Control.DeepSeq (NFData, ($!!))
1616
import Control.Exception (SomeException)
1717
import Data.List (isPrefixOf)
1818
import Development.IDE.GHC.Error ()
@@ -43,7 +43,7 @@ import GhcPlugins (
4343
xopt_set,
4444
)
4545
import HscTypes (InteractiveContext (ic_dflags))
46-
import Ide.Plugin.Eval.Util (asS)
46+
import Ide.Plugin.Eval.Util (asS, gStrictTry)
4747
import qualified Lexer as Lexer
4848
import Module (UnitId (DefiniteUnitId))
4949
import Outputable (
@@ -60,11 +60,11 @@ import SrcLoc (mkRealSrcLoc)
6060
import StringBuffer (stringToStringBuffer)
6161

6262
{- $setup
63-
>>> import GHC
64-
>>> import GHC.Paths
65-
>>> run act = runGhc (Just libdir) (getSessionDynFlags >>= act)
66-
>>> libdir
67-
"/Users/titto/.stack/programs/x86_64-osx/ghc-8.10.2/lib/ghc-8.10.2"
63+
>>> import GHC
64+
>>> import GHC.Paths
65+
>>> run act = runGhc (Just libdir) (getSessionDynFlags >>= act)
66+
>>> libdir
67+
"/Users/titto/.stack/programs/x86_64-osx/ghc-8.10.2/lib/ghc-8.10.2"
6868
-}
6969

7070
{- | Returns true if string is an expression
@@ -200,10 +200,3 @@ instance Show DynFlags where
200200

201201
vList :: [String] -> SDoc
202202
vList = vcat . map text
203-
204-
gStrictTry :: ExceptionMonad m => m b -> m (Either String b)
205-
gStrictTry op =
206-
gcatch
207-
-- gStrictTry op = MC.catch
208-
(op >>= \v -> return $! Right $! v)
209-
(\(err :: SomeException) -> return $! Left $! show $! err)

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

Lines changed: 68 additions & 52 deletions
Original file line numberDiff line numberDiff line change
@@ -1,79 +1,95 @@
1-
-- |Parse a Section, a group of zero or more tests defined in a multiline comment or a sequence of one line comments.
1+
{-# LANGUAGE RecordWildCards #-}
2+
{-# LANGUAGE ViewPatterns #-}
23
{-# LANGUAGE NoMonomorphismRestriction #-}
3-
{-# LANGUAGE RecordWildCards #-}
4-
{-# LANGUAGE ViewPatterns #-}
54
{-# OPTIONS_GHC -Wwarn #-}
65
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
76

8-
module Ide.Plugin.Eval.Parse.Section
9-
( allSections,
7+
-- |Parse a Section, a group of zero or more tests defined in a multiline comment or a sequence of one line comments.
8+
module Ide.Plugin.Eval.Parse.Section (
9+
allSections,
1010
validSections,
1111
Section (..),
12-
)
13-
where
12+
) where
1413

1514
import qualified Control.Applicative.Combinators.NonEmpty as NE
16-
import Control.Monad.Combinators (many, optional, some,
17-
(<|>))
18-
import qualified Data.List.NonEmpty as NE
19-
import Data.Maybe (catMaybes, fromMaybe)
20-
import Ide.Plugin.Eval.Parse.Parser (Parser, runParser,
21-
satisfy)
22-
import Ide.Plugin.Eval.Parse.Token (Token (BlockOpen, blockFormat, blockLanguage, blockName),
23-
TokenS, isBlockClose,
24-
isBlockOpen,
25-
isCodeLine,
26-
isPropLine,
27-
isStatement,
28-
isTextLine,
29-
unsafeContent)
30-
import Ide.Plugin.Eval.Types (Format (SingleLine),
31-
Loc,
32-
Located (Located, located, location),
33-
Section (..),
34-
Test (Example, Property),
35-
hasTests, unLoc)
15+
import Control.Monad.Combinators (
16+
many,
17+
optional,
18+
some,
19+
(<|>),
20+
)
21+
import qualified Data.List.NonEmpty as NE
22+
import Data.Maybe (catMaybes, fromMaybe)
23+
import Ide.Plugin.Eval.Parse.Parser (
24+
Parser,
25+
runParser,
26+
satisfy,
27+
)
28+
import Ide.Plugin.Eval.Parse.Token (
29+
Token (BlockOpen, blockFormat, blockLanguage, blockName),
30+
TokenS,
31+
isBlockClose,
32+
isBlockOpen,
33+
isCodeLine,
34+
isPropLine,
35+
isStatement,
36+
isTextLine,
37+
unsafeContent,
38+
)
39+
import Ide.Plugin.Eval.Types (
40+
Format (SingleLine),
41+
Loc,
42+
Located (Located, located, location),
43+
Section (..),
44+
Test (Example, Property),
45+
hasTests,
46+
unLoc,
47+
)
3648

3749
type Tk = Loc TokenS
3850

39-
4051
validSections :: [Tk] -> Either String [Section]
4152
validSections = (filter hasTests <$>) . allSections
4253

4354
allSections :: [Tk] -> Either String [Section]
4455
allSections = runParser sections
4556

46-
{-|
57+
{-
58+
>>> import Ide.Plugin.Eval.Parse.Token
4759
>>> import System.IO.Extra(readFileUTF8')
48-
>>> testSource fp = runParser sections . tokensFrom <$> readFileUTF8' fp
60+
>>> testSource_ = runParser sections . tokensFrom
61+
>>> testSource fp = testSource_ <$> readFileUTF8' fp
62+
63+
>>> testSource "plugins/default/src/Ide/Plugin/Eval/Test/TestGHC.hs"
64+
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}]
4965
5066
>>> testSource "test/testdata/eval/T11.hs"
51-
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}]
67+
Right [Section {sectionName = "", sectionTests = [Located {location = 2, located = Example {testLines = " :kind! a" :| [], testOutput = []}}], sectionLanguage = Plain, sectionFormat = SingleLine}]
5268
5369
>>> testSource "test/testdata/eval/T12.hs"
54-
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}]
70+
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}]
5571
72+
>>> testSource_ $ "{"++"-\n -" ++ "}"
73+
Right [Section {sectionName = "", sectionTests = [], sectionLanguage = Plain, sectionFormat = MultiLine}]
5674
-}
5775
sections :: Parser Tk [Section]
5876
sections =
59-
catMaybes <$> many (const Nothing <$> some code <|> Just <$> section)
60-
77+
catMaybes <$> many (const Nothing <$> some code <|> Just <$> section)
6178

6279
section :: Parser Tk Section
6380
section = sectionBody >>= sectionEnd
6481

6582
sectionBody :: Parser Tk Section
6683
sectionBody =
67-
do
68-
( \(unLoc -> BlockOpen {..}) ts ->
84+
( \(unLoc -> BlockOpen{..}) ts ->
6985
Section (fromMaybe "" blockName) (catMaybes ts) blockLanguage blockFormat
70-
)
71-
<$> open <*> many (Just <$> example <|> Just <$> property <|> const Nothing <$> doc)
86+
)
87+
<$> open <*> many (Just <$> example <|> Just <$> property <|> const Nothing <$> doc)
7288

7389
sectionEnd :: Section -> Parser Tk Section
7490
sectionEnd s
75-
| sectionFormat s == SingleLine = optional code *> return s
76-
| otherwise = close *> return s
91+
| sectionFormat s == SingleLine = optional code *> return s
92+
| otherwise = close *> return s
7793

7894
-- section = do
7995
-- s <-
@@ -98,19 +114,19 @@ doc = some text
98114

99115
example, property :: Parser Tk (Loc Test)
100116
property =
101-
( \(Located l p) rs ->
102-
Located l (Property (unsafeContent p) (unsafeContent . located <$> rs))
103-
)
104-
<$> prop
105-
<*> many nonEmptyText
117+
( \(Located l p) rs ->
118+
Located l (Property (unsafeContent p) (unsafeContent . located <$> rs))
119+
)
120+
<$> prop
121+
<*> many nonEmptyText
106122
example =
107-
( \es rs ->
108-
Located
109-
(location (NE.head es))
110-
(Example (unsafeContent . located <$> es) (unsafeContent . located <$> rs))
111-
)
112-
<$> NE.some statement
113-
<*> many nonEmptyText
123+
( \es rs ->
124+
Located
125+
(location (NE.head es))
126+
(Example (unsafeContent . located <$> es) (unsafeContent . located <$> rs))
127+
)
128+
<$> NE.some statement
129+
<*> many nonEmptyText
114130

115131
open, close, statement, nonEmptyText, text, prop, code :: Parser Tk Tk
116132
statement = is isStatement

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

Lines changed: 23 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -71,13 +71,15 @@ contentOf (TextLine c) = Just c
7171
contentOf _ = Nothing
7272

7373
{- | Parse source code and return a list of located Tokens
74+
>>> import Ide.Plugin.Eval.Types (unLoc)
7475
>>> tks src = map unLoc . tokensFrom <$> readFile src
7576
7677
>>> tks "test/testdata/eval/T1.hs"
7778
[CodeLine,CodeLine,CodeLine,CodeLine,BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = SingleLine},Statement " unwords example",CodeLine,CodeLine]
7879
79-
>>> tks "test/testdata/eval/T11.hs"
80-
[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]
80+
>>> tks "test/testdata/eval/TLanguageOptions.hs"
81+
[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]
82+
8183
-}
8284
tokensFrom :: String -> [Loc (Token String)]
8385
tokensFrom = tokens . lines
@@ -104,8 +106,8 @@ tokensFrom = tokens . lines
104106
>>> tokens ["{-# LANGUAGE TupleSections","#-}"]
105107
[Located {location = 0, located = CodeLine},Located {location = 1, located = CodeLine}]
106108
107-
-- FIX
108-
>>> tokens ["{"++"--"++"}"]
109+
>>> length $ tokens ["{"++"--"++"}"]
110+
2
109111
110112
>>> tokens []
111113
[]
@@ -215,26 +217,30 @@ multiStart :: Parser Char ()
215217
multiStart = string "{-" *> optional space *> return ()
216218

217219
multiClose :: TParser
218-
multiClose = string "-}" >> return (InCode, [BlockClose])
220+
multiClose = many space *> string "-}" >> return (InCode, [BlockClose])
219221

220222
optionStart :: Parser Char (State, [Token s])
221223
optionStart = string "{-#" *> tillEnd *> return (InCode, [CodeLine])
222224

223225
name :: Parser Char [Char]
224226
name = (:) <$> letterChar <*> many (alphaNumChar <|> char '_')
225227

226-
-- |
227-
-- >>>runParser languageAndName "|$"
228-
-- Right (Just Haddock,Just "")
229-
--
230-
-- >>>runParser languageAndName "|$start"
231-
-- Right (Just Haddock,Just "start")
232-
--
233-
-- >>>runParser languageAndName "^"
234-
-- Right (Just Haddock,Nothing)
235-
--
236-
-- >>>runParser languageAndName "$start"
237-
-- Right (Nothing,Just "start")
228+
{- |
229+
>>>runParser languageAndName "|$"
230+
Right (Just Haddock,Just "")
231+
232+
>>>runParser languageAndName "|$start"
233+
Right (Just Haddock,Just "start")
234+
235+
>>>runParser languageAndName "| $start"
236+
Right (Just Haddock,Just "start")
237+
238+
>>>runParser languageAndName "^"
239+
Right (Just Haddock,Nothing)
240+
241+
>>>runParser languageAndName "$start"
242+
Right (Nothing,Just "start")
243+
-}
238244
languageAndName :: Parser Char (Maybe Language, Maybe String)
239245
languageAndName =
240246
(,) <$> optional ((char '|' <|> char '^') >> pure Haddock)

0 commit comments

Comments
 (0)