Created
August 30, 2015 18:19
-
-
Save swlaschin/bbe70c768215b209c06c to your computer and use it in GitHub Desktop.
Serializing and deserializing a tree to JSON. Related blog post: http://fsharpforfunandprofit.com/posts/recursive-types-and-folds-3b/
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(* | |
RecursiveTypesAndFold-3b-json.fsx | |
Example: Serializing and deserializing a tree to JSON | |
Related blog post: http://fsharpforfunandprofit.com/posts/recursive-types-and-folds-3b/ | |
*) | |
// ============================================== | |
// PART 3b - Serializing and deserializing a tree to JSON (without error handling) | |
// ============================================== | |
// ============================================== | |
// Tree implementation | |
// ============================================== | |
type Tree<'LeafData,'INodeData> = | |
| LeafNode of 'LeafData | |
| InternalNode of 'INodeData * Tree<'LeafData,'INodeData> seq | |
module Tree = | |
let rec cata fLeaf fNode (tree:Tree<'LeafData,'INodeData>) :'r = | |
let recurse = cata fLeaf fNode | |
match tree with | |
| LeafNode leafInfo -> | |
fLeaf leafInfo | |
| InternalNode (nodeInfo,subtrees) -> | |
fNode nodeInfo (subtrees |> Seq.map recurse) | |
let rec fold fLeaf fNode acc (tree:Tree<'LeafData,'INodeData>) :'r = | |
let recurse = fold fLeaf fNode | |
match tree with | |
| LeafNode leafInfo -> | |
fLeaf acc leafInfo | |
| InternalNode (nodeInfo,subtrees) -> | |
// determine the local accumulator at this level | |
let localAccum = fNode acc nodeInfo | |
// thread the local accumulator through all the subitems using Seq.fold | |
let finalAccum = subtrees |> Seq.fold recurse localAccum | |
// ... and return it | |
finalAccum | |
let rec map fLeaf fNode (tree:Tree<'LeafData,'INodeData>) = | |
let recurse = map fLeaf fNode | |
match tree with | |
| LeafNode leafInfo -> | |
let newLeafInfo = fLeaf leafInfo | |
LeafNode newLeafInfo | |
| InternalNode (nodeInfo,subtrees) -> | |
let newSubtrees = subtrees |> Seq.map recurse | |
let newNodeInfo = fNode nodeInfo | |
InternalNode (newNodeInfo, newSubtrees) | |
let rec iter fLeaf fNode (tree:Tree<'LeafData,'INodeData>) = | |
let recurse = iter fLeaf fNode | |
match tree with | |
| LeafNode leafInfo -> | |
fLeaf leafInfo | |
| InternalNode (nodeInfo,subtrees) -> | |
subtrees |> Seq.iter recurse | |
fNode nodeInfo | |
// ============================================== | |
// GiftUsingTree | |
// ============================================== | |
module GiftUsingTree = | |
type Book = {title: string; price: decimal} | |
type ChocolateType = Dark | Milk | SeventyPercent | |
type Chocolate = {chocType: ChocolateType ; price: decimal} | |
type WrappingPaperStyle = | |
| HappyBirthday | |
| HappyHolidays | |
| SolidColor | |
// unified data for non-recursive cases | |
type GiftContents = | |
| Book of Book | |
| Chocolate of Chocolate | |
// unified data for recursive cases | |
type GiftDecoration = | |
| Wrapped of WrappingPaperStyle | |
| Boxed | |
| WithACard of string | |
type Gift = Tree<GiftContents,GiftDecoration> | |
// --------------------------------- | |
// Helper functions | |
// --------------------------------- | |
let fromBook book = | |
LeafNode (Book book) | |
let fromChoc choc = | |
LeafNode (Chocolate choc) | |
let wrapInPaper paperStyle innerGift = | |
let container = Wrapped paperStyle | |
InternalNode (container, [innerGift]) | |
let putInBox innerGift = | |
let container = Boxed | |
InternalNode (container, [innerGift]) | |
let withCard message innerGift = | |
let container = WithACard message | |
InternalNode (container, [innerGift]) | |
let putTwoThingsInBox innerGift innerGift2 = | |
let container = Boxed | |
InternalNode (container, [innerGift;innerGift2]) | |
// --------------------------------- | |
// Sample data | |
// --------------------------------- | |
let wolfHall = {title="Wolf Hall"; price=20m} | |
let yummyChoc = {chocType=SeventyPercent; price=5m} | |
let birthdayPresent = | |
wolfHall | |
|> fromBook | |
|> wrapInPaper HappyBirthday | |
|> withCard "Happy Birthday" | |
let christmasPresent = | |
yummyChoc | |
|> fromChoc | |
|> putInBox | |
|> wrapInPaper HappyHolidays | |
let twoBirthdayPresents = | |
let thing1 = wolfHall |> fromBook | |
let thing2 = yummyChoc |> fromChoc | |
putTwoThingsInBox thing1 thing2 | |
|> wrapInPaper HappyBirthday | |
let twoWrappedPresentsInBox = | |
let thing1 = wolfHall |> fromBook |> wrapInPaper HappyHolidays | |
let thing2 = yummyChoc |> fromChoc |> wrapInPaper HappyBirthday | |
putTwoThingsInBox thing1 thing2 | |
// --------------------------------- | |
// "totalCost" | |
// --------------------------------- | |
let totalCost gift = | |
let fLeaf costSoFar leafData = | |
match leafData with | |
| Book book -> | |
costSoFar + book.price | |
| Chocolate choc -> | |
costSoFar + choc.price | |
let fNode costSoFar nodeData = | |
match nodeData with | |
| Wrapped style -> | |
costSoFar + 0.5m | |
| Boxed -> | |
costSoFar + 1.0m | |
| WithACard message -> | |
costSoFar + 2.0m | |
// initial accumulator | |
let initialAcc = 0m | |
// call the fold | |
Tree.fold fLeaf fNode initialAcc gift | |
// --------------------------------- | |
// testing "totalCost" | |
// --------------------------------- | |
birthdayPresent |> totalCost | |
// 22.5m | |
christmasPresent |> totalCost | |
// 6.5m | |
twoBirthdayPresents |> totalCost | |
// 26.5m | |
// --------------------------------- | |
// "description" | |
// --------------------------------- | |
let description gift = | |
let fLeaf leafData = | |
match leafData with | |
| Book book -> | |
sprintf "'%s'" book.title | |
| Chocolate choc -> | |
sprintf "%A chocolate" choc.chocType | |
let fNode nodeData innerTexts = | |
let innerText = String.concat " & " innerTexts | |
match nodeData with | |
| Wrapped style -> | |
sprintf "%s wrapped in %A paper" innerText style | |
| Boxed -> | |
sprintf "%s in a box" innerText | |
| WithACard message -> | |
sprintf "%s with a card saying '%s'" innerText message | |
// main call | |
Tree.cata fLeaf fNode gift | |
// --------------------------------- | |
// testing "description" | |
// --------------------------------- | |
birthdayPresent |> description | |
// "'Wolf Hall' wrapped in HappyBirthday paper with a card saying 'Happy Birthday'" | |
christmasPresent |> description | |
// "SeventyPercent chocolate in a box wrapped in HappyHolidays paper" | |
twoBirthdayPresents |> description | |
// "'Wolf Hall' & SeventyPercent chocolate in a box wrapped in HappyBirthday paper" | |
twoWrappedPresentsInBox |> description | |
// "'Wolf Hall' wrapped in HappyHolidays paper & SeventyPercent chocolate wrapped in HappyBirthday paper in a box" | |
// --------------------------------- | |
// "whatsInside" | |
// --------------------------------- | |
let whatsInside gift = | |
let fLeaf leafData = | |
match leafData with | |
| Book book -> | |
"a book" | |
| Chocolate choc -> | |
"some chocolate" | |
let fNode nodeData innerTexts = | |
// convert to single string | |
String.concat " & " innerTexts | |
// main call | |
Tree.cata fLeaf fNode gift | |
// --------------------------------- | |
// testing "whatsInside" | |
// --------------------------------- | |
twoBirthdayPresents |> whatsInside | |
// "a book and some chocolate" | |
christmasPresent |> whatsInside | |
// "some chocolate" | |
twoWrappedPresentsInBox |> whatsInside | |
// "a book & some chocolate" | |
// ============================================== | |
// Json serialization without error handling | |
// ============================================== | |
#r "System.Runtime.Serialization.dll" | |
module JsonSerializer_WithoutErrorHandling = | |
open System.Runtime.Serialization | |
open System.Runtime.Serialization.Json | |
let toJson (o:'a) = | |
let serializer = new DataContractJsonSerializer(typeof<'a>) | |
let encoding = System.Text.UTF8Encoding() | |
use stream = new System.IO.MemoryStream() | |
serializer.WriteObject(stream,o) | |
stream.Close() | |
encoding.GetString(stream.ToArray()) | |
let fromJson<'a> str = | |
let serializer = new DataContractJsonSerializer(typeof<'a>) | |
let encoding = System.Text.UTF8Encoding() | |
use stream = new System.IO.MemoryStream(encoding.GetBytes(s=str)) | |
let obj = serializer.ReadObject(stream) | |
obj :?> 'a | |
// ============================================== | |
// TreeDto conversion without error handling | |
// ============================================== | |
module TreeDto_WithoutErrorHandling = | |
open Tree | |
/// A DTO that represents a Tree | |
/// The Leaf/Node choice is turned into a record | |
[<CLIMutableAttribute>] | |
type TreeDto<'LeafData,'NodeData> = { | |
leafData : 'LeafData | |
nodeData : 'NodeData | |
subtrees : TreeDto<'LeafData,'NodeData>[] } | |
/// Transform a Tree into a TreeDto | |
let treeToDto tree : TreeDto<'LeafData,'NodeData> = | |
let fLeaf leafData = | |
let nodeData = Unchecked.defaultof<'NodeData> | |
let subtrees = [||] | |
{leafData=leafData; nodeData=nodeData; subtrees=subtrees} | |
let fNode nodeData subtrees = | |
let leafData = Unchecked.defaultof<'NodeData> | |
let subtrees = subtrees |> Seq.toArray | |
{leafData=leafData; nodeData=nodeData; subtrees=subtrees} | |
// recurse to build up the TreeDto | |
Tree.cata fLeaf fNode tree | |
/// Transform a TreeDto into Tree | |
let rec dtoToTree (treeDto:TreeDto<'Leaf,'Node>) :Tree<'Leaf,'Node> = | |
let nullLeaf = Unchecked.defaultof<'Leaf> | |
let nullNode = Unchecked.defaultof<'Node> | |
// check if there is nodeData present | |
if treeDto.nodeData <> nullNode then | |
if treeDto.subtrees = null then | |
failwith "subtrees must not be null if node data present" | |
else | |
let subtrees = treeDto.subtrees |> Array.map dtoToTree | |
InternalNode (treeDto.nodeData,subtrees) | |
// check if there is leafData present | |
elif treeDto.leafData <> nullLeaf then | |
LeafNode (treeDto.leafData) | |
// if both missing then fail | |
else | |
failwith "expecting leaf or node data" | |
// ============================================== | |
// GiftDto conversion without error handling | |
// ============================================== | |
module GiftDtoExample_WithoutErrorHandling = | |
open System | |
open System.Collections.Generic | |
open GiftUsingTree | |
// unified data for non-recursive cases | |
[<CLIMutableAttribute>] | |
type GiftContentsDto = { | |
discriminator : string // "Book" or "Chocolate" | |
// for "Book" case only | |
bookTitle: string | |
// for "Chocolate" case only | |
chocolateType : string // one of "Dark" "Milk" "SeventyPercent" | |
// for all cases | |
price: decimal | |
} | |
// unified data for recursive cases | |
[<CLIMutableAttribute>] | |
type GiftDecorationDto = { | |
discriminator: string // "Wrapped" or "Boxed" or "WithACard" | |
// for "Wrapped" case only | |
wrappingPaperStyle: string // "HappyBirthday" or "HappyHolidays" or "SolidColor" | |
// for "WithACard" case only | |
message: string | |
} | |
type GiftDto = Tree<GiftContentsDto,GiftDecorationDto> | |
// --------------------------------- | |
// giftToDto | |
// --------------------------------- | |
/// transform a Gift to a GiftDto | |
let giftToDto (gift:Gift) :GiftDto = | |
let fLeaf leafData :GiftContentsDto = | |
match leafData with | |
| Book book -> | |
{discriminator= "Book"; bookTitle=book.title; chocolateType=null; price=book.price} | |
| Chocolate choc -> | |
let chocolateType = sprintf "%A" choc.chocType | |
{discriminator= "Chocolate"; bookTitle=null; chocolateType=chocolateType; price=choc.price} | |
let fNode nodeData :GiftDecorationDto = | |
match nodeData with | |
| Wrapped style -> | |
let wrappingPaperStyle = sprintf "%A" style | |
{discriminator= "Wrapped"; wrappingPaperStyle=wrappingPaperStyle; message=null} | |
| Boxed -> | |
{discriminator= "Boxed"; wrappingPaperStyle=null; message=null} | |
| WithACard message -> | |
{discriminator= "WithACard"; wrappingPaperStyle=null; message=message} | |
// main call | |
Tree.map fLeaf fNode gift | |
// --------------------------------- | |
// dtoToGift (more complicated!) | |
// --------------------------------- | |
let strToBookTitle str = | |
match str with | |
| null -> failwith "BookTitle must not be null" | |
| _ -> str | |
let strToChocolateType str = | |
match str with | |
| "Dark" -> Dark | |
| "Milk" -> Milk | |
| "SeventyPercent" -> SeventyPercent | |
| _ -> failwithf "ChocolateType %s not recognized" str | |
let strToWrappingPaperStyle str = | |
match str with | |
| "HappyBirthday" -> HappyBirthday | |
| "HappyHolidays" -> HappyHolidays | |
| "SolidColor" -> SolidColor | |
| _ -> failwithf "WrappingPaperStyle %s not recognized" str | |
let strToCardMessage str = | |
match str with | |
| null -> failwith "CardMessage must not be null" | |
| _ -> str | |
let bookFromDto (dto:GiftContentsDto) = | |
let bookTitle = strToBookTitle dto.bookTitle | |
Book {title=bookTitle; price=dto.price} | |
let chocolateFromDto (dto:GiftContentsDto) = | |
let chocType = strToChocolateType dto.chocolateType | |
Chocolate {chocType=chocType; price=dto.price} | |
let wrappedFromDto (dto:GiftDecorationDto) = | |
let wrappingPaperStyle = strToWrappingPaperStyle dto.wrappingPaperStyle | |
Wrapped wrappingPaperStyle | |
let boxedFromDto (dto:GiftDecorationDto) = | |
Boxed | |
let withACardFromDto (dto:GiftDecorationDto) = | |
let message = strToCardMessage dto.message | |
WithACard message | |
/// Transform a GiftDto to a Gift | |
let dtoToGift (giftDto:GiftDto) :Gift= | |
let fLeaf (leafDto:GiftContentsDto) = | |
match leafDto.discriminator with | |
| "Book" -> bookFromDto leafDto | |
| "Chocolate" -> chocolateFromDto leafDto | |
| _ -> failwithf "Unknown leaf discriminator '%s'" leafDto.discriminator | |
let fNode (nodeDto:GiftDecorationDto) = | |
match nodeDto.discriminator with | |
| "Wrapped" -> wrappedFromDto nodeDto | |
| "Boxed" -> boxedFromDto nodeDto | |
| "WithACard" -> withACardFromDto nodeDto | |
| _ -> failwithf "Unknown node discriminator '%s'" nodeDto.discriminator | |
// map the tree | |
Tree.map fLeaf fNode giftDto | |
// --------------------------------- | |
// testing | |
// --------------------------------- | |
open JsonSerializer_WithoutErrorHandling | |
open TreeDto_WithoutErrorHandling | |
let goodJson = christmasPresent |> giftToDto |> treeToDto |> toJson | |
let goodGift = goodJson |> fromJson |> dtoToTree |> dtoToGift | |
goodGift |> description | |
// Success "SeventyPercent chocolate in a box wrapped in HappyHolidays paper" | |
let badJson1 = goodJson.Replace("leafData","leafDataXX") | |
let badJson1_result = badJson1 |> fromJson |> dtoToTree |> dtoToGift | |
// Exception "The data contract type 'TreeDto' cannot be deserialized because the required data member 'leafData@' was not found." | |
let badJson2 = goodJson.Replace("Wrapped","Wrapped2") | |
let badJson2_result = badJson2 |> fromJson |> dtoToTree |> dtoToGift | |
// Exception "Unknown node discriminator 'Wrapped2'" | |
let badJson3 = goodJson.Replace("HappyHolidays","HappyHolidays2") | |
let badJson3_result = badJson3 |> fromJson |> dtoToTree |> dtoToGift | |
// Exception "WrappingPaperStyle HappyHolidays2 not recognized" | |
// goodJson value | |
(* | |
"{"leafData@":null,"nodeData@":{"discriminator@":"Wrapped","message@":null,"wrappingPaperStyle@":"HappyHolidays"},"subtrees@":[{"leafData@":null,"nodeData@":{"discriminator@":"Boxed","message@":null,"wrappingPaperStyle@":null},"subtrees@":[{"leafData@":{"bookTitle@":null,"chocolateType@":"SeventyPercent","discriminator@":"Chocolate","price@":5},"nodeData@":null,"subtrees@":[]}]}]}" | |
{ | |
"leafData@": null, | |
"nodeData@": { | |
"discriminator@": "Wrapped", | |
"message@": null, | |
"wrappingPaperStyle@": "HappyHolidays" | |
}, | |
"subtrees@": [ | |
{ | |
"leafData@": null, | |
"nodeData@": { | |
"discriminator@": "Boxed", | |
"message@": null, | |
"wrappingPaperStyle@": null | |
}, | |
"subtrees@": [ | |
{ | |
"leafData@": { | |
"bookTitle@": null, | |
"chocolateType@": "SeventyPercent", | |
"discriminator@": "Chocolate", | |
"price@": 5 | |
}, | |
"nodeData@": null, | |
"subtrees@": [] | |
} | |
] | |
} | |
] | |
} | |
*) | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment