{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DuplicateRecordFields #-}

module Eval (
    tests,
) where

import Control.Applicative.Combinators (
    skipManyTill
 )
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO (liftIO))
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Language.LSP.Test
import Language.LSP.Types
import Language.LSP.Types.Lens (command, title, range)
import Control.Lens (view, _Just, preview)
import System.Directory (doesFileExist)
import System.FilePath (
    (<.>),
    (</>),
 )
import Test.Hls.Util (hlsCommand, GhcVersion (GHC84, GHC86), knownBrokenForGhcVersions, knownBrokenInEnv, EnvSpec (HostOS, GhcVer), OS (Windows))
import Test.Tasty (
    TestTree,
    testGroup,
 )
import Test.Tasty.ExpectedFailure (
    expectFailBecause,
 )
import Test.Tasty.HUnit (
    testCase,
    (@?=),
 )
import Data.List.Extra (nubOrdOn)
import Ide.Plugin.Eval.Types (EvalParams(..))
import Data.Aeson (fromJSON)
import Data.Aeson.Types (Result(Success))

tests :: TestTree
tests =
    testGroup
        "eval"
        [ testCase "Produces Evaluate code lenses" $
            runSession hlsCommand fullCaps evalPath $ do
                doc <- openDoc "T1.hs" "haskell"
                lenses <- getEvalCodeLenses doc
                liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Evaluate..."]
        , testCase "Produces Refresh code lenses" $
            runSession hlsCommand fullCaps evalPath $ do
                doc <- openDoc "T2.hs" "haskell"
                lenses <- getEvalCodeLenses doc
                liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Refresh..."]
        , testCase "Code lenses have ranges" $
            runSession hlsCommand fullCaps evalPath $ do
                doc <- openDoc "T1.hs" "haskell"
                lenses <- getEvalCodeLenses doc
                liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)]
        , testCase "Multi-line expressions have a multi-line range" $ do
            runSession hlsCommand fullCaps evalPath $ do
                doc <- openDoc "T3.hs" "haskell"
                lenses <- getEvalCodeLenses doc
                liftIO $ map (view range) lenses @?= [Range (Position 3 0) (Position 5 0)]
        , testCase "Executed expressions range covers only the expression" $ do
            runSession hlsCommand fullCaps evalPath $ do
                doc <- openDoc "T2.hs" "haskell"
                lenses <- getEvalCodeLenses doc
                liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)]
        , testCase "Evaluation of expressions" $ goldenTest "T1.hs"
        , testCase "Reevaluation of expressions" $ goldenTest "T2.hs"
        , testCase "Evaluation of expressions w/ imports" $ goldenTest "T3.hs"
        , testCase "Evaluation of expressions w/ lets" $ goldenTest "T4.hs"
        , testCase "Refresh an evaluation" $ goldenTest "T5.hs"
        , testCase "Refresh an evaluation w/ lets" $ goldenTest "T6.hs"
        , testCase "Refresh a multiline evaluation" $ goldenTest "T7.hs"
        , testCase "Semantic and Lexical errors are reported" $ goldenTest "T8.hs"
        , testCase "Applies file LANGUAGE extensions" $ goldenTest "T9.hs"
        , testCase "Evaluate a type with :kind!" $ goldenTest "T10.hs"
        , testCase "Reports an error for an incorrect type with :kind!" $
            goldenTest "T11.hs"
        , testCase "Shows a kind with :kind" $ goldenTest "T12.hs"
        , testCase "Reports an error for an incorrect type with :kind" $
            goldenTest "T13.hs"
        , testCase "Returns a fully-instantiated type for :type" $
            goldenTest "T14.hs"
        , testCase "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" $
            goldenTest "T15.hs"
        , testCase "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" $
            goldenTest "T16.hs"
        , testCase ":type reports an error when given with unknown +x option" $
            goldenTest "T17.hs"
        , testCase "Reports an error when given with unknown command" $
            goldenTest "T18.hs"
        , testCase "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt" $
            goldenTest "T19.hs"
        , expectFailBecause "known issue - see a note in P.R. #361" $
            testCase ":type +d reflects the `default' declaration of the module" $
                goldenTest "T20.hs"
        , testCase ":type handles a multilined result properly" $
            goldenTest "T21.hs"
        , testCase ":t behaves exactly the same as :type" $
            goldenTest "T22.hs"
        , testCase ":type does \"dovetails\" for short identifiers" $
            goldenTest "T23.hs"
        , testCase ":kind! treats a multilined result properly" $
            goldenTest "T24.hs"
        , testCase ":kind treats a multilined result properly" $
            goldenTest "T25.hs"
        , testCase "local imports" $
            goldenTest "T26.hs"
        , testCase "Preserves one empty comment line after prompt" $
            goldenTest "T27.hs"
        , testCase
            "Multi line comments"
            $ goldenTest "TMulti.hs"
        , testCase
            "Multi line comments, with the last test line ends without newline"
            $ goldenTest "TEndingMulti.hs"
        , testCase
            "Evaluate expressions in Plain comments in both single line and multi line format"
            $ goldenTest "TPlainComment.hs"
        , testCase
            "Evaluate expressions in Haddock comments in both single line and multi line format"
            $ goldenTest "THaddock.hs"
        , testCase "Compare results (for Haddock tests only)" $
            goldenTest "TCompare.hs"
        , testCase "Local Modules imports are accessible in a test" $
            goldenTest "TLocalImport.hs"
        , -- , testCase "Local Modules can be imported in a test" $ goldenTest "TLocalImportInTest.hs"
          expectFailBecause "Unexplained but minor issue" $
            testCase "Setting language option TupleSections" $
                goldenTest "TLanguageOptionsTupleSections.hs"
        , testCase ":set accepts ghci flags" $
            goldenTest "TFlags.hs"
        , testCase "IO expressions are supported, stdout/stderr output is ignored" $
            goldenTest "TIO.hs"
        , testCase "Property checking" $ goldenTest "TProperty.hs"
        , testCase
            "Prelude has no special treatment, it is imported as stated in the module"
            $ goldenTest "TPrelude.hs"
        , testCase
            "Don't panic on {-# UNPACK #-} pragma"
            $ goldenTest "TUNPACK.hs"
        , testCase
            "Can handle eval inside nested comment properly"
            $ goldenTest "TNested.hs"
        , testCase "Test on last line insert results correctly" $ do
            runSession hlsCommand fullCaps evalPath $
                liftIO $ do
                    let mdl = "TLastLine.hs"
                    -- Write the test file, to make sure that it has no final line return
                    writeFile (evalPath </> mdl) "module TLastLine where\n\n-- >>> take 3 [1..]"
                    goldenTest mdl
            , testGroup "with preprocessors"
            [ knownBrokenInEnv [HostOS Windows, GhcVer GHC84, GhcVer GHC86]
                "CPP eval on Windows and/or GHC <= 8.6 fails for some reasons" $
              testCase "CPP support" $ goldenTest "TCPP.hs"
            , knownBrokenForGhcVersions [GHC84, GHC86]
                "Preprocessor known to fail on GHC <= 8.6"
                $ testCase "Literate Haskell Bird Style" $ goldenTest "TLHS.lhs"
            -- , testCase "Literate Haskell LaTeX Style" $ goldenTest "TLHSLateX.lhs"
            ]
        ]

goldenTest :: FilePath -> IO ()
goldenTest = goldenTestBy isEvalTest

{- |Execute all CodeLens accepted by 'filter'
 Compare results with the contents of corresponding '.expected' file (and creates it, if missing)
-}
goldenTestBy :: (CodeLens -> Bool) -> FilePath -> IO ()
goldenTestBy fltr input = runSession hlsCommand fullCaps evalPath $ do
    doc <- openDoc input "haskell"

    -- Execute lenses backwards, to avoid affecting their position in the source file
    codeLenses <- reverse <$> getCodeLensesBy fltr doc
    -- liftIO $ print codeLenses

    -- Execute sequentially, nubbing elements to avoid
    -- evaluating the same section with multiple tests
    -- more than twice
    mapM_ executeCmd
        $ nubOrdOn actSectionId [c | CodeLens{_command = Just c} <- codeLenses]

    edited <- replaceUnicodeQuotes <$> documentContents doc
    -- liftIO $ T.putStrLn edited

    let expectedFile = evalPath </> input <.> "expected"

    liftIO $ do
        -- Write expected file if missing
        missingExpected <- not <$> doesFileExist expectedFile
        when missingExpected $ T.writeFile expectedFile edited
        expected <- T.readFile expectedFile
        edited @?= expected

actSectionId :: Command -> Int
actSectionId Command{_arguments = Just (List [fromJSON -> Success EvalParams{..}])} = evalId
actSectionId _ = error "Invalid CodeLens"

getEvalCodeLenses :: TextDocumentIdentifier -> Session [CodeLens]
getEvalCodeLenses = getCodeLensesBy isEvalTest

getCodeLensesBy :: (CodeLens -> Bool) -> TextDocumentIdentifier -> Session [CodeLens]
getCodeLensesBy f doc = filter f <$> getCodeLenses doc

-- Execute command and wait for result
executeCmd :: Command -> Session ()
executeCmd cmd = do
    executeCommand cmd
    _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit)
    -- liftIO $ print _resp
    return ()

-- Execute only Eval tests to avoid interference from other plugins (e.g ghcide:typesignature.add)
isEvalTest :: CodeLens -> Bool
isEvalTest (CodeLens _ (Just (Command _ cmd _)) _)
    | ":eval:" `T.isInfixOf` cmd = True
isEvalTest _ = False

replaceUnicodeQuotes :: T.Text -> T.Text
replaceUnicodeQuotes = T.replace "‘" "'" . T.replace "’" "'"

evalPath :: FilePath
evalPath = "plugins/hls-eval-plugin/test/testdata"