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

-- | Expression execution
module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalSetup, 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           Development.IDE.Types.Location (Position (..), Range (..))
import           GHC                            (ExecOptions, ExecResult (..),
                                                 execStmt)
import           Ide.Plugin.Eval.Types          (Language (Plain), Loc,
                                                 Located (..),
                                                 Section (sectionLanguage),
                                                 Test (..), Txt, locate,
                                                 locate0)
import           Language.LSP.Types.Lens        (line, start)
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
startforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. HasLine s a => Lens' s a
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
startforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. HasLine s a => Lens' s a
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)"]


-- |GHC declarations required for expression evaluation
evalSetup :: Ghc ()
evalSetup :: Ghc ()
evalSetup = do
    ImportDecl GhcPs
preludeAsP <- forall (m :: * -> *). GhcMonad m => [Char] -> m (ImportDecl GhcPs)
parseImportDecl [Char]
"import qualified Prelude as P"
    [InteractiveImport]
context <- forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext
    forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext (ImportDecl GhcPs -> InteractiveImport
IIDecl ImportDecl GhcPs
preludeAsP forall a. a -> [a] -> [a]
: [InteractiveImport]
context)

-- | 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
        ]