Last active
August 30, 2015 19:53
-
-
Save swlaschin/2b06fe266e3299a656c1 to your computer and use it in GitHub Desktop.
Serializing and deserializing a tree to JSON (with error handling). 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-with-error-handling.fsx | |
Related blog post: http://fsharpforfunandprofit.com/posts/recursive-types-and-folds-3b/ | |
*) | |
// ============================================== | |
// PART 3b - Serializing and deserializing a tree to JSON (with 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" | |
// ============================================== | |
// Result type for error handling | |
// ============================================== | |
type Result<'a> = | |
| Success of 'a | |
| Failure of string list | |
module Result = | |
let retn x = | |
Success x | |
let failWithMsg msg = | |
Failure [msg] | |
let bind f xR = | |
match xR with | |
| Success x -> f x | |
| Failure errs -> Failure errs | |
let map f xR = | |
match xR with | |
| Success x -> Success (f x) | |
| Failure errs -> Failure errs | |
let apply fR xR = | |
match fR,xR with | |
| Success f, Success x -> Success (f x) | |
| Failure errs, Success x -> Failure errs | |
| Success f, Failure errs -> Failure errs | |
| Failure errs1, Failure errs2 -> Failure (errs1 @ errs2) | |
let lift2 f x y = | |
let (<!>) = map | |
let (<*>) = apply | |
f <!> x <*> y | |
let lift3 f x y z = | |
let (<!>) = map | |
let (<*>) = apply | |
f <!> x <*> y <*> z | |
/// Convert a list of Results into a Result of list | |
let sequenceList listOfResult = | |
// from the lower level | |
let (<*>) = apply | |
// from the traversable level | |
let cons head tail = head :: tail | |
// do the traverse | |
let folder head tail = | |
retn cons <*> head <*> tail | |
List.foldBack folder listOfResult (retn []) | |
/// Convert a seq of Results into a Result of seq | |
let sequenceSeq seqOfResult = | |
seqOfResult | |
|> List.ofSeq | |
|> sequenceList | |
|> map (List.toSeq) | |
// ============================================== | |
// Json serialization with error handling | |
// ============================================== | |
#r "System.Runtime.Serialization.dll" | |
module JsonSerializer_WithErrorHandling = | |
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 = | |
try | |
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 | |
|> Result.retn | |
with | |
| ex -> | |
Result.failWithMsg ex.Message | |
// ============================================== | |
// TreeDto conversion with error handling | |
// ============================================== | |
module TreeDto_WithErrorHandling = | |
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 dtoToTreeOfResults (treeDto:TreeDto<'Leaf,'Node>) :Tree<Result<'Leaf>,Result<'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 | |
LeafNode <| Result.failWithMsg "subtrees must not be null if node data present" | |
else | |
let subtrees = treeDto.subtrees |> Array.map dtoToTreeOfResults | |
InternalNode (Result.retn treeDto.nodeData,subtrees) | |
// check if there is leafData present | |
elif treeDto.leafData <> nullLeaf then | |
LeafNode <| Result.retn (treeDto.leafData) | |
// if both missing then fail | |
else | |
LeafNode <| Result.failWithMsg "expecting leaf or node data" | |
// val dtoToTreeOfResults : | |
// treeDto:TreeDto<'Leaf,'Node> -> Tree<Result<'Leaf>,Result<'Node>> | |
/// Convert a tree of Results into a Result of tree | |
let sequenceTreeOfResult tree = | |
// from the lower level | |
let (<*>) = Result.apply | |
let retn = Result.retn | |
// from the traversable level | |
let fLeaf data = | |
retn LeafNode <*> data | |
let fNode data subitems = | |
let makeNode data items = InternalNode(data,items) | |
let subItems = Result.sequenceSeq subitems | |
retn makeNode <*> data <*> subItems | |
// do the traverse | |
Tree.cata fLeaf fNode tree | |
// val sequenceTreeOfResult : | |
// tree:Tree<Result<'a>,Result<'b>> -> Result<Tree<'a,'b>> | |
let dtoToTree treeDto = | |
treeDto |> dtoToTreeOfResults |> sequenceTreeOfResult | |
// val dtoToTree : | |
// treeDto:TreeDto<'a,'b> -> Result<Tree<'a,'b>> | |
// ============================================== | |
// GiftDto conversion with error handling | |
// ============================================== | |
module GiftDtoExample_WithErrorHandling = | |
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 -> Result.failWithMsg "BookTitle must not be null" | |
| _ -> Result.retn str | |
let strToChocolateType str = | |
match str with | |
| "Dark" -> Result.retn Dark | |
| "Milk" -> Result.retn Milk | |
| "SeventyPercent" -> Result.retn SeventyPercent | |
| _ -> Result.failWithMsg (sprintf "ChocolateType %s not recognized" str) | |
let strToWrappingPaperStyle str = | |
match str with | |
| "HappyBirthday" -> Result.retn HappyBirthday | |
| "HappyHolidays" -> Result.retn HappyHolidays | |
| "SolidColor" -> Result.retn SolidColor | |
| _ -> Result.failWithMsg (sprintf "WrappingPaperStyle %s not recognized" str) | |
let strToCardMessage str = | |
match str with | |
| null -> Result.failWithMsg "CardMessage must not be null" | |
| _ -> Result.retn str | |
let bookFromDto (dto:GiftContentsDto) = | |
let book bookTitle price = | |
Book {title=bookTitle; price=price} | |
let bookTitle = strToBookTitle dto.bookTitle | |
let price = Result.retn dto.price | |
Result.lift2 book bookTitle price | |
let chocolateFromDto (dto:GiftContentsDto) = | |
let choc chocType price = | |
Chocolate {chocType=chocType; price=price} | |
let chocType = strToChocolateType dto.chocolateType | |
let price = Result.retn dto.price | |
Result.lift2 choc chocType price | |
let wrappedFromDto (dto:GiftDecorationDto) = | |
let wrappingPaperStyle = strToWrappingPaperStyle dto.wrappingPaperStyle | |
Result.map Wrapped wrappingPaperStyle | |
let boxedFromDto (dto:GiftDecorationDto) = | |
Result.retn Boxed | |
let withACardFromDto (dto:GiftDecorationDto) = | |
let message = strToCardMessage dto.message | |
Result.map WithACard message | |
open TreeDto_WithErrorHandling | |
/// Transform a GiftDto to a Result<Gift> | |
let dtoToGift (giftDto:GiftDto) :Result<Gift>= | |
let fLeaf (leafDto:GiftContentsDto) = | |
match leafDto.discriminator with | |
| "Book" -> bookFromDto leafDto | |
| "Chocolate" -> chocolateFromDto leafDto | |
| _ -> Result.failWithMsg (sprintf "Unknown leaf discriminator '%s'" leafDto.discriminator) | |
let fNode (nodeDto:GiftDecorationDto) = | |
match nodeDto.discriminator with | |
| "Wrapped" -> wrappedFromDto nodeDto | |
| "Boxed" -> boxedFromDto nodeDto | |
| "WithACard" -> withACardFromDto nodeDto | |
| _ -> Result.failWithMsg (sprintf "Unknown node discriminator '%s'" nodeDto.discriminator) | |
// map the tree | |
Tree.map fLeaf fNode giftDto |> sequenceTreeOfResult | |
// val dtoToGift : | |
// giftDto:GiftDto -> Result<Gift> | |
// --------------------------------- | |
// testing | |
// --------------------------------- | |
open JsonSerializer_WithErrorHandling | |
let goodJson = christmasPresent |> giftToDto |> treeToDto |> toJson | |
let goodGift = goodJson |> fromJson |> Result.bind dtoToTree |> Result.bind dtoToGift | |
goodGift |> Result.map description | |
// Success "SeventyPercent chocolate in a box wrapped in HappyHolidays paper" | |
let badJson1 = goodJson.Replace("leafData","leafDataXX") | |
let badJson1_result = badJson1 |> fromJson |> Result.bind dtoToTree |> Result.bind dtoToGift | |
// Failure ["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 |> Result.bind dtoToTree |> Result.bind dtoToGift | |
// Failure ["Unknown node discriminator 'Wrapped2'"] | |
let badJson3 = goodJson.Replace("HappyHolidays","HappyHolidays2") | |
let badJson3_result = badJson3 |> fromJson |> Result.bind dtoToTree |> Result.bind dtoToGift | |
// Failure ["WrappingPaperStyle HappyHolidays2 not recognized"] | |
// cause two errors | |
let badJson4 = goodJson.Replace("HappyHolidays","HappyHolidays2").Replace("SeventyPercent","SeventyPercent2") | |
let badJson4_result = badJson4 |> fromJson |> Result.bind dtoToTree |> Result.bind dtoToGift | |
// Failure ["WrappingPaperStyle HappyHolidays2 not recognized"; | |
// "ChocolateType SeventyPercent2 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