Skip to content

Commit 480c6bc

Browse files
tittoassinitittoassini
committed
Extended Eval Plugin (additional changes)
1 parent 9848239 commit 480c6bc

27 files changed

+746
-586
lines changed

‎haskell-language-server.cabal

Lines changed: 3 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
@@ -247,6 +246,7 @@ test-suite func-test
247246
, tasty-expected-failure
248247
, tasty-golden
249248
, tasty-rerun
249+
, QuickCheck
250250

251251
hs-source-dirs: test/functional plugins/tactics/src
252252

‎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/Parser.hs

Lines changed: 54 additions & 45 deletions
Original file line numberDiff line numberDiff line change
@@ -1,32 +1,35 @@
1-
-- |Simple List Parser, used for both line and test parsing.
21
{-# LANGUAGE DeriveFunctor #-}
3-
module Ide.Plugin.Eval.Parse.Parser
4-
( Parser
5-
, runParser
6-
, satisfy
7-
, alphaNumChar
8-
, letterChar
9-
, space
10-
, string
11-
, char
12-
, tillEnd
13-
)
14-
where
15-
16-
import Control.Applicative ( Alternative )
17-
import Control.Monad ( MonadPlus )
18-
import Control.Monad.Combinators ( empty
19-
, (<|>)
20-
)
21-
import Data.Char ( isAlphaNum
22-
, isLetter
23-
)
24-
import Data.List ( isPrefixOf )
2+
3+
-- |Simple List Parser, used for both line and test parsing.
4+
module Ide.Plugin.Eval.Parse.Parser (
5+
Parser,
6+
runParser,
7+
satisfy,
8+
alphaNumChar,
9+
letterChar,
10+
space,
11+
string,
12+
char,
13+
tillEnd,
14+
) where
15+
16+
import Control.Applicative (Alternative)
17+
import Control.Monad (MonadPlus, (>=>))
18+
import Control.Monad.Combinators (
19+
empty,
20+
(<|>),
21+
)
22+
import Data.Char (
23+
isAlphaNum,
24+
isLetter,
25+
)
26+
import Data.List (isPrefixOf)
2527

2628
type CharParser = Parser Char
2729

28-
-- $setup
29-
-- >>> import Control.Monad.Combinators
30+
{- $setup
31+
>>> import Control.Monad.Combinators
32+
-}
3033

3134
{- |
3235
>>> runParser (string "aa" <|> string "bb") "bb"
@@ -36,8 +39,8 @@ Right "bb"
3639
Right ["aa","aa","aa"]
3740
-}
3841
string :: String -> CharParser String
39-
string t = Parser
40-
$ \s -> if (t `isPrefixOf` s) then Just (t, drop (length t) s) else Nothing
42+
string t = Parser $
43+
\s -> if t `isPrefixOf` s then Just (t, drop (length t) s) else Nothing
4144

4245
letterChar :: Parser Char Char
4346
letterChar = satisfy isLetter
@@ -48,42 +51,48 @@ alphaNumChar = satisfy isAlphaNum
4851
space :: Parser Char Char
4952
space = char ' '
5053

51-
-- |
52-
-- >>> runParser (some $ char 'a') "aa"
53-
-- Right "aa"
54+
{- |
55+
>>> runParser (some $ char 'a') "aa"
56+
Right "aa"
57+
-}
5458
char :: Char -> CharParser Char
5559
char ch = satisfy (== ch)
5660

61+
{- |
62+
>>> runParser tillEnd "abc\ndef"
63+
Right "abc\ndef"
64+
-}
5765
tillEnd :: Parser t [t]
5866
tillEnd = Parser $ \s -> Just (s, [])
5967

6068
satisfy :: (t -> Bool) -> Parser t t
6169
satisfy f = Parser sel
62-
where
63-
sel [] = Nothing
64-
sel (t : ts) | f t = Just (t, ts)
65-
| otherwise = Nothing
70+
where
71+
sel [] = Nothing
72+
sel (t : ts)
73+
| f t = Just (t, ts)
74+
| otherwise = Nothing
6675

6776
newtype Parser t a = Parser {parse :: [t] -> Maybe (a, [t])} deriving (Functor)
6877

6978
instance Applicative (Parser t) where
70-
pure a = Parser (\s -> Just (a, s))
71-
(Parser p1) <*> (Parser p2) =
72-
Parser (\s -> p1 s >>= \(f, s1) -> p2 s1 >>= \(a, s2) -> return (f a, s2))
79+
pure a = Parser (\s -> Just (a, s))
80+
(Parser p1) <*> (Parser p2) =
81+
Parser (p1 >=> (\(f, s1) -> p2 s1 >>= \(a, s2) -> return (f a, s2)))
7382

7483
instance Alternative (Parser t) where
75-
empty = Parser (\_ -> Nothing)
76-
p <|> q = Parser $ \s -> parse p s <|> parse q s
84+
empty = Parser (const Nothing)
85+
p <|> q = Parser $ \s -> parse p s <|> parse q s
7786

7887
instance Monad (Parser t) where
79-
return = pure
80-
(>>=) f g = Parser $ \s -> parse f s >>= \(a, s') -> parse (g a) s'
88+
return = pure
89+
(>>=) f g = Parser (parse f >=> (\(a, s') -> parse (g a) s'))
8190

8291
instance MonadPlus (Parser t)
8392

8493
runParser :: Show t => Parser t a -> [t] -> Either String a
8594
runParser m s = case parse m s of
86-
Just (res, []) -> Right res
87-
Just (_, ts) ->
88-
Left $ "Parser did not consume entire stream, left: " ++ show ts
89-
Nothing -> Left "No match"
95+
Just (res, []) -> Right res
96+
Just (_, ts) ->
97+
Left $ "Parser did not consume entire stream, left: " ++ show ts
98+
Nothing -> Left "No match"

‎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

0 commit comments

Comments
 (0)