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