{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}
{-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-}

-- | Expression execution
module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, propSetup, testCheck, asStatements,myExecStmt) where

import           Control.Lens                ((^.))
import           Control.Monad.IO.Class
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.GHC.Compat
import           GHC                         (ExecOptions, ExecResult (..),
                                              execStmt)
import           Ide.Plugin.Eval.Types       (Language (Plain), Loc,
                                              Located (..),
                                              Section (sectionLanguage),
                                              Test (..), Txt, locate, locate0)
import qualified Language.LSP.Protocol.Lens  as L
import           Language.LSP.Protocol.Types (Position (Position),
                                              Range (Range))
import           System.IO.Extra             (newTempFile, readFile')

-- | Return the ranges of the expression and result parts of the given test
testRanges :: Test -> (Range, Range)
testRanges :: Test -> (Range, Range)
testRanges Test
tst =
    let startLine :: UInt
startLine = Test -> Range
testRange Test
tst forall s a. s -> Getting a s a -> a
^. forall s a. HasStart s a => Lens' s a
L.start forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasLine s a => Lens' s a
L.line
        (forall a b. (Integral a, Num b) => a -> b
fromIntegral -> UInt
exprLines, forall a b. (Integral a, Num b) => a -> b
fromIntegral -> UInt
resultLines) = Test -> (Line, Line)
testLengths Test
tst
        resLine :: UInt
resLine = UInt
startLine forall a. Num a => a -> a -> a
+ UInt
exprLines
     in ( Position -> Position -> Range
Range
            (UInt -> UInt -> Position
Position UInt
startLine UInt
0)
            --(Position (startLine + exprLines + resultLines) 0),
            (UInt -> UInt -> Position
Position UInt
resLine UInt
0)
        , Position -> Position -> Range
Range (UInt -> UInt -> Position
Position UInt
resLine UInt
0) (UInt -> UInt -> Position
Position (UInt
resLine forall a. Num a => a -> a -> a
+ UInt
resultLines) UInt
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 :: Test -> Range
resultRange = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Test -> (Range, Range)
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 :: forall a. (Semigroup a, IsString a) => [Diff a] -> [a]
showDiffs = forall a b. (a -> b) -> [a] -> [b]
map forall a. (Semigroup a, IsString a) => Diff a -> a
showDiff

showDiff :: (Semigroup a, IsString a) => Diff a -> a
showDiff :: forall a. (Semigroup a, IsString a) => Diff a -> a
showDiff (First a
w)  = a
"WAS " forall a. Semigroup a => a -> a -> a
<> a
w
showDiff (Second a
w) = a
"NOW " forall a. Semigroup a => a -> a -> a
<> a
w
showDiff (Both a
w a
_) = a
w

testCheck :: Bool -> (Section, Test) -> [T.Text] -> [T.Text]
testCheck :: Bool -> (Section, Test) -> [Text] -> [Text]
testCheck Bool
diff (Section
section, Test
test) [Text]
out
    | Bool -> Bool
not Bool
diff Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Test -> [[Char]]
testOutput Test
test) Bool -> Bool -> Bool
|| Section -> Language
sectionLanguage Section
section forall a. Eq a => a -> a -> Bool
== Language
Plain = [Text]
out
    | Bool
otherwise = forall a. (Semigroup a, IsString a) => [Diff a] -> [a]
showDiffs forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> [Diff a]
getDiff (forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Test -> [[Char]]
testOutput Test
test) [Text]
out

testLengths :: Test -> (Int, Int)
testLengths :: Test -> (Line, Line)
testLengths (Example NonEmpty [Char]
e [[Char]]
r Range
_)  = (forall a. NonEmpty a -> Line
NE.length NonEmpty [Char]
e, forall (t :: * -> *) a. Foldable t => t a -> Line
length [[Char]]
r)
testLengths (Property [Char]
_ [[Char]]
r Range
_) = (Line
1, forall (t :: * -> *) a. Foldable t => t a -> Line
length [[Char]]
r)

-- |A one-line Haskell statement
type Statement = Loc String

asStatements :: Test -> [Statement]
asStatements :: Test -> [Statement]
asStatements Test
lt = forall a. Loc [a] -> [Loc a]
locate forall a b. (a -> b) -> a -> b
$ forall l a. l -> a -> Located l a
Located (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Test -> Range
testRange Test
lt forall s a. s -> Getting a s a -> a
^. forall s a. HasStart s a => Lens' s a
L.start forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasLine s a => Lens' s a
L.line) (Test -> [[Char]]
asStmts Test
lt)

asStmts :: Test -> [Txt]
asStmts :: Test -> [[Char]]
asStmts (Example NonEmpty [Char]
e [[Char]]
_ Range
_) = forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
e
asStmts (Property [Char]
t [[Char]]
_ Range
_) =
    [[Char]
"prop11 = " forall a. [a] -> [a] -> [a]
++ [Char]
t, [Char]
"(propEvaluation prop11 :: IO String)"]



-- | A wrapper of 'InteractiveEval.execStmt', capturing the execution result
myExecStmt :: String -> ExecOptions -> Ghc (Either String (Maybe String))
myExecStmt :: [Char] -> ExecOptions -> Ghc (Either [Char] (Maybe [Char]))
myExecStmt [Char]
stmt ExecOptions
opts = do
    ([Char]
temp, IO ()
purge) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ([Char], IO ())
newTempFile
    Name
evalPrint <- forall a. [a] -> a
head forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). GhcMonad m => [Char] -> m [Name]
runDecls ([Char]
"evalPrint x = P.writeFile "forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
temp forall a. Semigroup a => a -> a -> a
<> [Char]
" (P.show x)")
    forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc -> HscEnv
hsc {hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext -> Name -> InteractiveContext
setInteractivePrintName (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc) Name
evalPrint}
    Either [Char] (Maybe [Char])
result <- forall (m :: * -> *).
GhcMonad m =>
[Char] -> ExecOptions -> m ExecResult
execStmt [Char]
stmt ExecOptions
opts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              ExecComplete (Left SomeException
err) Word64
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show SomeException
err
              ExecComplete (Right [Name]
_) Word64
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\[Char]
x -> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
x then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just [Char]
x) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
readFile' [Char]
temp
              ExecBreak{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [Char]
"breakpoints are not supported"
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
purge
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Either [Char] (Maybe [Char])
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 :: [Statement]
propSetup =
    forall a. [a] -> [Loc a]
locate0
        [ [Char]
":set -XScopedTypeVariables -XExplicitForAll"
        , [Char]
"import qualified Test.QuickCheck as Q11"
        , [Char]
"propEvaluation p = Q11.quickCheckWithResult Q11.stdArgs p >>= error . Q11.output" -- uses `error` to get a multi-line display
        ]