Skip to content

Instantly share code, notes, and snippets.

@swlaschin
Created August 30, 2015 12:50
Show Gist options
  • Save swlaschin/60938b4417d12cfa0a97 to your computer and use it in GitHub Desktop.
Save swlaschin/60938b4417d12cfa0a97 to your computer and use it in GitHub Desktop.
Introduction to recursive types and catamorphisms. Related blog post: http://fsharpforfunandprofit.com/posts/recursive-types-and-folds/
(*
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})
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment