IRC with parse combinators

irc-parser.fsx

module Parser =
    type ParseError = {
        Message: string list
    }
    
    type Parser<'a> = char list -> char list * Result<'a, ParseError>
            
    /// Bind function with non-empty lists
    let parseList (f: Parser<'a>) = fun inp ->
        match inp with
        | [] -> (inp, Error { Message = ["Empty list"] })
        | xs -> f xs
    
    let dummyParser r: Parser<'a> = fun inp -> (inp, Ok r)
    
    let bindParser (f: 'a -> Parser<'b>) (p: Parser<'c>) =                
        fun inp ->
            match p inp with 
            | rest, Ok r -> (f r) rest 
            | rest, Error r -> (rest, Error r)

    let chain (p1: Parser<'a>) (p2: Parser<'b>) = fun inp ->
        match p1 inp with
        | rest, Ok parsed1 ->
            match p2 rest with 
            | rest, Ok parsed2 -> (rest, Ok (parsed1, parsed2))
            | rest, Error err -> (rest, Error err)
        | rest, Error err -> (rest, Error err)

    let parseLetter =
        let p (head :: tail) =
            match head with 
            | c when 'a' <= c && c <= 'z'   -> (tail, Ok c)
            | c when 'A' <= c && c <= 'Z'   -> (tail, Ok c)
            | _ -> (tail, Error { Message = [$"Not a letter: {head}"] })
        parseList p

    let parseNumber =
        let p (head :: tail) =
            match head with  
            | c when '0' <= c && c <= '9'   -> (tail, Ok c)
            | _ -> (tail, Error { Message = [$"Not a number: {head}"] })
        parseList p
    
    let parseEspecialChar =
        let p (head :: tail) =
            match head with
            | '-' | '[' | ']' | '\\' | '`' | '^' | '{' | '}' -> (tail, Ok head)
            | _ -> (tail, Error { Message = [$"Not a especial: {head}"] })
        parseList p

    let parseEither (p1: Parser<'a>) (p2: Parser<'b>) = fun inp ->
        match p1 inp with
        | rest, Ok r1 -> (rest, Ok r1)
        | _, Error _ -> p2 inp
    
    let parseAscii = parseEither parseLetter parseNumber
    
    let tilFail (p: Parser<'a>): Parser<'b> = fun inp ->
        let rec helper seq xs =
            match p xs with         
            | rest, Ok r -> helper (seq @ [r]) rest
            | _, Error _ -> (xs, Ok seq)                
        helper [] inp
        
    let parseChar c =
        let p (head :: tail) =
            match head with
            | _ when c = head -> (tail, Ok head)
            | _ -> (tail, Error { Message = [$"Given char {head} not match with {c} "] })
        parseList p
    
    let rec tilSome (p: Parser<'a>)  = fun xs ->
        match p xs with         
        | rest, Ok r -> (rest, Ok r)
        | [], Error err -> ([], Error err)
        | rest, Error _ -> tilSome p rest
    
    let parseLine (inp: string) (p: Parser<'a>) =
        match (Seq.toList >> p) inp  with
        | rest, Ok parsed -> Ok (parsed, rest)
        | _, Error err -> Error $"fail to parse <{err.Message}>"
    
    type ParserBuilder() =
        member x.Bind(p, func) = bindParser func p    
        member this.Return(x) = dummyParser x
    
    let parser = new ParserBuilder()

type Tag = { Key : string; Value: string }
type Prefix = {
    Ident: string
    Nick: string
    Host: string
}

type Message = {
    Tags : Map<string, Tag>
    Prefix: Prefix
    Command: string
    Params: string list
}

let (|>>) p f = Parser.bindParser f p

let foldChar xs =
    string (List.fold (fun (sb:StringBuilder) (c:char) -> sb.Append(c)) 
        (StringBuilder())
        xs)
    
// let tagParser =
//     let parseKey = Parser.parseEither Parser.parseAscii (Parser.parseChar '-')
//     let parseValue = Parser.parseAscii
//     
//     Parser.tilFail parseKey |>> (fun key ->
//         Parser.parseChar '=' |>> (fun _ ->
//             Parser.tilFail parseValue |>> (fun value ->                
//                 Parser.dummyParser { Key = $"{foldChar key}"; Value = $"{foldChar value}" }
//             )
//         ) 
//    )

// tagParser takes string as input an return a Parser implementation
let tagParser = Parser.parser {
    let parseKey = Parser.parseEither Parser.parseAscii (Parser.parseChar '-')
    let parseValue = Parser.parseAscii
    
    let! key = Parser.tilFail parseKey
    let! _ = Parser.parseChar '='
    let! value =  Parser.tilFail parseValue
    
    return { Key = foldChar key; Value = foldChar value }
}

printf "%A\n" (Parser.parseLine "badge-info=test;test=123232" tagParser)