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

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

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 (compileExpr)
import GHC.LanguageExtensions.Type (Extension (..))
import GhcMonad (Ghc, GhcMonad, liftIO)
import Ide.Plugin.Eval.Types (
    Language (Plain),
    Loc,
    Section (sectionLanguage),
    Test (..),
    Txt,
    locate,
    locate0, Located(..)
 )
import InteractiveEval (runDecls)
import Unsafe.Coerce (unsafeCoerce)
import Control.Lens ((^.))
import Language.LSP.Types.Lens (start, line)

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

-- |Evaluate an expression (either a pure expression or an IO a)
evalExpr :: GhcMonad m => [Char] -> m String
evalExpr :: Txt -> m Txt
evalExpr Txt
e = do
    HValue
res <- Txt -> m HValue
forall (m :: * -> *). GhcMonad m => Txt -> m HValue
compileExpr (Txt -> m HValue) -> Txt -> m HValue
forall a b. (a -> b) -> a -> b
$ Txt
"asPrint (" Txt -> Txt -> Txt
forall a. [a] -> [a] -> [a]
++ Txt
e Txt -> Txt -> Txt
forall a. [a] -> [a] -> [a]
++ Txt
")"
    IO Txt -> m Txt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HValue -> IO Txt
forall a b. a -> b
unsafeCoerce HValue
res :: 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 =
    (Txt -> Ghc [Name]) -> [Txt] -> Ghc ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
        Txt -> Ghc [Name]
forall (m :: * -> *). GhcMonad m => Txt -> m [Name]
runDecls
        [ Txt
"class Print f where asPrint :: f -> IO String"
        , Txt
"instance Show a => Print (IO a) where asPrint io = io >>= return . show"
        , Txt
"instance Show a => Print a where asPrint a = return (show a)"
        ]

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