Generic recursive types. Related blog post: http://fsharpforfunandprofit.com/posts/recursive-types-and-folds-3/

RecursiveTypesAndFold-3.fsx

(*
RecursiveTypesAndFold-3.fsx

Related blog post: http://fsharpforfunandprofit.com/posts/recursive-types-and-folds-3/
*)

// ==============================================
// PART 3 - Generic recursive types
// ==============================================


// ==============================================
// LinkedList
// ==============================================

type LinkedList<'a> = 
    | Empty
    | Cons of head:'a * tail:LinkedList<'a>

let linkedList = Cons (1, Cons (2, Cons(3, Empty)))  
// same as 1 :: 2 :: 3 :: []
// or      [1; 2; 3]

module LinkedList = 

    let rec cata fCons fEmpty list :'r=
        let recurse = cata fCons fEmpty 
        match list with
        | Empty -> 
            fEmpty
        | Cons (element,list) -> 
            fCons element (recurse list)
    (*
    val cata : 
        fCons:('a -> 'r -> 'r) -> 
        fEmpty:'r -> 
        list:LinkedList<'a> 
        -> 'r
    *)

    let rec foldWithEmpty fCons fEmpty acc list :'r=
        let recurse = foldWithEmpty fCons fEmpty 
        match list with
        | Empty -> 
            fEmpty acc 
        | Cons (element,list) -> 
            let newAcc = fCons acc element 
            recurse newAcc list

    let rec fold fCons acc list :'r =
        let recurse = fold fCons 
        match list with
        | Empty -> 
            acc 
        | Cons (element,list) -> 
            let newAcc = fCons acc element 
            recurse newAcc list
    (*
    val fold : 
        fCons:('State -> 'a -> 'State) -> 
        acc:'State -> 
        list:LinkedList<'a> -> 
        'State

    // comparing fold with List version
    LinkedList.fold' : ('r     -> 'a -> 'r    ) -> 'r      -> LinkedList<'a> -> 'r
    List.fold        : ('State -> 'T -> 'State) -> 'State -> 'T list         -> 'State
    *)

    let foldBack fCons list acc :'r=
        let fEmpty' generator = 
            generator acc 
        let fCons' generator element= 
            fun innerResult -> 
                let newResult = fCons element innerResult 
                generator newResult 
        let initialGenerator = id
        foldWithEmpty fCons' fEmpty' initialGenerator  list 

    (*
    // comparing foldBack with List version
    LinkedList.foldBack : ('a -> 'r     -> 'r    ) -> LinkedList<'a> -> 'r     -> 'r
    List.foldBack       : ('T -> 'State -> 'State) -> 'T list        -> 'State -> 'State
    *)

    let toList linkedList = 
        let fCons head tail = head::tail
        let initialState = [] 
        foldBack fCons linkedList initialState 

    let ofList list = 
        let fCons head tail = Cons(head,tail)
        let initialState = Empty
        List.foldBack fCons list initialState 

    // ---------------------------------
    // Using fold to implement other functions
    // ---------------------------------

    /// map a function "f" over all elements
    let map f list = 
        // helper function
        let folder head tail =
            Cons(f head,tail)

        foldBack folder list Empty

    /// return a new list of elements for which "pred" is true
    let filter pred list = 
        // helper function
        let folder head tail =
            if pred head then 
                Cons(head,tail)
            else
                tail

        foldBack folder list Empty

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

let sumExample = 
    let linkedList = Cons (1, Cons (2, Cons(3, Empty)))  
    linkedList |> LinkedList.foldWithEmpty (+) id 0

let sumExample2 = 
    let linkedList = Cons (1, Cons (2, Cons(3, Empty)))  
    linkedList |> LinkedList.fold (+) 0
    // Result => 6

let toListExample = 
    let linkedList = Cons (1, Cons (2, Cons(3, Empty)))  
    linkedList |> LinkedList.toList       
    // Result => [1; 2; 3]

let ofListExample = 
    let list = [1;2;3]
    list |> LinkedList.ofList       
    // Result => Cons (1,Cons (2,Cons (3,Empty)))

let mapExample = 
    let linkedList = Cons (1, Cons (2, Cons(3, Empty)))  
    linkedList |> LinkedList.map (fun i -> i+10)
    // Result => Cons (11,Cons (12,Cons (13,Empty)))

let filterExample = 
    let isOdd n = (n%2=1)
    let linkedList = Cons (1, Cons (2, Cons(3, Empty)))  
    linkedList |> LinkedList.filter isOdd
    // Result => Cons (1,Cons (3,Empty))

// ==============================================
// LazyLinkedList
// ==============================================

// this version doesn't work
//
// type LazyLinkedList<'a> = 
//    | Empty
//    | Cons of head:'a * tail:(unit -> LazyLinkedList<'a>)

type LazyLinkedNode<'a> = 
    | LEmpty
    | LCons of head:'a * tail:LazyLinkedList<'a>

and LazyLinkedList<'a> = 
    (unit -> LazyLinkedNode<'a>)


let lazyLinkedList = fun () -> LCons (1, fun () -> LCons (2, fun () -> LCons(3, fun () -> LEmpty)))  
// same as 1 :: 2 :: 3 :: []
// or      [1; 2; 3]

module LazyLinkedList = 

    let rec cata fCons fEmpty (list:'a LazyLinkedList) :'r=
        let recurse = cata fCons fEmpty 
        match list() with
        | LEmpty -> 
            fEmpty
        | LCons (element,list) -> 
            fCons element (recurse list)
    (*
    val cata : 
        fCons:('a -> 'r -> 'r) -> 
        fEmpty:'r -> 
        list:LazyLinkedList<'a> 
        -> 'r
    *)

    let rec foldWithEmpty fCons fEmpty acc (list:'b LazyLinkedList) :'r=
        let recurse = foldWithEmpty fCons fEmpty 
        match list() with
        | LEmpty -> 
            fEmpty acc 
        | LCons (element,list) -> 
            let newAcc = fCons acc element 
            recurse newAcc list

    (*
    val foldWithEmpty :
      fCons:('a -> 'b -> 'a) ->
      fEmpty:('a -> 'r) -> 
      acc:'a -> 
      list:LazyLinkedList<'b> -> 
      'r
    *)
  
    let rec fold fCons acc (list:'a LazyLinkedList) :'r =
        let recurse = fold fCons 
        match list() with
        | LEmpty -> 
            acc 
        | LCons (element,list) -> 
            let newAcc = fCons acc element 
            recurse newAcc list
    (*
    val fold : 
        fCons:('r -> 'a -> 'r) -> 
        acc:'r -> 
        list:LazyLinkedList<'a> -> 
        'r

    // comparing fold with List version
    LazyLinkedList.fold' : ('r     -> 'a -> 'r    ) -> 'r      -> LazyLinkedList<'a> -> 'r
    List.fold            : ('State -> 'T -> 'State) -> 'State -> 'T list             -> 'State
    *)

    let foldBack fCons list acc :'r=
        let fEmpty' generator = 
            generator acc 
        let fCons' generator element= 
            fun innerResult -> 
                let newResult = fCons element innerResult 
                generator newResult 
        let initialGenerator = id
        foldWithEmpty fCons' fEmpty' initialGenerator  list 

    (*
    val foldBack : 
        fCons:('a -> 'r -> 'r) -> 
        list:LazyLinkedList<'a> -> 
        acc:'r -> 
        'r

    // comparing foldBack with List version
    LazyLinkedList.foldBack : ('a -> 'r     -> 'r    ) -> LazyLinkedList<'a> -> 'r     -> 'r
    List.foldBack           : ('T -> 'State -> 'State) -> 'T list            -> 'State -> 'State
    *)


    let toList linkedList = 
        let fCons head tail = head::tail
        let initialState = [] 
        foldBack fCons linkedList initialState 

    let ofList list = 
        let fCons head tail = fun () -> LCons(head,tail)
        let initialState = fun () -> LEmpty
        List.foldBack fCons list initialState 

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

let lazyOfListExample = 
    let list = [1;2;3]
    list 
    |> LazyLinkedList.ofList       
    |> LazyLinkedList.toList       
    // Result => [1; 2; 3]
    
let lazySumExample = 
    let list = [1;2;3]
    list 
    |> LazyLinkedList.ofList       
    |> LazyLinkedList.fold (+) 0
    // Result => 6


// ==============================================
// Three ways to refactor the gift type
// ==============================================

module GiftOriginal = 

    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

// ==============================================
// refactoring to a structure wih only ONE recursive reference
// ==============================================

module GiftRefactored_V1 = 

    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 =
        // non-recursive case
        | Contents of GiftContents
        // recursive case
        | Decoration of Gift * GiftDecoration

    // ---------------------------------
    // Helper constructor functions
    // ---------------------------------

    let fromBook book = 
        Contents (Book book)

    let fromChoc choc = 
        Contents (Chocolate choc)

    let wrapInPaper paperStyle innerGift = 
        let decoration = Wrapped paperStyle 
        Decoration (innerGift, decoration)

    let putInBox innerGift = 
        let decoration = Boxed
        Decoration (innerGift, decoration)

    let withCard message innerGift = 
        let decoration = WithACard message
        Decoration (innerGift, decoration)
    
    // ---------------------------------
    // Sample data
    // ---------------------------------

    let wolfHall = {title="Wolf Hall"; price=20m}
    let yummyChoc = {chocType=SeventyPercent; price=5m}

    let birthdayPresent = 
        let gift0 = Contents (Book wolfHall)
        let decoration0 = Wrapped HappyBirthday
        let gift1 = Decoration (gift0, decoration0)
        let decoration1 = WithACard "Happy Birthday"
        let gift2 = Decoration (gift1, decoration1)
        gift2 

    let birthdayPresent2 = 
        wolfHall 
        |> fromBook
        |> wrapInPaper HappyBirthday
        |> withCard "Happy Birthday"
     
    let christmasPresent = 
        yummyChoc
        |> fromChoc
        |> putInBox
        |> wrapInPaper HappyHolidays

// ==============================================
// refactoring to a generic Container structure 
// ==============================================

type Container<'ContentData,'DecorationData> =
    | Contents of 'ContentData
    | Decoration of 'DecorationData * Container<'ContentData,'DecorationData> 

module Container = 

    let rec cata fContents fDecoration (container:Container<'ContentData,'DecorationData>) :'r = 
        let recurse = cata fContents fDecoration 
        match container with
        | Contents contentData -> 
            fContents contentData 
        | Decoration (decorationData,subContainer) -> 
            fDecoration decorationData (recurse subContainer)
(*
val cata :
    // function parameters
    fContents:('ContentData -> 'r) ->
    fDecoration:('DecorationData -> 'r -> 'r) ->
    // input
    container:Container<'ContentData,'DecorationData> -> 
    // return value
    'r
*)

    let rec fold fContents fDecoration acc (container:Container<'ContentData,'DecorationData>) :'r = 
        let recurse = fold fContents fDecoration 
        match container with
        | Contents contentData -> 
            fContents acc contentData 
        | Decoration (decorationData,subContainer) -> 
            let newAcc = fDecoration acc decorationData
            recurse newAcc subContainer
(*
val fold :
    // function parameters
    fContents:('a -> 'ContentData -> 'r) ->
    fDecoration:('a -> 'DecorationData -> 'a) ->
    // accumulator
    acc:'a -> 
    // input
    container:Container<'ContentData,'DecorationData> -> 
    // return value
    'r
*)

    let foldBack fContents fDecoration (container:Container<'ContentData,'DecorationData>) :'r = 
        let fContents' generator contentData =
            generator (fContents contentData)
        let fDecoration' generator decorationData =
            let newGenerator innerValue =
                let newInnerValue = fDecoration decorationData innerValue 
                generator newInnerValue 
            newGenerator 
        fold fContents' fDecoration' id container
(*

val foldBack :
    // function parameters
    fContents:('ContentData -> 'r) ->
    fDecoration:('DecorationData -> 'r -> 'r) ->
    // input
    container:Container<'ContentData,'DecorationData> -> 
    // return value
    'r
*)

    let rec map fMapContents fMapDecoration (container:Container<'ContentData,'DecorationData>)  =  
        let recurse = map fMapContents fMapDecoration 
        match container with
        | Contents contentData -> 
            Contents (fMapContents contentData)
        | Decoration (decorationData,subContainer) -> 
            Decoration (fMapDecoration decorationData, recurse subContainer)
(*
val map :
    fMapContents:('ContentData -> 'a) ->
    fMapDecoration:('DecorationData -> 'b) ->
    // input
    container:Container<'ContentData,'DecorationData> -> 
    // return value
    Container<'a,'b>
*)


module GiftUsingContainer = 

    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 = Container<GiftContents,GiftDecoration>

    // ---------------------------------
    // Helper constructor functions
    // ---------------------------------

    let fromBook book = 
        Contents (Book book)

    let fromChoc choc = 
        Contents (Chocolate choc)

    let wrapInPaper paperStyle innerGift = 
        let container = Wrapped paperStyle 
        Decoration (container, innerGift)

    let putInBox innerGift = 
        let container = Boxed
        Decoration (container, innerGift)

    let withCard message innerGift = 
        let container = WithACard message
        Decoration (container, innerGift)

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

    // ---------------------------------
    // Define and test "totalCost"
    // ---------------------------------

    let totalCost gift =  

        let fContents costSoFar contentData = 
            match contentData with
            | Book book ->
                costSoFar + book.price
            | Chocolate choc ->
                costSoFar + choc.price

        let fDecoration costSoFar decorationInfo = 
            match decorationInfo with
            | Wrapped style ->
                costSoFar + 0.5m
            | Boxed ->
                costSoFar + 1.0m
            | WithACard message ->
                costSoFar + 2.0m

        // initial accumulator
        let initialAcc = 0m

        // call the fold
        Container.fold fContents fDecoration initialAcc gift 

    birthdayPresent |> totalCost 
    // 22.5m

    christmasPresent |> totalCost 
    // 6.5m

    // ---------------------------------
    // Define and test "description"
    // ---------------------------------

    let description gift =

        let fContents contentData = 
            match contentData with
            | Book book ->
                sprintf "'%s'" book.title
            | Chocolate choc ->
                sprintf "%A chocolate" choc.chocType

        let fDecoration decorationInfo innerText = 
            match decorationInfo 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
        Container.foldBack fContents fDecoration gift  
        

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

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



// ==============================================
// Refactoring gift to a record
// ==============================================

// refactoring types
module GiftRefactored_Record = 

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

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

    type WrappingPaperStyle = 
        | HappyBirthday
        | HappyHolidays
        | SolidColor

    type GiftContents = 
        | Book of Book
        | Chocolate of Chocolate 

    type GiftDecoration = 
        | Wrapped of WrappingPaperStyle
        | Boxed 
        | WithACard of string

    type Gift = {contents: GiftContents; decorations: GiftDecoration list}

    // ---------------------------------
    // Helper constructor functions
    // ---------------------------------

    let fromBook book = 
        { contents = (Book book); decorations = [] }

    let fromChoc choc = 
        { contents = (Chocolate choc); decorations = [] }

    let wrapInPaper paperStyle innerGift = 
        let decoration = Wrapped paperStyle 
        { innerGift with decorations = decoration::innerGift.decorations }

    let putInBox innerGift = 
        let decoration = Boxed
        { innerGift with decorations = decoration::innerGift.decorations }

    let withCard message innerGift = 
        let decoration = WithACard message
        { innerGift with decorations = decoration::innerGift.decorations }

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

    // ---------------------------------
    // Define and test "totalCost"
    // ---------------------------------

    let totalCost gift =  
        
        let contentCost = 
            match gift.contents with
            | Book book ->
                book.price
            | Chocolate choc ->
                choc.price

        let decorationFolder costSoFar decorationInfo = 
            match decorationInfo with
            | Wrapped style ->
                costSoFar + 0.5m
            | Boxed ->
                costSoFar + 1.0m
            | WithACard message ->
                costSoFar + 2.0m

        let decorationCost = 
            gift.decorations |> List.fold decorationFolder 0m

        // total cost
        contentCost + decorationCost 

    birthdayPresent |> totalCost 
    // 22.5m

    christmasPresent |> totalCost 
    // 6.5m

    // ---------------------------------
    // Define and test "description"
    // ---------------------------------

    let description gift =

        let contentDescription = 
            match gift.contents with
            | Book book ->
                sprintf "'%s'" book.title
            | Chocolate choc ->
                sprintf "%A chocolate" choc.chocType

        let decorationFolder decorationInfo innerText = 
            match decorationInfo 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 

        List.foldBack decorationFolder gift.decorations contentDescription
        

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

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