toml-parser-example.fs

// Learn more about F# at http://fsharp.org

open System
open TomlParser.Toml
open FParsec

[<EntryPoint>]
let main argv =
    let res = 
        run toml 
            """# This is a TOML document.
        
            title = "TOML Example"
        
            [owner]
            name = "Tom Preston-Werner"
            dob = 1979-05-27T07:32:00-08:00 # First class dates
        
            [database]
            server = "192.168.1.1"
            ports = [ 8000, 8001, 8002 ]
            connection_max = 5000
            enabled = true
        
            [servers]
        
              # Indentation (tabs and/or spaces) is allowed but not required
              [servers.alpha]
              ip = "10.0.0.1"
              dc = "eqdc10"
        
              [servers.beta]
              ip = "10.0.0.2"
              dc = "eqdc10"
        
            [clients]
            data = [ ["gamma", "delta"], [1, 2] ]
        
            # Line breaks are OK when inside arrays
            hosts = [
              "alpha",
              "omega"
            ]"""
    printfn "%A" res
    0 // return an integer exit code
    
 //   Success: (((Some [Comment " This is a TOML document."],
 //  Some (Some (Title "TOML Example"))), Some []),
 //[("owner",
 //  [Attr ("name", String "Tom Preston-Werner");
 //   Attr ("dob", DateTime 27.05.1979 19:32:00)]);
 // ("database",
 //  [Attr ("server", String "192.168.1.1");
 //   Attr ("ports", Array [|Num 8000; Num 8001; Num 8002|]);
 //   Attr ("connection_max", Num 5000); Attr ("enabled", Bool true)]);
 // ("servers",
 //  [Comment " Indentation (tabs and/or spaces) is allowed but not required";
 //   SubType
 //     ("alpha", Attrs [|("ip", String "10.0.0.1"); ("dc", String "eqdc10")|]);
 //   SubType
 //     ("beta", Attrs [|("ip", String "10.0.0.2"); ("dc", String "eqdc10")|])]);
 // ("clients",
 //  [Attr
 //     ("data",
 //      Array
 //        [|Array [|String "gamma"; String "delta"|]; Array [|Num 1; Num 2|]|]);
 //   Comment " Line breaks are OK when inside arrays";
 //   Attr ("hosts", Array [|String "alpha"; String "omega"|])])])

toml-parser.fs

namespace TomlParser

open System

type TomlType =
    | String of string
    | Num of int32
    | Float of float
    | Bool of bool
    | DateTime of DateTime
    | Array of TomlType []

type Attr = string * TomlType

type Object = 
    | Attrs of Attr []
    | Attr of Attr
    | SubType of string * Object
    | Type of string * Object
    | Comment of string
    | Title of string

module Int32 =
    let order i =
        let mutable x = i
        let mutable cnt = 0
        while x / 10 > 0 do
            x <- x / 10
            cnt <- cnt + 1
        cnt + 1

module Float = 
    let reduce (f: float) =
        let mutable x = f
        while x >= 1. do
            x <- x / 10.
        x


module Toml =
    open FParsec
    
    let comment : Parser<Object, unit> = spaces .>>? pstring "#" >>. manyCharsTill anyChar newline |>> Comment

    let alphabet = 
        seq { "ABCDEFGHIJKLMNOPQRSTUVWXYZ".ToCharArray()
              "ABCDEFGHIJKLMNOPQRSTUVWXYZ" |> Seq.map (Char.ToLower) |> Seq.toArray
              "_".ToCharArray() }
        |> Array.concat

    let alphabetStrTill c = manyCharsTill (anyOf alphabet) (pchar c)

    let anyStrTill c = manyCharsTill anyChar (pchar c)

    let anyStr = manyChars <| anyOf alphabet

    let manySpaces = manyChars <| anyOf [|' '; '\t'|]

    let name : Parser<string, unit> = spaces >>. pstring "[" >>. (alphabetStrTill ']') //.>> pstring "]"

    let subName : Parser<string * string, unit> = spaces >>? pstring "[" >>? (alphabetStrTill '.') .>>.? (alphabetStrTill ']') 
        

    let tomlStr : Parser<TomlType, unit> = pstring "\"" >>. (anyStrTill '"') |>> String
    let tomlNum : Parser<TomlType, unit> = pint32 |>> Num
    let tomlFloat : Parser<TomlType, unit> = pint32 .>>? pchar '.' .>>.? pint32 >>=? fun (whole, particle) -> 
            float whole + (particle |> float |> Float.reduce)
            |> Float
            |> preturn
    let tomlDateTime : Parser<TomlType, unit> = manyChars (anyOf [|'0';'1';'2';'3';'4';'5';'6';'7';'8';'9';':';'-';'.';'T'|] ) >>=? fun s -> 
        match DateTime.TryParse(s, System.Globalization.CultureInfo.InvariantCulture, System.Globalization.DateTimeStyles.None) with
        | (true, dt) -> preturn dt
        | (false, _) -> fail <| sprintf "\"%s\" is not a date" s
        |>> DateTime
    let tomlBool = anyStr >>=? fun s -> 
        match s with 
        | "true" -> preturn true 
        | "false" -> preturn false 
        | _ -> fail <| sprintf "%s is not bool" s
        |>> Bool

    let tomlType = choice [
        tomlDateTime
        tomlStr
        tomlFloat
        tomlNum
        tomlBool
    ]

    let tomlArray tomlType = pchar '[' >>.  sepBy (optional spaces >>. tomlType .>> optional spaces) (pchar ',') .>> pchar ']' |>> (List.toArray >> Array)

    let private tomlTypes' = choice [
        tomlDateTime
        tomlStr
        tomlFloat
        tomlNum
        tomlBool
        tomlArray tomlType
    ]

    let tomlTypes = choice [
        tomlDateTime .>> optional comment
        tomlStr .>> optional comment
        tomlFloat .>> optional comment   
        tomlNum .>> optional comment
        tomlBool .>> optional comment
        tomlArray tomlTypes'
    ]

    let remainingSpaces = manySpaces .>> newline

    let attr s : Parser<Attr, unit> = optional manySpaces >>. s .>> manySpaces .>> pchar '=' .>> manySpaces .>>. tomlTypes .>> optional remainingSpaces .>> optional manySpaces
    
    let objects = choice [
        comment
        subName .>>? spaces .>>.? (many (attr (manyChars <| anyOf alphabet))) >>=? (fun ((_, s), l) -> (s, Attrs <| Seq.toArray l) |> SubType |> preturn)
        attr (manyChars <| anyOf alphabet) |>> Attr
    ]

    let optManyComments = opt (many (attempt comment))

    let emptyLine = manySpaces >>. newline >>. manySpaces >>. newline

    // name .>> spaces .>>.? subName >>= (fun (s, (s1, s2)) -> preturn (s, s2))
    let object = optional remainingSpaces >>. name .>>? optional remainingSpaces .>>? optional manySpaces .>>.? many (attempt objects .>> optional spaces)

    let title = opt <| attr (pstring "title") >>= fun attr -> attr |> Option.map (fun ("title", String s) -> Title s) |> preturn

    let toml = optional spaces >>. optManyComments .>> optional spaces .>>. opt title .>> optional spaces .>>. optManyComments .>>. manyTill (object .>> spaces) eof