Advanced(?) domain-driven design in F#

Program.fs

[<EntryPoint>]
let main argv =
    printfn "Should be zero (netWeight emptyPallet): %A" Stock.shouldBeZero
    printfn "harvesterPartsWeight: %A" Stock.harvesterPartsWeight
    printfn "grossWeight harvesterParts: %A" (Stock.grossWeight Stock.harvesterParts)
    printfn "grossWeight emptyPallet: %A" (Stock.grossWeight Stock.emptyPallet)
    printfn "netWeight harvesterParts: %A" (Stock.netWeight Stock.harvesterParts)
    printfn "value harvesterParts: %A" (Stock.value Stock.harvesterParts)
    printfn "boxLabels harvesterParts: %A" (Stock.boxLabels Stock.harvesterParts)
    printfn "boxLabels emptyPallet: %A" (Stock.boxLabels Stock.emptyPallet)
    0
(*
Should be zero (netWeight emptyPallet): 0
harvesterPartsWeight: 112
grossWeight harvesterParts: 122
grossWeight emptyPallet: 10
netWeight harvesterParts: 112
value harvesterParts: 1345
boxLabels harvesterParts: [BoxLabel "Engine"; BoxLabel "Electronics"; BoxLabel "Inertial navigation"; BoxLabel "Wiring"]
boxLabels emptyPallet: []
*)

Stock.fs

module Stock

open TypeEquality

type BoxLabel = BoxLabel of string
type PalletLabel = PalletLabel of string

/// A box represented by type 'a'.
/// or
/// A box with additional data of type 'a'.
/// or
/// A relation between a box with the given label and an entity represented by type 'a'.
/// or
/// A box with a data "hole" of type 'a' in it.
type Box<'a> = Box of BoxLabel * 'a

/// Similarly to type 'Box<a>'.
type Pallet<'a> = Pallet of PalletLabel * 'a

/// A marker type for thing related to boxes. Intended to be used only as a type variable and "has no values".
type IsBox = IsBox of IsBox
/// Similarly to 'IsBox'.
type IsPallet = IsPallet of IsPallet

/// Warehouse stock is physically organized in boxes and pallets. A box can contain other boxes. A pallet holds boxes.
/// No other nesting forms are allowed.
///
/// Values of type 'Stock<b,p,a>' represent this nested stock organization structure. A box contains data of type 'b'
/// and a pallet of type 'p'. Type 't' encodes the top level of the nested stock: either a box or a pallet.
type Stock<'b,'p,'t> =
    | BoxLevel of Box<{| Data : 'b; InnerBoxes : List<Stock<'b,'p,IsBox>> |}> * TypeEquality<'t,IsBox>
    | PalletLevel of Pallet<{| Data : 'p; Boxes : List<Stock<'b,'p,IsBox>> |}> * TypeEquality<'t,IsPallet>

/// A helper for constructing a tree of boxes.
let box (label : BoxLabel) (data : 'b) (innerBoxes : List<Stock<'b,_,IsBox>>) =
    BoxLevel (Box (label, {| Data = data; InnerBoxes = innerBoxes |}), refl)
    
/// A helper for constructing a tree of boxes with a pallet root.
let pallet (label : PalletLabel) (data : 'p) (boxes: List<Stock<_,'p,IsBox>>) =
    PalletLevel (Pallet (label, {| Data = data; Boxes = boxes |}), refl)

/// Recursively process a stock tree in bottom-up manner. The two provided (non-recursive) functions process a single
/// box (level) or the pallet (level) and have access to the intermediate results computed at the level below. This is
/// a recursion scheme, like e.g. 'fold'.
let rec catamorphism<'b,'p,'t,'r>
    (f : Box<{| Data : 'b; InnerBoxes : List<'r> |}> -> 'r)
    (g : Pallet<{| Data : 'p; Boxes : List<'r> |}> -> 'r)
    (stock : Stock<'b,'p,'t>) : 'r =
    match stock with
    | BoxLevel (Box (label, dataAndNested), _) ->
        f (Box (label, {| dataAndNested with InnerBoxes = dataAndNested.InnerBoxes |> List.map (catamorphism f g) |}))
    | PalletLevel (Pallet (label, dataAndBoxes), _) ->
        g (Pallet (label, {| dataAndBoxes with Boxes = dataAndBoxes.Boxes |> List.map (catamorphism f g) |}))
// The _complete_ type annotation is required for polymorphic recursion to work.

// That was the minimal but already powerful and modular model. Now come the examples.

[<Measure>]
type kg

[<Measure>]
type eur

type Weight = int<kg>
type Value = int<eur>

/// An empty pallet with its own weight.
let emptyPallet<'box> = pallet (PalletLabel "Pallet-1") 10<kg> []

/// A pallet with weights and values for the contents of boxes.
let harvesterParts =
    pallet (PalletLabel "Harvester parts") 10<kg> [
        box (BoxLabel "Engine") (100<kg>, 1_000<eur>) []
        box (BoxLabel "Electronics") (1<kg>, 0<eur>) [ // Intermediate package, only its own weight, no value
            box (BoxLabel "Inertial navigation") (10<kg>, 300<eur>) []
            box (BoxLabel "Wiring") (1<kg>, 45<eur>) []
        ]
    ]

// It is statically impossible to create an invalid warehouse stock configuration: the following will not type check.

//let invalid =
//    pallet (PalletLabel "Outer pallet") () [
//        pallet (PalletLabel "Small pallet?") () [] // "The type 'IsBox' does not match the type 'IsPallet'"
//    ]

// Similarly impossible:

//let invalid =
//    box (BoxLabel "This box is larger than a pallet") () [
//        pallet (PalletLabel "So let's put a pallet inside of it!") () []
//    ]

// Now let's do some warehouse logic.

let netWeight stock : Weight =
    catamorphism
        (fun (Box (_, d)) -> let (weight, value) = d.Data in weight + List.sum d.InnerBoxes) // Just read this!
        (fun (Pallet (_, d)) -> List.sum d.Boxes) // Net
        stock

let shouldBeZero = netWeight emptyPallet

let harvesterPartsWeight = netWeight harvesterParts

let grossWeight stock : Weight =
    catamorphism
        (fun (Box (_, d)) -> let (weight, value) = d.Data in weight + List.sum d.InnerBoxes)
        (fun (Pallet (_, d)) -> d.Data + List.sum d.Boxes) // Gross
        stock

// A sanity check
do
    if grossWeight emptyPallet + netWeight harvesterParts <> grossWeight harvesterParts then failwith "Wrong pallet!"

let value stock : Value =
    catamorphism
        (fun (Box (_, d)) -> let (weight, value) = d.Data in value + List.sum d.InnerBoxes)
        (fun (Pallet (_, d)) -> List.sum d.Boxes) // Pallets themselves have no business value
        stock

// Some other computation which is not sum-like as everything above

let boxLabels stock : List<BoxLabel> =
    catamorphism
        (fun (Box (label, d)) -> label :: List.concat d.InnerBoxes)
        (fun (Pallet (_, d)) -> List.concat d.Boxes)
        stock

TypeEquality.fs

module TypeEquality

// See my other gists.