|
1 | | -{-# LANGUAGE LambdaCase #-} |
2 | | -{-# LANGUAGE OverloadedStrings #-} |
3 | | -{-# LANGUAGE ViewPatterns #-} |
4 | | -{-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-} |
5 | | - |
6 | | --- | Expression execution |
7 | | -module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalSetup, propSetup, testCheck, asStatements,myExecStmt) where |
8 | | - |
9 | | -import Control.Lens ((^.)) |
10 | | -import Control.Monad.IO.Class |
11 | | -import Data.Algorithm.Diff (Diff, PolyDiff (..), getDiff) |
12 | | -import qualified Data.List.NonEmpty as NE |
13 | | -import Data.String (IsString) |
14 | | -import qualified Data.Text as T |
15 | | -import Development.IDE.GHC.Compat |
16 | | -import Development.IDE.Types.Location (Position (..), Range (..)) |
17 | | -import GHC (ExecOptions, ExecResult (..), |
18 | | - execStmt) |
19 | | -import Ide.Plugin.Eval.Types (Language (Plain), Loc, |
20 | | - Located (..), |
21 | | - Section (sectionLanguage), |
22 | | - Test (..), Txt, locate, |
23 | | - locate0) |
24 | | -import Language.LSP.Types.Lens (line, start) |
25 | | -import System.IO.Extra (newTempFile, readFile') |
26 | | - |
27 | | --- | Return the ranges of the expression and result parts of the given test |
28 | | -testRanges :: Test -> (Range, Range) |
29 | | -testRanges tst = |
30 | | - let startLine = testRange tst ^. start.line |
31 | | - (fromIntegral -> exprLines, fromIntegral -> resultLines) = testLengths tst |
32 | | - resLine = startLine + exprLines |
33 | | - in ( Range |
34 | | - (Position startLine 0) |
35 | | - --(Position (startLine + exprLines + resultLines) 0), |
36 | | - (Position resLine 0) |
37 | | - , Range (Position resLine 0) (Position (resLine + resultLines) 0) |
38 | | - ) |
39 | | - |
40 | | -{- |The document range where a test is defined |
41 | | - testRange :: Loc Test -> Range |
42 | | - testRange = fst . testRanges |
43 | | --} |
44 | | - |
45 | | --- |The document range where the result of the test is defined |
46 | | -resultRange :: Test -> Range |
47 | | -resultRange = snd . testRanges |
48 | | - |
49 | | --- TODO: handle BLANKLINE |
50 | | -{- |
51 | | ->>> showDiffs $ getDiff ["abc","def","ghi","end"] ["abc","def","Z","ZZ","end"] |
52 | | -["abc","def","WAS ghi","NOW Z","NOW ZZ","end"] |
53 | | --} |
54 | | -showDiffs :: (Semigroup a, IsString a) => [Diff a] -> [a] |
55 | | -showDiffs = map showDiff |
56 | | - |
57 | | -showDiff :: (Semigroup a, IsString a) => Diff a -> a |
58 | | -showDiff (First w) = "WAS " <> w |
59 | | -showDiff (Second w) = "NOW " <> w |
60 | | -showDiff (Both w _) = w |
61 | | - |
62 | | -testCheck :: (Section, Test) -> [T.Text] -> [T.Text] |
63 | | -testCheck (section, test) out |
64 | | - | null (testOutput test) || sectionLanguage section == Plain = out |
65 | | - | otherwise = showDiffs $ getDiff (map T.pack $ testOutput test) out |
66 | | - |
67 | | -testLengths :: Test -> (Int, Int) |
68 | | -testLengths (Example e r _) = (NE.length e, length r) |
69 | | -testLengths (Property _ r _) = (1, length r) |
70 | | - |
71 | | --- |A one-line Haskell statement |
72 | | -type Statement = Loc String |
73 | | - |
74 | | -asStatements :: Test -> [Statement] |
75 | | -asStatements lt = locate $ Located (fromIntegral $ testRange lt ^. start.line) (asStmts lt) |
76 | | - |
77 | | -asStmts :: Test -> [Txt] |
78 | | -asStmts (Example e _ _) = NE.toList e |
79 | | -asStmts (Property t _ _) = |
80 | | - ["prop11 = " ++ t, "(propEvaluation prop11 :: IO String)"] |
81 | | - |
82 | | - |
83 | | --- |GHC declarations required for expression evaluation |
84 | | -evalSetup :: Ghc () |
85 | | -evalSetup = do |
86 | | - preludeAsP <- parseImportDecl "import qualified Prelude as P" |
87 | | - context <- getContext |
88 | | - setContext (IIDecl preludeAsP : context) |
89 | | - |
90 | | --- | A wrapper of 'InteractiveEval.execStmt', capturing the execution result |
91 | | -myExecStmt :: String -> ExecOptions -> Ghc (Either String (Maybe String)) |
92 | | -myExecStmt stmt opts = do |
93 | | - (temp, purge) <- liftIO newTempFile |
94 | | - evalPrint <- head <$> runDecls ("evalPrint x = P.writeFile "<> show temp <> " (P.show x)") |
95 | | - modifySession $ \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) evalPrint} |
96 | | - result <- execStmt stmt opts >>= \case |
97 | | - ExecComplete (Left err) _ -> pure $ Left $ show err |
98 | | - ExecComplete (Right _) _ -> liftIO $ Right . (\x -> if null x then Nothing else Just x) <$> readFile' temp |
99 | | - ExecBreak{} -> pure $ Right $ Just "breakpoints are not supported" |
100 | | - liftIO purge |
101 | | - pure result |
102 | | - |
103 | | -{- |GHC declarations required to execute test properties |
104 | | -
|
105 | | -Example: |
106 | | -
|
107 | | -prop> \(l::[Bool]) -> reverse (reverse l) == l |
108 | | -+++ OK, passed 100 tests. |
109 | | -
|
110 | | -prop> \(l::[Bool]) -> reverse l == l |
111 | | -*** Failed! Falsified (after 6 tests and 2 shrinks): |
112 | | -[True,False] |
113 | | --} |
114 | | -propSetup :: [Loc [Char]] |
115 | | -propSetup = |
116 | | - locate0 |
117 | | - [ ":set -XScopedTypeVariables -XExplicitForAll" |
118 | | - , "import qualified Test.QuickCheck as Q11" |
119 | | - , "propEvaluation p = Q11.quickCheckWithResult Q11.stdArgs p >>= error . Q11.output" -- uses `error` to get a multi-line display |
120 | | - ] |
| 1 | +{-# LANGUAGE LambdaCase #-} |
| 2 | +{-# LANGUAGE OverloadedStrings #-} |
| 3 | +{-# LANGUAGE ViewPatterns #-} |
| 4 | +{-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-} |
| 5 | + |
| 6 | +-- | Expression execution |
| 7 | +module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalSetup, propSetup, testCheck, asStatements,myExecStmt) where |
| 8 | + |
| 9 | +import Control.Lens ((^.)) |
| 10 | +import Control.Monad.IO.Class |
| 11 | +import Data.Algorithm.Diff (Diff, PolyDiff (..), getDiff) |
| 12 | +import qualified Data.List.NonEmpty as NE |
| 13 | +import Data.String (IsString) |
| 14 | +import qualified Data.Text as T |
| 15 | +import Development.IDE.GHC.Compat |
| 16 | +import Development.IDE.Types.Location (Position (..), Range (..)) |
| 17 | +import GHC (ExecOptions, ExecResult (..), |
| 18 | + execStmt) |
| 19 | +import Ide.Plugin.Eval.Types (Language (Plain), Loc, |
| 20 | + Located (..), |
| 21 | + Section (sectionLanguage), |
| 22 | + Test (..), Txt, locate, |
| 23 | + locate0) |
| 24 | +import Language.LSP.Types.Lens (line, start) |
| 25 | +import System.IO.Extra (newTempFile, readFile') |
| 26 | + |
| 27 | +-- | Return the ranges of the expression and result parts of the given test |
| 28 | +testRanges :: Test -> (Range, Range) |
| 29 | +testRanges tst = |
| 30 | + let startLine = testRange tst ^. start.line |
| 31 | + (fromIntegral -> exprLines, fromIntegral -> resultLines) = testLengths tst |
| 32 | + resLine = startLine + exprLines |
| 33 | + in ( Range |
| 34 | + (Position startLine 0) |
| 35 | + --(Position (startLine + exprLines + resultLines) 0), |
| 36 | + (Position resLine 0) |
| 37 | + , Range (Position resLine 0) (Position (resLine + resultLines) 0) |
| 38 | + ) |
| 39 | + |
| 40 | +{- |The document range where a test is defined |
| 41 | + testRange :: Loc Test -> Range |
| 42 | + testRange = fst . testRanges |
| 43 | +-} |
| 44 | + |
| 45 | +-- |The document range where the result of the test is defined |
| 46 | +resultRange :: Test -> Range |
| 47 | +resultRange = snd . testRanges |
| 48 | + |
| 49 | +-- TODO: handle BLANKLINE |
| 50 | +{- |
| 51 | +>>> showDiffs $ getDiff ["abc","def","ghi","end"] ["abc","def","Z","ZZ","end"] |
| 52 | +["abc","def","WAS ghi","NOW Z","NOW ZZ","end"] |
| 53 | +-} |
| 54 | +showDiffs :: (Semigroup a, IsString a) => [Diff a] -> [a] |
| 55 | +showDiffs = map showDiff |
| 56 | + |
| 57 | +showDiff :: (Semigroup a, IsString a) => Diff a -> a |
| 58 | +showDiff (First w) = "WAS " <> w |
| 59 | +showDiff (Second w) = "NOW " <> w |
| 60 | +showDiff (Both w _) = w |
| 61 | + |
| 62 | +testCheck :: Bool -> (Section, Test) -> [T.Text] -> [T.Text] |
| 63 | +testCheck diff (section, test) out |
| 64 | + | not diff || null (testOutput test) || sectionLanguage section == Plain = out |
| 65 | + | otherwise = showDiffs $ getDiff (map T.pack $ testOutput test) out |
| 66 | + |
| 67 | +testLengths :: Test -> (Int, Int) |
| 68 | +testLengths (Example e r _) = (NE.length e, length r) |
| 69 | +testLengths (Property _ r _) = (1, length r) |
| 70 | + |
| 71 | +-- |A one-line Haskell statement |
| 72 | +type Statement = Loc String |
| 73 | + |
| 74 | +asStatements :: Test -> [Statement] |
| 75 | +asStatements lt = locate $ Located (fromIntegral $ testRange lt ^. start.line) (asStmts lt) |
| 76 | + |
| 77 | +asStmts :: Test -> [Txt] |
| 78 | +asStmts (Example e _ _) = NE.toList e |
| 79 | +asStmts (Property t _ _) = |
| 80 | + ["prop11 = " ++ t, "(propEvaluation prop11 :: IO String)"] |
| 81 | + |
| 82 | + |
| 83 | +-- |GHC declarations required for expression evaluation |
| 84 | +evalSetup :: Ghc () |
| 85 | +evalSetup = do |
| 86 | + preludeAsP <- parseImportDecl "import qualified Prelude as P" |
| 87 | + context <- getContext |
| 88 | + setContext (IIDecl preludeAsP : context) |
| 89 | + |
| 90 | +-- | A wrapper of 'InteractiveEval.execStmt', capturing the execution result |
| 91 | +myExecStmt :: String -> ExecOptions -> Ghc (Either String (Maybe String)) |
| 92 | +myExecStmt stmt opts = do |
| 93 | + (temp, purge) <- liftIO newTempFile |
| 94 | + evalPrint <- head <$> runDecls ("evalPrint x = P.writeFile "<> show temp <> " (P.show x)") |
| 95 | + modifySession $ \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) evalPrint} |
| 96 | + result <- execStmt stmt opts >>= \case |
| 97 | + ExecComplete (Left err) _ -> pure $ Left $ show err |
| 98 | + ExecComplete (Right _) _ -> liftIO $ Right . (\x -> if null x then Nothing else Just x) <$> readFile' temp |
| 99 | + ExecBreak{} -> pure $ Right $ Just "breakpoints are not supported" |
| 100 | + liftIO purge |
| 101 | + pure result |
| 102 | + |
| 103 | +{- |GHC declarations required to execute test properties |
| 104 | +
|
| 105 | +Example: |
| 106 | +
|
| 107 | +prop> \(l::[Bool]) -> reverse (reverse l) == l |
| 108 | ++++ OK, passed 100 tests. |
| 109 | +
|
| 110 | +prop> \(l::[Bool]) -> reverse l == l |
| 111 | +*** Failed! Falsified (after 6 tests and 2 shrinks): |
| 112 | +[True,False] |
| 113 | +-} |
| 114 | +propSetup :: [Loc [Char]] |
| 115 | +propSetup = |
| 116 | + locate0 |
| 117 | + [ ":set -XScopedTypeVariables -XExplicitForAll" |
| 118 | + , "import qualified Test.QuickCheck as Q11" |
| 119 | + , "propEvaluation p = Q11.quickCheckWithResult Q11.stdArgs p >>= error . Q11.output" -- uses `error` to get a multi-line display |
| 120 | + ] |
0 commit comments