{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where

import Control.Lens.Operators
import Control.Monad.IO.Class
import Data.List (intercalate)
import qualified Data.Text as T
import qualified Data.Text.Utf16.Rope.Mixed as Rope

import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import qualified Language.LSP.Protocol.Lens as L
import qualified Language.LSP.VFS as L
import Language.LSP.Server

import qualified HSVIS.Parser as HV


parseFile :: NormalizedUri -> T.Text -> [Diagnostic]
parseFile (NormalizedUri _ fpath) source =
  case HV.parse (T.unpack fpath) (T.unpack source) of
    HV.This errs -> map mkDiag errs
    HV.These errs _ -> map mkDiag errs
    HV.That _ -> []
  where
    mkDiag :: HV.ErrMsg -> Diagnostic
    mkDiag msg = Diagnostic
      { _range =
          let HV.Pos line col = HV.errPos msg
              -- TODO: col needs to be UTF-16 based, which this is not
              pos = Position (fromIntegral line) (fromIntegral col)
          in Range pos pos
      , _severity = Just DiagnosticSeverity_Error
      , _code = Nothing
      , _codeDescription = Nothing
      , _source = Just "hs-vis"
      , _message = T.pack $ intercalate "\n" $
          HV.errMsg msg : ["In " ++ entry | entry <- reverse (HV.errStk msg)]
      , _tags = Nothing
      , _relatedInformation = Nothing
      , _data_ = Nothing
      }

publishDiagsForUri :: Uri -> LspM () ()
publishDiagsForUri fileUri = do
  getVirtualFile (toNormalizedUri fileUri) >>= \case
    Just vfile -> do
      let diags = parseFile (toNormalizedUri fileUri)
                            (Rope.toText (vfile ^. L.file_text))
      liftIO $ appendFile "/home/tom/hsvislsplog.txt" ("  -> publishing diags: " ++ show diags ++ "\n")
      sendNotification SMethod_TextDocumentPublishDiagnostics PublishDiagnosticsParams
        { _uri = fileUri
        , _version = Just (vfile ^. L.lsp_version)
        , _diagnostics = diags }
    Nothing -> pure ()

handlers :: Handlers (LspM ())
handlers =
  mconcat
    [ notificationHandler SMethod_Initialized $ \_notif -> do
        sendNotification SMethod_WindowShowMessage (ShowMessageParams MessageType_Info "initialized!")
        liftIO $ appendFile "/home/tom/hsvislsplog.txt" "initialized\n"
        pure ()
    , notificationHandler SMethod_TextDocumentDidOpen $ \notif -> do
        let fileUri = notif ^. L.params . L.textDocument . L.uri
        -- liftIO $ appendFile "/home/tom/hsvislsplog.txt" ("Handle (open): " ++ show fileUri ++ "\n")
        publishDiagsForUri fileUri
    , notificationHandler SMethod_TextDocumentDidChange $ \notif -> do
        let fileUri = notif ^. L.params . L.textDocument . L.uri
        -- liftIO $ appendFile "/home/tom/hsvislsplog.txt" ("Handle (change): " ++ show fileUri ++ "\n")
        publishDiagsForUri fileUri
        pure ()
    , notificationHandler SMethod_TextDocumentDidClose $ \notif -> do
        let fileUri = notif ^. L.params . L.textDocument . L.uri
        -- liftIO $ appendFile "/home/tom/hsvislsplog.txt" ("Close: " ++ show fileUri ++ "\n")
        publishDiagsForUri fileUri
        pure ()
    ]

main :: IO Int
main =
  runServer $
    ServerDefinition
      { parseConfig = const $ const $ Right ()
      , onConfigChange = const $ pure ()
      , defaultConfig = ()
      , configSection = "hs_vis"
      , doInitialize = \env _req -> pure $ Right env
      , staticHandlers = \_caps -> handlers
      , interpretHandler = \env -> Iso (runLspT env) liftIO
      , options = defaultOptions
          { optTextDocumentSync = Just $ TextDocumentSyncOptions
              { _openClose = Just True
              , _change = Just TextDocumentSyncKind_Incremental
              , _willSave = Nothing
              , _willSaveWaitUntil = Nothing
              , _save = Nothing }}
      }