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

-- | Expression execution

module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalExtensions, evalSetup, propSetup, testCheck, asStatements,myExecStmt) where

import           Control.Lens                   ((^.))
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.Types.Location (Position (..), Range (..))
import           GHC                            (ExecOptions, ExecResult (..),
                                                 execStmt)
import           GHC.LanguageExtensions.Type    (Extension (..))
import           GhcMonad                       (Ghc, liftIO, modifySession)
import           HscTypes
import           Ide.Plugin.Eval.Types          (Language (Plain), Loc,
                                                 Located (..),
                                                 Section (sectionLanguage),
                                                 Test (..), Txt, locate,
                                                 locate0)
import           InteractiveEval                (getContext, parseImportDecl,
                                                 runDecls, setContext)
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 :: Int
startLine = Test -> Range
testRange Test
tst Range -> Getting Int Range Int -> Int
forall s a. s -> Getting a s a -> a
^. (Position -> Const Int Position) -> Range -> Const Int Range
forall s a. HasStart s a => Lens' s a
start((Position -> Const Int Position) -> Range -> Const Int Range)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> Getting Int Range Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasLine s a => Lens' s a
line
        (Int
exprLines, Int
resultLines) = Test -> (Int, Int)
testLenghts Test
tst
        resLine :: Int
resLine = Int
startLine Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
exprLines
     in ( Position -> Position -> Range
Range
            (Int -> Int -> Position
Position Int
startLine Int
0)
            --(Position (startLine + exprLines + resultLines) 0),

            (Int -> Int -> Position
Position Int
resLine Int
0)
        , Position -> Position -> Range
Range (Int -> Int -> Position
Position Int
resLine Int
0) (Int -> Int -> Position
Position (Int
resLine Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
resultLines) Int
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 :: (Section, Test) -> [T.Text] -> [T.Text]
testCheck :: (Section, Test) -> [Text] -> [Text]
testCheck (Section
section, Test
test) [Text]
out
    | [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

testLenghts :: Test -> (Int, Int)
testLenghts :: Test -> (Int, Int)
testLenghts (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)
testLenghts (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 (Test -> Range
testRange Test
lt Range -> Getting Int Range Int -> Int
forall s a. s -> Getting a s a -> a
^. (Position -> Const Int Position) -> Range -> Const Int Range
forall s a. HasStart s a => Lens' s a
start((Position -> Const Int Position) -> Range -> Const Int Range)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> Getting Int Range Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const Int Int) -> Position -> Const Int 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 extensions required for expression evaluation

evalExtensions :: [Extension]
evalExtensions :: [Extension]
evalExtensions =
    [ Extension
OverlappingInstances
    , Extension
UndecidableInstances
    , Extension
FlexibleInstances
    , Extension
IncoherentInstances
    , Extension
TupleSections
    ]

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

        ]