{-
  Copyright (c) Meta Platforms, Inc. and affiliates.
  All rights reserved.

  This source code is licensed under the BSD-style license found in the
  LICENSE file in the root directory of this source tree.
-}

-- Barebones parser for LSIF/JSON dumps to LSIF.Types
-- Examples given in
-- https://github.com/microsoft/language-server-protocol/blob/main/indexFormat/specification.md
--

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ApplicativeDo #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Data.LSIF.JSON ({-instances -}) where

import Data.Aeson.Types
import Data.Text ( Text )
import qualified Data.Vector as V
import Control.Applicative ( Alternative((<|>)) )

import Data.Maybe ( fromMaybe )
import Data.LSIF.Types
import Data.LSIF.Gen

instance FromJSON LSIF where
  parseJSON = withArray "LSIF" $ fmap LSIF . V.mapM parseJSON

instance FromJSON KeyFact where
  parseJSON = withObject "LSIF.KeyFact" $ \o -> do
    id_ <- o .: "id"
    type_ <- o .: "type"
    fact <- case (type_::Text) of
      "vertex" -> parseVertex o
      "edge" -> parseEdge o
      _ -> fail $ "FromJSON.KeyFact: unknown object type: " <> show type_
    return KeyFact{..}

parseDiagnostic :: Value -> Parser Diagnostic
parseDiagnostic (Object o) = Diagnostic
  <$> o .: "severity"
  <*> o .: "code"
  <*> o .: "message"
  <*> o .: "range"
parseDiagnostic v = fail ("Unrecognized value in diagnostic results" <> show v)

parseHoverContents :: Value -> Parser HoverContents
parseHoverContents (Object o) = HoverSignature
  <$> (o .: "language" <|> o .: "kind")
  <*> o .: "value"
parseHoverContents (String s) = pure (HoverText s)
parseHoverContents v = fail ("Unrecognized value in hover contents: " <> show v)

instance FromJSON Marker where
  parseJSON (String str) = case str of
    "begin" -> pure Begin
    "end" -> pure End
    s -> fail ("FromJSON.Marker: unknown marker: " <> show s)
  parseJSON s = fail ("FromJSON.Marker. unknown marker: " <> show s)

instance FromJSON Scope where
  parseJSON (String str) = case str of
    "project" -> pure ProjectScope
    "document" -> pure DocumentScope
    s -> fail ("FromJSON.Scope: unknown scope: " <> show s)
  parseJSON s = fail ("FromJSON.Scope: unknown scope: " <> show s)

-- | lsif dumps are rows of flattened objects, indexed by tags
parseVertex :: Object -> Parser Fact
parseVertex o = do
  label::Text <- o .: "label"
  case label of
    "metaData" -> MetaData
      <$> o .: "version"
      <*> o .: "projectRoot"
      <*> o .: "positionEncoding"
      <*> o .: "toolInfo"
    "project" -> Project
      <$> o .: "kind"
    "$event" -> Event
      <$> o .: "kind"
      <*> o .: "scope"
      <*> o .: "data"
    "range" -> SymbolRange
      <$> (Range <$> o .: "start" <*> o .: "end")
      <*> o .:? "tag"
    "document" -> Document
      <$> o .: "uri"
      <*> (o .: "languageId" <|> o .: "language")
    "moniker" -> Moniker
      <$> o .: "kind"
      <*> o .: "scheme"
      <*> o .: "identifier"
    "packageInformation" -> PackageInformation
      <$> o .: "name"
      <*> o .: "manager"
      <*> (fromMaybe "" <$> (o .:? "version"))
    "hoverResult" -> do
      result <- o .: "result"
      cs <- result .: "contents"
      contents <- case cs of
        Array arr -> V.mapM parseHoverContents arr
        Object{} -> V.singleton <$> parseHoverContents cs
        t -> fail $ "hoverResult: contents: unhandled type: " <> show t
      return HoverResult{..}

    "resultSet" -> pure ResultSet
    "definitionResult" -> pure DefinitionResult
    "declarationResult" -> pure DeclarationResult
    "referenceResult" -> pure ReferenceResult

    "diagnosticResult" -> do
      rs <- o .: "result"
      LsifDiagnosticResult <$> withArray "diagnosticResult"
        (V.mapM parseDiagnostic) rs

    "documentSymbolResult" -> do
      rs <- o .: "result"
      LsifDocumentSymbolResult <$> withArray "documentSymbols"
        (V.mapM (withObject "documentSymbolId" (.: "id"))) rs

    _ -> pure LsifUnknown

instance FromJSON Tag where
  parseJSON (Object o) = do
    lsifType <- o .: "type"
    case lsifType::Text of
      "definition" -> Definition
        <$> o .: "text"
        <*> o .: "kind"
        <*> o .: "fullRange"
        <*> o .:? "tagDetail"
      "declaration" -> Definition
        <$> o .: "text"
        <*> o .: "kind"
        <*> o .: "fullRange"
        <*> o .:? "tagDetail"
      "reference" -> Reference
        <$> o .: "text"
      _ -> UnknownSymbol
        <$> o .: "text"
  parseJSON s = fail ("FromJSON.Tag: unknown tag type: " <> show s)

instance FromJSON ToolInfo where
  parseJSON = withObject "ToolInfo" $ \o -> ToolInfo
    <$> o .: "name"
    <*> (fromMaybe [] <$> o .:? "args")
    <*> o .: "version"

parseProperty :: Text -> Parser Property
parseProperty "definitions" = pure Definitions
parseProperty "references" = pure References
parseProperty "referenceResults" = pure ReferenceResults
parseProperty s = fail ("Unknown property: parsePropery: " <> show s)

parseEdgeLabel :: Text -> Maybe Label
parseEdgeLabel "moniker" = pure EdgeMoniker
parseEdgeLabel "packageInformation" = pure EdgePackageInformation
parseEdgeLabel "nextMoniker" = pure EdgeNextMoniker
parseEdgeLabel "next" = pure EdgeNext
parseEdgeLabel "textDocument/hover" = pure EdgeTextDocumentHover
parseEdgeLabel "textDocument/definition" = pure EdgeTextDocumentDefinition
parseEdgeLabel "textDocument/references" = pure EdgeTextDocumentReferences
parseEdgeLabel "textDocument/diagnostic" = pure EdgeTextDocumentDiagnostic
parseEdgeLabel "textDocument/documentSymbol" =
  pure EdgeTextDocumentDocumentSymbol
parseEdgeLabel "textDocument/foldingRange" = pure EdgeTextDocumentFoldingRange
parseEdgeLabel "sourcegraph:documentationString" = Nothing
parseEdgeLabel "sourcegraph:documentationChildren" = Nothing
parseEdgeLabel _ = Nothing

-- | lsif edges
parseEdge :: Object -> Parser Fact
parseEdge o = do
  label <- o .: "label"
  case label of
    "contains" -> Contains
      <$> o .: "outV"
      <*> o .: "inVs"
    "item" -> Item
      <$> o .: "outV"
      <*> o .: "inVs"
      <*> o .: "document"
      <*> explicitParseFieldMaybe
            (withText "property" parseProperty) o "property"
    s -> case parseEdgeLabel s of
      Nothing -> pure LsifUnknown -- skip unknown edges
      Just lbl -> Edge lbl
        <$> o .: "outV"
        <*> o .: "inV"

-- https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#symbolKind
instance FromJSON SymbolKind where
  parseJSON (Number n) = pure $ case n of
    1 -> SkFile
    2 -> SkModule
    3 -> SkNamespace
    4 -> SkPackage
    5 -> SkClass
    6 -> SkMethod
    7 -> SkProperty
    8 -> SkField
    9 -> SkConstructor
    10 -> SkEnum
    11 -> SkInterface
    12 -> SkFunction
    13 -> SkVariable
    14 -> SkConstant
    15 -> SkString
    16 -> SkNumber
    17 -> SkBoolean
    18 -> SkArray
    19 -> SkObject
    20 -> SkKey
    21 -> SkNull
    22 -> SkEnumMember
    23 -> SkStruct
    24 -> SkEvent
    25 -> SkOperator
    26 -> SkTypeParameter
    _ -> SkUnknown
  parseJSON s = fail ("FromJSON.SymbolKind: " <> show s)

-- From https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#textDocumentItem
instance FromJSON LanguageId where
  parseJSON (String s) = pure $ case s of
    "abap" -> ABAP
    "bat" -> WindowsBat
    "bibtex" -> BibTeX
    "clojure" -> Clojure
    "coffeescript" -> Coffeescript
    "c" -> C
    "cpp" -> Cpp
    "csharp" -> CSharp
    "css" -> CSS
    "diff" -> Diff
    "dart" -> Dart
    "dockerfile" -> Dockerfile
    "elixir" -> Elixir
    "erlang" -> Erlang
    "fsharp" -> FSharp
    "git-commit" -> Git
    "git-rebase" -> Git
    "go" -> Go
    "groovy" -> Groovy
    "handlebars" -> Handlebars
    "haskell" -> Haskell
    "html" -> HTML
    "ini" -> Ini
    "java" -> Java
    "javascript" -> JavaScript
    "javascriptreact" -> JavaScriptReact
    "json" -> JSON
    "latex" -> LaTeX
    "less" -> Less
    "lua" -> Lua
    "makefile" -> Makefile
    "markdown" -> Markdown
    "objective-c" -> ObjectiveC
    "objective-cpp" -> ObjectiveCpp
    "perl" -> Perl
    "perl6" -> Perl6
    "php" -> PHP
    "powershell" -> Powershell
    "jade" -> Pug
    "python" -> Python
    "r" -> R
    "razor" -> Razor
    "ruby" -> Ruby
    "rust" -> Rust
    "scss" -> SCSS
    "scala" -> Scala
    "shaderlab" -> ShaderLab
    "shellscript" -> Shell
    "sql" -> SQL
    "swift" -> Swift
    "typescript" -> TypeScript
    "typescriptreact" -> TypeScriptReact
    "tex" -> TeX
    "vb" -> VisualBasic
    "xml" -> XML
    "xsl" -> XSL
    "yaml" -> YAML
    _ -> UnknownLanguage
  parseJSON s = fail ("FromJSON.LanguageId: " <> show s)