{-# 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 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
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
line
        (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> UInt
exprLines, Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> UInt
resultLines) = Test -> (Int, Int)
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 :: [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 :: 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
|| [Txt] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Test -> [Txt]
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 ((Txt -> Text) -> [Txt] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Txt -> Text
T.pack ([Txt] -> [Text]) -> [Txt] -> [Text]
forall a b. (a -> b) -> a -> b
$ Test -> [Txt]
testOutput Test
test) [Text]
out

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

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

asStatements :: Test -> [Statement]
asStatements :: Test -> [Statement]
asStatements Test
lt = Loc [Txt] -> [Statement]
forall a. Loc [a] -> [Loc a]
locate (Loc [Txt] -> [Statement]) -> Loc [Txt] -> [Statement]
forall a b. (a -> b) -> a -> b
$ Int -> [Txt] -> Loc [Txt]
forall l a. l -> a -> Located l a
Located (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt -> Int) -> UInt -> Int
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
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
line) (Test -> [Txt]
asStmts Test
lt)

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


-- |GHC declarations required for expression evaluation
evalSetup :: Ghc ()
evalSetup :: Ghc ()
evalSetup = do
    ImportDecl GhcPs
preludeAsP <- Txt -> Ghc (ImportDecl GhcPs)
forall (m :: * -> *). GhcMonad m => Txt -> m (ImportDecl GhcPs)
parseImportDecl Txt
"import qualified Prelude as P"
    [InteractiveImport]
context <- Ghc [InteractiveImport]
forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext
    [InteractiveImport] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext (ImportDecl GhcPs -> InteractiveImport
IIDecl ImportDecl GhcPs
preludeAsP InteractiveImport -> [InteractiveImport] -> [InteractiveImport]
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 :: Txt -> ExecOptions -> Ghc (Either Txt (Maybe Txt))
myExecStmt Txt
stmt ExecOptions
opts = do
    (Txt
temp, IO ()
purge) <- IO (Txt, IO ()) -> Ghc (Txt, IO ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Txt, IO ())
newTempFile
    Name
evalPrint <- [Name] -> Name
forall a. [a] -> a
head ([Name] -> Name) -> Ghc [Name] -> Ghc Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Txt -> Ghc [Name]
forall (m :: * -> *). GhcMonad m => Txt -> m [Name]
runDecls (Txt
"evalPrint x = P.writeFile "Txt -> Txt -> Txt
forall a. Semigroup a => a -> a -> a
<> Txt -> Txt
forall a. Show a => a -> Txt
show Txt
temp Txt -> Txt -> Txt
forall a. Semigroup a => a -> a -> a
<> Txt
" (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 :: InteractiveContext
hsc_IC = InteractiveContext -> Name -> InteractiveContext
setInteractivePrintName (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc) Name
evalPrint}
    Either Txt (Maybe Txt)
result <- Txt -> ExecOptions -> Ghc ExecResult
forall (m :: * -> *).
GhcMonad m =>
Txt -> ExecOptions -> m ExecResult
execStmt Txt
stmt ExecOptions
opts Ghc ExecResult
-> (ExecResult -> Ghc (Either Txt (Maybe Txt)))
-> Ghc (Either Txt (Maybe Txt))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              ExecComplete (Left SomeException
err) Word64
_ -> Either Txt (Maybe Txt) -> Ghc (Either Txt (Maybe Txt))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Txt (Maybe Txt) -> Ghc (Either Txt (Maybe Txt)))
-> Either Txt (Maybe Txt) -> Ghc (Either Txt (Maybe Txt))
forall a b. (a -> b) -> a -> b
$ Txt -> Either Txt (Maybe Txt)
forall a b. a -> Either a b
Left (Txt -> Either Txt (Maybe Txt)) -> Txt -> Either Txt (Maybe Txt)
forall a b. (a -> b) -> a -> b
$ SomeException -> Txt
forall a. Show a => a -> Txt
show SomeException
err
              ExecComplete (Right [Name]
_) Word64
_ -> IO (Either Txt (Maybe Txt)) -> Ghc (Either Txt (Maybe Txt))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Txt (Maybe Txt)) -> Ghc (Either Txt (Maybe Txt)))
-> IO (Either Txt (Maybe Txt)) -> Ghc (Either Txt (Maybe Txt))
forall a b. (a -> b) -> a -> b
$ Maybe Txt -> Either Txt (Maybe Txt)
forall a b. b -> Either a b
Right (Maybe Txt -> Either Txt (Maybe Txt))
-> (Txt -> Maybe Txt) -> Txt -> Either Txt (Maybe Txt)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Txt
x -> if Txt -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Txt
x then Maybe Txt
forall a. Maybe a
Nothing else Txt -> Maybe Txt
forall a. a -> Maybe a
Just Txt
x) (Txt -> Either Txt (Maybe Txt))
-> IO Txt -> IO (Either Txt (Maybe Txt))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Txt -> IO Txt
readFile' Txt
temp
              ExecBreak{} -> Either Txt (Maybe Txt) -> Ghc (Either Txt (Maybe Txt))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Txt (Maybe Txt) -> Ghc (Either Txt (Maybe Txt)))
-> Either Txt (Maybe Txt) -> Ghc (Either Txt (Maybe Txt))
forall a b. (a -> b) -> a -> b
$ Maybe Txt -> Either Txt (Maybe Txt)
forall a b. b -> Either a b
Right (Maybe Txt -> Either Txt (Maybe Txt))
-> Maybe Txt -> Either Txt (Maybe Txt)
forall a b. (a -> b) -> a -> b
$ Txt -> Maybe Txt
forall a. a -> Maybe a
Just Txt
"breakpoints are not supported"
    IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
purge
    Either Txt (Maybe Txt) -> Ghc (Either Txt (Maybe Txt))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either Txt (Maybe Txt)
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 =
    [Txt] -> [Statement]
forall a. [a] -> [Loc a]
locate0
        [ Txt
":set -XScopedTypeVariables -XExplicitForAll"
        , Txt
"import qualified Test.QuickCheck as Q11"
        , Txt
"propEvaluation p = Q11.quickCheckWithResult Q11.stdArgs p >>= error . Q11.output" -- uses `error` to get a multi-line display
        ]