module Development.IDE.Core.IdeConfiguration
  ( IdeConfiguration(..)
  , registerIdeConfiguration
  , getIdeConfiguration
  , parseConfiguration
  , parseWorkspaceFolder
  , isWorkspaceFile
  , modifyWorkspaceFolders
  , modifyClientSettings
  , getClientSettings
  )
where

import           Control.Concurrent.Strict

import           Control.Monad
import           Control.Monad.IO.Class
import           Data.Aeson.Types               (Value)
import           Data.Hashable                  (Hashed, hashed, unhashed)
import           Data.HashSet                   (HashSet, singleton)
import           Data.Text                      (isPrefixOf)
import           Development.IDE.Core.Shake
import           Development.IDE.Graph
import           Development.IDE.Types.Location
import           Language.LSP.Protocol.Types
import           System.FilePath                (isRelative)

-- | Lsp client relevant configuration details
data IdeConfiguration = IdeConfiguration
  { IdeConfiguration -> HashSet NormalizedUri
workspaceFolders :: HashSet NormalizedUri
  , IdeConfiguration -> Hashed (Maybe Value)
clientSettings   :: Hashed (Maybe Value)
  }
  deriving (Int -> IdeConfiguration -> ShowS
[IdeConfiguration] -> ShowS
IdeConfiguration -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IdeConfiguration] -> ShowS
$cshowList :: [IdeConfiguration] -> ShowS
show :: IdeConfiguration -> String
$cshow :: IdeConfiguration -> String
showsPrec :: Int -> IdeConfiguration -> ShowS
$cshowsPrec :: Int -> IdeConfiguration -> ShowS
Show)

newtype IdeConfigurationVar = IdeConfigurationVar {IdeConfigurationVar -> Var IdeConfiguration
unIdeConfigurationRef :: Var IdeConfiguration}

instance IsIdeGlobal IdeConfigurationVar

registerIdeConfiguration :: ShakeExtras -> IdeConfiguration -> IO ()
registerIdeConfiguration :: ShakeExtras -> IdeConfiguration -> IO ()
registerIdeConfiguration ShakeExtras
extras =
  forall a. IsIdeGlobal a => ShakeExtras -> a -> IO ()
addIdeGlobalExtras ShakeExtras
extras forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var IdeConfiguration -> IdeConfigurationVar
IdeConfigurationVar forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. a -> IO (Var a)
newVar

getIdeConfiguration :: Action IdeConfiguration
getIdeConfiguration :: Action IdeConfiguration
getIdeConfiguration =
  forall a. (HasCallStack, IsIdeGlobal a) => Action a
getIdeGlobalAction forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Var a -> IO a
readVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdeConfigurationVar -> Var IdeConfiguration
unIdeConfigurationRef

parseConfiguration :: InitializeParams -> IdeConfiguration
parseConfiguration :: InitializeParams -> IdeConfiguration
parseConfiguration InitializeParams {Maybe Text
Maybe Value
Maybe ProgressToken
Maybe TraceValues
Maybe ([WorkspaceFolder] |? Null)
Maybe (Text |? Null)
Maybe
  (Rec (("name" .== Text) .+ (("version" .== Maybe Text) .+ Empty)))
ClientCapabilities
Int32 |? Null
Uri |? Null
$sel:_workDoneToken:InitializeParams :: InitializeParams -> Maybe ProgressToken
$sel:_processId:InitializeParams :: InitializeParams -> Int32 |? Null
$sel:_clientInfo:InitializeParams :: InitializeParams
-> Maybe
     (Rec (("name" .== Text) .+ (("version" .== Maybe Text) .+ Empty)))
$sel:_locale:InitializeParams :: InitializeParams -> Maybe Text
$sel:_rootPath:InitializeParams :: InitializeParams -> Maybe (Text |? Null)
$sel:_rootUri:InitializeParams :: InitializeParams -> Uri |? Null
$sel:_capabilities:InitializeParams :: InitializeParams -> ClientCapabilities
$sel:_initializationOptions:InitializeParams :: InitializeParams -> Maybe Value
$sel:_trace:InitializeParams :: InitializeParams -> Maybe TraceValues
$sel:_workspaceFolders:InitializeParams :: InitializeParams -> Maybe ([WorkspaceFolder] |? Null)
_workspaceFolders :: Maybe ([WorkspaceFolder] |? Null)
_trace :: Maybe TraceValues
_initializationOptions :: Maybe Value
_capabilities :: ClientCapabilities
_rootUri :: Uri |? Null
_rootPath :: Maybe (Text |? Null)
_locale :: Maybe Text
_clientInfo :: Maybe
  (Rec (("name" .== Text) .+ (("version" .== Maybe Text) .+ Empty)))
_processId :: Int32 |? Null
_workDoneToken :: Maybe ProgressToken
..} =
  IdeConfiguration {Hashed (Maybe Value)
HashSet NormalizedUri
clientSettings :: Hashed (Maybe Value)
workspaceFolders :: HashSet NormalizedUri
clientSettings :: Hashed (Maybe Value)
workspaceFolders :: HashSet NormalizedUri
..}
 where
  workspaceFolders :: HashSet NormalizedUri
workspaceFolders =
    forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Hashable a => a -> HashSet a
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uri -> NormalizedUri
toNormalizedUri) (forall a. (a |? Null) -> Maybe a
nullToMaybe Uri |? Null
_rootUri)
      forall a. Semigroup a => a -> a -> a
<> (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap)
           (forall a. Hashable a => a -> HashSet a
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorkspaceFolder -> NormalizedUri
parseWorkspaceFolder)
           (forall a. (a |? Null) -> Maybe a
nullToMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ([WorkspaceFolder] |? Null)
_workspaceFolders)
  clientSettings :: Hashed (Maybe Value)
clientSettings = forall a. Hashable a => a -> Hashed a
hashed Maybe Value
_initializationOptions

parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri
parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri
parseWorkspaceFolder WorkspaceFolder{Uri
$sel:_uri:WorkspaceFolder :: WorkspaceFolder -> Uri
_uri :: Uri
_uri} =
  Uri -> NormalizedUri
toNormalizedUri Uri
_uri

modifyWorkspaceFolders
  :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()
modifyWorkspaceFolders :: IdeState
-> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()
modifyWorkspaceFolders IdeState
ide HashSet NormalizedUri -> HashSet NormalizedUri
f = IdeState -> (IdeConfiguration -> IdeConfiguration) -> IO ()
modifyIdeConfiguration IdeState
ide IdeConfiguration -> IdeConfiguration
f'
  where f' :: IdeConfiguration -> IdeConfiguration
f' (IdeConfiguration HashSet NormalizedUri
ws Hashed (Maybe Value)
initOpts) = HashSet NormalizedUri -> Hashed (Maybe Value) -> IdeConfiguration
IdeConfiguration (HashSet NormalizedUri -> HashSet NormalizedUri
f HashSet NormalizedUri
ws) Hashed (Maybe Value)
initOpts

modifyClientSettings
  :: IdeState -> (Maybe Value -> Maybe Value) -> IO ()
modifyClientSettings :: IdeState -> (Maybe Value -> Maybe Value) -> IO ()
modifyClientSettings IdeState
ide Maybe Value -> Maybe Value
f = IdeState -> (IdeConfiguration -> IdeConfiguration) -> IO ()
modifyIdeConfiguration IdeState
ide IdeConfiguration -> IdeConfiguration
f'
  where f' :: IdeConfiguration -> IdeConfiguration
f' (IdeConfiguration HashSet NormalizedUri
ws Hashed (Maybe Value)
clientSettings) =
            HashSet NormalizedUri -> Hashed (Maybe Value) -> IdeConfiguration
IdeConfiguration HashSet NormalizedUri
ws (forall a. Hashable a => a -> Hashed a
hashed forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Value -> Maybe Value
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Hashed a -> a
unhashed forall a b. (a -> b) -> a -> b
$ Hashed (Maybe Value)
clientSettings)

modifyIdeConfiguration
  :: IdeState -> (IdeConfiguration -> IdeConfiguration) -> IO ()
modifyIdeConfiguration :: IdeState -> (IdeConfiguration -> IdeConfiguration) -> IO ()
modifyIdeConfiguration IdeState
ide IdeConfiguration -> IdeConfiguration
f = do
  IdeConfigurationVar Var IdeConfiguration
var <- forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState IdeState
ide
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Var a -> (a -> a) -> IO a
modifyVar' Var IdeConfiguration
var IdeConfiguration -> IdeConfiguration
f

isWorkspaceFile :: NormalizedFilePath -> Action Bool
isWorkspaceFile :: NormalizedFilePath -> Action Bool
isWorkspaceFile NormalizedFilePath
file =
  if String -> Bool
isRelative (NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
file)
    then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    else do
      IdeConfiguration {Hashed (Maybe Value)
HashSet NormalizedUri
clientSettings :: Hashed (Maybe Value)
workspaceFolders :: HashSet NormalizedUri
clientSettings :: IdeConfiguration -> Hashed (Maybe Value)
workspaceFolders :: IdeConfiguration -> HashSet NormalizedUri
..} <- Action IdeConfiguration
getIdeConfiguration
      let toText :: NormalizedUri -> Text
toText = Uri -> Text
getUri forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedUri -> Uri
fromNormalizedUri
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
          (\NormalizedUri
root -> NormalizedUri -> Text
toText NormalizedUri
root Text -> Text -> Bool
`isPrefixOf` NormalizedUri -> Text
toText (NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
file))
          HashSet NormalizedUri
workspaceFolders

getClientSettings :: Action (Maybe Value)
getClientSettings :: Action (Maybe Value)
getClientSettings = forall a. Hashed a -> a
unhashed forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdeConfiguration -> Hashed (Maybe Value)
clientSettings forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action IdeConfiguration
getIdeConfiguration