3 people like it.
Like the snippet!

Improved Generic Units of Measure

Improved version of http://fssnip.net/pm/title/Extending-units-of-measure-to-arbitrary-types that adopts the "type class" approach and sheds requirement for passing the witness type when tag/untagging UoM values.

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45:

type UoM = class end
with
    static member inline Tag< ^W, ^t, ^tm when (^W or ^t) : (static member IsUoM : ^t * ^tm -> unit)> (t : ^t) = (# "" t : ^tm #)
    static member inline UnTag< ^W, ^t, ^tm when (^W or ^t) : (static member IsUoM : ^t * ^tm -> unit)> (t : ^tm) = (# "" t : ^t #)

let inline tag (x : 't) : 'tm = UoM.Tag<UoM, 't, 'tm> x
let inline untag (x : 'tm) : 't = UoM.UnTag<UoM, 't, 'tm> x

// Extending UoM to existing types
open System

[<MeasureAnnotatedAbbreviation>]
type Guid<[<Measure>] 'Measure> = Guid

[<MeasureAnnotatedAbbreviation>]
type string<[<Measure>] 'Measure> = string

type UoM with
    // Be *very* careful when writing this; bad args will result in invalid IL
    static member IsUoM(_ : Guid, _ : Guid<'Measure>) = ()
    static member IsUoM(_ : string, _ : string<'Measure>) = ()

// Extending UoM to new types
[<MeasureAnnotatedAbbreviation>]
type Foo<[<Measure>] 'Measure> = Foo
and Foo = Foo
with
    // Be *very* careful when writing this; bad args will result in invalid IL
    static member IsUoM(_ : Foo, _ : Foo<'Measure>) = ()


// Example
[<Measure>] type processId = class end
[<Measure>] type taskId = class end
[<Measure>] type bar = class end

type Entry = { ProcessId : Guid<processId> ; TaskId : Guid<taskId> ; Bar : Foo<bar> }


let value = { ProcessId = tag <| Guid.NewGuid() ; TaskId = tag <| Guid.NewGuid() ; Bar = tag Foo }

match value with
| { ProcessId = pid ; TaskId = tid ; Bar = bar} -> 
    { ProcessId = pid ; TaskId = tid ; Bar = bar}
//    { ProcessId = pid ; TaskId = pid ; Bar = bar} // uncomment for type error

static member UoM.Tag : t:'t -> 'tm (requires member IsUoM)

Full name: Script.UoM.Tag

type unit = Unit

Full name: Microsoft.FSharp.Core.unit

val t : 't (requires member IsUoM)

static member UoM.UnTag : t:'tm -> 't (requires member IsUoM)

Full name: Script.UoM.UnTag

val t : 'tm

val tag : x:'t -> 'tm (requires member IsUoM)

Full name: Script.tag

val x : 't (requires member IsUoM)

type UoM =
  static member IsUoM : Guid * Guid<'Measure> -> unit
  static member IsUoM : string * string<'Measure> -> unit
  static member Tag : t:'t -> 'tm (requires member IsUoM)
  static member UnTag : t:'tm -> 't (requires member IsUoM)

Full name: Script.UoM

static member UoM.Tag : t:'t -> 'tm (requires member IsUoM)

val untag : x:'tm -> 't (requires member IsUoM)

Full name: Script.untag

val x : 'tm

static member UoM.UnTag : t:'tm -> 't (requires member IsUoM)

namespace System

Multiple items
type MeasureAnnotatedAbbreviationAttribute =
inherit Attribute
new : unit -> MeasureAnnotatedAbbreviationAttribute

Full name: Microsoft.FSharp.Core.MeasureAnnotatedAbbreviationAttribute

--------------------
new : unit -> MeasureAnnotatedAbbreviationAttribute

Multiple items
type Guid =
  struct
    new : b:byte[] -> Guid + 4 overloads
    member CompareTo : value:obj -> int + 1 overload
    member Equals : o:obj -> bool + 1 overload
    member GetHashCode : unit -> int
    member ToByteArray : unit -> byte[]
    member ToString : unit -> string + 2 overloads
    static val Empty : Guid
    static member NewGuid : unit -> Guid
    static member Parse : input:string -> Guid
    static member ParseExact : input:string * format:string -> Guid
    ...
  end

Full name: System.Guid

--------------------
type Guid<'Measure> = Guid

Full name: Script.Guid<_>

--------------------
Guid()
Guid(b: byte []) : unit
Guid(g: string) : unit
Guid(a: int, b: int16, c: int16, d: byte []) : unit
Guid(a: uint32, b: uint16, c: uint16, d: byte, e: byte, f: byte, g: byte, h: byte, i: byte, j: byte, k: byte) : unit
Guid(a: int, b: int16, c: int16, d: byte, e: byte, f: byte, g: byte, h: byte, i: byte, j: byte, k: byte) : unit

Multiple items
type MeasureAttribute =
inherit Attribute
new : unit -> MeasureAttribute

Full name: Microsoft.FSharp.Core.MeasureAttribute

--------------------
new : unit -> MeasureAttribute

Multiple items
val string : value:'T -> string

Full name: Microsoft.FSharp.Core.Operators.string

--------------------
type string = String

Full name: Microsoft.FSharp.Core.string

--------------------
type string<'Measure> = string

Full name: Script.string<_>

static member UoM.IsUoM : Guid * Guid<'Measure> -> unit

Full name: Script.UoM.IsUoM

static member UoM.IsUoM : string * string<'Measure> -> unit

Full name: Script.UoM.IsUoM

Multiple items
union case Foo.Foo: Foo

--------------------
type Foo =
| Foo
static member IsUoM : Foo * Foo<'Measure> -> unit

Full name: Script.Foo

--------------------
type Foo<'Measure> = Foo

Full name: Script.Foo<_>

static member Foo.IsUoM : Foo * Foo<'Measure> -> unit

Full name: Script.Foo.IsUoM

[<Measure>]
type processId

Full name: Script.processId

[<Measure>]
type taskId

Full name: Script.taskId

[<Measure>]
type bar

Full name: Script.bar

type Entry =
  {ProcessId: Guid<processId>;
   TaskId: Guid<taskId>;
   Bar: Foo<bar>;}

Full name: Script.Entry

Entry.ProcessId: Guid<processId>

Entry.TaskId: Guid<taskId>

Entry.Bar: Foo<bar>

val value : Entry

Full name: Script.value

Guid.NewGuid() : Guid

val pid : Guid<processId>

val tid : Guid<taskId>

Multiple items
val bar : Foo<bar>

--------------------
[<Measure>]
type bar

Full name: Script.bar

Raw view Test code New version

More information

Link:	http://fssnip.net/7SK
Posted:	7 years ago
Author:	Eirik Tsarpalis
Tags:	units of measure