content: {-# LANGUAGE TypeOperators #-}
  {-# LANGUAGE OverloadedStrings #-}
  
  -- More or less the features discussed as 'Language features' in the LSP spec.
  module Daedalus.LSP.LanguageFeatures where
  
  import           Control.Lens
  import           Control.Monad (guard)
  import           Control.Monad.Reader
  import           Data.Foldable
  import qualified Data.Map                    as Map
  import           Data.Maybe                  (fromMaybe, maybeToList)
  import qualified Data.Text                   as Text
  
  import           Language.LSP.Server         (getClientCapabilities)
  import qualified Language.LSP.Protocol.Types as J
  import qualified Language.LSP.Protocol.Message as J
  import qualified Language.LSP.Protocol.Lens  as J
  
  import           Daedalus.Rec                (forgetRecs)
  import           Daedalus.Scope
  import           Daedalus.SourceRange
  import           Daedalus.Type.AST
  import           Daedalus.Type.Pretty(ppNamedRuleType,ppTypeInContext)
  
  import           Daedalus.LSP.Diagnostics    (sourceRangeToRange)
  import           Daedalus.LSP.Monad
  import           Daedalus.LSP.Position
  import qualified Daedalus.LSP.SemanticTokens as SI
  
  -- -----------------------------------------------------------------------------
  -- Semantic tokens (highlighting etc.)
  
  semanticTokens :: (Either J.ResponseError (J.SemanticTokens J.|? J.Null) -> ServerM ()) -> 
                    Maybe J.Range -> J.NormalizedUri -> ServerM ()
  semanticTokens resp m_range uri = do
    e_mr <- uriToModuleState uri
  
    -- caps <- getClientCapabilities
    let m_semcaps = Nothing -- caps ^. J.textDocument >>= view J.semanticTokens
  
    -- case e_mr of
    --   Right mr | FinishedStatus _tks <- mr ^. msTokens . passStatus ->
    --              liftIO $ debugM "reactor.semanticTokens" $ "Got some tokens " ++ show (SI.semanticTokens m_range m_semcaps mr)
    --   Right _ -> liftIO $ debugM "reactor.semanticTokens" $ "No tokens"
    --   Left  _ -> liftIO $ debugM "reactor.semanticTokens" $ "No results"
  
    -- case m_semcaps of
    --   Nothing   -> liftIO $ debugM "reactor.semanticTokens" $ "No caps"
    --   Just caps -> liftIO $ debugM "reactor.semanticTokens" $ "Caps " ++ show (caps ^. J.tokenTypes)
      
    -- We might want to cache these?
    resp $ fmap (maybeToNull . SI.semanticTokens m_range m_semcaps) e_mr
  
  -- -----------------------------------------------------------------------------
  -- Definition links
  
  
  definition :: (Either J.ResponseError (J.Definition J.|? ([J.DefinitionLink] J.|? J.Null)) -> ServerM ()) ->
                J.NormalizedUri -> J.Position -> ServerM ()
  definition resp uri pos = do
    e_mr <- uriToModuleState uri
    resp $ fmap (J.InR . J.InL . doDefinition uri pos) e_mr
  
  -- This currently returns a location, but we could return a
  -- locationlink --- we need the range of the target defn.
  doDefinition :: J.NormalizedUri -> J.Position -> ModuleState -> [J.DefinitionLink]
  doDefinition _uri pos ms = maybeToList $ do
    (m, _, _)   <- passStatusToMaybe (ms ^. msTCRes)
    (_, gscope) <- passStatusToMaybe (ms ^. msScopeRes)
    
    d <- declAtPos pos m
    let allnis = declToNames d
    ni <- find (positionInRange pos) allnis
    let isNameDef ni' = niName ni' == niName ni && niNameRefClass ni' == NameDef
    targetRange <-
      case nameScopedIdent (niName ni) of
        Unknown _ -> Nothing -- shouldn't happen
        Local _ -> range <$> find isNameDef allnis
        ModScope mn i -> do
          scope <- Map.lookup mn gscope
          range . snd <$> Map.lookup i (identScope scope)
  
    pure (J.DefinitionLink $ sourceRangeToLocationLink targetRange)
    
  -- -----------------------------------------------------------------------------
  -- Renaming (locals only right now)
  
  -- FIXME: we could do this on just the scoped module, we don't need TC (also for highlight)
  
  -- | Renames a symbol, currently only in a single module.  It will
  -- return Nothing if the symbol is defined in another module.  This
  -- doesn't guarantee that the edits will result in a well formed module.
  
  rename :: (Either J.ResponseError (J.WorkspaceEdit J.|? J.Null) -> ServerM ()) -> J.NormalizedUri ->
            J.Position -> Text.Text -> ServerM ()
  rename resp uri pos newName = do
    e_tcn <- uriToTCModule uri
    resp $ case e_tcn of
      Left err   -> Left err
      Right m_tcm  -> Right . J.InL $ fromMaybe mempty $ doRename pos uri newName =<< m_tcm
  
  doRename :: J.Position -> J.NormalizedUri -> Text.Text -> TCModule SourceRange -> Maybe J.WorkspaceEdit
  doRename pos uri newName m = do
    d <- declAtPos pos m
    let allnis = declToNames d
    ni <- find (positionInRange pos) allnis
    let allnis' =
          if isLocalName (niName ni)
          then allnis
          -- This is pretty gross
          else concatMap declToNames (forgetRecs (tcModuleDecls m))
        nis = filter ((==) (niName ni) . niName) allnis'
    -- if we don't have a definition in this file, we do nothing
    guard (any ((==) NameDef . niNameRefClass) allnis')
    -- Otherwise replace everything.
    --
    -- FIXME: We use 'changes' instead of 'documentChanges' until we
    -- export the version etc. from the worker.
    let edits = [ J.TextEdit (sourceRangeToRange (range ni')) newName | ni' <- nis ]
        emap = Map.singleton (J.fromNormalizedUri uri) edits
    pure (set J.changes (Just emap) mempty)
  
  -- -----------------------------------------------------------------------------
  -- Highlighting
  --
  -- This returns a list of places that a symbol is referenced.
  
  highlight :: (Either J.ResponseError ([J.DocumentHighlight] J.|? J.Null) -> ServerM ()) -> J.NormalizedUri -> J.Position ->
               ServerM ()
  highlight resp uri pos = do
    e_tc <- uriToTCModule uri
    resp $ fmap (maybeToNull . fmap (doHighlight pos)) e_tc
  
  doHighlight :: J.Position -> TCModule SourceRange -> [J.DocumentHighlight]
  doHighlight pos m = fromMaybe mempty $ do
    d <- declAtPos pos m
    let allnis = declToNames d
    ni <- find (positionInRange pos) allnis
    let allnis' =
          if isLocalName (niName ni)
          then allnis
          -- This is pretty gross
          else concatMap declToNames (forgetRecs (tcModuleDecls m))
        nis = filter ((==) (niName ni) . niName) allnis'
    pure (map niToHighlight nis)
    where
      niToHighlight ni = J.DocumentHighlight (sourceRangeToRange (range ni))
                         (Just $ case niNameRefClass ni of
                                   NameDef -> J.DocumentHighlightKind_Write
                                   NameUse -> J.DocumentHighlightKind_Read
                         )
  
  -- FIXME: what about version ?
  -- FIXME: check uri against module's URI
  hover :: (Either J.ResponseError (J.Hover J.|? J.Null) -> ServerM ()) -> J.NormalizedUri -> J.Position -> ServerM ()
  hover resp uri pos = do
    e_tc <- uriToTCModule uri
  
    -- case e_tc of
    --   Right (Just m) -> do
    --     let Just d = declAtPos pos m
    --     liftIO $ debugM "reactor.hover" (show pos ++ "\n" ++ show (exprTree d))
        
    --   _ -> liftIO $ debugM "reactor.hover" "Didn't find a tc'd module"
  
    -- case e_tc of
    --   Right Nothing -> liftIO $ debugM "reactor.hover" "Module hasn't been type checked"
    --   Right (Just m) -> do
    --     liftIO $ debugM "reactor.hover" "Found a module"
    --     void $ traverse (liftIO . debugM "reactor.hover" . (show . bullets . map (viewSome pp)))
    --       $ typeAtModule pos m
          
    --   _ -> liftIO $ debugM "reactor.hover" "Didn't find a tc'd module"
  
    -- resp (Right Nothing)
    resp $ fmap (maybeToNull . (doHover pos =<<)) e_tc
  
  doHover :: J.Position -> TCModule SourceRange -> Maybe J.Hover
  doHover pos m = do
    info <- typeAtModule pos m
    let msg = Text.pack $ show $
              case typeOfExpr info of
                Just t  -> ppTypeInContext (typeOfDecl info) t
                Nothing -> ppNamedRuleType (nameOfDecl info) (typeOfDecl info)
  
    let ms = J.InL $ J.MarkupContent J.MarkupKind_PlainText msg
    pure $ J.Hover ms (Just (sourceRangeToRange (typeLoc info)))
  
  