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
115 snippetCompletion :: Text -> Text -> CompletionItem
116 snippetCompletion label snippet = (defaultCompletion label) {_kind = pure CompletionItemKind_Snippet, _insertText = pure snippet, _insertTextFormat = pure T.InsertTextFormat_Snippet}
117
118 defaultCompletion :: Text -> CompletionItem
119 defaultCompletion n =
120 CompletionItem
121 n
122 Nothing
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
141 --
142 missingToSuggestion :: [(Text, SymbolTableValue)] -> [Lexeme] -> [CompletionItem]
143 missingToSuggestion table (x : _) = makeMissingTokenHint x
144 where
145 makeMissingTokenHint (L_Missing s) = case s of
146 MissingExpression -> makeExpressionSuggestions table
147 MissingDomain -> makeDomainSuggestions table
148 MissingUnknown -> []
149 makeMissingTokenHint LMissingIdentifier = freeIdentifierSuggestion table
150 makeMissingTokenHint l = [defaultCompletion $ lexemeText l]
151 missingToSuggestion table _ = makeSuggestionsFromSymbolTable table
152
153 keywordCompletions :: [CompletionItem]
154 keywordCompletions = []
155
156 getLowestLevelTaggedRegion :: SourcePos -> HLTree -> Maybe TreeItemLinks
157 getLowestLevelTaggedRegion p tr =
158 let regs = filterContaining p tr
159 in case [t | HLTagged t _ <- regs, t /= TIGeneral] of
160 [] -> Nothing
161 ins -> Just $ last ins
162
163 topLevelSuggestions :: [CompletionItem]
164 topLevelSuggestions =
165 uncurry snippetCompletion
166 <$> [ ("find", "find $1 : $2"),
167 ("given", "such that $0"),
168 ("such that", "given $1 : $2")
169 ]
170
171 freeIdentifierSuggestion :: a -> [CompletionItem]
172 freeIdentifierSuggestion _ = [defaultCompletion "identifier"]