ParserGeneric.fs 18 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389
  1. module Qsp.Parser.Generic
  2. open FParsec
  3. open FsharpMyExtension
  4. open FsharpMyExtension.Either
  5. open Qsp
  6. let runEither p str =
  7. match run p str with
  8. | Success(x, _, _) -> Right x
  9. | Failure(x, _, _) -> Left x
  10. let runStateEither p st str =
  11. match runParserOnString p st "" str with
  12. | Success(x, st, _) -> st, Right(x)
  13. | Failure(x, _, st) -> st, Left(x)
  14. let isIdentifierChar c = isLetter c || isDigit c || c = '_' || c = '.'
  15. let ident<'UserState> =
  16. skipChar '_' >>? many1Satisfy isIdentifierChar
  17. |>> fun ident -> "_" + ident
  18. <|> many1Satisfy2L isLetter isIdentifierChar "identifier"
  19. : Parser<_, 'UserState>
  20. let ws<'UserState> =
  21. skipManySatisfy (fun c -> System.Char.IsWhiteSpace c && c <> '\n')
  22. : Parser<_, 'UserState>
  23. let ws1<'UserState> =
  24. skipMany1SatisfyL (fun c -> System.Char.IsWhiteSpace c && c <> '\n') "any white space except '\\n'"
  25. : Parser<_, 'UserState>
  26. let char_ws c = pchar c .>> ws
  27. let bet opened closed = between <| char_ws opened <| pchar closed
  28. let bet_ws opened closed p = bet opened closed p .>> ws
  29. let optList p = p <|>% []
  30. let nl<'UserState> = skipMany1 newline : Parser<unit, 'UserState>
  31. let stringLiteral<'UserState> =
  32. let normalChar c = satisfy (fun c' -> c' <> c)
  33. let p c = manyChars (normalChar c <|> attempt(pchar c >>. pchar c))
  34. let bet openedChar closedChar = between (pchar openedChar) (pchar closedChar)
  35. bet '"' '"' (p '"')
  36. <|> bet '\'' '\'' (p '\'')
  37. <|> bet '{' '}' (p '}') // TODO: забавно: проверил компилятор, и тот напрочь не воспринимает экранирование `}}`
  38. : Parser<_, 'UserState>
  39. /// Дело в том, что названия переменных могут начинаться с ключевых слов ("**if**SomethingTrue", например), а значит, чтобы это пресечь, можно воспользоваться именно этой функцией так:
  40. /// ```fsharp
  41. /// pstring "if" .>>? notFollowedVar
  42. /// ```
  43. let notFollowedVarCont<'UserState> =
  44. notFollowedBy (satisfy isIdentifierChar)
  45. : Parser<_, 'UserState>
  46. /// A document highlight kind.
  47. [<RequireQualifiedAccess>]
  48. type DocumentHighlightKind =
  49. /// A textual occurrence.
  50. | Text = 1
  51. /// Read-access of a symbol, like reading a variable.
  52. | Read = 2
  53. /// Write-access of a symbol, like writing to a variable.
  54. | Write = 3
  55. type VarHighlightKind =
  56. | ReadAccess
  57. | WriteAccess
  58. // type Var =
  59. type VarHighlights =
  60. {
  61. Ma: Map<Ast.Var, (Tokens.InlineRange * VarHighlightKind) list>
  62. Ranges: (Tokens.InlineRange * Ast.Var) list
  63. }
  64. let varHighlightsEmpty =
  65. {
  66. Ma = Map.empty
  67. Ranges = []
  68. }
  69. type LocHighlights =
  70. {
  71. Ma: Map<Ast.LocationName, (Tokens.InlineRange * VarHighlightKind) list>
  72. Ranges: (Tokens.InlineRange * Ast.LocationName) list
  73. }
  74. let locHighlightsEmpty =
  75. {
  76. Ma = Map.empty
  77. Ranges = []
  78. }
  79. type Highlights =
  80. {
  81. VarHighlights: VarHighlights
  82. LocHighlights: LocHighlights
  83. }
  84. let highlightsEmpty =
  85. {
  86. VarHighlights = varHighlightsEmpty
  87. LocHighlights = locHighlightsEmpty
  88. }
  89. type 'a Parser = Parser<'a, State>
  90. and State =
  91. {
  92. Tokens: Tokens.Token list
  93. /// Здесь ошибки только те, что могут определиться во время поверхностного семантического разбора, то есть это то, что не нуждается в нескольких проходах. Например, можно определить, что в коде пытаются переопределить встроенную функцию, и это будет ошибкой.
  94. ///
  95. /// А если хочется понять, что инструкция `gt 'some loc'` верна, то придется пройтись дважды, чтобы определить, существует ли вообще `'some loc'`. Если бы локации определялись последовательно, то есть нельзя было бы обратиться к той, что — ниже, тогда потребовался только один проход. Но в таком случае придется вводить что-то вроде `rec`, чтобы перейти на локацию, определенную ниже. Но всё это возвращает к той же задаче, потому ну его.
  96. SemanticErrors: (Tokens.InlineRange * string) list
  97. /// Информация обо всём и вся
  98. Hovers: (Tokens.InlineRange * string) list
  99. Highlights: Highlights
  100. /// Нужен для `elseif` конструкции. Эх, если бы ее можно было как-то именно там оставить, но увы.
  101. IsEndOptional : bool
  102. LastSymbolPos : FParsec.Position
  103. /// Локации, которые неопределенны именно в этом документе, но переходы к ним есть
  104. NotDefinedLocs: Map<Ast.LocationName, Tokens.InlineRange list>
  105. // Я тут, это самое, оставлю. Никто не возражает?
  106. PStmts: Parser<Ast.Statement list>
  107. /// `&lt;a gt ''x''>`
  108. SingleQuotNestedCount: int
  109. DoubleQuotNestedCount: int
  110. HtmlAttDoubleNested: int
  111. }
  112. let emptyState =
  113. {
  114. Tokens = []
  115. SemanticErrors = []
  116. Hovers = []
  117. IsEndOptional = false
  118. LastSymbolPos = FParsec.Position("", 0L, 1L, 1L)
  119. Highlights = highlightsEmpty
  120. NotDefinedLocs = Map.empty
  121. PStmts = FParsec.Primitives.failFatally "PStmts not implemented"
  122. SingleQuotNestedCount = 0
  123. DoubleQuotNestedCount = 0
  124. HtmlAttDoubleNested = 0
  125. }
  126. let pGetDefLocPos locName =
  127. getUserState
  128. |>> fun st ->
  129. match Map.tryFind locName st.Highlights.LocHighlights.Ma with
  130. | None ->
  131. None
  132. | Some(value) ->
  133. value
  134. |> List.tryPick (fun (r, kind) ->
  135. match kind with
  136. | WriteAccess -> Some r
  137. | _ -> None
  138. )
  139. let appendVarHighlight (r:Tokens.InlineRange) (var:Ast.Var) highlightKind =
  140. let var = mapSnd String.toLower var // for case-insensitively
  141. updateUserState (fun st ->
  142. { st with
  143. Highlights =
  144. {
  145. st.Highlights with
  146. VarHighlights =
  147. {
  148. Ranges = (r, var)::st.Highlights.VarHighlights.Ranges
  149. Ma =
  150. let v = r, highlightKind
  151. st.Highlights.VarHighlights.Ma
  152. |> Map.addOrMod var [v] (fun xs -> v::xs)
  153. }
  154. }
  155. }
  156. )
  157. let appendLocHighlight (r:Tokens.InlineRange) (loc:string) highlightKind =
  158. let loc = String.toLower loc // без шуток, они тоже case-insensitively, хотя и представляют из себя string
  159. updateUserState (fun st ->
  160. { st with
  161. Highlights =
  162. {
  163. st.Highlights with
  164. LocHighlights =
  165. {
  166. Ranges = (r, loc)::st.Highlights.LocHighlights.Ranges
  167. Ma =
  168. let v = r, highlightKind
  169. st.Highlights.LocHighlights.Ma
  170. |> Map.addOrMod loc [v] (fun xs -> v::xs)
  171. }
  172. }
  173. }
  174. )
  175. let appendToken2 tokenType r =
  176. updateUserState (fun st ->
  177. let token =
  178. { Tokens.TokenType = tokenType
  179. Tokens.Range = r }
  180. { st with Tokens = token :: st.Tokens }
  181. )
  182. let toRange (p1:FParsec.Position) (p2:FParsec.Position) =
  183. {
  184. Tokens.InlineRange.Line = p1.Line // Должно выполняться условие `p1.Line = p2.Line`
  185. Tokens.InlineRange.Column1 = p1.Column
  186. Tokens.InlineRange.Column2 = p2.Column // Должно выполняться условие `p2.Column > p1.Column`
  187. }
  188. let appendToken tokenType p =
  189. getPosition .>>.? p .>>. getPosition
  190. >>= fun ((p1, p), p2) ->
  191. let r = toRange p1 p2
  192. appendToken2 tokenType r
  193. >>. preturn p
  194. let applyRange p =
  195. getPosition .>>.? p .>>. getPosition
  196. >>= fun ((p1, p), p2) ->
  197. let range = toRange p1 p2
  198. preturn (range, p)
  199. let appendHover2 msg range =
  200. updateUserState (fun st ->
  201. { st with Hovers = (range, msg) :: st.Hovers }
  202. )
  203. let appendSemanticError range msg =
  204. updateUserState (fun st ->
  205. { st with SemanticErrors =
  206. (range, msg) :: st.SemanticErrors })
  207. let appendHover msg p =
  208. (getPosition .>>.? p .>>. getPosition)
  209. >>= fun ((p1, p), p2) ->
  210. let r = toRange p1 p2
  211. appendHover2 msg r
  212. >>. preturn p
  213. let appendTokenHover tokenType msg p =
  214. (getPosition .>>.? p .>>. getPosition)
  215. >>= fun ((p1, p), p2) ->
  216. let r = toRange p1 p2
  217. appendToken2 tokenType r
  218. >>. appendHover2 msg r
  219. >>. preturn p
  220. let pSingleNested =
  221. updateUserState (fun st ->
  222. { st with
  223. SingleQuotNestedCount = st.SingleQuotNestedCount + 1
  224. })
  225. let pSingleUnnested =
  226. updateUserState (fun st ->
  227. { st with
  228. SingleQuotNestedCount = st.SingleQuotNestedCount - 1
  229. })
  230. let pGetSingleNested =
  231. getUserState |>> fun x -> x.SingleQuotNestedCount
  232. let pDoubleNested =
  233. updateUserState (fun st ->
  234. { st with
  235. DoubleQuotNestedCount = st.DoubleQuotNestedCount + 1
  236. })
  237. let pDoubleUnnested =
  238. updateUserState (fun st ->
  239. { st with
  240. DoubleQuotNestedCount = st.DoubleQuotNestedCount - 1
  241. })
  242. let pGetDoubleNested =
  243. getUserState |>> fun x -> x.DoubleQuotNestedCount
  244. let pHtmlAttDoubleNested =
  245. updateUserState (fun st ->
  246. { st with
  247. HtmlAttDoubleNested = st.HtmlAttDoubleNested + 1
  248. })
  249. let pHtmlAttDoubleUnnested =
  250. updateUserState (fun st ->
  251. { st with
  252. HtmlAttDoubleNested = st.HtmlAttDoubleNested - 1
  253. })
  254. let pGetHtmlAttDoubleNested =
  255. getUserState |>> fun x -> x.HtmlAttDoubleNested
  256. open Tokens
  257. let charsReplicate n (c:char) =
  258. System.String.Concat (Array.replicate n c)
  259. // Это такой фокус, чтобы напрочь во всем запутаться. А кто говорил, что это чисто функциональное программирование? Ну-ну.
  260. let pstmts : _ Parser =
  261. getUserState >>= fun st -> st.PStmts
  262. let stringLiteralWithToken pexpr : _ Parser =
  263. let bet tokenType openedChar closedChar pnested punnested pgetNested =
  264. let p nestedCount =
  265. many1Satisfy (fun c' -> not (c' = closedChar || c' = '\n' || c' = '<'))
  266. <|> (pstring (charsReplicate (pown 2 nestedCount) closedChar) // 1 2, 2 4
  267. >>% string closedChar)
  268. <|> (skipChar '<' >>? notFollowedBy (skipChar '<' <|> skipChar 'a' <|> skipString "/a>") >>% "<")
  269. let pattValBody nestedCount closedCharAtt =
  270. many1Satisfy (fun c' -> not (c' = closedChar || c' = '\n' || c' = '&' || c' = closedCharAtt))
  271. <|> (pstring (charsReplicate (pown 2 nestedCount) closedChar)
  272. >>% string closedChar)
  273. <|> (pchar '&'
  274. >>. ((pstring "quot" >>% "\"" <|> pstring "apos" >>% "'") .>> pchar ';'
  275. <|>% "&") )
  276. // <|> (skipChar '<' >>? notFollowedBy (skipChar '<' <|> skipChar 'a' <|> skipString "/a>") >>% "<")
  277. let plineKind nestedCount =
  278. let plineKind, plineKindRef = createParserForwardedToRef()
  279. let plineKinds =
  280. pipe2
  281. (many plineKind)
  282. (many
  283. (newline >>. many plineKind))
  284. (fun x xs -> x::xs)
  285. let pATag =
  286. // А вот здесь вообще начинается прелюбопытная штука:
  287. // 1. Все `"` экранируются в `&quot;`, а сам `&` — в `&amp;`
  288. // 2. Если нужно еще вложить, то используется `&quot;&quot;`
  289. pstring "<a href=\"exec:"
  290. >>. (attempt // TODO: Если в значении аттрибута нету подстановки, тогда нужно пытататься разобрать его статически. К черту производительность, главное, понятность
  291. (pHtmlAttDoubleNested
  292. >>. spaces >>. notEmpty pstmts
  293. .>> pHtmlAttDoubleUnnested
  294. |>> Ast.StaticStmts)
  295. <|> (appendToken tokenType (many1Strings (pattValBody nestedCount '"')) // TODO: здесь можно и нужно отобразить подстановки.
  296. |>> Ast.Raw))
  297. .>> pchar '"' .>> spaces .>> pchar '>' // что ж, не всё так просто. Дело в том, что во вложенном `pstmts` все `stringLiteral` заместо привычных `"` и `'` использует либо `&quot;` и `''`, либо `&apos;`. Да еще и `&` экранирует в `&amp;`. И всё это кучу раз вкладывается и перевкладывается. Честно сказать, голова пухнет от всех этих страстей. А еще на `if` жаловался, ну-ну.
  298. .>>. plineKinds .>> pstring "</a>" // вот надо были тебе эти дурацкие вложения? Еще скажи, что хотел полноценный HTML-parser сделать. Ой, точно, хочет! Ха-ха.
  299. |>> fun (stmts, line) -> Ast.HyperLinkKind(stmts, line) // Вот смотрю я на эти былины и диву даюсь, право слово. Это ж надо было до такого додуматься. Метаметамета...программирование какое-то
  300. plineKindRef :=
  301. appendToken tokenType (many1Strings (p nestedCount)) |>> Ast.StringKind
  302. <|> (appendToken TokenType.InterpolationBegin (pstring "<<")
  303. >>. (ws >>. pexpr |>> Ast.ExprKind) // это может *немного* запутать, но, эм, но есть какое-то "но", да... Никакого "но" нету — код безнадежно запутанный 😭. Так, здесь экранизация — внутри экранизации, поэтому порождает в два раза больше открывающих скобок. Я сделал всего два уровня и наивно надеюсь, что этого хватит. То есть сейчас он обрабатывает вот эту зверюгу: `'<<''<<''''x''''>>''>>'`. Страшно, правда? Но что-то мне подсказывает, что это так не работает. Проверил, работает, что еще больше ужасает. И `'<<''<<''''<<''''''''это чудовище''''''''>>''''>>''>>'` работает...
  304. .>> ws .>> appendToken TokenType.InterpolationEnd (pstring ">>"))
  305. <|> attempt pATag // TODO: тут бы предупреждение какое-нибудь не помешало: мол, не осилил
  306. plineKind <|> (pchar '<' >>% Ast.StringKind "<")
  307. pgetNested >>=? fun nestedCount ->
  308. let pOpened = pstring (charsReplicate (pown 2 nestedCount) openedChar)
  309. let pClosed = pstring (charsReplicate (pown 2 nestedCount) closedChar)
  310. let plineKind = plineKind (nestedCount + 1)
  311. appendToken tokenType (pOpened .>> pnested)
  312. >>. pipe2
  313. (many plineKind)
  314. (many
  315. (newline >>. many plineKind)
  316. .>> punnested
  317. .>> appendToken tokenType pClosed) // TODO: Здесь самое то использовать `PunctuationDefinitionStringEnd`
  318. (fun x xs -> (x:Ast.Line)::xs)
  319. bet TokenType.StringQuotedSingle '\'' '\'' pSingleNested pSingleUnnested pGetSingleNested
  320. <|> (pGetHtmlAttDoubleNested >>=? fun x ->
  321. if x > 0 then
  322. fail "not implemented HtmlAttDoubleNested"
  323. else
  324. bet TokenType.StringQuotedDouble '"' '"' pDoubleNested pDoubleUnnested pGetDoubleNested)
  325. let pbraces tokenType : _ Parser =
  326. let pbraces, pbracesRef = createParserForwardedToRef()
  327. let p = many1Satisfy (isNoneOf "{}\n")
  328. pbracesRef :=
  329. pipe2
  330. (appendToken tokenType
  331. (many1Satisfy2 ((=) '{') (isNoneOf "{}\n")) )
  332. (many
  333. (appendToken tokenType (many1Strings p)
  334. <|> newlineReturn "\n"
  335. <|> pbraces
  336. )
  337. .>>. appendToken tokenType (pchar '}'))
  338. (fun x (xs, closedChar) ->
  339. seq {
  340. yield x
  341. yield! xs
  342. yield string closedChar
  343. }
  344. |> System.String.Concat
  345. )
  346. pipe2
  347. (appendToken tokenType
  348. (pchar '{' >>. manyStrings p)
  349. .>>. opt (newlineReturn "\n"))
  350. (many
  351. (appendToken tokenType (many1Strings p)
  352. <|> newlineReturn "\n"
  353. <|> pbraces
  354. )
  355. .>> appendToken tokenType (pchar '}')) // TODO: Здесь самое то использовать `PunctuationDefinitionStringEnd`
  356. (fun (x, nl) xs ->
  357. match nl with
  358. | None ->
  359. x::xs |> System.String.Concat
  360. | Some nl ->
  361. x::nl::xs |> System.String.Concat)