{-# LANGUAGE DuplicateRecordFields #-}
module Development.IDE.Core.IdeConfiguration
  ( IdeConfiguration(..)
  , registerIdeConfiguration
  , getIdeConfiguration
  , parseConfiguration
  , parseWorkspaceFolder
  , isWorkspaceFile
  , modifyWorkspaceFolders
  , modifyClientSettings
  , getClientSettings
  )
where

import           Control.Concurrent.Extra
import           Control.Monad
import           Data.Hashable                  (Hashed, hashed, unhashed)
import           Data.HashSet                   (HashSet, singleton)
import           Data.Text                      (Text, isPrefixOf)
import           Data.Aeson.Types               (Value)
import           Development.IDE.Core.Shake
import           Development.IDE.Types.Location
import           Development.Shake
import           Language.Haskell.LSP.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
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 =
  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. IsIdeGlobal a => Action a
getIdeGlobalAction Action IdeConfigurationVar
-> (IdeConfigurationVar -> Action IdeConfiguration)
-> Action IdeConfiguration
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO IdeConfiguration -> Action IdeConfiguration
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 Int
Maybe Text
Maybe Value
Maybe Trace
Maybe Uri
Maybe (List WorkspaceFolder)
ClientCapabilities
$sel:_processId:InitializeParams :: InitializeParams -> Maybe Int
$sel:_rootPath:InitializeParams :: InitializeParams -> Maybe Text
$sel:_rootUri:InitializeParams :: InitializeParams -> Maybe Uri
$sel:_initializationOptions:InitializeParams :: InitializeParams -> Maybe Value
$sel:_capabilities:InitializeParams :: InitializeParams -> ClientCapabilities
$sel:_trace:InitializeParams :: InitializeParams -> Maybe Trace
$sel:_workspaceFolders:InitializeParams :: InitializeParams -> Maybe (List WorkspaceFolder)
_workspaceFolders :: Maybe (List WorkspaceFolder)
_trace :: Maybe Trace
_capabilities :: ClientCapabilities
_initializationOptions :: Maybe Value
_rootUri :: Maybe Uri
_rootPath :: Maybe Text
_processId :: Maybe Int
..} =
  IdeConfiguration :: HashSet NormalizedUri -> Hashed (Maybe Value) -> IdeConfiguration
IdeConfiguration {Hashed (Maybe Value)
HashSet NormalizedUri
clientSettings :: Hashed (Maybe Value)
workspaceFolders :: HashSet NormalizedUri
$sel:clientSettings:IdeConfiguration :: Hashed (Maybe Value)
$sel:workspaceFolders:IdeConfiguration :: HashSet NormalizedUri
..}
 where
  workspaceFolders :: HashSet NormalizedUri
workspaceFolders =
    (Uri -> HashSet NormalizedUri)
-> Maybe Uri -> HashSet NormalizedUri
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) Maybe Uri
_rootUri
      HashSet NormalizedUri
-> HashSet NormalizedUri -> HashSet NormalizedUri
forall a. Semigroup a => a -> a -> a
<> ((List WorkspaceFolder -> HashSet NormalizedUri)
-> Maybe (List WorkspaceFolder) -> HashSet NormalizedUri
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((List WorkspaceFolder -> HashSet NormalizedUri)
 -> Maybe (List WorkspaceFolder) -> HashSet NormalizedUri)
-> ((WorkspaceFolder -> HashSet NormalizedUri)
    -> List WorkspaceFolder -> HashSet NormalizedUri)
-> (WorkspaceFolder -> HashSet NormalizedUri)
-> Maybe (List WorkspaceFolder)
-> HashSet NormalizedUri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WorkspaceFolder -> HashSet NormalizedUri)
-> List WorkspaceFolder -> HashSet NormalizedUri
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)
           Maybe (List WorkspaceFolder)
_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 =
  Uri -> NormalizedUri
toNormalizedUri (Uri -> NormalizedUri)
-> (WorkspaceFolder -> Uri) -> WorkspaceFolder -> NormalizedUri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Uri
Uri (Text -> Uri)
-> (WorkspaceFolder -> Text) -> WorkspaceFolder -> Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WorkspaceFolder -> Text
_uri :: WorkspaceFolder -> Text)

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
  Var IdeConfiguration
-> (IdeConfiguration -> IO IdeConfiguration) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var IdeConfiguration
var (IdeConfiguration -> IO IdeConfiguration
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IdeConfiguration -> IO IdeConfiguration)
-> (IdeConfiguration -> IdeConfiguration)
-> IdeConfiguration
-> IO IdeConfiguration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (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
$sel:clientSettings:IdeConfiguration :: IdeConfiguration -> Hashed (Maybe Value)
$sel:workspaceFolders:IdeConfiguration :: IdeConfiguration -> HashSet NormalizedUri
..} <- 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 (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