never executed always true always false
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module Conjure.LSP.Util where
4
5 import Conjure.Language
6 import Conjure.Language.AST.ASTParser (parseProgram)
7 import Conjure.Language.AST.Reformer
8 import Conjure.Language.AST.Syntax (ProgramTree)
9 import Conjure.Language.Lexer
10 import Conjure.Language.Parser (PipelineError (..), lexAndParse)
11 import Conjure.Language.Validator (DiagnosticRegion (..), RegionInfo (..), ValidatorDiagnostic, ValidatorState (ValidatorState, regionInfo), initialState, runValidator, validateModel)
12 import Conjure.Language.Validator qualified as V (Diagnostic (..), ValidatorDiagnostic (..))
13 import Conjure.Prelude
14 import Conjure.UI.ErrorDisplay (displayError, displayWarning)
15 import Control.Lens ((^.))
16 import Data.Foldable (find)
17 import Data.Sequence qualified as Seq
18 import Data.Text (pack)
19 import Language.LSP.Protocol.Lens (HasUri (uri))
20 import Language.LSP.Protocol.Types as L
21 import Language.LSP.Server
22 import Language.LSP.VFS (VirtualFile, virtualFileText)
23 import Text.Megaparsec (SourcePos (..), mkPos, unPos)
24 import Language.LSP.Protocol.Message
25
26 data ProcessedFile = ProcessedFile
27 { model :: Model,
28 diagnostics :: [ValidatorDiagnostic],
29 state :: ValidatorState,
30 parseTree :: ProgramTree
31 }
32
33 processFile :: Text -> Either PipelineError ProcessedFile
34 processFile t = do
35 parsed <- lexAndParse parseProgram t
36 let (m, d, s) = runValidator (validateModel parsed) (initialState parsed Nothing) -- TODO: wire up
37 return $ ProcessedFile m d s parsed
38
39 getErrorsForURI :: NormalizedUri -> LspM () (Either Text ProcessedFile)
40 getErrorsForURI furi = do
41 r <- getVirtualFile furi
42 let f = maybe "" virtualFileText r
43 getErrorsFromText f
44
45 getErrorsFromText :: Text -> LspM () (Either Text ProcessedFile)
46 getErrorsFromText t = return $ either (Left . pack . show) Right $ processFile t
47
48 getDiagnostics :: ProcessedFile -> [Diagnostic]
49 getDiagnostics (ProcessedFile {diagnostics = ds}) = mapMaybe valErrToDiagnostic ds
50
51 valErrToDiagnostic :: V.ValidatorDiagnostic -> Maybe Diagnostic
52 valErrToDiagnostic (V.ValidatorDiagnostic region message) = do
53 let range = getRangeFromRegion region
54 let (severity, msg) = getDiagnosticDetails message
55 Just $ Diagnostic range (Just severity) Nothing Nothing Nothing msg Nothing Nothing Nothing
56
57 getRangeFromRegion :: DiagnosticRegion -> L.Range
58 getRangeFromRegion (DiagnosticRegion {drSourcePos = (SourcePos _ r c), drLength = l}) =
59 let row = unPos r
60 col = unPos c
61 in Range (fixPosition row col) (fixPosition row (col + max 1 l))
62
63 getDiagnosticDetails :: V.Diagnostic -> (DiagnosticSeverity, Text)
64 getDiagnosticDetails x = case x of
65 V.Error et -> (DiagnosticSeverity_Error, pack $ displayError et)
66 V.Warning wt -> (DiagnosticSeverity_Warning, pack $ displayWarning wt)
67 V.Info it -> (DiagnosticSeverity_Hint, pack $ show it)
68
69 sendInfoMessage :: Text -> LspM () ()
70 sendInfoMessage t = sendNotification SMethod_WindowShowMessage (ShowMessageParams MessageType_Info t)
71
72 sendErrorMessage :: Text -> LspM () ()
73 sendErrorMessage t = sendNotification SMethod_WindowShowMessage (ShowMessageParams MessageType_Error t)
74
75 -- 0 index rows and cols as well as type coercion
76 fixPosition :: (Integral a) => a -> a -> Position
77 fixPosition r c = Position (fromIntegral r - 1) (fromIntegral c - 1)
78
79 withFile :: (HasUri a Uri, Show a) => a -> (VirtualFile -> LspM () n) -> LspM () ()
80 withFile fp f = do
81 let td = fp ^. uri
82 let doc = toNormalizedUri td
83 mdoc <- getVirtualFile doc
84 case mdoc of
85 Just vf -> void $ f vf
86 _ -> sendErrorMessage (pack . show $ "No virtual file found for: " <> pretty (show fp))
87
88 getProcessedDoc :: (HasUri a Uri, Show a) => a -> LspM () (Maybe ProcessedFile)
89 getProcessedDoc d = do
90 let td = d ^. uri
91 let doc = toNormalizedUri td
92 mdoc <- getVirtualFile doc
93 case mdoc of
94 Just vf -> do
95 case processFile $ virtualFileText vf of
96 Left msg -> sendErrorMessage (pack $ show msg) >> return Nothing
97 Right file -> return . pure $ file
98 _ -> Nothing <$ sendErrorMessage (pack . show $ "No virtual file found for: " <> stringToDoc (show d))
99
100 withProcessedDoc :: (HasUri a Uri, Show a) => a -> (ProcessedFile -> LspM () n) -> LspM () ()
101 withProcessedDoc d f = do
102 a <- getProcessedDoc d
103 case a of
104 Nothing -> return ()
105 Just pf -> void $ f pf
106
107 getRelevantRegions :: ValidatorState -> Position -> [RegionInfo]
108 getRelevantRegions (ValidatorState {regionInfo = info}) pos = sortOn rRegion $ concatMap filteredFlatten info
109 where
110 p :: RegionInfo -> Bool
111 p (RegionInfo {rRegion = reg}) = case reg of
112 DiagnosticRegion sp sp' _ _ ->
113 sourcePosToPosition sp
114 <= pos
115 && sourcePosToPosition sp'
116 >= pos
117 filteredFlatten :: RegionInfo -> [RegionInfo]
118 filteredFlatten r@RegionInfo {rChildren = c} | p r = r : concatMap filteredFlatten c
119 filteredFlatten _ = []
120
121 sourcePosToPosition :: SourcePos -> Position
122 sourcePosToPosition (SourcePos _ r c) =
123 Position
124 (fromInteger $ -1 + toInteger (unPos r))
125 (fromInteger $ -1 + toInteger (unPos c))
126
127 positionToSourcePos :: Position -> SourcePos
128 positionToSourcePos (Position r c) =
129 SourcePos
130 ""
131 (mkPos ri)
132 (mkPos ci)
133 where
134 ri = fromIntegral r + 1
135 ci = fromIntegral c + 1
136
137 regionToRange :: DiagnosticRegion -> L.Range
138 regionToRange (DiagnosticRegion sp ep _ _) = L.Range (sourcePosToPosition sp) (sourcePosToPosition ep)
139
140 regionToLocation :: DiagnosticRegion -> L.Location
141 regionToLocation reg@(DiagnosticRegion (SourcePos f _ _) _ _ _) =
142 L.Location
143 (filePathToUri f)
144 (regionToRange reg)
145
146 snippet :: Text -> MarkupContent
147 snippet = mkMarkdownCodeBlock "essence"
148
149 prettyPos :: Position -> Doc
150 prettyPos (Position (pretty . show -> r) (pretty . show -> c)) = r <> ":" <> c
151
152 getNextTokenStart :: Position -> ProgramTree -> Position
153 getNextTokenStart ref tree =
154 let toks = flatten tree
155 tokSp = map (sourcePosToPosition . oSourcePos . offsets) (toList toks)
156 in fromMaybe posInf $ find (ref <=) tokSp
157
158 posInf :: Position
159 posInf = Position (negate 1) (negate 1)
160
161 tokensAtPosition :: Position -> Seq.Seq ETok -> [ETok]
162 tokensAtPosition p s = maybeToList (find (posAfter p) s)
163 where
164 posAfter q t = q < sourcePosToPosition (oSourcePos $ offsets t)