YAML(のサブセット)のパーサを書く試み

Patterns.fs

module Patterns

open Microsoft.FSharp.Reflection

let (|PrimitiveType|ListType|RecordType|) t =
  if t = typeof<int> || t = typeof<string> then
    PrimitiveType
  else if FSharpType.IsRecord t then
    RecordType t
  else if t.GetGenericTypeDefinition() = typedefof<list<_>> then
    ListType (t.GetGenericArguments().[0])
  else
    failwithf "%s is not supported type." t.Name

let (|IntType|StrType|OtherType|) t =
  if t = typeof<int> then IntType
  else if t = typeof<string> then StrType
  else OtherType t

ReflectionUtils.fs

module ReflectionUtils

open Microsoft.FSharp.Reflection
open Patterns

/// xs(obj list)をtのlistにする
/// (unboxするだけでは、obj listをint list等に変換できずに落ちる)
let specialize t (xs: obj list) =
  let nil, cons =
    let listType = typedefof<list<_>>.MakeGenericType([| t |])
    let cases = FSharpType.GetUnionCases(listType)
    cases.[0], cases.[1]
  // リフレクションを使ったcons
  let consR x xs =
    ref (FSharpValue.MakeUnion(cons, [| x; !xs |]))
  // リフレクションを使ったnil
  let nilR = FSharpValue.MakeUnion(nil, [||])
  // リストの移し替え
  !(List.foldBack consR xs (ref nilR))

/// プロパティ名と値のペアのリストを、ty型のレコードに変換する
let toRecord ty xs =
  let convTo t (x: obj) =
    match t with
    | IntType -> int ((string x).Trim()) |> box
    | StrType | OtherType _ -> x
  let conv (field: System.Reflection.PropertyInfo) =
    xs
    |> List.find (fst >> ((=)field.Name))
    |> (snd >> (convTo field.PropertyType))
  
  let args =
    ty |> FSharpType.GetRecordFields
       |> Array.map conv
  FSharpValue.MakeRecord(ty, args)

Yaml.fs

module Yaml

open FParsec
open Microsoft.FSharp.Reflection

open Patterns
open ReflectionUtils

type Context = {
  PreIndent: int64
  Indents: int64 list
}
with
  static member empty = { PreIndent = 0L; Indents = [ 0L ] }

type Parser<'a> = Parser<'a, Context>

// 基本的なパーサ
let ws = spaces
let pstr_ws str = pstring str .>> ws
let pchar_ws ch = pchar ch .>> ws
let pint_ws = pint32 .>> many (anyOf [' '; '\t'])

/// startChから始まり、endChで終わる、カンマで区切られたpの連続
let pinline startCh endCh p =
  let sep = ','
  let ends = string sep + string endCh
  sepBy (p ends) (pchar_ws sep)
  |> between (pchar_ws startCh) (pchar_ws endCh)
/// pprefixで始まる、行ごとのpの連続
let pblock pprefix p =
  let tryParse p =
    choice [
      attempt ((fun s -> Reply(())) >>. p |>> (fun x -> x) |>> Some)
      preturn None
    ]
  let rec pblock' p res = parse {
    let! e = tryParse p
    match e with
    | None -> return res
    | Some e ->
      do! spaces |> optional
      let! r = pblock' p (e::res)
      return r
  }
  let indentIndent indent (c: Context) = { PreIndent = c.Indents.Head; Indents = indent::c.Indents }
  let deindentIndent (c: Context) = { PreIndent = c.Indents.Head; Indents = c.Indents.Tail }
  let psuffix level = parse {
    let! state = getUserState
    do! fun stream ->
      if state.Indents.Head <= level then Reply(()) else Reply()
    do! updateUserState deindentIndent
    return ()
  }
  let pindentContinue pre crnt = fun stream ->
    if pre <= crnt then Reply(()) else Reply()
  let pprefix' = parse {
    let crnt = ref 0L
    let! { PreIndent = preIndent; Indents = indents } = getUserState .>> fun stream -> crnt := stream.Column - 1L; Reply(())
    let indent = match indents with indent::_ -> indent | [] -> failwith "oops!"
    do! pindentContinue preIndent !crnt
    do! pprefix |>> ignore
    return ()
  }
  parse {
    let! { PreIndent = preIndent; Indents = indents } = getUserState
    let indent = match indents with indent::_ -> indent | [] -> failwith "oops!"
    let newIndent = ref indent
    do! (fun stream ->
      newIndent := stream.Column - 1L
      Reply(())
    )
    do! updateUserState (indentIndent !newIndent)
    let! result = pblock' (pprefix' >>. (p "\n")) [] |>> List.rev
    do! psuffix !newIndent
    return result
  }

/// ty型のリストをパースするパーサを生成する
let rec plist ty =
  let plistElem ty ends =
    match ty with
    | IntType -> pint_ws |>> unbox
    | StrType -> manyChars (noneOf ends) |>> (fun s -> unbox (s.Trim()))
    | OtherType (ListType ty) -> plist ty |>> unbox
    | OtherType (RecordType ty) -> precord ty |>> unbox
    | OtherType (PrimitiveType) -> failwithf "%s is not supported type." ty.Name
  let plist' p =
    choice [
      attempt (p |> pinline '[' ']')
      p |> pblock (pstring "- ")
    ]
  plist' (plistElem ty) |>> (specialize ty >> unbox)
/// レコードをパースするパーサを生成する
and precord ty =
  let precord' p =
    let msg = ref ""
    parse {
      let! xs = p
      try
        return xs |> toRecord ty
      with e -> msg := e.Message
    } <?> !msg
  
  let getFieldType name =
    let prop = ty |> FSharpType.GetRecordFields |> Array.tryFind (fun p -> p.Name = name)
    prop |> Option.map (fun p -> p.PropertyType)
  let pfield ends = parse {
    let! name = manyCharsTill anyChar (pstring ": ")
    let! value =
      match getFieldType name with
      | Some(ListType t) -> plist t |>> box
      | Some(RecordType t) -> precord t |>> box
      | Some(PrimitiveType) -> manyChars (noneOf ends) |>> box
      | None -> pzero
    return name, value
  }
  choice [
    attempt (pfield |> pinline '{' '}' |> precord')
    (pfield |> pblock (preturn ()) |> precord')
  ]

let pbody = function
| ListType t -> plist t
| RecordType t -> precord t
| PrimitiveType as t ->
    match t with
    | IntType -> pint_ws |>> unbox
    | StrType -> manyChars anyChar |>> (fun s -> unbox (s.Trim()))
    | OtherType t -> failwithf "%s is not supported type." t.Name

let parse<'a> yamlStr: 'a =
  let parser = pbody typeof<'a> .>> ws .>> followedBy eof
  match yamlStr |> FParsec.CharParsers.runParserOnString parser Context.empty "" with
  | Success(res, _, _) -> unbox res
  | Failure(msg, err, state) -> failwithf "msg: %s\nerr: %A\nstate: %A" msg err state

YamlScenario.fs

module YamlScenario

open NUnit.Framework
open NaturalSpec

module int =
  [<Scenario>]
  let ``42というYAML文字列を42に変換できる``() =
    Given "42"
    |> When Yaml.parse<int>
    |> It should equal 42
    |> Verify

// parseにstringを直接指定すると、何でも食べる
module string =
  [<Scenario>]
  let ``42というYAML文字列を"42"に変換できる``() =
    Given "42"
    |> When Yaml.parse<string>
    |> It should equal "42"
    |> Verify

  [<Scenario>]
  let ``hogeというYAML文字列を"hoge"に変換できる``() =
    Given "hoge"
    |> When Yaml.parse<string>
    |> It should equal "hoge"
    |> Verify

  [<Scenario>]
  let ``[1, 2, 3]というYAML文字列を"[1, 2, 3]"に変換できる``() =
    Given "[1, 2, 3]"
    |> When Yaml.parse<string>
    |> It should equal "[1, 2, 3]"
    |> Verify

module ``int list`` =
  [<Scenario>]
  let ``[1, 2, 3]というYAML文字列を[1; 2; 3]に変換できる``() =
    Given "[1, 2, 3]"
    |> When Yaml.parse<int list>
    |> It should equal [1; 2; 3]
    |> Verify

  [<Scenario>]
  let ``[1, 2, 4]というYAML文字列を[1; 2; 4]に変換できる``() =
    Given "[1, 2, 4]"
    |> When Yaml.parse<int list>
    |> It should equal [1; 2; 4]
    |> Verify

  [<Scenario>]
  let ``[ 10 ,2,3 ]というYAML文字列を[1; 2; 3]に変換できる``() =
    Given "[ 10 ,2,3 ]"
    |> When Yaml.parse<int list>
    |> It should equal [10; 2; 3]
    |> Verify

  [<Scenario>]
  let ブロック形式のリストも扱える() =
    Given "- 10\n\
           - 20\t \n\
           - -10"
    |> When Yaml.parse<int list>
    |> It should equal [10; 20; -10]
    |> Verify

module ``string list`` =
  [<Scenario>]
  let ``[ abc, def , ghi ]というYAML文字列を["abc"; "def"; "ghi"]に変換できる``() =
    Given "[ abc, def , ghi ]"
    |> When Yaml.parse<string list>
    |> It should equal ["abc"; "def"; "ghi"]
    |> Verify

  [<Scenario>]
  let ブロック形式のリストも扱える() =
    Given "- hoge\n\
           - piyo\n\
           - foo"
    |> When Yaml.parse<string list>
    |> It should equal ["hoge"; "piyo"; "foo"]
    |> Verify

module 単純なレコード =
  type t = { Name: string; Age: int }
  [<Scenario>]
  let ``{ Name: hoge piyo, Age: 20 }というYAML文字列を{ Name = "hoge piyo"; Age = 20 }に変換できる``() =
    Given "{ Name: hoge piyo, Age: 20 }"
    |> When Yaml.parse<t>
    |> It should equal { Name = "hoge piyo"; Age = 20 }
    |> Verify

  [<Scenario>]
  let ブロック形式のレコードも扱える() =
    Given "Name: hoge piyo\n\
           Age: 20"
    |> When Yaml.parse<t>
    |> It should equal { Name = "hoge piyo"; Age = 20 }
    |> Verify

module ``インラインのstring listを持つレコード`` =
  type t = { Name: string; Comunities: string list }
  [<Scenario>]
  let ``{ Name: aaa bbb, Comunities: [ F#, Scala ] }というYAML文字列を{ Name = "aaa bbb"; Comunities = ["F#"; "Scala"] }に変換できる``() =
    Given "{ Name: aaa bbb, Comunities: [ F#, Scala ] }"
    |> When Yaml.parse<t>
    |> It should equal { Name = "aaa bbb"; Comunities = ["F#"; "Scala"] }
    |> Verify

  [<Scenario>]
  let ブロック形式のレコードも扱える() =
    Given "Name: aaa bbb\n\
           Comunities: [F#, Scala]"
    |> When Yaml.parse<t>
    |> It should equal { Name = "aaa bbb"; Comunities = ["F#"; "Scala"] }
    |> Verify

  [<Scenario>]
  let インデントを扱える() =
    Given "Name: aaa bbb\n\
           Comunities: - F#\n" +
          "            - Scala\n" +
          "            - OCaml"
    |> When Yaml.parse<t>
    |> It should equal { Name = "aaa bbb"; Comunities = [ "F#"; "Scala"; "OCaml" ] }
    |> Verify

module ``インラインのint listを持つレコード`` =
  type t = { Hoge: string; Piyo: int list }
  [<Scenario>]
  let ``{ Hoge: 42, Piyo: [ 1, 2, 3 ] }というYAML文字列を{ Hoge = "42"; Piyo = [1; 2; 3] }に変換できる``() =
    Given "{ Hoge: 42, Piyo: [ 1, 2, 3 ] }"
    |> When Yaml.parse<t>
    |> It should equal { Hoge = "42"; Piyo = [ 1; 2; 3 ] }
    |> Verify

module ``リストのレコード`` =
  type s = { Name: string; Age: int }
  type t = s list
  [<Scenario>]
  let ``[ { Name: hoge piyo, Age: 20 }, { Name: foo bar, Age: 30 } ]というYAML文字列を[ { Name = "hoge piyo"; Age = 20 }; { Name = "foo bar"; Age = 30 } ]に変換できる``() =
    Given "[ { Name: hoge piyo, Age: 20 }, { Name: foo bar, Age: 30 } ]"
    |> When Yaml.parse<t>
    |> It should equal [ { Name = "hoge piyo"; Age = 20 }; { Name = "foo bar"; Age = 30 } ]
    |> Verify

  [<Scenario>]
  let ブロックもOK() =
    Given "- { Name: hoge piyo, Age: 20 }\n\
           - { Name: foo bar, Age: 30 }"
    |> When Yaml.parse<t>
    |> It should equal [ { Name = "hoge piyo"; Age = 20 }; { Name = "foo bar"; Age = 30 } ]
    |> Verify

module ``レコードのレコード`` =
  type s = { Name: string; Age: int }
  type t = { Person: s; Communities: string list }
  [<Scenario>]
  let インラインがOK() =
    Given "{ Person: { Name: hoge piyo, Age: 20 }, Communities: [F#, Scala] }"
    |> When Yaml.parse<t>
    |> It should equal { Person = { Name = "hoge piyo"; Age = 20 }; Communities = ["F#"; "Scala"] }
    |> Verify

  [<Scenario>]
  let ブロックもOK() =
    Given "Person: { Name: hoge piyo, Age: 20 }\n\
           Communities: [F#, Scala]"
    |> When Yaml.parse<t>
    |> It should equal { Person = { Name = "hoge piyo"; Age = 20 }; Communities = ["F#"; "Scala"] }
    |> Verify

module ``レコードのレコードのリスト`` =
  type s = { Name: string; Age: int }
  type t = { Person: s; Communities: string list }
  [<Scenario>]
  let OK() =
    Given "- { Person: { Name: hoge piyo, Age: 20 }, Communities: [F#, Scala] }\n\
           - { Person: { Name: foo bar, Age: 30 }, Communities: [Java, C#] }"
    |> When Yaml.parse<t list>
    |> It should equal [ { Person = { Name = "hoge piyo"; Age = 20 }; Communities = ["F#"; "Scala"] }
                         { Person = { Name = "foo bar"; Age = 30 }; Communities = ["Java"; "C#"] } ]
    |> Verify

module ブロックのブロック =
  [<Scenario>]
  let OK() =
    Given ("- - F#\n" +
          "  - Scala\n" +
          "- - Java\n" +
          "  - C#")
    |> When Yaml.parse<string list list>
    |> It should equal [ [ "F#"; "Scala" ]; [ "Java"; "C#"] ]
    |> Verify