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

module Utils where

import           Control.DeepSeq (deepseq)
import qualified Control.Exception as E
import           Control.Lens hiding (List, failing, (<.>), (.=))
import           Control.Monad (unless, void)
import           Control.Monad.IO.Class
import           Data.Aeson
import           Data.Foldable
import           Data.Function (on)
import           Data.IORef (writeIORef)
import           Data.Maybe
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import           Ide.Plugin.Tactic as Tactic
import           Ide.Types (IdePlugins(..))
import           Language.LSP.Protocol.Types
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title, error)
import           System.Directory (doesFileExist)
import           System.FilePath
import           Test.Hls
import           Test.Hspec
import           Test.Hspec.Formatters (FailureReason(ExpectedButGot))
import           Wingman.LanguageServer (mkShowMessageParams)
import           Wingman.Types


plugin :: PluginTestDescriptor Log
plugin = mkPluginTestDescriptor Tactic.descriptor "tactics"

------------------------------------------------------------------------------
-- | 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 -> fromIntegral -> line)
  (subtract 1 -> fromIntegral -> col) =
    Range (Position line col) (Position line $ col + 1)


------------------------------------------------------------------------------
-- | Get the title of a code action.
codeActionTitle :: (Command |? CodeAction) -> Maybe Text
codeActionTitle InL{}                               = Nothing
codeActionTitle (InR(CodeAction title _ _ _ _ _ _ _)) = Just title


resetGlobalHoleRef :: IO ()
resetGlobalHoleRef = writeIORef globalHoleRef 0


runSessionForTactics :: Session a -> IO a
runSessionForTactics act = do
  recorder <- pluginTestRecorder
  runSessionWithServer'
    (plugin recorder)
    def
    (def { ignoreLogNotifications = False })
    fullCaps
    tacticPath
    act

------------------------------------------------------------------------------
-- | Make a tactic unit test.
mkTest
    :: Foldable t
    => String  -- ^ The test name
    -> FilePath  -- ^ The file name stem (without extension) to load
    -> Int  -- ^ Cursor line
    -> Int  -- ^ Cursor column
    -> t ( Bool -> Bool   -- Use 'not' for actions that shouldn't be present
         , TacticCommand  -- An expected command ...
         , Text           -- ... for this variable
         ) -- ^ A collection of (un)expected code actions.
    -> SpecWith (Arg Bool)
mkTest name fp line col ts = it name $ do
  resetGlobalHoleRef
  actions <- E.handle (\(UnexpectedResponseError _ _) -> pure []) 
              $ runSessionForTactics $ do
    doc <- openDoc (fp <.> "hs") "haskell"
    -- wait for diagnostics to start coming
    void waitForDiagnostics
    -- wait for the entire build to finish, so that Tactics code actions that
    -- use stale data will get uptodate stuff
    void $ waitForTypecheck doc
    getCodeActions doc $ pointRange line col
  let titles = mapMaybe codeActionTitle actions
  for_ ts $ \(f, tc, var) -> do
    let title = tacticTitle tc var
    liftIO $
      (title `elem` titles) `shouldSatisfy` f

data InvokeTactic = InvokeTactic
  { it_command :: TacticCommand
  , it_argument :: Text
  , it_line :: Int
  , it_col :: Int
  }

invokeTactic :: TextDocumentIdentifier -> InvokeTactic -> Session ()
invokeTactic doc InvokeTactic{..} = do
    -- wait for the entire build to finish, so that Tactics code actions that
    -- use stale data will get uptodate stuff
    void waitForDiagnostics
    void $ waitForTypecheck doc
    actions <- getCodeActions doc $ pointRange it_line it_col
    case find ((== Just (tacticTitle it_command it_argument)) . codeActionTitle) actions of
      Just (InR CodeAction {_command = Just c}) -> do
          executeCommand c
          void $ skipManyTill anyMessage $ message SMethod_WorkspaceApplyEdit
      _ -> error $ show actions


mkGoldenTest
    :: (Text -> Text -> Assertion)
    -> [InvokeTactic]
    -> FilePath
    -> SpecWith ()
mkGoldenTest eq invocations input =
  it (input <> " (golden)") $ do
    resetGlobalHoleRef
    runSessionForTactics $ do
      doc <- openDoc (input <.> "hs") "haskell"
      traverse_ (invokeTactic doc) invocations
      edited <- documentContents doc
      let expected_name = input <.> "expected" <.> "hs"
      -- 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 `eq` expected


mkCodeLensTest
    :: FilePath
    -> SpecWith ()
mkCodeLensTest input =
  it (input <> " (golden)") $ do
    resetGlobalHoleRef
    runSessionForTactics $ do
      doc <- openDoc (input <.> "hs") "haskell"
      _ <- waitForDiagnostics
      lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc
      for_ lenses $ \(CodeLens _ (Just cmd) _) ->
        executeCommand cmd
      _resp <- skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)
      edited <- documentContents doc
      let expected_name = input <.> "expected" <.> "hs"
      -- 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 `shouldBe` expected


------------------------------------------------------------------------------
-- | A test that no code lenses can be run in the file
mkNoCodeLensTest
    :: FilePath
    -> SpecWith ()
mkNoCodeLensTest input =
  it (input <> " (no code lenses)") $ do
    resetGlobalHoleRef
    runSessionForTactics $ do
      doc <- openDoc (input <.> "hs") "haskell"
      _ <- waitForBuildQueue
      lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc
      liftIO $ lenses `shouldBe` []



isWingmanLens :: CodeLens -> Bool
isWingmanLens (CodeLens _ (Just (Command _ cmd _)) _)
    = T.isInfixOf ":tactics:" cmd
isWingmanLens _ = False


mkShowMessageTest
    :: TacticCommand
    -> Text
    -> Int
    -> Int
    -> FilePath
    -> UserFacingMessage
    -> SpecWith ()
mkShowMessageTest tc occ line col input ufm =
  it (input <> " (golden)") $ do
    resetGlobalHoleRef
    runSessionForTactics $ do
      doc <- openDoc (input <.> "hs") "haskell"
      _ <- waitForDiagnostics
      actions <- getCodeActions doc $ pointRange line col
      Just (InR CodeAction {_command = Just c})
        <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions
      executeCommand c
      TNotificationMessage _ _ err <- skipManyTill anyMessage (message SMethod_WindowShowMessage)
      liftIO $ err `shouldBe` mkShowMessageParams ufm


goldenTest :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith ()
goldenTest tc occ line col = mkGoldenTest shouldBe [InvokeTactic tc occ line col]

goldenTestMany :: FilePath -> [InvokeTactic] -> SpecWith ()
goldenTestMany = flip $ mkGoldenTest shouldBe

goldenTestNoWhitespace :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith ()
goldenTestNoWhitespace tc occ line col = mkGoldenTest shouldBeIgnoringSpaces [InvokeTactic tc occ line col]


shouldBeIgnoringSpaces :: Text -> Text -> Assertion
shouldBeIgnoringSpaces = assertFun f ""
  where
    f = (==) `on` T.unwords . T.words


assertFun
    :: Show a
    => (a -> a -> Bool)
    -> String -- ^ The message prefix
    -> a      -- ^ The expected value
    -> a      -- ^ The actual value
    -> Assertion
assertFun eq preface expected actual =
  unless (eq actual expected) $ do
    (prefaceMsg
      `deepseq` expectedMsg
      `deepseq` actualMsg
      `deepseq`
        E.throwIO
          (HUnitFailure Nothing $ show $ ExpectedButGot prefaceMsg expectedMsg actualMsg))
  where
    prefaceMsg
      | null preface = Nothing
      | otherwise = Just preface
    expectedMsg = show expected
    actualMsg = show actual



------------------------------------------------------------------------------
-- | Don't run a test.
failing :: Applicative m => String -> b -> m ()
failing _ _ = pure ()


tacticPath :: FilePath
tacticPath = "old/test/golden"


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