never executed always true always false
1 module Conjure.LSP.Handlers.Suggestions (suggestionHandler) where
2
3 import Conjure.LSP.Util (ProcessedFile (ProcessedFile), getNextTokenStart, getRelevantRegions, positionToSourcePos, sourcePosToPosition, withProcessedDoc)
4 import Conjure.Language (Type (..))
5 import Conjure.Language.AST.Reformer
6 -- (Class (..), Kind (..), RegionInfo (..), ValidatorState (regionInfo), RegionType (..), StructuralType (..),symbolTable)
7
8 import Conjure.Language.AST.Syntax (LToken (MissingToken))
9 import Conjure.Language.Lexemes
10 import Conjure.Language.Lexer
11 import Conjure.Language.Pretty (prettyT)
12 import Conjure.Language.Validator
13 import Conjure.Prelude
14 import Control.Lens
15 import Data.Map.Strict qualified as Map
16 import Language.LSP.Protocol.Lens (HasParams (..), HasPosition (position), HasTextDocument (textDocument))
17 import Language.LSP.Protocol.Message
18 import Language.LSP.Protocol.Types (CompletionItem (..), CompletionItemKind (..), type (|?) (..))
19 import Language.LSP.Protocol.Types qualified as T
20 import Language.LSP.Server (Handlers, LspM, requestHandler)
21 import Text.Megaparsec (SourcePos)
22
23 suggestionHandler :: Handlers (LspM ())
24 suggestionHandler = requestHandler SMethod_TextDocumentCompletion $ \req res -> do
25 let ps = req ^. params . textDocument
26 let context = req ^. params . position
27 withProcessedDoc ps $ \(ProcessedFile _ diags valState pt) -> do
28 let nextTStart = getNextTokenStart context pt
29 let roi = getRelevantRegions valState nextTStart
30 let innermostSymbolTable = if null roi then [] else Map.toList . rTable $ last roi
31 let errors = [(r, d) | (ValidatorDiagnostic r (Error (TokenError d))) <- diags]
32 let contextTokens = take 1 [lexeme w | (r, MissingToken w) <- errors, isInRange nextTStart r]
33 let missingTokenBasedHint = missingToSuggestion innermostSymbolTable contextTokens
34 -- sendInfoMessage $ pack . show $ context
35 let tlSymbol = getLowestLevelTaggedRegion (positionToSourcePos context) $ makeTree pt
36 let tlSymbolSuggestion = case tlSymbol of
37 Just (TIDomain _) -> makeDomainSuggestions innermostSymbolTable
38 Just (TIExpression _) -> makeExpressionSuggestions innermostSymbolTable
39 Just (TIList t) -> makeTagSuggestions innermostSymbolTable t
40 _ -> [] -- or for debugging -> [defaultCompletion $ pack . show $ tlSymbol]
41 res
42 $ Right
43 $ InL
44 . nubBy isSameInsertion
45 $ concat
46 [ missingTokenBasedHint,
47 tlSymbolSuggestion,
48 keywordCompletions
49 ]
50
51 isSameInsertion :: CompletionItem -> CompletionItem -> Bool
52 isSameInsertion CompletionItem {_label = a} CompletionItem {_label = b} = a == b
53
54 isInRange :: T.Position -> DiagnosticRegion -> Bool
55 isInRange p reg = sourcePosToPosition (drSourcePos reg) == p
56
57 makeSuggestionsFromSymbolTable :: [(Text, SymbolTableValue)] -> [CompletionItem]
58 makeSuggestionsFromSymbolTable = map symbolToHint
59
60 makeDomainSuggestions :: [(Text, SymbolTableValue)] -> [CompletionItem]
61 makeDomainSuggestions table = stDomains ++ newDomainPlaceholders
62 where
63 stDomains = map symbolToHint $ [x | x@(_, (_, _, Kind DomainType t)) <- table, typesUnifyS [t, TypeAny]]
64 newDomainPlaceholders =
65 uncurry snippetCompletion
66 <$> [ ("int", "int"),
67 ("int", "bool"),
68 ("matrix", "matrix indexed by ${1:[index_domains]} of ${2:type}"),
69 ("set", "set of $1"),
70 ("mset", "mset of $1")
71 ]
72
73 makeExpressionSuggestions :: [(Text, SymbolTableValue)] -> [CompletionItem]
74 makeExpressionSuggestions table = stExprs ++ newExpressionPlaceholders
75 where
76 stExprs = map symbolToHint $ [x | x@(_, (_, _, Kind ValueType {} t)) <- table, typesUnifyS [t, TypeAny]]
77 newExpressionPlaceholders = []
78
79 makeTagSuggestions :: [(Text, SymbolTableValue)] -> ListItemClasses -> [CompletionItem]
80 makeTagSuggestions table tag = case tag of
81 ICAttribute -> defaultCompletion <$> ["size"]
82 ICExpression -> makeExpressionSuggestions table
83 ICDomain -> makeDomainSuggestions table
84 ICRange -> uncurry snippetCompletion <$> [("openL", "..$1"), ("closed", "$1..$2"), ("openR", "$1..")]
85 ICIdentifier -> freeIdentifierSuggestion table
86 ICStatement -> topLevelSuggestions
87
88 symbolToHint :: (Text, SymbolTableValue) -> CompletionItem
89 symbolToHint (name, (_, _, k)) =
90 let typeName = prettyT k
91 in (defaultCompletion name) {_detail = Just typeName, _kind = pure $ getCIKind k}
92
93 getCIKind :: Kind -> CompletionItemKind
94 getCIKind (Kind DomainType _) = CompletionItemKind_Class
95 getCIKind (Kind ValueType {} t) = case t of
96 TypeAny -> CompletionItemKind_Variable
97 TypeBool -> CompletionItemKind_Variable
98 TypeInt _ -> CompletionItemKind_Variable
99 TypeEnum _ -> CompletionItemKind_Enum
100 TypeUnnamed _ -> CompletionItemKind_Variable
101 TypeTuple _ -> CompletionItemKind_Variable
102 TypeRecord _ -> CompletionItemKind_Variable
103 TypeRecordMember _ _ -> CompletionItemKind_EnumMember
104 TypeVariant _ -> CompletionItemKind_Variable
105 TypeVariantMember _ _ -> CompletionItemKind_EnumMember
106 TypeList _ -> CompletionItemKind_Variable
107 TypeMatrix _ _ -> CompletionItemKind_Variable
108 TypeSet _ -> CompletionItemKind_Variable
109 TypeMSet _ -> CompletionItemKind_Variable
110 TypeFunction _ _ -> CompletionItemKind_Variable
111 TypeSequence _ -> CompletionItemKind_Variable
112 TypeRelation _ -> CompletionItemKind_Variable
113 TypePartition _ -> CompletionItemKind_Variable
114 TypePermutation{} -> CompletionItemKind_Variable
115
116 snippetCompletion :: Text -> Text -> CompletionItem
117 snippetCompletion label snippet = (defaultCompletion label) {_kind = pure CompletionItemKind_Snippet, _insertText = pure snippet, _insertTextFormat = pure T.InsertTextFormat_Snippet}
118
119 defaultCompletion :: Text -> CompletionItem
120 defaultCompletion n =
121 CompletionItem
122 n
123 Nothing
124 Nothing
125 Nothing
126 Nothing
127 Nothing
128 Nothing
129 Nothing
130 Nothing
131 Nothing
132 Nothing
133 Nothing
134 Nothing
135 Nothing
136 Nothing
137 Nothing
138 Nothing
139 Nothing
140 Nothing
141
142 --
143 missingToSuggestion :: [(Text, SymbolTableValue)] -> [Lexeme] -> [CompletionItem]
144 missingToSuggestion table (x : _) = makeMissingTokenHint x
145 where
146 makeMissingTokenHint (L_Missing s) = case s of
147 MissingExpression -> makeExpressionSuggestions table
148 MissingDomain -> makeDomainSuggestions table
149 MissingUnknown -> []
150 makeMissingTokenHint LMissingIdentifier = freeIdentifierSuggestion table
151 makeMissingTokenHint l = [defaultCompletion $ lexemeText l]
152 missingToSuggestion table _ = makeSuggestionsFromSymbolTable table
153
154 keywordCompletions :: [CompletionItem]
155 keywordCompletions = []
156
157 getLowestLevelTaggedRegion :: SourcePos -> HLTree -> Maybe TreeItemLinks
158 getLowestLevelTaggedRegion p tr =
159 let regs = filterContaining p tr
160 in case [t | HLTagged t _ <- regs, t /= TIGeneral] of
161 [] -> Nothing
162 ins -> Just $ last ins
163
164 topLevelSuggestions :: [CompletionItem]
165 topLevelSuggestions =
166 uncurry snippetCompletion
167 <$> [ ("find", "find $1 : $2"),
168 ("given", "such that $0"),
169 ("such that", "given $1 : $2")
170 ]
171
172 freeIdentifierSuggestion :: a -> [CompletionItem]
173 freeIdentifierSuggestion _ = [defaultCompletion "identifier"]