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
(Int -> IdeConfiguration -> ShowS)
-> (IdeConfiguration -> String)
-> ([IdeConfiguration] -> ShowS)
-> Show IdeConfiguration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IdeConfiguration -> ShowS
showsPrec :: Int -> IdeConfiguration -> ShowS
$cshow :: IdeConfiguration -> String
show :: IdeConfiguration -> String
$cshowList :: [IdeConfiguration] -> ShowS
showList :: [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 =
  ShakeExtras -> IdeConfigurationVar -> IO ()
forall a. IsIdeGlobal a => ShakeExtras -> a -> IO ()
addIdeGlobalExtras ShakeExtras
extras (IdeConfigurationVar -> IO ())
-> (Var IdeConfiguration -> IdeConfigurationVar)
-> Var IdeConfiguration
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var IdeConfiguration -> IdeConfigurationVar
IdeConfigurationVar (Var IdeConfiguration -> IO ())
-> (IdeConfiguration -> IO (Var IdeConfiguration))
-> IdeConfiguration
-> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IdeConfiguration -> IO (Var IdeConfiguration)
forall a. a -> IO (Var a)
newVar

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

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

parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri
parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri
parseWorkspaceFolder WorkspaceFolder{Uri
_uri :: Uri
$sel:_uri:WorkspaceFolder :: WorkspaceFolder -> 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 (Maybe Value -> Hashed (Maybe Value)
forall a. Hashable a => a -> Hashed a
hashed (Maybe Value -> Hashed (Maybe Value))
-> (Hashed (Maybe Value) -> Maybe Value)
-> Hashed (Maybe Value)
-> Hashed (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Value -> Maybe Value
f (Maybe Value -> Maybe Value)
-> (Hashed (Maybe Value) -> Maybe Value)
-> Hashed (Maybe Value)
-> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hashed (Maybe Value) -> Maybe Value
forall a. Hashed a -> a
unhashed (Hashed (Maybe Value) -> Hashed (Maybe Value))
-> Hashed (Maybe Value) -> Hashed (Maybe Value)
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 <- IdeState -> IO IdeConfigurationVar
forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState IdeState
ide
  IO IdeConfiguration -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO IdeConfiguration -> IO ()) -> IO IdeConfiguration -> IO ()
forall a b. (a -> b) -> a -> b
$ Var IdeConfiguration
-> (IdeConfiguration -> IdeConfiguration) -> IO IdeConfiguration
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 Bool -> Action Bool
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    else do
      IdeConfiguration {Hashed (Maybe Value)
HashSet NormalizedUri
workspaceFolders :: IdeConfiguration -> HashSet NormalizedUri
clientSettings :: IdeConfiguration -> Hashed (Maybe Value)
workspaceFolders :: HashSet NormalizedUri
clientSettings :: Hashed (Maybe Value)
..} <- Action IdeConfiguration
getIdeConfiguration
      let toText :: NormalizedUri -> Text
toText = Uri -> Text
getUri (Uri -> Text) -> (NormalizedUri -> Uri) -> NormalizedUri -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedUri -> Uri
fromNormalizedUri
      Bool -> Action Bool
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Action Bool) -> Bool -> Action Bool
forall a b. (a -> b) -> a -> b
$
        (NormalizedUri -> Bool) -> HashSet NormalizedUri -> Bool
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 = Hashed (Maybe Value) -> Maybe Value
forall a. Hashed a -> a
unhashed (Hashed (Maybe Value) -> Maybe Value)
-> (IdeConfiguration -> Hashed (Maybe Value))
-> IdeConfiguration
-> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdeConfiguration -> Hashed (Maybe Value)
clientSettings (IdeConfiguration -> Maybe Value)
-> Action IdeConfiguration -> Action (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action IdeConfiguration
getIdeConfiguration