{-# 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 Range -> Getting UInt Range UInt -> UInt
forall s a. s -> Getting a s a -> a
^. (Position -> Const UInt Position) -> Range -> Const UInt Range
forall s a. HasStart s a => Lens' s a
Lens' Range Position
L.start ((Position -> Const UInt Position) -> Range -> Const UInt Range)
-> ((UInt -> Const UInt UInt) -> Position -> Const UInt Position)
-> Getting UInt Range UInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UInt -> Const UInt UInt) -> Position -> Const UInt Position
forall s a. HasLine s a => Lens' s a
Lens' Position UInt
L.line
        (Line -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> UInt
exprLines, Line -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> UInt
resultLines) = Test -> (Line, Line)
testLengths Test
tst
        resLine :: UInt
resLine = UInt
startLine UInt -> UInt -> UInt
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 UInt -> UInt -> UInt
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 = (Range, Range) -> Range
forall a b. (a, b) -> b
snd ((Range, Range) -> Range)
-> (Test -> (Range, Range)) -> Test -> Range
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 = (Diff a -> a) -> [Diff a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Diff a -> a
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 " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
w
showDiff (Second a
w) = a
"NOW " a -> a -> a
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
|| [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Test -> [[Char]]
testOutput Test
test) Bool -> Bool -> Bool
|| Section -> Language
sectionLanguage Section
section Language -> Language -> Bool
forall a. Eq a => a -> a -> Bool
== Language
Plain = [Text]
out
    | Bool
otherwise = [Diff Text] -> [Text]
forall a. (Semigroup a, IsString a) => [Diff a] -> [a]
showDiffs ([Diff Text] -> [Text]) -> [Diff Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text] -> [Diff Text]
forall a. Eq a => [a] -> [a] -> [Diff a]
getDiff (([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
T.pack ([[Char]] -> [Text]) -> [[Char]] -> [Text]
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
_)  = (NonEmpty [Char] -> Line
forall a. NonEmpty a -> Line
NE.length NonEmpty [Char]
e, [[Char]] -> Line
forall a. [a] -> Line
forall (t :: * -> *) a. Foldable t => t a -> Line
length [[Char]]
r)
testLengths (Property [Char]
_ [[Char]]
r Range
_) = (Line
1, [[Char]] -> Line
forall a. [a] -> Line
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 = Loc [[Char]] -> [Statement]
forall a. Loc [a] -> [Loc a]
locate (Loc [[Char]] -> [Statement]) -> Loc [[Char]] -> [Statement]
forall a b. (a -> b) -> a -> b
$ Line -> [[Char]] -> Loc [[Char]]
forall l a. l -> a -> Located l a
Located (UInt -> Line
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt -> Line) -> UInt -> Line
forall a b. (a -> b) -> a -> b
$ Test -> Range
testRange Test
lt Range -> Getting UInt Range UInt -> UInt
forall s a. s -> Getting a s a -> a
^. (Position -> Const UInt Position) -> Range -> Const UInt Range
forall s a. HasStart s a => Lens' s a
Lens' Range Position
L.start ((Position -> Const UInt Position) -> Range -> Const UInt Range)
-> ((UInt -> Const UInt UInt) -> Position -> Const UInt Position)
-> Getting UInt Range UInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UInt -> Const UInt UInt) -> Position -> Const UInt Position
forall s a. HasLine s a => Lens' s a
Lens' Position UInt
L.line) (Test -> [[Char]]
asStmts Test
lt)

asStmts :: Test -> [Txt]
asStmts :: Test -> [[Char]]
asStmts (Example NonEmpty [Char]
e [[Char]]
_ Range
_) = NonEmpty [Char] -> [[Char]]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
e
asStmts (Property [Char]
t [[Char]]
_ Range
_) =
    [[Char]
"prop11 = " [Char] -> [Char] -> [Char]
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) <- IO ([Char], IO ()) -> Ghc ([Char], IO ())
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ([Char], IO ())
newTempFile
    Name
evalPrint <- [Name] -> Name
forall a. HasCallStack => [a] -> a
head ([Name] -> Name) -> Ghc [Name] -> Ghc Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Ghc [Name]
forall (m :: * -> *). GhcMonad m => [Char] -> m [Name]
runDecls ([Char]
"evalPrint x = P.writeFile " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
temp [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" (P.show x)")
    (HscEnv -> HscEnv) -> Ghc ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> Ghc ()) -> (HscEnv -> HscEnv) -> Ghc ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc -> HscEnv
hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) evalPrint}
    Either [Char] (Maybe [Char])
result <- [Char] -> ExecOptions -> Ghc ExecResult
forall (m :: * -> *).
GhcMonad m =>
[Char] -> ExecOptions -> m ExecResult
execStmt [Char]
stmt ExecOptions
opts Ghc ExecResult
-> (ExecResult -> Ghc (Either [Char] (Maybe [Char])))
-> Ghc (Either [Char] (Maybe [Char]))
forall a b. Ghc a -> (a -> Ghc b) -> Ghc b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              ExecComplete (Left SomeException
err) Word64
_ -> Either [Char] (Maybe [Char]) -> Ghc (Either [Char] (Maybe [Char]))
forall a. a -> Ghc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] (Maybe [Char])
 -> Ghc (Either [Char] (Maybe [Char])))
-> Either [Char] (Maybe [Char])
-> Ghc (Either [Char] (Maybe [Char]))
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] (Maybe [Char])
forall a b. a -> Either a b
Left ([Char] -> Either [Char] (Maybe [Char]))
-> [Char] -> Either [Char] (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
err
              ExecComplete (Right [Name]
_) Word64
_ -> IO (Either [Char] (Maybe [Char]))
-> Ghc (Either [Char] (Maybe [Char]))
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either [Char] (Maybe [Char]))
 -> Ghc (Either [Char] (Maybe [Char])))
-> IO (Either [Char] (Maybe [Char]))
-> Ghc (Either [Char] (Maybe [Char]))
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> Either [Char] (Maybe [Char])
forall a b. b -> Either a b
Right (Maybe [Char] -> Either [Char] (Maybe [Char]))
-> ([Char] -> Maybe [Char])
-> [Char]
-> Either [Char] (Maybe [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\[Char]
x -> if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
x then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
x) ([Char] -> Either [Char] (Maybe [Char]))
-> IO [Char] -> IO (Either [Char] (Maybe [Char]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
readFile' [Char]
temp
              ExecBreak{} -> Either [Char] (Maybe [Char]) -> Ghc (Either [Char] (Maybe [Char]))
forall a. a -> Ghc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] (Maybe [Char])
 -> Ghc (Either [Char] (Maybe [Char])))
-> Either [Char] (Maybe [Char])
-> Ghc (Either [Char] (Maybe [Char]))
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> Either [Char] (Maybe [Char])
forall a b. b -> Either a b
Right (Maybe [Char] -> Either [Char] (Maybe [Char]))
-> Maybe [Char] -> Either [Char] (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"breakpoints are not supported"
    IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
purge
    Either [Char] (Maybe [Char]) -> Ghc (Either [Char] (Maybe [Char]))
forall a. a -> Ghc a
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 =
    [[Char]] -> [Statement]
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
        ]