|
| 1 | +{-# LANGUAGE RecordWildCards #-} |
| 2 | +{-# LANGUAGE OverloadedRecordDot #-} |
| 3 | +{-# LANGUAGE DataKinds #-} |
| 4 | +{-# LANGUAGE OverloadedStrings #-} |
| 5 | +{-# LANGUAGE DerivingStrategies #-} |
| 6 | +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} |
| 7 | +module Ide.Plugin.CompleteCase |
| 8 | + ( descriptor |
| 9 | + ) |
| 10 | + where |
| 11 | + |
| 12 | +import Control.Monad.IO.Class (MonadIO (liftIO)) |
| 13 | +import Control.Monad.Trans.Except (ExceptT(..), mapExceptT, throwE,runExceptT) |
| 14 | + |
| 15 | +import Development.IDE (Action, |
| 16 | + IdeState (shakeExtras), |
| 17 | + Range (Range), Recorder, |
| 18 | + WithPriority (WithPriority), |
| 19 | + cmapWithPrio) |
| 20 | + |
| 21 | +import Development.IDE.Core.PluginUtils |
| 22 | +import Development.IDE.Core.PositionMapping (PositionMapping, |
| 23 | + toCurrentRange) |
| 24 | +import Ide.Logger (Pretty (..), |
| 25 | + Priority (Debug, Error, Info, Warning), |
| 26 | + Recorder, WithPriority, |
| 27 | + cmapWithPrio, logWith, |
| 28 | + nest, |
| 29 | + toCologActionWithPrio, |
| 30 | + vcat, viaShow, (<+>)) |
| 31 | +import Ide.Plugin.Error |
| 32 | +import Ide.PluginUtils (positionInRange) |
| 33 | +import Ide.Types (PluginDescriptor (..), |
| 34 | + PluginId, |
| 35 | + PluginMethodHandler, |
| 36 | + PluginCommand(..), |
| 37 | + CommandFunction(..), |
| 38 | + ResolveFunction, |
| 39 | + mkResolveHandler, |
| 40 | + defaultPluginDescriptor, |
| 41 | + mkPluginHandler, defaultPluginPriority) |
| 42 | +import Language.LSP.Protocol.Message (Method (..), |
| 43 | + SMethod (..)) |
| 44 | +import Language.LSP.Protocol.Types (NormalizedFilePath, Null (Null), |
| 45 | + Position (..), |
| 46 | + CodeAction(..), |
| 47 | + CompletionParams (..), |
| 48 | + CodeActionContext (..), |
| 49 | + Diagnostic(..), |
| 50 | + Range(..), |
| 51 | + CodeActionKind(..), |
| 52 | + TextEdit(..), |
| 53 | + Position(..), |
| 54 | + CodeActionParams (..), |
| 55 | + WorkspaceEdit(..), |
| 56 | + TextDocumentIdentifier (TextDocumentIdentifier), |
| 57 | + Uri, type (|?) (InL, InR), CompletionList, CompletionItem (CompletionItem)) |
| 58 | +import Prelude hiding (log, span) |
| 59 | + |
| 60 | +import Data.Typeable (Typeable) |
| 61 | +import Data.Hashable (Hashable(..)) |
| 62 | +import Control.DeepSeq (NFData (..)) |
| 63 | +import GHC.Generics (Generic(..)) |
| 64 | + |
| 65 | +import Data.ByteString qualified as BS |
| 66 | + |
| 67 | +import qualified Development.IDE.Core.Shake as Shake |
| 68 | +import Development.IDE.Graph.Internal.Types |
| 69 | +import Development.IDE.Graph.Internal.Rules |
| 70 | +import Development.IDE.Core.Tracing |
| 71 | +import Development.IDE.Types.Shake (encodeShakeValue, ShakeValue (ShakeNoCutoff)) |
| 72 | +import Development.IDE.Types.Shake (A(..)) |
| 73 | +import Development.IDE.Types.Shake (Value(..)) |
| 74 | + |
| 75 | +import Language.LSP.Server (ProgressCancellable (Cancellable), |
| 76 | + sendNotification, |
| 77 | + sendRequest, |
| 78 | + withIndefiniteProgress) |
| 79 | + |
| 80 | +import Data.Text qualified as T |
| 81 | +import Data.Map.Strict qualified as Map |
| 82 | + |
| 83 | + |
| 84 | +-- data Log |
| 85 | +-- = LogShake Shake.Log |
| 86 | +-- | LogNoAST |
| 87 | +-- | LogRequest Range |
| 88 | +-- deriving stock Show |
| 89 | + |
| 90 | +-- instance Pretty Log where |
| 91 | +-- pretty log = case log of |
| 92 | +-- LogShake shakeLog -> pretty shakeLog |
| 93 | +-- LogNoAST -> "no HieAst exist for file" |
| 94 | +-- LogRequest range -> pretty $ show range |
| 95 | +type CompleteCaseLog = String |
| 96 | + |
| 97 | + |
| 98 | +descriptor :: Recorder (WithPriority CompleteCaseLog) -> PluginId -> PluginDescriptor IdeState |
| 99 | +descriptor recorder plId = (defaultPluginDescriptor plId "Provides **case** completions") |
| 100 | + { pluginHandlers = |
| 101 | + mkPluginHandler SMethod_TextDocumentCompletion (requestCompletionHandler recorder) |
| 102 | + <> mkPluginHandler SMethod_TextDocumentCodeAction (requestResolveMissingCases recorder) |
| 103 | + <> mkResolveHandler SMethod_CompletionItemResolve (requestCompletionsResolve recorder) |
| 104 | + , pluginPriority = defaultPluginPriority |
| 105 | + } |
| 106 | + |
| 107 | +-- textCompletionCommand :: PluginId -> PluginCommand IdeState |
| 108 | +-- textCompletionCommand plId = PluginCommand "completeCase" "addCompletion" (runCompletionCommand plId) |
| 109 | + |
| 110 | +-- runCompletionCommand :: PluginId -> CommandFunction IdeState CompletionParams |
| 111 | +-- runCompletionCommand plId st mtoken CompletionParams {..} = |
| 112 | +-- let cmd = do |
| 113 | +-- throwE (PluginInternalError "woops") |
| 114 | + |
| 115 | +-- -- pure $ InR (InR Null) |
| 116 | + |
| 117 | + |
| 118 | +-- in ExceptT $ |
| 119 | +-- withIndefiniteProgress "Evaluating" mtoken Cancellable $ \_updater -> |
| 120 | +-- runExceptT $ cmd |
| 121 | + |
| 122 | + |
| 123 | +requestCompletionsResolve :: Recorder (WithPriority CompleteCaseLog) -> ResolveFunction IdeState CompletionItem 'Method_CompletionItemResolve |
| 124 | +requestCompletionsResolve recorder ide _ q@CompletionItem {..} file _ = |
| 125 | + do |
| 126 | + logWith recorder Info $ "RESOLVE!!!!!:" |
| 127 | + logWith recorder Info $ (show q) |
| 128 | + |
| 129 | + pure q |
| 130 | + |
| 131 | + |
| 132 | +requestResolveMissingCases :: Recorder (WithPriority CompleteCaseLog) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction |
| 133 | +requestResolveMissingCases recorder ide _ q@(CodeActionParams{..}) = |
| 134 | + do |
| 135 | + let has_typecheck_hole = not $ null $ filter (\diag -> T.isInfixOf "Found hole: " $ diag._message ) type_check_diags |
| 136 | + has_missing_patterns = filter (\diag -> T.isInfixOf "Pattern match" diag._message) q._context._diagnostics |
| 137 | + logWith recorder Info $ "requestResolveMissingCases:" |
| 138 | + -- logWith recorder Info $ (show q) |
| 139 | + logWith recorder Info $ "has_hole: " <> show has_typecheck_hole |
| 140 | + logWith recorder Info $ "has_missing_pats: " <> (show $ not $ null $ has_missing_patterns) |
| 141 | + -- TODO: |
| 142 | + let indentation = 2 |
| 143 | + |
| 144 | + case has_missing_patterns of |
| 145 | + [missing_diag] -> do |
| 146 | + let is_lambda_case = T.isInfixOf "\\case" missing_diag._message && not (T.isInfixOf "\\cases" missing_diag._message) |
| 147 | + is_lambda_cases = T.isInfixOf "\\case" missing_diag._message && not (T.isInfixOf "\\cases" missing_diag._message) |
| 148 | + result_start_line = missing_diag._range._end._line |
| 149 | + result_start_col = missing_diag._range._end._character + if is_lambda_case then 5 else if is_lambda_cases then 6 else 1 |
| 150 | + result_whitespace = missing_diag._range._start._character + indentation |
| 151 | + -- "Pattern match(es) are non-exhaustive\nIn a \\case alternative:\n Patterns of type \8216Maybe Config\8217 not matched:\n Nothing\n Just _" |
| 152 | + msg_lines = T.strip <$> (drop 3 $ T.lines missing_diag._message) |
| 153 | + |
| 154 | + pure |
| 155 | + $ InL [ InR |
| 156 | + CodeAction { |
| 157 | + _title = "add missing matches " |
| 158 | + , _kind = Just $ CodeActionKind_RefactorRewrite |
| 159 | + , _diagnostics = Just [missing_diag] |
| 160 | + , _disabled = Nothing |
| 161 | + , _isPreferred = Just True |
| 162 | + , _edit = Just |
| 163 | + WorkspaceEdit { |
| 164 | + _changes = Just $ Map.fromList [(uri, [ |
| 165 | + TextEdit { |
| 166 | + _range = |
| 167 | + Range { |
| 168 | + _start = Position { _line = result_start_line, _character = result_start_col } |
| 169 | + , _end = Position { _line = result_start_line, _character = result_start_col} |
| 170 | + } |
| 171 | + , _newText = "\n" <> (T.unlines $ (\x -> T.replicate (fromIntegral result_whitespace) " " <> x <> " -> _ ") <$> msg_lines) } |
| 172 | + ] ) ] |
| 173 | + , _documentChanges = Nothing |
| 174 | + , _changeAnnotations = Nothing |
| 175 | + } |
| 176 | + , _command = Nothing |
| 177 | + , _data_ = Nothing } |
| 178 | + ] |
| 179 | + _ -> pure $ InR Null |
| 180 | + |
| 181 | + |
| 182 | + where |
| 183 | + uri :: Uri |
| 184 | + TextDocumentIdentifier uri = _textDocument |
| 185 | + |
| 186 | + type_check_diags = |
| 187 | + filter (\diag -> diag._source == Just "typecheck") (q._context._diagnostics) |
| 188 | + |
| 189 | + |
| 190 | + |
| 191 | +requestCompletionHandler :: Recorder (WithPriority CompleteCaseLog) -> PluginMethodHandler IdeState 'Method_TextDocumentCompletion |
| 192 | +requestCompletionHandler recorder ide _ q@CompletionParams {..} = do |
| 193 | + do |
| 194 | + logWith recorder Info $ "requestCompletionHandler:" |
| 195 | + logWith recorder Info $ (show q) |
| 196 | + |
| 197 | + let fp :: NormalizedFilePath = undefined -- <- getNormalizedFilePathE uri |
| 198 | + |
| 199 | + mapExceptT liftIO $ runCompletions ide fp pos |
| 200 | + |
| 201 | + where |
| 202 | + uri :: Uri |
| 203 | + TextDocumentIdentifier uri = _textDocument |
| 204 | + |
| 205 | + pos = _position |
| 206 | + |
| 207 | +runCompletions :: IdeState -> NormalizedFilePath -> Position -> ExceptT PluginError IO ([CompletionItem] |? (CompletionList |? Null)) |
| 208 | +runCompletions ide file positions = |
| 209 | + pure $ InR (InR Null) |
| 210 | + |
| 211 | + |
| 212 | + |
| 213 | +-- data CaseCompletions = CaseCompletions |
| 214 | +-- deriving (Eq, Show, Typeable, Generic) |
| 215 | +-- instance Hashable CaseCompletions |
| 216 | +-- instance NFData CaseCompletions |
| 217 | + |
| 218 | + |
| 219 | +-- -- addRule |
| 220 | +-- -- :: forall key value. (RuleResult key ~ value, Typeable key, Hashable key, Eq key,Typeable value) |
| 221 | +-- -- => (key -> Maybe BS.ByteString -> RunMode -> Action (RunResult value)) |
| 222 | +-- -- -> Rules () |
| 223 | + |
| 224 | +-- produceCompletions :: Recorder (WithPriority CompleteCaseLog) -> Rules () |
| 225 | +-- produceCompletions recorder = do |
| 226 | +-- define recorder (\k file -> pure Nothing) |
| 227 | +-- -- (\CaseCompletions file -> |
| 228 | +-- -- do |
| 229 | +-- -- logWith recorder Info $ "Trying to find completions on " <> show file |
| 230 | +-- -- pure (RunResult ChangedStore (encodeShakeValue ShakeNoCutoff) $ A (Failed False) ) :: Action (Shake.IdeResult CachedCompletions)) |
| 231 | +-- where |
| 232 | +-- define :: Shake.IdeRule k v => Recorder (WithPriority CompleteCaseLog) -> (k -> NormalizedFilePath -> Action (Shake.IdeResult v)) -> Rules () |
| 233 | +-- define recorder op = defineEarlyCutOff recorder $ Shake.Rule $ \k v -> (Nothing, ) <$> op k v |
| 234 | + |
| 235 | +-- defineEarlyCutOff :: Shake.IdeRule k v => Recorder (WithPriority CompleteCaseLog) -> Shake.RuleBody k v -> Rules () |
| 236 | +-- defineEarlyCutOff recorder (Shake.Rule op) = |
| 237 | +-- addRule $ \(Shake.Q (key, file)) (old :: Maybe BS.ByteString) mode -> do |
| 238 | +-- extras <- Shake.getShakeExtras |
| 239 | +-- defineEarlyCutoff' key file mbOld mode action |
| 240 | + |
| 241 | +-- defineEarlyCutoff' ::Shake.IdeRule k v => NormalizedFilePath -> Maybe BS.ByteString -> RunMode -> (Development.IDE.Types.Shake.Value v -> Action (Maybe BS.ByteString, Shake.IdeResult v)) -> Action (RunResult (A (RuleResult k))) |
| 242 | +-- defineEarlyCutoff' = undefined |
0 commit comments