Code from O'Reilly webcast: "Domain Modelling with the F# Type System" http://www.oreilly.com/pub/e/3340

1-ConciseDDD.fsx

// ================================================
// DDD : Model a card game
// ================================================

(*
A card is a combination of a Suit (Heart, Spade) and a Rank (Two, Three, ... King, Ace)
A hand is a list of cards
A deck  is a list of cards
A player has a name and a hand
A game consists of a deck and list of players
*)

module CardGame =

    type Suit = Club | Diamond | Spade | Heart

    type Rank = Two | Three | Four | Five | Six | Seven | Eight 
                       | Nine | Ten | Jack | Queen | King | Ace

    type Card = Suit * Rank

    type Hand = Card list
    type Deck = Card list

    type Player = {Name : string; Hand : Hand}
    type Game = {Deck : Deck; Players : Player list}

    type ShuffledDeck = ShuffledDeck of Deck
    type Shuffle = Deck -> ShuffledDeck 

    type Deal = ShuffledDeck -> (ShuffledDeck  * Card)
    type PickupCard = (Hand * Card) -> Hand


module CardGameUtil = 
    open CardGame
    open System

    let allSuits = [Club; Diamond; Spade; Heart]
    let allRanks = [Two; Three; Four; Five; Six; Seven; Eight; Nine; Ten; Jack; Queen; King; Ace]
    let newDeck :Deck = 
        [ for suit in allSuits do
            for rank in allRanks do
                yield (suit,rank) ]
    
    let shuffle : Shuffle =
        let rand = Random()
        fun deck ->
            deck
            |> List.map (fun card -> card, rand.Next()) 
            |> List.sortBy snd
            |> List.map fst
            |> ShuffledDeck


    let deal : Deal = 
        fun (ShuffledDeck deck) -> 
            match deck with 
            | first::rest -> (ShuffledDeck rest,first)
            | [] -> failwith "empty deck"

    let makeHand n deck = 
        let rec loop n deck hand = 
            match n with 
            | 0 -> 
                let sortedHand:Hand = hand |> List.sort
                (deck,sortedHand)
            | _ -> 
                let newDeck,card = deal deck
                let newHand = card::hand 
                loop (n-1) newDeck newHand 
        loop n deck []

open CardGame
open CardGameUtil 

let deck = newDeck |> shuffle
let deck1, hand1 = makeHand 5 deck 
let deck2, hand2 = makeHand 5 deck1 
let deck3, hand3 = makeHand 5 deck2 
hand1, hand2, hand3  


// ================================================
// DDD : Model the cargo example from the DDD book
// ================================================

module Cargo = 
    open System

    type TrackingId = TrackingId  of string
    type Location = Location of string

    type RouteSpecification = {
        Origin: Location
        Destination: Location } 

    type TransportStatus = Claimed | NotReceived | InPort | OnboardCarrier | Unknown

    type UntrackedCargo = {
        RouteSpecification : RouteSpecification 
        TransportStatus : TransportStatus }

    type TrackedCargo = {
        TrackingId : TrackingId 
        Cargo : UntrackedCargo }

    type Leg = {
        LoadLocation : Location
        UnloadLocation : Location
        LoadTime : DateTime 
        UnloadTime : DateTime }

    type Itinerary = Leg list

    type RoutedCargo = {
      Itinerary : Itinerary 
      Cargo : TrackedCargo }

    type Track = UntrackedCargo * TrackingId -> TrackedCargo 
    type Route = TrackedCargo * Itinerary -> RoutedCargo        
    type Reroute = RoutedCargo * Itinerary -> RoutedCargo        

    type ActiveCargo = {
      LastLocation: Location
      Cargo : RoutedCargo }

    type Start = RoutedCargo  * Location -> ActiveCargo 
    type Handle = ActiveCargo * Location -> ActiveCargo 

    let (|OnLand|AtSea|Completed|) status =
        match status with
        | Claimed -> Completed
        | NotReceived -> OnLand
        | InPort -> OnLand
        | OnboardCarrier -> AtSea
        | Unknown -> OnLand

    // custom methods
    type Location with 
        member this.Code = match this with Location code -> code
    type TrackedCargo with 
        member this.TransportStatus = this.Cargo.TransportStatus
        member this.Origin = this.Cargo.RouteSpecification.Origin
        member this.Dest = this.Cargo.RouteSpecification.Destination
        member this.UpdateStatus s = {this with Cargo = {this.Cargo with TransportStatus=s}}
    type RoutedCargo with 
        member this.TransportStatus = this.Cargo.TransportStatus
        member this.Origin = this.Cargo.Origin
        member this.Dest = this.Cargo.Dest
        member this.UpdateStatus s = {this with Cargo = this.Cargo.UpdateStatus s}
    type ActiveCargo with 
        member this.TransportStatus = this.Cargo.TransportStatus
        member this.Origin = this.Cargo.Origin
        member this.Dest = this.Cargo.Dest
        member this.UpdateStatus s = {this with Cargo = this.Cargo.UpdateStatus s}


module CargoImpl = 
    open Cargo
    open System

    // implementation
    let track id cargo = 
        { TrackingId = id; Cargo = cargo }
    let route itinerary cargo = 
        { Itinerary= itinerary; Cargo = cargo }
    let handle loc cargo = 
        { cargo with LastLocation = loc}
    let makeLeg load unload = 
        { LoadLocation=load; UnloadLocation=unload; LoadTime=DateTime.Now; UnloadTime=DateTime.Now}
    let updateStatus status (cargo:ActiveCargo) =
        cargo.UpdateStatus status

    let start loc cargo = 
        { LastLocation = loc; Cargo = cargo}
        |> updateStatus OnboardCarrier 

    let depart loc cargo =
        cargo
        |> updateStatus OnboardCarrier 
        |> handle loc

    let arrive loc cargo =
        cargo
        |> handle loc
        |> updateStatus (if loc = cargo.Dest then Claimed else InPort)
        
    let printInfo (cargo:ActiveCargo) = 
        match cargo.TransportStatus with
        | AtSea -> printfn "%s->%s : at sea departed from %s" cargo.Origin.Code cargo.Dest.Code cargo.LastLocation.Code
        | OnLand -> printfn "%s->%s : on land at %s" cargo.Origin.Code cargo.Dest.Code cargo.LastLocation.Code
        | Completed -> printfn "%s->%s : at final destination" cargo.Origin.Code cargo.Dest.Code 
        cargo

    let newyork = Location "USNYC"
    let helsinki = Location "FIHEL"
    let rotterdam = Location "NLRTM"



open Cargo
open CargoImpl

let untracked = {
    RouteSpecification = { Origin = newyork; Destination = helsinki }
    TransportStatus = OnboardCarrier
    }

let leg1 = makeLeg newyork rotterdam
let leg2 = makeLeg rotterdam helsinki

let cargo = 
    untracked 
    |> track (TrackingId "AB123")
    |> route [leg1; leg2]
    |> start newyork 
    |> printInfo
    |> arrive rotterdam
    |> printInfo
    |> depart rotterdam
    |> printInfo
    |> arrive helsinki
    |> printInfo

2-AlgebraicTypes.fsx

(*
DDD Algebraic types
*)

open System

// ================================================
// Product types
// ================================================

let intPair = 1,2  
// val intPair : int * int = (1, 2)


let boolPair = true,false
// val boolPair : bool * bool = (true, false)


type Person = Person of string

type Birthday = Person * DateTime

let today = DateTime.Today
let alice = Person "Alice"

let alicesBirthday : Birthday = alice, today


// ================================================
// Sum types - Temp
// ================================================

type Temp = 
  | F of int
  | C of float


let isFever temp =
    match temp with
    | F tempInF -> tempInF > 102
    | C tempInC -> tempInC > 38.9


let tempF = F 100
isFever tempF 

let tempC = C 39.0
isFever tempC


let convertTemp temp =
    match temp with
    | F tempInF -> 
        let tempInC = (float tempInF - 32.0) / 1.8 
        C tempInC 
    | C tempInC -> 
        let tempInF = int (tempInC * 1.8) + 32
        F tempInF 

let zeroC = C 0.0
let zeroF = convertTemp zeroC

let boilingF = F 212
let boilingC = convertTemp boilingF 

let feverF = F 102
let feverC  = convertTemp feverF 


// ================================================
// Sum types - PaymentMethod 
// ================================================

type CardType = Visa | Mastercard
type CardNumber = CardNumber of int


type PaymentMethod = 
  | Cash
  | Cheque of int
  | Card of CardType * CardNumber


let printPayment meth = 
    match meth with
    | Cash -> printfn "Paid in cash"
    | Cheque checkNo -> printfn "Paid by cheque: %i" checkNo
    | Card (cardType,cardNo) -> printfn "Paid with %A %A" cardType cardNo


let cheque = Cheque 1234
let card = Card (Visa, CardNumber 1234)

printPayment cheque
printPayment card

3-DesigningWithTypes.fsx

(*
DDD Designing with types
*)

open System


// ================================================
// Using options
// ================================================

// nothing special about Option -- no compiler support needed
type Optional<'T> = 
    | Something of 'T
    | Nothing

// type alias
type optional<'T> = Optional<'T>

type PersonalName = 
    {
    FirstName: string
    MiddleInitial: string optional
    LastName: string
    }

// ================================================
// Using single choice types to keep types distinct
// ================================================

(*
Is an EmailAddress just a string?
Is a CustomerId just a int?
Use single choice types to keep them distinct
*)

type EmailAddress = EmailAddress of string
type PhoneNumber = PhoneNumber of string

let value1a = EmailAddress "123"
let value1b = PhoneNumber "123"
let areEqual1 = (value1a=value1b)


type CustomerId = CustomerId of int
type OrderId = OrderId of int

let value2a = CustomerId 123
let value2b = OrderId 123
let areEqual2 = (value2a=value2b)


// ================================================
// (from slides) Constructing optional values
// ================================================

open System.Text.RegularExpressions

let createEmailAddress (s:string) = 
    if Regex.IsMatch(s,@"^\S+@\S+\.\S+$") 
        then Some (EmailAddress s)
        else None
// val createEmailAddress : s:string -> EmailAddress option

type String50 = String50 of string

let createString50 (s:string) = 
    if s.Length <= 50
        then Some (String50 s)
        else None
// val createString50 : s:string -> String50 option


type OrderLineQty = OrderLineQty of int

let createOrderLineQty qty = 
    if qty >0 && qty <= 99
        then Some (OrderLineQty qty)
        else None
// val createOrderLineQty : qty:int -> OrderLineQty option







createEmailAddress "x@example.com"
createEmailAddress "example.com"






let create n = 
    match createOrderLineQty n with
    | Some qty -> qty
    | None -> failwith "should not happen"


let decrement (OrderLineQty i) = 
    let newQty = createOrderLineQty (i-1)
    match newQty with
    | Some qty -> printfn "New qty is %A" qty
    | None -> printfn "Item will be removed" 

let one = create 1
let two = create 2

decrement two
decrement one






// ================================================
// The final domain!
// ================================================


module StringTypes =

    type String1 = String1 of string
    type String50 = String50 of string

    let createString1 (s:string) = 
        if (s.Length <= 1)
            then Some (String50 s)
            else None

    let createString50 (s:string) = 
        if s.Length <= 50
            then Some (String50 s)
            else None

module DomainTypes =

    open StringTypes

    type EmailAddress = 
        EmailAddress of string

    type VerifiedEmail = 
       VerifiedEmail of EmailAddress

    type EmailContactInfo = 
      | Unverified of EmailAddress
      | Verified of VerifiedEmail


    type PersonalName = {
      FirstName: String50
      MiddleInitial: String1 option
      LastName: String50 }

    type Contact = {
      Name: PersonalName 
      Email: EmailContactInfo }


    type VerificationHash = byte[]

    type VerificationService = 
        (EmailAddress *  VerificationHash) -> VerifiedEmail option

    type Result = string

    type PasswordResetService = 
        VerifiedEmail -> Result

// ================================================
// (from slides) The new domain with address info added as well
// ================================================

module DomainTypes_WithAddress =

    open StringTypes

    type EmailAddress = 
        EmailAddress of string

    type VerifiedEmail = 
       VerifiedEmail of EmailAddress

    type EmailContactInfo = 
      | Unverified of EmailAddress
      | Verified of VerifiedEmail

    type PostalContactInfo = {
      address1: string 
      address2: string
      address3: string
      address4: string
      country: string
      }

    type ContactInfo = 
        | EmailOnly of EmailContactInfo
        | AddrOnly of PostalContactInfo
        | EmailAndAddr of EmailContactInfo * PostalContactInfo

    type PersonalName = {
      FirstName: String50
      MiddleInitial: String1 option
      LastName: String50 }

    type Contact = {
      Name: PersonalName 
      ContactInfo : ContactInfo  }



// ================================================
// Worked example: Modeling email state transition
//
// See email_transition_diagram.png
//
// ================================================

(*
All the state transitions are going to work the same way.

1) Start with the domain types that are independent of state
2) Create the "API"
  2a) Create a type to represent the data stored for each type
  2b) Create a type that represent the choice of all the states
  2c Create transition functions that transition from one state type to another
     These functions take as input: 
       * a state type
       * and maybe some extra data
     These functions output: 
       * a new state type
       * or maybe a state OPTION if the transition might not work

3) Clients then write functions using the state union type and the "API"

*)

// Let's see this in action using the email transitions as our example

// 1) Start with the domain types that are independent of state
module EmailDomainTypes = 

    type EmailAddress = 
        EmailAddress of string

// 2) Create the "API"
module EmailApi = 
    open EmailDomainTypes

    // 2a) Create a type to represent the data stored for each type
    type VerifiedEmail = 
        VerifiedEmail of EmailAddress

    // 2b) Create a type that represent the choice of all the states
    type EmailContactInfo = 
        | UnverifiedState of EmailAddress
        | VerifiedState of VerifiedEmail


    // 2c) Create transition functions that transition from one *individual* state to the next
    module EmailVerificationService =

        let verify email hash =
            if hash="OK" then
                Some (VerifiedEmail email)
            else
                None

// 3) Clients write functions using the state union type 
module EmailApiClient = 
    open EmailDomainTypes
    open EmailApi

    // Rule: "You can't send a verification message to a verified email"
    let sendVerificationMessage state =
        match state with
        | UnverifiedState email -> 
            printfn "Sending verification message to %A" email
        | VerifiedState _ ->
            printfn "Already verified"

    // Rule: "You can't send a password reset message to a unverified email "
    let sendPasswordResetMessage state =
        match state with
        | UnverifiedState email -> 
            printfn "Not verified. Can't send" 
        | VerifiedState (VerifiedEmail email) ->
            printfn "Sending password reset message to %A" email

// Examples
open EmailDomainTypes
open EmailApi
open EmailApiClient

let emailAddress = EmailAddress "abc@example.com"

let unverifiedEmailState = 
    UnverifiedState emailAddress 

let verifiedEmailState = 
    let hash = "OK"
    let verifiedEmailOpt = EmailVerificationService.verify emailAddress hash 
    let verifiedEmail = verifiedEmailOpt.Value // don't do this in real code!
    VerifiedState verifiedEmail  

sendVerificationMessage unverifiedEmailState 
sendVerificationMessage verifiedEmailState 

sendPasswordResetMessage unverifiedEmailState 
sendPasswordResetMessage verifiedEmailState