Serializing and deserializing a tree to JSON. Related blog post: http://fsharpforfunandprofit.com/posts/recursive-types-and-folds-3b/

RecursiveTypesAndFold-3b-json.fsx

(*
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@": []
        }
      ]
    }
  ]
}

*)