{-# 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,
    Located (Located),
    Section (sectionLanguage),
    Test (Example, Property, testOutput),
    Txt,
    locate,
    locate0,
 )
import InteractiveEval (runDecls)
import Unsafe.Coerce (unsafeCoerce)

-- | Return the ranges of the expression and result parts of the given test
testRanges :: Loc Test -> (Range, Range)
testRanges :: Loc Test -> (Range, Range)
testRanges (Located Line
line Test
tst) =
    let startLine :: Line
startLine = Line
line
        (Line
exprLines, Line
resultLines) = Test -> (Line, Line)
testLenghts Test
tst
        resLine :: Line
resLine = Line
startLine Line -> Line -> Line
forall a. Num a => a -> a -> a
+ Line
exprLines
     in ( Position -> Position -> Range
Range
            (Line -> Line -> Position
Position Line
startLine Line
0)
            --(Position (startLine + exprLines + resultLines) 0),
            (Line -> Line -> Position
Position Line
resLine Line
0)
        , Position -> Position -> Range
Range (Line -> Line -> Position
Position Line
resLine Line
0) (Line -> Line -> Position
Position (Line
resLine Line -> Line -> Line
forall a. Num a => a -> a -> a
+ Line
resultLines) Line
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 :: Loc Test -> Range
resultRange :: Loc Test -> Range
resultRange = (Range, Range) -> Range
forall a b. (a, b) -> b
snd ((Range, Range) -> Range)
-> (Loc Test -> (Range, Range)) -> Loc Test -> Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc 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 -> (Line, Line)
testLenghts (Example NonEmpty Txt
e [Txt]
r) = (NonEmpty Txt -> Line
forall a. NonEmpty a -> Line
NE.length NonEmpty Txt
e, [Txt] -> Line
forall (t :: * -> *) a. Foldable t => t a -> Line
length [Txt]
r)
testLenghts (Property Txt
_ [Txt]
r) = (Line
1, [Txt] -> Line
forall (t :: * -> *) a. Foldable t => t a -> Line
length [Txt]
r)

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

asStatements :: Loc Test -> [Statement]
asStatements :: Loc Test -> [Statement]
asStatements Loc Test
lt = Loc [Txt] -> [Statement]
forall a. Loc [a] -> [Loc a]
locate (Test -> [Txt]
asStmts (Test -> [Txt]) -> Loc Test -> Loc [Txt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Loc Test
lt)

asStmts :: Test -> [Txt]
asStmts :: Test -> [Txt]
asStmts (Example NonEmpty Txt
e [Txt]
_) = NonEmpty Txt -> [Txt]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Txt
e
asStmts (Property Txt
t [Txt]
_) =
    [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
        ]