Skip to content

Instantly share code, notes, and snippets.

@Rickasaurus
Created October 8, 2013 21:12
Show Gist options
  • Save Rickasaurus/6891785 to your computer and use it in GitHub Desktop.
Save Rickasaurus/6891785 to your computer and use it in GitHub Desktop.
pseudo-dynamic json parsing into a DU with FSharp.Data
type ParseError = string list
type HashBlocking = { CustomerField: string; ProviderField: string }
type SuffixArrayBlocking = { CustomerField: string; ProviderField: string }
type BlockingMethod =
| Hash of HashBlocking
| SuffixArray of SuffixArrayBlocking
type FieldConfig =
{
FieldName: string
FieldType: string
}
type Configuration =
{
CustomerDescriptor: FieldConfig list
ProviderDescriptor: FieldConfig list
Blocking: BlockingMethod list
}
open System.Reflection
open Microsoft.FSharp.Reflection
open SafeBlock.Types
open FSharp.Data.Json
open FSharp.Data.Json.Extensions
let isChoice1 o = match o with | Choice1Of2 _ -> true | Choice2Of2 _ -> false
let getChoice1 o = match o with | Choice1Of2 o -> o | Choice2Of2 _ -> failwith "Expected Choice1, but was Choice2"
let getChoice2 o = match o with | Choice2Of2 o -> o | Choice1Of2 _ -> failwith "Expected Choice2, but was Choice1"
let jsonToFieldConfig (key: string, value: JsonValue) : (FieldConfig, ParseError) Choice =
match value with
| JsonValue.String s -> { FieldName = key; FieldType = s } |> Choice1Of2
| _ -> ["Type of " + key + " is not a json string"] |> Choice2Of2
let jsonToDescriptor (json: JsonValue) : (FieldConfig list, ParseError) Choice =
match json with
| JsonValue.Object objects ->
let tupled = objects |> Map.toList
let fieldResults, failedResults = tupled |> List.map jsonToFieldConfig |> List.zip (tupled |> List.map fst) |> List.partition (snd >> isChoice1)
if failedResults |> List.isEmpty then
fieldResults |> List.map (snd >> getChoice1) |> Choice1Of2
else
[ for key, fieldConfig in failedResults do
match fieldConfig with | Choice1Of2 _ -> () | Choice2Of2 e -> yield ("Errors found while parsing field: " + key); yield! e
] |> Choice2Of2
| _ -> Choice2Of2 ["Descriptor must contain a json object."]
let blockingTypes : (string, ((string, string) Map -> BlockingMethod)) Map =
let cases = FSharpType.GetUnionCases typeof<BlockingMethod>
[
for case in cases do
let fieldpi : PropertyInfo =
let fs = case.GetFields() in if fs.Length <> 1 then failwith "All BlockingMethod cases must have a single member."
else fs.[0]
let fieldType = fieldpi.PropertyType
if not <| FSharpType.IsRecord fieldType then failwith "All BlockingMethod cases must have a single member which contains a record."
let fields = FSharpType.GetRecordFields fieldType
let fieldNames = fields |> Array.map (fun f -> f.Name)
let rCtor = FSharpValue.PreComputeRecordConstructor fieldType
let uCtor = FSharpValue.PreComputeUnionConstructor case
let func m =
try
let values = fieldNames |> Array.map (fun fn -> m |> Map.find fn |> box)
uCtor [|rCtor values|] :?> BlockingMethod
with ex -> failwith ("Failed while constructing a BlockingMethod configuration: " + ex.Message)
yield case.Name, func
] |> Map.ofList
let jsonToBlockingConfig (blockType: string) (json: JsonValue) : (BlockingMethod, ParseError) Choice =
let bCtor = blockingTypes |> Map.tryFind blockType
match bCtor, json with
| Some ctor, JsonValue.Object objects ->
let kvpairs = objects |> Map.map (fun k -> function | JsonValue.String s -> s | _ -> failwith "Only strings are currently supported in the blocking configuration")
ctor kvpairs |> Choice1Of2
| None, _ -> Choice2Of2 ["Constructor not found for BlockingMethod: " + blockType]
| Some _, _ -> Choice2Of2 ["Config must contain a json object type."]
let jsonToBlocking (json: JsonValue) : (BlockingMethod, ParseError) Choice =
match json with
| JsonValue.Object objects ->
let gf v = objects |> Map.tryFind v
match gf "Type", gf "Config" with
| Some (JsonValue.String rtype), Some cfg ->
match jsonToBlockingConfig rtype cfg with
| Choice1Of2 blk -> blk |> Choice1Of2
| Choice2Of2 err -> ("Errors found while parsing the Blocking field: " + rtype) :: err |> Choice2Of2
| Some rtype, Some cfg -> ["Type field of Blocking definition should contain a string"] |> Choice2Of2
| None, _ -> ["Blocking definition must include a Type field."] |> Choice2Of2
| _, None -> ["Blocking definition must include a Config field."] |> Choice2Of2
| _ -> Choice2Of2 ["Each item in the Blocking array must contain a json object."]
let jsonToBlockingList (json: JsonValue) : (BlockingMethod list, ParseError) Choice =
match json with
| JsonValue.Array array ->
let res = array |> Array.toList |> List.map jsonToBlocking
let blocks, failed = res |> List.partition isChoice1 |> fun (b,f) -> b |> List.map getChoice1, f |> List.map getChoice2
if failed |> List.isEmpty then blocks |> Choice1Of2
else ("Errors found in one or more Blocking definitions." :: List.collect id failed) |> Choice2Of2
| _ -> Choice2Of2 ["Blocking must contain a json object."]
let jsonToConfiguration (jsonFile: JsonValue) : (Configuration, ParseError) Choice =
match jsonFile with
| JsonValue.Object objects ->
let gf v = objects |> Map.tryFind v
match gf "CustomerDescriptor", gf "ProviderDescriptor", gf "Blocking" with
| Some (cd), Some(pd), Some (blocks) ->
match jsonToDescriptor cd, jsonToDescriptor pd, jsonToBlockingList blocks with
| Choice1Of2 cds, Choice1Of2 pds, Choice1Of2 blk -> { CustomerDescriptor = cds; ProviderDescriptor = pds; Blocking = blk } |> Choice1Of2
| cdo, pdo, bko ->
[
match cdo with | Choice1Of2 _ -> () | Choice2Of2 e -> yield! "Errors found while parsing CustomerDescriptor." :: e
match pdo with | Choice1Of2 _ -> () | Choice2Of2 e -> yield! "Errors found while parsing ProviderDescriptor." :: e
match bko with | Choice1Of2 _ -> () | Choice2Of2 e -> yield! "Errors found while parsing Blocking." :: e
] |> Choice2Of2
| cdo, pdo, bo ->
[
if cdo.IsNone then yield "CustomerDescriptor field not found on top level json object."
if pdo.IsNone then yield "ProviderDescriptor field not found on top level json object."
if bo.IsNone then yield "Blocking field not found on top level json object."
] |> Choice2Of2
| _ -> Choice2Of2 ["Top level of configuration file must be a json object."]
let fileToConfiguration (filename: string) : (Configuration, ParseError) Choice =
use file = System.IO.File.OpenRead(filename)
let json = JsonValue.Load file
jsonToConfiguration json
let textToConfiguration (text: string) : (Configuration, ParseError) Choice =
let json = JsonValue.Parse text
jsonToConfiguration json
open System
open Xunit
open SafeBlock.Types
open SafeBlock.IO
let ``simple config`` = """
{
"CustomerDescriptor": { "CName": "String" },
"ProviderDescriptor": { "PName": "String" },
"Blocking": [{"Type": "Hash", "Config": { "CustomerField": "CName", "ProviderField": "PName" } } ]
}"""
[<Fact>]
let ``simplest possible config file should parse`` () =
let config = textToConfiguration ``simple config``
match config with
| Choice2Of2 err ->
let failtext = err |> List.fold (fun s t -> s + Environment.NewLine + t) ""
failwith failtext
| Choice1Of2 success ->
Assert.Equal(1, success.Blocking.Length)
Assert.Equal(success.Blocking.[0], (BlockingMethod.Hash {CustomerField = "CName"; ProviderField = "PName"}))
Assert.Equal(1, success.CustomerDescriptor.Length)
Assert.Equal(success.CustomerDescriptor.[0], { FieldName = "CName"; FieldType = "String" })
Assert.Equal(1, success.ProviderDescriptor.Length)
Assert.Equal(success.ProviderDescriptor.[0], { FieldName = "PName"; FieldType = "String" })
@tel
Copy link

tel commented Oct 9, 2013

Woah. I had no idea F# was "just" ML with extensions.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment