Parsec.fs 19 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457
  1. module Qsp.Parser.Main
  2. open FParsec
  3. open FsharpMyExtension
  4. open FsharpMyExtension.Either
  5. open Qsp
  6. open Qsp.Ast
  7. open Qsp.Parser.Generic
  8. open Qsp.Parser.Expr
  9. let ppunctuationTerminator : _ Parser =
  10. appendToken Tokens.TokenType.PunctuationTerminatorStatement (pchar '&')
  11. let pImplicitVarWhenAssign p =
  12. applyRange p
  13. >>= fun (range, (name:string)) ->
  14. let nameLower = name.ToLower()
  15. Defines.vars
  16. |> Map.tryFind nameLower
  17. |> function
  18. | Some dscr ->
  19. appendHover2 dscr range
  20. | None ->
  21. if Map.containsKey nameLower Defines.procs then
  22. appendSemanticError range "Нельзя переопределять процедуру"
  23. elif Map.containsKey nameLower Defines.functions then
  24. appendSemanticError range "Нельзя переопределять функцию"
  25. else
  26. let dscr = "Пользовательская глобальная переменная числового типа"
  27. appendHover2 dscr range
  28. >>. appendToken2 Tokens.TokenType.Variable range
  29. >>. appendVarHighlight range (ImplicitNumericType, name) VarHighlightKind.WriteAccess
  30. >>. preturn name
  31. let pAssign stmts =
  32. let assdef name ass =
  33. let asscode =
  34. between (pchar '{' >>. spaces) (spaces >>. char_ws '}') stmts
  35. |>> fun stmts -> AssignCode(ass, stmts)
  36. let call =
  37. ident >>=?
  38. fun name ->
  39. followedBy (
  40. ident
  41. <|> (puint32 >>% "")
  42. <|> stringLiteral)
  43. >>. sepBy1 pexpr (char_ws ',')
  44. |>> fun args -> Assign(ass, Func(name, args)) // То есть `a = min x, y` можно, что ли? Хм...
  45. let assexpr = call <|> (pexpr |>> fun defExpr -> Assign(ass, defExpr))
  46. let str_ws s =
  47. appendToken Tokens.TokenType.OperatorAssignment
  48. (pstring s)
  49. .>> ws
  50. choice [
  51. str_ws "-=" >>. pexpr |>> fun defExpr -> Assign(ass, Expr.Expr(Minus, Var name, defExpr))
  52. str_ws "=-" >>. pexpr |>> fun defExpr -> Assign(ass, Expr.Expr(Minus, defExpr, Var name))
  53. (str_ws "+=" <|> str_ws "=+") >>. pexpr |>> fun defExpr -> Assign(ass, Expr.Expr(Plus, Var name, defExpr))
  54. str_ws "=" >>. (asscode <|> assexpr)
  55. ]
  56. let assign name =
  57. let arr =
  58. bet_ws '[' ']' (opt pexpr)
  59. |>> fun braketExpr ->
  60. match braketExpr with
  61. | Some braketExpr ->
  62. AssignArr(name, braketExpr)
  63. | None -> AssignArrAppend name
  64. arr <|>% AssignVar name >>=? assdef name
  65. let pExplicitAssign =
  66. let p =
  67. appendToken
  68. Tokens.TokenType.Type
  69. ((pstringCI "set" <|> pstringCI "let") .>>? notFollowedVarCont)
  70. .>> ws
  71. >>. (pexplicitVar VarHighlightKind.WriteAccess <|> (pImplicitVarWhenAssign ident |>> fun name -> ImplicitNumericType, name))
  72. p <|> pexplicitVar VarHighlightKind.WriteAccess .>>? ws
  73. >>=? assign
  74. let pImlicitAssign =
  75. pImplicitVarWhenAssign notFollowedByBinOpIdent .>>? ws
  76. >>=? fun name ->
  77. assign (ImplicitNumericType, name)
  78. pExplicitAssign <|> pImlicitAssign
  79. let pcallProc =
  80. let f defines p =
  81. applyRange p
  82. >>= fun (range, name) ->
  83. let p =
  84. defines
  85. |> Map.tryFind (String.toLower name)
  86. |> function
  87. | Some (dscr, sign) ->
  88. appendHover2 dscr range
  89. >>% Some sign
  90. | None ->
  91. [
  92. "Такой процедуры нет, а если есть, то напишите мне, автору расширения, пожалуйста, и я непременно добавлю."
  93. "Когда-нибудь добавлю: 'Возможно, вы имели ввиду: ...'"
  94. ]
  95. |> String.concat "\n"
  96. |> appendSemanticError range
  97. >>% None
  98. appendToken2 Tokens.TokenType.Procedure range
  99. >>. p
  100. |>> fun sign -> name, range, sign
  101. let pProcWithAsterix: _ Parser =
  102. let p =
  103. pchar '*' >>. many1Satisfy isIdentifierChar
  104. |>> sprintf "*%s" // да, так и хочется использоваться `many1Satisfy2`, но она довольствуется лишь первым символом, то есть '*', потому не подходит
  105. f Defines.proceduresWithAsterix p
  106. let procHoverAndToken =
  107. f Defines.procs notFollowedByBinOpIdent
  108. let pDefProc : _ Parser =
  109. Defines.procs
  110. |> Seq.sortByDescending (fun (KeyValue(name, _)) -> name) // для жадности
  111. |> Seq.map (fun (KeyValue(name, (dscr, sign))) ->
  112. applyRange (pstringCI name .>>? notFollowedVarCont)
  113. >>= fun (range, name) ->
  114. appendToken2 Tokens.TokenType.Procedure range
  115. >>. appendHover2 dscr range
  116. >>% (name, range, sign)
  117. )
  118. |> List.ofSeq
  119. |> choice
  120. /// Особый случай, который ломает к чертям весь заявленный синтаксис
  121. let adhoc =
  122. let createIdent name =
  123. pstringCI name .>>? notFollowedVarCont
  124. let p name name2 =
  125. createIdent name .>>? ws1 .>>.? createIdent name2
  126. applyRange
  127. ((p "add" "obj"
  128. <|> (createIdent "del" .>>? ws1 .>>.? (createIdent "obj" <|> createIdent "act"))
  129. |>> fun (name1, name2) -> name1 + name2)
  130. <|> (p "close" "all" |>> fun (name1, name2) -> sprintf "%s %s" name1 name2))
  131. >>= fun (range, name) ->
  132. match Map.tryFind (String.toLower name) Defines.procs with
  133. | Some (dscr, sign) ->
  134. appendToken2 Tokens.TokenType.Procedure range
  135. >>. appendHover2 dscr range
  136. >>% (name, range, sign)
  137. | None -> failwithf "'%s' not found in predef procs" name
  138. pProcWithAsterix
  139. .>> ws .>>. sepBy (applyRange pexpr) (char_ws ',') // Кстати, `,` — "punctuation.separator.parameter.js"
  140. <|> (adhoc <|> pDefProc .>> ws
  141. .>>. (followedBy (skipNewline <|> skipChar '&' <|> eof) >>% []
  142. <|> bet_ws '(' ')' (sepBy (applyRange pexpr) (pchar ',' >>. ws))
  143. <|> sepBy1 (applyRange pexpr) (char_ws ','))
  144. |>> fun ((name, range, sign), args) -> ((name, range, Some sign), args))
  145. <|> (procHoverAndToken
  146. .>>? (ws1 <|> followedBy (satisfy (isAnyOf "'\"")))
  147. .>>.? sepBy1 (applyRange pexpr) (char_ws ','))
  148. >>= fun ((name, range, sign), args) ->
  149. match sign with
  150. | None ->
  151. preturn (CallSt(name, List.map snd args))
  152. | Some x ->
  153. let procNameLower = String.toLower name
  154. let pLoc =
  155. if Set.contains procNameLower Defines.transferOperatorsSet then
  156. match args with
  157. | (r, Val (String [[StringKind locName]]))::_ ->
  158. getUserState
  159. >>= fun (x:State) ->
  160. let nested =
  161. if x.SingleQuotNestedCount > x.DoubleQuotNestedCount then // TODO: ничего хорошего из этого не получится
  162. x.SingleQuotNestedCount
  163. else
  164. x.DoubleQuotNestedCount
  165. |> (+) 1
  166. let r =
  167. { r with
  168. Column1 = r.Column1 + int64 nested // чтобы `'` или `"` пропустить
  169. Column2 = r.Column2 - int64 nested
  170. }
  171. let locNameLower = String.toLower locName
  172. appendLocHighlight r locNameLower VarHighlightKind.ReadAccess
  173. >>. pGetDefLocPos locNameLower
  174. >>= function
  175. | None ->
  176. updateUserState (fun st ->
  177. { st with
  178. NotDefinedLocs =
  179. st.NotDefinedLocs
  180. |> Map.addOrMod locNameLower [r] (fun xs -> r::xs)
  181. }
  182. )
  183. | Some _ -> preturn ()
  184. | _ -> preturn ()
  185. else
  186. preturn ()
  187. args
  188. |> Array.ofList
  189. |> Defines.getFuncByOverloadType x
  190. |> function
  191. | None ->
  192. let msg =
  193. Defines.Show.printSignature name x
  194. |> sprintf "Ожидается одна из перегрузок:\n%s"
  195. appendSemanticError range msg
  196. | Some () ->
  197. preturn ()
  198. >>. pLoc
  199. >>% CallSt(name, List.map snd args)
  200. let pcomment : _ Parser =
  201. let stringLiteralWithToken : _ Parser =
  202. let bet tokenType openedChar closedChar =
  203. let p =
  204. many1Satisfy (fun c' -> not (c' = closedChar || c' = '\n'))
  205. <|> (attempt(skipChar closedChar >>. skipChar closedChar)
  206. >>% string closedChar + string closedChar)
  207. pipe2
  208. (appendToken tokenType (pchar openedChar)
  209. >>. appendToken tokenType (manyStrings p))
  210. (many
  211. (newline >>. appendToken tokenType (manyStrings p))
  212. .>> appendToken tokenType (pchar closedChar)) // TODO: Здесь самое то использовать `PunctuationDefinitionStringEnd`
  213. (fun x xs ->
  214. x::xs |> String.concat "\n"
  215. |> fun x -> sprintf "%c%s%c" openedChar x closedChar
  216. )
  217. bet Tokens.TokenType.Comment '\'' '\''
  218. <|> bet Tokens.TokenType.Comment '"' '"'
  219. let p =
  220. appendToken Tokens.TokenType.Comment
  221. (many1Satisfy (fun c -> c <> '\n' && c <> ''' && c <> '"' && c <> '{'))
  222. <|> stringLiteralWithToken
  223. <|> (pbraces Tokens.TokenType.Comment |>> sprintf "{%s}")
  224. appendToken Tokens.TokenType.Comment (pchar '!')
  225. >>. manyStrings p |>> Statement.Comment
  226. let psign =
  227. appendToken Tokens.TokenType.LabelColon
  228. (pchar ':')
  229. >>. ws
  230. >>. appendToken Tokens.TokenType.NameLabel
  231. (many1SatisfyL ((<>) '\n') "labelName") // TODO: literal? Trim trailing spaces
  232. |>> Label
  233. let genKeywordParser tokenType keyword =
  234. let dscr =
  235. Defines.keywords
  236. |> List.tryPick (fun (name, dscr) ->
  237. if name = keyword then Some dscr
  238. else None)
  239. |> Option.defaultWith (fun () -> failwithf "not found %s" keyword)
  240. appendTokenHover tokenType dscr
  241. (pstringCI keyword .>>? notFollowedVarCont)
  242. let pexit : _ Parser =
  243. genKeywordParser Tokens.TokenType.Exit "exit"
  244. >>% Exit
  245. let pendKeyword : _ Parser =
  246. genKeywordParser Tokens.TokenType.End "end"
  247. let pstmts' pstmt =
  248. many
  249. (pstmt .>> spaces
  250. .>> (skipMany (ppunctuationTerminator .>> spaces)))
  251. let pstmts1' pstmt =
  252. many1
  253. (pstmt .>> spaces
  254. .>> (skipMany (ppunctuationTerminator .>> spaces)))
  255. let pstmt =
  256. let pstmt, pstmtRef = createParserForwardedToRef<Statement, _>()
  257. let pInlineStmts =
  258. many (pstmt .>> ws .>> skipMany (ppunctuationTerminator .>> ws))
  259. let pInlineStmts1 =
  260. many1 (pstmt .>> ws .>> skipMany (ppunctuationTerminator .>> ws))
  261. let pstmts = pstmts' pstmt
  262. let pcolonKeyword : _ Parser =
  263. appendToken Tokens.TokenType.Colon (pchar ':')
  264. let pAct =
  265. let pactKeyword : _ Parser =
  266. genKeywordParser Tokens.TokenType.Act "act"
  267. let pactHeader = pactKeyword .>> ws >>. sepBy1 pexpr (char_ws ',') .>> pcolonKeyword
  268. pipe2
  269. pactHeader
  270. ((ws >>? skipNewline >>. spaces >>. pstmts .>> pendKeyword)
  271. <|> (spaces >>. pInlineStmts .>> optional pendKeyword))
  272. (fun expr body ->
  273. Act(expr, body))
  274. let pFor =
  275. let pForHeader =
  276. genKeywordParser Tokens.TokenType.For "for" >>. ws
  277. >>. (pexplicitVar VarHighlightKind.WriteAccess
  278. <|> (pImplicitVarWhenAssign ident |>> fun name -> ImplicitNumericType, name))
  279. .>> ws .>> appendToken Tokens.TokenType.OperatorAssignment (pchar '=')
  280. .>> ws .>>. pexpr
  281. .>> genKeywordParser Tokens.TokenType.To "to"
  282. .>> ws .>>. pexpr
  283. .>>. opt (genKeywordParser Tokens.TokenType.Step "step"
  284. .>> ws >>. pexpr)
  285. .>> pcolonKeyword
  286. pipe2
  287. pForHeader
  288. ((ws >>? skipNewline >>. spaces >>. pstmts .>> pendKeyword)
  289. <|> (spaces >>. pInlineStmts .>> optional pendKeyword))
  290. (fun (((var, fromExpr), toExpr), stepExpr) body ->
  291. For(var, fromExpr, toExpr, stepExpr, body))
  292. let pIf =
  293. let pifKeyword : _ Parser =
  294. genKeywordParser Tokens.TokenType.If "if"
  295. let pelseifKeyword : _ Parser =
  296. genKeywordParser Tokens.TokenType.ElseIf "elseif"
  297. let pelseKeyword : _ Parser =
  298. genKeywordParser Tokens.TokenType.Else "else"
  299. let pifHeader = pifKeyword .>> ws >>. pexpr .>> pcolonKeyword
  300. let pelseifHeader = pelseifKeyword .>> ws >>. pexpr .>> pcolonKeyword
  301. let setIsEndOptionalTo boolean =
  302. updateUserState (fun x -> { x with IsEndOptional = boolean })
  303. let p =
  304. ws .>>? skipNewline >>. spaces >>. pstmts .>> setIsEndOptionalTo false
  305. <|> (spaces >>. pInlineStmts .>> setIsEndOptionalTo true)
  306. let pElse1 =
  307. pelseKeyword >>. ws
  308. >>. (pInlineStmts1 .>> opt pendKeyword
  309. <|> (spaces >>. pstmts .>> pendKeyword))
  310. let pend =
  311. getUserState
  312. >>= fun x ->
  313. if x.IsEndOptional then
  314. optional pendKeyword
  315. else
  316. pendKeyword >>% ()
  317. let pelseIf =
  318. many1 (pelseifHeader .>>. p)
  319. .>>. (pElse1 <|> (pend >>% []))
  320. |>> fun (elifs, elseBody) ->
  321. let rec f = function
  322. | (expr, thenBody)::xs ->
  323. [If(expr, thenBody, f xs)]
  324. | [] -> elseBody
  325. f elifs
  326. // `end` нужен, чтобы инструкции, определенные ниже, не ушли в тело `if`
  327. // ```qsps
  328. // if expr:
  329. // stmt1
  330. // end & ! без него `stmt2` станет принадлежать телу `if`
  331. // stmt2
  332. // ...
  333. // ```
  334. // `if expr: stmt1 & stmt2 & ...` — такому выражению `end` не нужен, поскольку эту роль выполняет конец строки.
  335. // Также работает и с `elif expr: stmt1 & stmt2 & ...`, и с `else expr: stmt1 & stmt2 & ...`.
  336. pipe2
  337. (pifHeader .>> ws)
  338. ((pInlineStmts1 .>>. (pelseIf <|> pElse1 <|> (opt pendKeyword >>% []))
  339. <|> (spaces >>. pstmts .>>. (pelseIf <|> pElse1 <|> (pendKeyword >>% [])))))
  340. (fun expr (thenBody, elseBody) ->
  341. If(expr, thenBody, elseBody))
  342. pstmtRef :=
  343. choice [
  344. pcomment
  345. pexit
  346. psign
  347. pIf
  348. pAct
  349. pFor
  350. pAssign pstmts
  351. pcallProc
  352. notFollowedBy (pchar '-' >>. ws >>. (skipNewline <|> skipChar '-' <|> eof)) // `-` завершает локацию
  353. >>. (pexpr |>> StarPl)
  354. ]
  355. pstmt
  356. let pstmts = pstmts' pstmt
  357. let pstmts1 = pstmts1' pstmt
  358. let psharpKeyword : _ Parser =
  359. appendToken Tokens.TokenType.SharpBeginLoc (pchar '#')
  360. let pminusKeyword : _ Parser =
  361. appendToken Tokens.TokenType.MinusEndLoc (pchar '-') // хотя здесь больше подошел бы обычный `end`
  362. let ploc =
  363. let pendKeyword =
  364. applyRange (pstringCI "end" .>>? notFollowedVarCont)
  365. >>= fun (range, _) ->
  366. appendToken2 Tokens.TokenType.End range
  367. >>. appendSemanticError range "Лишний `end`"
  368. pipe2
  369. (psharpKeyword .>> ws
  370. >>. (applyRange
  371. (many1Strings
  372. (many1Satisfy (isNoneOf " \t\n")
  373. <|> (many1Satisfy (isAnyOf " \t") .>>? notFollowedByNewline))
  374. <?> "location name")
  375. >>= fun (r, name) ->
  376. let pCheckLocExists r2 locName =
  377. pGetDefLocPos locName
  378. >>= function
  379. | Some r ->
  380. sprintf "Локация уже определена в\n%A" r
  381. |> appendSemanticError r2
  382. | None -> preturn ()
  383. let locNameLower = String.toLower name
  384. pCheckLocExists r locNameLower
  385. >>. updateUserState (fun st ->
  386. { st with
  387. NotDefinedLocs =
  388. Map.remove locNameLower st.NotDefinedLocs // ну да, к чему проверки? И так удалит
  389. }
  390. )
  391. >>. appendLocHighlight r locNameLower VarHighlightKind.WriteAccess // и все равно добавить, даже в случае семантической ошибки? Хм, ¯\_(ツ)_/¯
  392. >>. appendToken2 Tokens.TokenType.StringQuotedSingle r
  393. >>. preturn name
  394. )
  395. .>> spaces)
  396. (many (pstmts1 .>> many (pendKeyword .>> spaces)) |>> List.concat
  397. .>> (pminusKeyword .>> ws
  398. .>> appendToken Tokens.TokenType.Comment
  399. (skipManySatisfy ((<>) '\n'))))
  400. (fun name body -> Location(name, body))
  401. let pAfterAll =
  402. preturn ()
  403. let start str =
  404. let emptyState =
  405. { emptyState with PStmts = pstmts }
  406. let p =
  407. spaces >>. many (ploc .>> spaces)
  408. .>> (getPosition >>= fun p ->
  409. updateUserState (fun st ->
  410. { st with LastSymbolPos = p}))
  411. runParserOnString (p .>> pAfterAll .>> eof)
  412. emptyState
  413. ""
  414. str
  415. let startOnFile enc path =
  416. let emptyState =
  417. { emptyState with PStmts = pstmts }
  418. let p =
  419. spaces >>. many (ploc .>> spaces)
  420. .>> (getPosition >>= fun p ->
  421. updateUserState (fun st ->
  422. { st with LastSymbolPos = p}))
  423. runParserOnFile (p .>> pAfterAll .>> eof)
  424. emptyState
  425. path
  426. enc