Thinking Domain......

Domain.fsx

module Domain

#load "DomainHelper.fsx"

open DomainHelper
open System

/// constrained to be not null and at most 50 chars
type String50 = private String50 of string
type ValidatedString50 = Validated<string, String50, string>

let string50 =
    Domain<string, String50, string>(
        String50,
        (fun (String50 s) -> s),
        (fun str ->
            if String.IsNullOrEmpty(str) then
                Error [ "NullOrEmpty" ]
            elif String.length str > 50 then
                Error [ "Over 50" ]
            else
                Ok str)
    )

/// constrained to be bigger than 1/1/1900 and less than today's date
type Birthdate = private Birthdate of DateTime
type ValidatedBirthdate = Validated<DateTime, Birthdate, string>

let birthdate =
    Domain<DateTime, Birthdate, string>(
        Birthdate,
        (fun (Birthdate b) -> b),
        (fun dt ->
            if dt < DateTime(1990, 1, 1) then
                Error [ "Must be bigger than 1/1/1900" ]
            else
                Ok dt)
    )

/// Nested cases
type Person =
    private
        { First: String50
          Last: String50
          Birthdate: Birthdate }

type PersonDto =
    { First: ValidatedString50
      Last: ValidatedString50
      Birthdate: ValidatedBirthdate }

let person =
    Domain<PersonDto, Person, string>(
        (fun p ->
            { First = string50.Value p.First
              Last = string50.Value p.Last
              Birthdate = birthdate.Value p.Birthdate }),
        (fun p ->
            { First = string50.ofDomain p.First
              Last = string50.ofDomain p.Last
              Birthdate = birthdate.ofDomain p.Birthdate }),
        (fun p ->
            match p.First, p.Last, p.Birthdate with
            | Valid _, Valid _, Valid _ -> Ok p
            | (BoxInvalid v), (BoxInvalid v'), (BoxInvalid v'') ->
                (v @ v' @ v'')
                |> List.map (fun e -> $"%A{e}")
                |> Error)
    )

DomainHelper.fsx

module DomainHelper

type InvalidType<'dto, 'domain, 'error> =
    | CreateFailed of 'dto * 'error list
    | UpdateFailed of 'domain voption * 'dto * 'error list
    | MargedError of InvalidType<obj, obj, 'error> list

type Validated<'dto, 'domain, 'error> =
    private
    | Valid of domain: 'domain
    | Invalid of error: InvalidType<'dto, 'domain, 'error>

let invalidCreateFailed dto errors = (CreateFailed >> Invalid) (dto, errors)

let invalidUpdateFailed domain dto errors =
    (UpdateFailed >> Invalid) (domain, dto, errors)

let boxInvalid (validated: Validated<'dto, 'domain, 'error>) =
    match validated with
    | Valid _ -> []
    | Invalid ex ->
        [ match ex with
          | CreateFailed (dto, errors) -> CreateFailed(box dto, errors)
          | UpdateFailed (domain, dto, errors) -> UpdateFailed(ValueOption.map box domain, box dto, errors)
          | MargedError marged -> MargedError marged ]

let (|BoxInvalid|) = boxInvalid

let margeInvalids validateds =
    [ for v in validateds do
          yield! boxInvalid v ]

let invalidMargedErrors invalids = (MargedError >> Invalid) invalids

/// Controls `Validated<'dto, 'domain, 'error>`.
type Domain<'dto, 'domain, 'error>
    (
        fromDto: 'dto -> 'domain,
        toDto: 'domain -> 'dto,
        validate: 'dto -> Result<'dto, 'error list>
    ) =

    member _.Create dto : Validated<'dto, 'domain, 'error> =
        match validate dto with
        | Ok v -> Valid(fromDto v)
        | Error error -> invalidCreateFailed dto error

    member this.ofDomain domain = toDto domain |> this.Create


    member _.Update newValueArg (currentValue: Validated<'dto, 'domain, 'error>) =
        match (validate newValueArg), currentValue with
        | Ok v, _ -> Valid(fromDto v)
        | Error error, Valid c -> invalidUpdateFailed (ValueSome c) newValueArg error
        | Error error, Invalid _ -> invalidUpdateFailed ValueNone newValueArg error


    member _.IsValid(validated: Validated<'dto, 'domain, 'error>) =
        match validated with
        | Valid _ -> true
        | Invalid _ -> false

    member _.IsInvalid(validated: Validated<'dto, 'domain, 'error>) =
        match validated with
        | Valid _ -> false
        | Invalid _ -> true

    member _.Fold onValid onInvalid (validated: Validated<'dto, 'domain, 'error>) =
        match validated with
        | Valid x -> onValid x
        | Invalid ex -> onInvalid ex

    member this.ToResult validated = this.Fold(toDto >> Ok) Error validated

    member _.ValueWith f (domain: 'domain) = f domain
    member _.DtoWith f (dto: 'dto) = f dto

    member this.ValueOr f validated = this.Fold id f validated
    member this.DtoOr f validated = this.Fold toDto f validated

    member this.Value validated =
        this.ValueOr(fun ex -> invalidOp $"This value is Invalid.\n{ex}") validated

    member this.Dto validated =
        this.DtoOr(fun ex -> invalidOp $"This value is Invalid.\n{ex}") validated

    member this.DefaultWith f validated = this.Fold id (ignore >> f) validated

    member this.DefaultDtoWith f validated = this.Fold toDto (ignore >> f) validated

    member this.DefaultValue value validated =
        this.DefaultWith(fun _ -> value) validated

    member this.DefaultDto value validated =
        this.DefaultDtoWith(fun _ -> value) validated

    member this.Tee f validated = this.Fold f ignore validated

    member this.TeeDto f validated = this.Fold(toDto >> f) ignore validated

    member this.TeeInvalid f validated = this.Fold ignore f validated

    member _.Map f validated : Validated<'dto, 'domain, 'error> =
        match validated with
        | Valid x ->
            let x' = (f >> toDto) x

            match validate x' with
            | Ok v -> Valid(fromDto v)
            | Error error -> invalidUpdateFailed (ValueSome x) x' error
        | invalid -> invalid

    member this.MapDto f validated =
        match validated with
        | Valid x -> this.Update((toDto >> f) x) validated
        | invalid -> invalid

    member _.MapInvalid f validated : Validated<'dto, 'domain, 'error> =
        match validated with
        | Invalid ex -> f ex |> Invalid
        | valid -> valid

    member private _.Lift2Proto
        f
        (xValidated: Validated<'dto, 'domain, 'error>)
        (yValidated: Validated<'dto, 'domain, 'error>)
        =
        match xValidated, yValidated with
        | Valid x, Valid y ->
            let x' = f x y

            match validate x' with
            | Ok v -> Valid(fromDto v)
            | Error error -> invalidUpdateFailed (ValueSome x) x' error
        | (Invalid _ as ex), Valid _ -> ex
        | Valid _, (Invalid _ as ex) -> ex
        | (BoxInvalid v), (BoxInvalid v') -> invalidMargedErrors (v @ v')

    member this.Lift2 f (xValidated: Validated<'dto, 'domain, 'error>) (yValidated: Validated<'dto, 'domain, 'error>) =
        this.Lift2Proto(fun x y -> f x y |> toDto) xValidated yValidated

    member this.Lift2Dto
        f
        (xValidated: Validated<'dto, 'domain, 'error>)
        (yValidated: Validated<'dto, 'domain, 'error>)
        =
        this.Lift2Proto(fun x y -> f (toDto x) (toDto y)) xValidated yValidated

    member private _.ApplyProto
        onValid
        (fValidated: Validated<'dto, _ -> _, 'error>)
        (xValidated: Validated<'dto, 'domain, 'error>)
        =
        match fValidated, xValidated with
        | Valid f, Valid x -> onValid f x
        | (BoxInvalid v), Valid _ -> invalidMargedErrors v
        | Valid _, (Invalid _ as ex) -> ex
        | (BoxInvalid v), (BoxInvalid v') -> invalidMargedErrors (v @ v')

    member this.Apply
        (fValidated: Validated<'dto, 'domain -> 'domain, 'error>)
        (xValidated: Validated<'dto, 'domain, 'error>)
        =
        this.ApplyProto
            (fun f x ->
                let x' = (f >> toDto) x

                match validate x' with
                | Ok v -> Valid(fromDto v)
                | Error error -> invalidUpdateFailed (ValueSome x) x' error)
            fValidated
            xValidated

    member this.ApplyDto
        (fValidated: Validated<'dto, 'dto -> 'dto, 'error>)
        (xValidated: Validated<'dto, 'domain, 'error>)
        : Validated<'dto, 'domain, 'error> =
        this.ApplyProto(fun f x -> this.Update((toDto >> f) x) xValidated) fValidated xValidated

let (|Valid|Invalid|) (validated: Validated<'dto, 'domain, 'error>) =
    match validated with
    | Valid value -> Valid value
    | Invalid ex -> Invalid ex

Usage.fsx

#load "DomainHelper.fsx"
#load "Domain.fsx"

open Domain
open System

let fooBar =
    person.Create
        { First = string50.Create "Foo"
          Last = string50.Create "Bar"
          Birthdate = birthdate.Create(DateTime(1990, 3, 4)) }

// val fooBar: DomainHelper.Validated<PersonDto,Person,string> =
//   Valid { First = String50 "Foo"
//         Last = String50 "Bar"
//         Birthdate = Birthdate 1990/03/04 0:00:00 }

let hogeFuga =
    person.Create
        { First = string50.Create "Hoge"
          Last = string50.Create "Fuga"
          Birthdate = birthdate.Create(DateTime(2999, 2, 8)) }

// val hogeFuga: DomainHelper.Validated<PersonDto,Person,string> =
//   Valid { First = String50 "Hoge"
//         Last = String50 "Fuga"
//         Birthdate = Birthdate 2999/02/08 0:00:00 }

module String50 =
    let concat = string50.Lift2Dto(fun s1 s2 -> s1 + s2)

module Person =
    let margeName =
        person.Lift2Dto (fun p1 p2 ->
            { p1 with
                First = String50.concat p1.First p2.First
                Last = String50.concat p1.Last p2.Last })

let marged = Person.margeName fooBar hogeFuga

// val marged: DomainHelper.Validated<PersonDto,Person,string> =
//   Valid { First = String50 "FooHoge"
//         Last = String50 "BarFuga"
//         Birthdate = Birthdate 1990/03/04 0:00:00 }

let invalidPerson =
    person.Create
        { First = string50.Create ""
          Last = string50.Create "Bar"
          Birthdate = birthdate.Create(DateTime 1) }
    |> person.MapDto(fun p -> { p with Last = p.Last |> string50.Update "Foooooo" })

// val invalidPerson: DomainHelper.Validated<PersonDto,Person,string> =
//   Invalid
//   (CreateFailed
//      ({ First = Invalid (CreateFailed ("", ["NullOrEmpty"]))
//         Last = Valid (String50 "Bar")
//         Birthdate =
//          Invalid
//            (CreateFailed (0001/01/01 0:00:00, ["Must be bigger than 1/1/1900"])) },
//       ["CreateFailed ("", ["NullOrEmpty"])";
//        "CreateFailed (0001/01/01 0:00:00, ["Must be bigger than 1/1/1900"])"]))