{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ViewPatterns          #-}

module Ide.Plugin.Cabal.Outline where

import           Control.Monad.IO.Class
import           Data.Maybe
import qualified Data.Text                               as T
import           Data.Text.Encoding                      (decodeUtf8)
import           Development.IDE.Core.Rules
import           Development.IDE.Core.Shake              (IdeState (shakeExtras),
                                                          runIdeAction,
                                                          useWithStaleFast)
import           Development.IDE.Types.Location          (toNormalizedFilePath')
import           Distribution.Fields.Field               (Field (Field, Section),
                                                          Name (Name))
import           Distribution.Parsec.Position            (Position)
import           Ide.Plugin.Cabal.Completion.CabalFields (onelineSectionArgs)
import           Ide.Plugin.Cabal.Completion.Types       (ParseCabalFields (..),
                                                          cabalPositionToLSPPosition)
import           Ide.Plugin.Cabal.Orphans                ()
import           Ide.Types                               (PluginMethodHandler)
import           Language.LSP.Protocol.Message           (Method (..))
import           Language.LSP.Protocol.Types             (DocumentSymbol (..))
import qualified Language.LSP.Protocol.Types             as LSP


moduleOutline :: PluginMethodHandler IdeState Method_TextDocumentDocumentSymbol
moduleOutline :: PluginMethodHandler IdeState 'Method_TextDocumentDocumentSymbol
moduleOutline IdeState
ideState PluginId
_ LSP.DocumentSymbolParams {_textDocument :: DocumentSymbolParams -> TextDocumentIdentifier
_textDocument = LSP.TextDocumentIdentifier Uri
uri} =
  case Uri -> Maybe FilePath
LSP.uriToFilePath Uri
uri of
    Just (FilePath -> NormalizedFilePath
toNormalizedFilePath' -> NormalizedFilePath
fp) -> do
      Maybe ([Field Position], PositionMapping)
mFields <- IO (Maybe ([Field Position], PositionMapping))
-> ExceptT
     PluginError
     (HandlerM Config)
     (Maybe ([Field Position], PositionMapping))
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ([Field Position], PositionMapping))
 -> ExceptT
      PluginError
      (HandlerM Config)
      (Maybe ([Field Position], PositionMapping)))
-> IO (Maybe ([Field Position], PositionMapping))
-> ExceptT
     PluginError
     (HandlerM Config)
     (Maybe ([Field Position], PositionMapping))
forall a b. (a -> b) -> a -> b
$ FilePath
-> ShakeExtras
-> IdeAction (Maybe ([Field Position], PositionMapping))
-> IO (Maybe ([Field Position], PositionMapping))
forall a. FilePath -> ShakeExtras -> IdeAction a -> IO a
runIdeAction FilePath
"cabal-plugin.fields" (IdeState -> ShakeExtras
shakeExtras IdeState
ideState) (ParseCabalFields
-> NormalizedFilePath
-> IdeAction (Maybe ([Field Position], PositionMapping))
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping))
useWithStaleFast ParseCabalFields
ParseCabalFields NormalizedFilePath
fp)
      case (([Field Position], PositionMapping) -> [Field Position])
-> Maybe ([Field Position], PositionMapping)
-> Maybe [Field Position]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Field Position], PositionMapping) -> [Field Position]
forall a b. (a, b) -> a
fst Maybe ([Field Position], PositionMapping)
mFields of
        Just [Field Position]
fieldPositions -> ([SymbolInformation] |? ([DocumentSymbol] |? Null))
-> ExceptT
     PluginError
     (HandlerM Config)
     ([SymbolInformation] |? ([DocumentSymbol] |? Null))
forall a. a -> ExceptT PluginError (HandlerM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([SymbolInformation] |? ([DocumentSymbol] |? Null))
 -> ExceptT
      PluginError
      (HandlerM Config)
      ([SymbolInformation] |? ([DocumentSymbol] |? Null)))
-> ([SymbolInformation] |? ([DocumentSymbol] |? Null))
-> ExceptT
     PluginError
     (HandlerM Config)
     ([SymbolInformation] |? ([DocumentSymbol] |? Null))
forall a b. (a -> b) -> a -> b
$ ([DocumentSymbol] |? Null)
-> [SymbolInformation] |? ([DocumentSymbol] |? Null)
forall a b. b -> a |? b
LSP.InR ([DocumentSymbol] -> [DocumentSymbol] |? Null
forall a b. a -> a |? b
LSP.InL [DocumentSymbol]
allSymbols)
          where
            allSymbols :: [DocumentSymbol]
allSymbols = (Field Position -> Maybe DocumentSymbol)
-> [Field Position] -> [DocumentSymbol]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Field Position -> Maybe DocumentSymbol
documentSymbolForField [Field Position]
fieldPositions
        Maybe [Field Position]
Nothing -> ([SymbolInformation] |? ([DocumentSymbol] |? Null))
-> ExceptT
     PluginError
     (HandlerM Config)
     ([SymbolInformation] |? ([DocumentSymbol] |? Null))
forall a. a -> ExceptT PluginError (HandlerM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([SymbolInformation] |? ([DocumentSymbol] |? Null))
 -> ExceptT
      PluginError
      (HandlerM Config)
      ([SymbolInformation] |? ([DocumentSymbol] |? Null)))
-> ([SymbolInformation] |? ([DocumentSymbol] |? Null))
-> ExceptT
     PluginError
     (HandlerM Config)
     ([SymbolInformation] |? ([DocumentSymbol] |? Null))
forall a b. (a -> b) -> a -> b
$ [SymbolInformation]
-> [SymbolInformation] |? ([DocumentSymbol] |? Null)
forall a b. a -> a |? b
LSP.InL []
    Maybe FilePath
Nothing -> MessageResult 'Method_TextDocumentDocumentSymbol
-> ExceptT
     PluginError
     (HandlerM Config)
     (MessageResult 'Method_TextDocumentDocumentSymbol)
forall a. a -> ExceptT PluginError (HandlerM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MessageResult 'Method_TextDocumentDocumentSymbol
 -> ExceptT
      PluginError
      (HandlerM Config)
      (MessageResult 'Method_TextDocumentDocumentSymbol))
-> MessageResult 'Method_TextDocumentDocumentSymbol
-> ExceptT
     PluginError
     (HandlerM Config)
     (MessageResult 'Method_TextDocumentDocumentSymbol)
forall a b. (a -> b) -> a -> b
$ [SymbolInformation]
-> [SymbolInformation] |? ([DocumentSymbol] |? Null)
forall a b. a -> a |? b
LSP.InL []

-- | Creates a @DocumentSymbol@ object for the
--   cabal AST, without displaying @fieldLines@ and
--   displaying @Section Name@ and @SectionArgs@ in one line.
--
--   @fieldLines@ are leaves of a cabal AST, so they are omitted
--   in the outline. Sections have to be displayed in one line, because
--   the AST representation looks unnatural. See examples:
--
-- *  part of a cabal file:
--
-- >   if impl(ghc >= 9.8)
-- >      ghc-options: -Wall
--
-- * AST representation:
--
-- >   if
-- >      impl
-- >      (
-- >      ghc >= 9.8
-- >      )
-- >
-- >      ghc-options:
-- >        -Wall
--
-- * resulting @DocumentSymbol@:
--
-- >   if impl(ghc >= 9.8)
-- >      ghc-options:
-- >
documentSymbolForField :: Field Position -> Maybe DocumentSymbol
documentSymbolForField :: Field Position -> Maybe DocumentSymbol
documentSymbolForField (Field (Name Position
pos FieldName
fieldName) [FieldLine Position]
_) =
  DocumentSymbol -> Maybe DocumentSymbol
forall a. a -> Maybe a
Just
    (Range -> DocumentSymbol
defDocumentSymbol Range
range)
      { _name = decodeUtf8 fieldName,
        _kind = LSP.SymbolKind_Field,
        _children = Nothing
      }
  where
    range :: Range
range = Position -> Range
cabalPositionToLSPRange Position
pos Range -> Text -> Range
`addNameLengthToLSPRange` FieldName -> Text
decodeUtf8 FieldName
fieldName
documentSymbolForField (Section (Name Position
pos FieldName
fieldName) [SectionArg Position]
sectionArgs [Field Position]
fields) =
  DocumentSymbol -> Maybe DocumentSymbol
forall a. a -> Maybe a
Just
    (Range -> DocumentSymbol
defDocumentSymbol Range
range)
      { _name = joinedName,
        _kind = LSP.SymbolKind_Object,
        _children =
          Just
            (mapMaybe documentSymbolForField fields)
      }
  where
    joinedName :: Text
joinedName = FieldName -> Text
decodeUtf8 FieldName
fieldName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [SectionArg Position] -> Text
forall ann. [SectionArg ann] -> Text
onelineSectionArgs [SectionArg Position]
sectionArgs
    range :: Range
range = Position -> Range
cabalPositionToLSPRange Position
pos Range -> Text -> Range
`addNameLengthToLSPRange` Text
joinedName

-- | Creates a single point LSP range
--   using cabal position
cabalPositionToLSPRange :: Position -> LSP.Range
cabalPositionToLSPRange :: Position -> Range
cabalPositionToLSPRange Position
pos = Position -> Position -> Range
LSP.Range Position
lspPos Position
lspPos
  where
    lspPos :: Position
lspPos = Position -> Position
cabalPositionToLSPPosition Position
pos

addNameLengthToLSPRange :: LSP.Range -> T.Text -> LSP.Range
addNameLengthToLSPRange :: Range -> Text -> Range
addNameLengthToLSPRange (LSP.Range Position
pos1 (LSP.Position UInt
line UInt
char)) Text
name =
  Position -> Position -> Range
LSP.Range
    Position
pos1
    (UInt -> UInt -> Position
LSP.Position UInt
line (UInt
char UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
T.length Text
name)))

defDocumentSymbol :: LSP.Range -> DocumentSymbol
defDocumentSymbol :: Range -> DocumentSymbol
defDocumentSymbol Range
range = DocumentSymbol
  { _detail :: Maybe Text
_detail = Maybe Text
forall a. Maybe a
Nothing
  , _deprecated :: Maybe Bool
_deprecated = Maybe Bool
forall a. Maybe a
Nothing
  , _name :: Text
_name = Text
""
  , _kind :: SymbolKind
_kind = SymbolKind
LSP.SymbolKind_File
  , _range :: Range
_range = Range
range
  , _selectionRange :: Range
_selectionRange = Range
range
  , _children :: Maybe [DocumentSymbol]
_children = Maybe [DocumentSymbol]
forall a. Maybe a
Nothing
  , _tags :: Maybe [SymbolTag]
_tags = Maybe [SymbolTag]
forall a. Maybe a
Nothing
  }