Introduction to recursive types and catamorphisms. Related blog post: http://fsharpforfunandprofit.com/posts/recursive-types-and-folds/

RecursiveTypesAndFold-1.fsx

(*
RecursiveTypesAndFold-1.fsx

Related blog post: http://fsharpforfunandprofit.com/posts/recursive-types-and-folds/
*)
 
// ==============================================
// PART 1 - Introduction to recursive types and catamorphisms
// ==============================================


// =======================
// Gift domain
// =======================

type Book = {title: string; price: decimal}

type ChocolateType = Dark | Milk | SeventyPercent
type Chocolate = {chocType: ChocolateType ; price: decimal}

type WrappingPaperStyle = 
    | HappyBirthday
    | HappyHolidays
    | SolidColor

type Gift =
    | Book of Book
    | Chocolate of Chocolate 
    | Wrapped of Gift * WrappingPaperStyle
    | Boxed of Gift 
    | WithACard of Gift * message:string

// ---------------------------------
// Sample data
// ---------------------------------

// A Book
let wolfHall = {title="Wolf Hall"; price=20m}

// A Chocolate
let yummyChoc = {chocType=SeventyPercent; price=5m}

// A Gift
let birthdayPresent = WithACard (Wrapped (Book wolfHall, HappyBirthday), "Happy Birthday")
//  WithACard (
//    Wrapped (
//      Book {title = "Wolf Hall"; price = 20M},
//      HappyBirthday),
//    "Happy Birthday")

// A Gift
let christmasPresent = Wrapped (Boxed (Chocolate yummyChoc), HappyHolidays)
//  Wrapped (
//    Boxed (
//      Chocolate {chocType = SeventyPercent; price = 5M}),
//    HappyHolidays)

// ---------------------------------
// RULE: A recursive type must have a least one case that is not recursive
// ---------------------------------

module ImpossibleGift  =
    type ImpossibleGift =
        | Wrapped of ImpossibleGift * WrappingPaperStyle
        | Boxed of ImpossibleGift
        | WithACard of ImpossibleGift* message:string

    let rec a() = Boxed <| b()
    and b() = Boxed <| a()

    //a()

// ---------------------------------
// "description"
// ---------------------------------

let rec description gift =
    match gift with 
    | Book book -> 
        sprintf "'%s'" book.title 
    | Chocolate choc -> 
        sprintf "%A chocolate" choc.chocType
    | Wrapped (innerGift,style) -> 
        sprintf "%s wrapped in %A paper" (description innerGift) style
    | Boxed innerGift -> 
        sprintf "%s in a box" (description innerGift) 
    | WithACard (innerGift,message) -> 
        sprintf "%s with a card saying '%s'" (description innerGift) message

// ---------------------------------
// 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"

// ---------------------------------
// "totalCost"
// ---------------------------------

let rec totalCost gift =
    match gift with 
    | Book book -> 
        book.price
    | Chocolate choc -> 
        choc.price
    | Wrapped (innerGift,style) -> 
        (totalCost innerGift) + 0.5m
    | Boxed innerGift -> 
        (totalCost innerGift) + 1.0m
    | WithACard (innerGift,message) -> 
        (totalCost innerGift) + 2.0m

// ---------------------------------
// testing "totalCost"
// ---------------------------------

birthdayPresent |> totalCost 
// 22.5m

christmasPresent |> totalCost 
// 6.5m

// ---------------------------------
// "whatsInside"
// ---------------------------------

let rec whatsInside gift =
    match gift with 
    | Book book -> 
        "A book"
    | Chocolate choc -> 
        "Some chocolate"
    | Wrapped (innerGift,style) -> 
        whatsInside innerGift
    | Boxed innerGift -> 
        whatsInside innerGift
    | WithACard (innerGift,message) -> 
        whatsInside innerGift

// ---------------------------------
// testing "whatsInside"
// ---------------------------------

birthdayPresent |> whatsInside 
// "A book"

christmasPresent |> whatsInside 
// "Some chocolate"

// =======================
// Catamorphism - Parameterize all the things
// =======================

// Version 1
let rec cataGift fBook fChocolate fWrapped fBox fCard gift =
    match gift with 
    | Book book -> 
        fBook book
    | Chocolate choc -> 
        fChocolate choc
    | Wrapped (innerGift,style) -> 
        let innerGiftResult = cataGift fBook fChocolate fWrapped fBox fCard innerGift
        fWrapped (innerGiftResult,style)
    | Boxed innerGift -> 
        let innerGiftResult = cataGift fBook fChocolate fWrapped fBox fCard innerGift
        fBox innerGiftResult 
    | WithACard (innerGift,message) -> 
        let innerGiftResult = cataGift fBook fChocolate fWrapped fBox fCard innerGift
        fCard (innerGiftResult,message) 

// Version 2 - define "recurse"
let rec cataGift2 fBook fChocolate fWrapped fBox fCard gift =
    let recurse = cataGift fBook fChocolate fWrapped fBox fCard
    match gift with 
    | Book book -> 
        fBook book
    | Chocolate choc -> 
        fChocolate choc
    | Wrapped (innerGift,style) -> 
        let innerGiftResult = recurse innerGift
        fWrapped (innerGiftResult,style)
    | Boxed innerGift -> 
        let innerGiftResult = recurse innerGift
        fBox innerGiftResult 
    | WithACard (innerGift,message) -> 
        let innerGiftResult = recurse innerGift
        fCard (innerGiftResult,message) 

// Version 3 - use "recurse" directly
let rec cataGift3 fBook fChocolate fWrapped fBox fCard gift =
    let recurse = cataGift fBook fChocolate fWrapped fBox fCard
    match gift with 
    | Book book -> 
        fBook book
    | Chocolate choc -> 
        fChocolate choc
    | Wrapped (gift,style) -> 
        fWrapped (recurse gift,style)
    | Boxed gift -> 
        fBox (recurse gift)
    | WithACard (gift,message) -> 
        fCard (recurse gift,message) 

// Version 4 - name the return type 'r
let rec cataGift4 fBook fChocolate fWrapped fBox fCard gift :'r =
//                                 name the return type =>  ~~~~ 
    let recurse = cataGift fBook fChocolate fWrapped fBox fCard
    match gift with 
    | Book book -> 
        fBook book
    | Chocolate choc -> 
        fChocolate choc
    | Wrapped (gift,style) -> 
        fWrapped (recurse gift,style)
    | Boxed gift -> 
        fBox (recurse gift)
    | WithACard (gift,message) -> 
        fCard (recurse gift,message) 

(*
val cataGift :
  fBook:(Book -> 'r) ->
  fChocolate:(Chocolate -> 'r) ->
  fWrapped:('r * WrappingPaperStyle -> 'r) ->
  fBox:('r -> 'r) ->
  fCard:('r * string -> 'r) -> 
  // input value
  gift:Gift -> 
  // return value
  'r
*)


// =======================
// Rules for creating catamorphisms
//
//    * Create a function parameter to handle each case in the structure.
//    * For non-recursive cases, pass the function parameter all the data associated with that case.
//    * For recursive cases, perform two steps:
//      * First, call the catamorphism recursively on the nested value.
//      * Then pass the handler all the data associated with that case, but with the result of the catamorphism replacing the original nested value.
//
// =======================

// ---------------------------------
// defining and testing "totalCostUsingCata"
// ---------------------------------

let totalCostUsingCata gift =
    let fBook (book:Book) = 
        book.price
    let fChocolate (choc:Chocolate) = 
        choc.price
    let fWrapped  (innerCost,style) = 
        innerCost + 0.5m
    let fBox innerCost = 
        innerCost + 1.0m
    let fCard (innerCost,message) = 
        innerCost + 2.0m
    // call the catamorphism
    cataGift fBook fChocolate fWrapped fBox fCard gift

// benefits removed pattern matching
// means we can pass in lambdas to define on the fly

birthdayPresent |> totalCostUsingCata 
// 22.5m

(*
// The Gift.Book constructor 
Book -> Gift

// The fBook handler
Book -> 'r

// The Gift.Wrapped constructor 
Gift * WrappingPaperStyle -> Gift

// The fWrapped handler
'r   * WrappingPaperStyle -> 'r

// The Gift.Boxed constructor 
Gift -> Gift

// The fBox handler
'r   -> 'r

*)

// ---------------------------------
// defining and testing "descriptionUsingCata"
// ---------------------------------

let descriptionUsingCata gift =
    let fBook (book:Book) = 
        sprintf "'%s'" book.title 
    let fChocolate (choc:Chocolate) = 
        sprintf "%A chocolate" choc.chocType
    let fWrapped  (innerText,style) = 
        sprintf "%s wrapped in %A paper" innerText style
    let fBox innerText = 
        sprintf "%s in a box" innerText
    let fCard (innerText,message) = 
        sprintf "%s with a card saying '%s'" innerText message
    // call the catamorphism
    cataGift fBook fChocolate fWrapped fBox fCard gift

birthdayPresent |> descriptionUsingCata  
// "'Wolf Hall' wrapped in HappyBirthday paper with a card saying 'Happy Birthday'"

christmasPresent |> descriptionUsingCata  
// "SeventyPercent chocolate in a box wrapped in HappyHolidays paper"

// =======================
// Benefit 1 - Structure hiding
// =======================

module UsingCatasForStructureHiding = 

    module V1 = 
        type Gift =
            | Book of Book
            | Chocolate of Chocolate 
            | Wrapped of Gift * WrappingPaperStyle
            | Boxed of Gift 

        let rec cataGift fBook fChocolate fWrapped fBox gift :'r =
            let recurse = cataGift fBook fChocolate fWrapped fBox 
            match gift with 
            | Book book -> 
                fBook book
            | Chocolate choc -> 
                fChocolate choc
            | Wrapped (gift,style) -> 
                fWrapped (recurse gift,style)
            | Boxed gift -> 
                fBox (recurse gift)
    module V2 = 

        type Gift =
            | Book of Book
            | Chocolate of Chocolate 
            | Wrapped of Gift * WrappingPaperStyle
            | Boxed of Gift 
            | WithACard of Gift * message:string

        /// Uses Gift_V2 but is still backwards compatible with the earlier design.
        let rec cataGift fBook fChocolate fWrapped fBox gift :'r =
            let recurse = cataGift fBook fChocolate fWrapped fBox 
            match gift with 
            | Book book -> 
                fBook book
            | Chocolate choc -> 
                fChocolate choc
            | Wrapped (gift,style) -> 
                fWrapped (recurse gift,style)
            | Boxed gift -> 
                fBox (recurse gift)
            // pass through the new case silently
            | WithACard (gift,message) -> 
                recurse gift

    module ActivePatterns =
        open V2

        let rec (|Book|Chocolate|Wrapped|Boxed|) gift =
            match gift with 
            | Gift.Book book -> 
                Book book
            | Gift.Chocolate choc -> 
                Chocolate choc
            | Gift.Wrapped (gift,style) -> 
                Wrapped (gift,style)
            | Gift.Boxed gift -> 
                Boxed gift
            | Gift.WithACard (gift,message) -> 
                // ignore the message and recurse into the gift
                (|Book|Chocolate|Wrapped|Boxed|) gift

        let birthdayPresent = WithACard (Wrapped (Book wolfHall, HappyBirthday), "Happy Birthday")

        let rec whatsInside gift =
            match gift with 
            | Book book -> 
                "A book"
            | Chocolate choc -> 
                "Some chocolate"
            | Wrapped (gift,style) -> 
                whatsInside gift
            | Boxed gift -> 
                whatsInside gift

// =======================
// Benefit 2 - functions
// =======================

let handleContents fBook fChocolate gift =
    let fWrapped (innerGiftResult,style) =   
        innerGiftResult
    let fBox innerGiftResult = 
        innerGiftResult
    let fCard (innerGiftResult,message) = 
        innerGiftResult

    // call the catamorphism
    cataGift fBook fChocolate fWrapped fBox fCard gift

birthdayPresent 
|> handleContents 
    (fun book -> "The book you wanted for your birthday") 
    (fun choc -> "Your fave chocolate")
// Result => "The book you wanted for your birthday"

christmasPresent 
|> handleContents 
    (fun book -> "The book you wanted for Christmas") 
    (fun choc -> "Don't eat too much over the holidays!")
// Result => "Don't eat too much over the holidays!"


// ==============================================
// Benefit 3 - Cata as a mapper
// ==============================================
module ChocolateFreeGift =

    type GiftMinusChocolate =
        | Book of Book
        | Apology of string
        | Wrapped of GiftMinusChocolate * WrappingPaperStyle

    let removeChocolate gift =
        let fBook (book:Book) = 
            Book book
        let fChocolate (choc:Chocolate) = 
            Apology "sorry I ate your chocolate"
        let fWrapped (innerGiftResult,style) = 
            Wrapped (innerGiftResult,style) 
        let fBox innerGiftResult = 
            innerGiftResult
        let fCard (innerGiftResult,message) = 
            innerGiftResult
        // call the catamorphism
        cataGift fBook fChocolate fWrapped fBox fCard gift

    birthdayPresent |> removeChocolate
    // GiftMinusChocolate = Wrapped (Book {title = "Wolf Hall"; price = 20M}, HappyBirthday)

    christmasPresent |> removeChocolate
    // GiftMinusChocolate = Wrapped (Apology "sorry I ate your chocolate", HappyHolidays)


// ==============================================
// Benefit 3b - Cata as a constructor
// ==============================================


let deepCopy gift =
    let fBook book = 
        Book book 
    let fChocolate (choc:Chocolate) = 
        Chocolate choc
    let fWrapped (innerGiftResult,style) = 
        Wrapped (innerGiftResult,style) 
    let fBox innerGiftResult = 
        Boxed innerGiftResult
    let fCard (innerGiftResult,message) = 
        WithACard (innerGiftResult,message) 
    // call the catamorphism
    cataGift fBook fChocolate fWrapped fBox fCard gift

let deepCopy_shorter gift =
    let fBook = Book 
    let fChocolate = Chocolate 
    let fWrapped = Wrapped 
    let fBox = Boxed 
    let fCard = WithACard 
    // call the catamorphism
    cataGift fBook fChocolate fWrapped fBox fCard gift

christmasPresent |> deepCopy
// Result => 
//   Wrapped ( 
//    Boxed (Chocolate {chocType = SeventyPercent; price = 5M;}),
//    HappyHolidays)

// ==============================================
// Benefit 3c - upgradeChocolate using cata as a constructor
// ==============================================

let upgradeChocolate gift =
    let fBook = Book 
    let fChocolate (choc:Chocolate) = 
        Chocolate {choc with chocType = SeventyPercent}
    let fWrapped = Wrapped 
    let fBox = Boxed 
    let fCard = WithACard 
    // call the catamorphism
    cataGift fBook fChocolate fWrapped fBox fCard gift

// create some chocolate I don't like
let cheapChoc = Boxed (Chocolate {chocType=Milk; price=5m})

// upgrade it!
cheapChoc |> upgradeChocolate
// Result =>
//   Boxed (Chocolate {chocType = SeventyPercent; price = 5M})