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

module Tactic
  ( tests
  )
where

import           Control.Applicative.Combinators ( skipManyTill )
import           Control.Lens hiding ((<.>))
import           Control.Monad (unless)
import           Control.Monad.IO.Class
import           Data.Aeson
import           Data.Either (isLeft)
import           Data.Foldable
import           Data.Maybe
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import           Ide.Plugin.Tactic.TestTypes
import           Language.Haskell.LSP.Test
import           Language.Haskell.LSP.Types (ExecuteCommandParams(ExecuteCommandParams), ClientMethod (..), Command, ExecuteCommandResponse, ResponseMessage (..), ApplyWorkspaceEditRequest, Position(..) , Range(..) , CAResult(..) , CodeAction(..))
import           Language.Haskell.LSP.Types.Lens hiding (id, capabilities, message, executeCommand, applyEdit, rename)
import           System.Directory (doesFileExist)
import           System.FilePath
import           Test.Hls.Util
import           Test.Tasty
import           Test.Tasty.ExpectedFailure (ignoreTestBecause)
import           Test.Tasty.HUnit


------------------------------------------------------------------------------
-- | Get a range at the given line and column corresponding to having nothing
-- selected.
--
-- NB: These coordinates are in "file space", ie, 1-indexed.
pointRange :: Int -> Int -> Range
pointRange
  (subtract 1 -> line)
  (subtract 1 -> col) =
    Range (Position line col) (Position line $ col + 1)


------------------------------------------------------------------------------
-- | Get the title of a code action.
codeActionTitle :: CAResult -> Maybe Text
codeActionTitle CACommand{} = Nothing
codeActionTitle (CACodeAction(CodeAction title _ _ _ _)) = Just title


tests :: TestTree
tests = testGroup
  "tactic"
  [ mkTest
      "Produces intros code action"
      "T1.hs" 2 14
      [ (id, Intros, "")
      ]
  , mkTest
      "Produces destruct and homomorphism code actions"
      "T2.hs" 2 21
      [ (id, Destruct, "eab")
      , (id, Homomorphism, "eab")
      ]
  , mkTest
      "Won't suggest homomorphism on the wrong type"
      "T2.hs" 8 8
      [ (not, Homomorphism, "global")
      ]
  , mkTest
      "Won't suggest intros on the wrong type"
      "T2.hs" 8 8
      [ (not, Intros, "")
      ]
  , mkTest
      "Produces (homomorphic) lambdacase code actions"
      "T3.hs" 4 24
      [ (id, HomomorphismLambdaCase, "")
      , (id, DestructLambdaCase, "")
      ]
  , mkTest
      "Produces lambdacase code actions"
      "T3.hs" 7 13
      [ (id, DestructLambdaCase, "")
      ]
  , mkTest
      "Doesn't suggest lambdacase without -XLambdaCase"
      "T2.hs" 11 25
      [ (not, DestructLambdaCase, "")
      ]
  , goldenTest "GoldenIntros.hs"            2 8  Intros ""
  , goldenTest "GoldenEitherAuto.hs"        2 11 Auto ""
  , goldenTest "GoldenJoinCont.hs"          4 12 Auto ""
  , goldenTest "GoldenIdentityFunctor.hs"   3 11 Auto ""
  , goldenTest "GoldenIdTypeFam.hs"         7 11 Auto ""
  , goldenTest "GoldenEitherHomomorphic.hs" 2 15 Auto ""
  , goldenTest "GoldenNote.hs"              2 8  Auto ""
  , goldenTest "GoldenPureList.hs"          2 12 Auto ""
  , goldenTest "GoldenListFmap.hs"          2 12 Auto ""
  , goldenTest "GoldenFromMaybe.hs"         2 13 Auto ""
  , goldenTest "GoldenFoldr.hs"             2 10 Auto ""
  , goldenTest "GoldenSwap.hs"              2 8  Auto ""
  , goldenTest "GoldenFmapTree.hs"          4 11 Auto ""
  , goldenTest "GoldenGADTDestruct.hs"      7 17 Destruct "gadt"
  , goldenTest "GoldenGADTDestructCoercion.hs" 8 17 Destruct "gadt"
  , goldenTest "GoldenGADTAuto.hs"          7 13 Auto ""
  , goldenTest "GoldenSwapMany.hs"          2 12 Auto ""
  , goldenTest "GoldenBigTuple.hs"          4 12 Auto ""
  , goldenTest "GoldenShow.hs"              2 10 Auto ""
  , goldenTest "GoldenShowCompose.hs"       2 15 Auto ""
  , goldenTest "GoldenShowMapChar.hs"       2 8  Auto ""
  , goldenTest "GoldenSuperclass.hs"        7 8  Auto ""
  , ignoreTestBecause "It is unreliable in circleci builds"
      $ goldenTest "GoldenApplicativeThen.hs"   2 11 Auto ""
  , goldenTest "GoldenSafeHead.hs"          2 12 Auto ""
  , expectFail "GoldenFish.hs"              5 18 Auto ""
  , goldenTest "GoldenArbitrary.hs"         25 13 Auto ""
  ]


------------------------------------------------------------------------------
-- | Make a tactic unit test.
mkTest
    :: Foldable t
    => String  -- ^ The test name
    -> FilePath  -- ^ The file to load
    -> Int  -- ^ Cursor line
    -> Int  -- ^ Cursor columnn
    -> t ( Bool -> Bool   -- Use 'not' for actions that shouldnt be present
         , TacticCommand  -- An expected command ...
         , Text           -- ... for this variable
         ) -- ^ A collection of (un)expected code actions.
    -> TestTree
mkTest name fp line col ts =
  testCase name $ do
  runSession hlsCommand fullCaps tacticPath $ do
    doc <- openDoc fp "haskell"
    _ <- waitForDiagnostics
    actions <- getCodeActions doc $ pointRange line col
    let titles = mapMaybe codeActionTitle actions
    for_ ts $ \(f, tc, var) -> do
      let title = tacticTitle tc var
      liftIO $
        f (elem title titles)
          @? ("Expected a code action with title " <> T.unpack title)


goldenTest :: FilePath -> Int -> Int -> TacticCommand -> Text -> TestTree
goldenTest input line col tc occ =
  testCase (input <> " (golden)") $ do
    runSession hlsCommand fullCaps tacticPath $ do
      doc <- openDoc input "haskell"
      _ <- waitForDiagnostics
      actions <- getCodeActions doc $ pointRange line col
      Just (CACodeAction CodeAction {_command = Just c})
        <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions
      executeCommand c
      _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message
      edited <- documentContents doc
      let expected_name = tacticPath </> input <.> "expected"
      -- Write golden tests if they don't already exist
      liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do
        T.writeFile expected_name edited
      expected <- liftIO $ T.readFile expected_name
      liftIO $ edited @?= expected


expectFail :: FilePath -> Int -> Int -> TacticCommand -> Text -> TestTree
expectFail input line col tc occ =
  testCase (input <> " (golden)") $ do
    runSession hlsCommand fullCaps tacticPath $ do
      doc <- openDoc input "haskell"
      _ <- waitForDiagnostics
      actions <- getCodeActions doc $ pointRange line col
      Just (CACodeAction CodeAction {_command = Just c})
        <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions
      resp <- executeCommandWithResp c
      liftIO $ unless (isLeft $ _result resp) $
        assertFailure "didn't fail, but expected one"


tacticPath :: FilePath
tacticPath = "test/testdata/tactic"


executeCommandWithResp :: Command -> Session ExecuteCommandResponse
executeCommandWithResp cmd = do
  let args = decode $ encode $ fromJust $ cmd ^. arguments
      execParams = ExecuteCommandParams (cmd ^. command) args Nothing
  request WorkspaceExecuteCommand execParams