Kiln » babybearparser
Clone URL:  
/ babybearparser
Parser.fs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
module babybearparser.Parser open FParsec.CharParsers open FParsec.Primitives open System type Keyword = Word of string | Phrase of string type Filter = | Author of string | Date of DateTime * DateTime | File of string | Project of string | Repo of string type Atom = KeywordAtom of Keyword | FilterAtom of Filter type ParseError (msg: string) = inherit Exception (msg) (* Utilities *) let pipeline (f, a) = f a let failIfNone msg = function | Some x -> preturn x | None -> fail msg let stringToDate = function | "today" -> DateTime.UtcNow.Date |> Some | "yesterday" -> DateTime.UtcNow.Date.AddDays -1. |> Some | s -> try DateTime.Parse s |> Some with :? FormatException -> None let findFilter = function | "author" -> Author | "file" -> File | "project" -> Project | "repo" -> Repo | _ -> raise <| ParseError "Invalid filter name" (* Parsers *) let word = many1Satisfy <| fun c -> c <> ' ' let phraseEscape = pchar '\\' >>. pchar '"' let phraseInnard = phraseEscape <|> noneOf "\"" let phraseInnards = manyChars phraseInnard let phrase = between (pchar '"') (pchar '"') phraseInnards let keyword = (phrase |>> Phrase) <|> (word |>> Word) let filterName = ["author"; "file"; "project"; "repo"] |> Seq.map pstring |> choice let regularFilter = (filterName |>> findFilter) .>>? (pchar ':') .>>. (phrase <|> word <?> "filter argument") |>> pipeline let dateWord = many1Chars <| noneOf ". " let fullDate = (phrase <|> dateWord) |>> stringToDate >>= failIfNone "Unrecognized date" let dateStart = fullDate <|>% DateTime.MinValue let dateEnd = fullDate <|>% DateTime.UtcNow.Date let dateFilter = pstring "date:" >>. dateStart .>> pstring ".." .>>. dateEnd |>> Date let filter = regularFilter <|> dateFilter let atom = (filter |>> FilterAtom) <|> (keyword |>> KeywordAtom) let spaces = many1Satisfy <| fun c -> c = ' ' let atoms = sepBy atom spaces let parse input = match run atoms input with | Success (x, _, _) -> x | Failure (x, _, _) -> raise <| ParseError x