/
Code.hs
137 lines (118 loc) · 5.48 KB
/
Code.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-}
-- | Expression execution
module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalExtensions, evalSetup, propSetup, testCheck, asStatements,myExecStmt) where
import Control.Lens ((^.))
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 (ExecOptions, ExecResult (..),
execStmt)
import GHC.LanguageExtensions.Type (Extension (..))
import GhcMonad (Ghc, liftIO, modifySession)
import HscTypes
import Ide.Plugin.Eval.Types (Language (Plain), Loc,
Located (..),
Section (sectionLanguage),
Test (..), Txt, locate,
locate0)
import InteractiveEval (execOptions, getContext,
parseImportDecl, runDecls,
setContext)
import Language.LSP.Types.Lens (line, start)
import System.IO.Extra (newTempFile, readFileUTF8')
-- | Return the ranges of the expression and result parts of the given test
testRanges :: Test -> (Range, Range)
testRanges tst =
let startLine = testRange tst ^. start.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 :: 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 :: Test -> [Statement]
asStatements lt = locate $ Located (testRange lt ^. start.line) (asStmts lt)
asStmts :: Test -> [Txt]
asStmts (Example e _ _) = NE.toList e
asStmts (Property t _ _) =
["prop11 = " ++ t, "(propEvaluation prop11 :: 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 = do
preludeAsP <- parseImportDecl "import qualified Prelude as P"
encodingAsP <- parseImportDecl "import qualified GHC.IO.Encoding as P"
context <- getContext
setContext (IIDecl encodingAsP : IIDecl preludeAsP : context)
execStmt "P.setLocaleEncoding P.utf8" execOptions >>= \case
ExecComplete (Left err) _ -> error $ "failed to set encoding in eval setup: " <> show err
ExecComplete (Right _) _ -> pure ()
ExecBreak{} -> error "breakpoints are not supported"
-- | A wrapper of 'InteractiveEval.execStmt', capturing the execution result
myExecStmt :: String -> ExecOptions -> Ghc (Either String (Maybe String))
myExecStmt stmt opts = do
(temp, purge) <- liftIO newTempFile
evalPrint <- head <$> runDecls ("evalPrint x = P.writeFile "<> show temp <> " (P.show x)")
modifySession $ \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) evalPrint}
result <- execStmt stmt opts >>= \case
ExecComplete (Left err) _ -> pure $ Left $ show err
ExecComplete (Right _) _ -> liftIO $ Right . (\x -> if null x then Nothing else Just x) <$> readFileUTF8' temp
ExecBreak{} -> pure $ Right $ Just "breakpoints are not supported"
liftIO purge
pure result
{- |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
]