fsharp-typeclasses.staticmethods/Monoid.fs at master · SteveGilham/fsharp-typeclasses.staticmethods · GitHub

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
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
module Data.Monoid

open Prelude

#nowarn "64"

type Monoid = Monoid with
    static member        mempty (Monoid, _:List<'a> ) = []   :List<'a>
    static member        mempty (Monoid, _:Maybe<'a>) = None :Maybe<'a>
    static member        mempty (Monoid, _:array<'a>) = [||] :array<'a>
    static member        mempty (Monoid, _:string   ) = ""
    static member        mempty (Monoid, _:Ordering ) = EQ
    static member        mempty (Monoid, _:unit     ) = ()

let inline mempty() : ^R = ((^C or ^R) : (static member mempty  : ^C * ^R -> _) (Monoid, defaultof< ^R>))

type Monoid with static member inline mempty  (Monoid, _: 'a*'b         ) =
                    (mempty(),mempty()                           ): 'a*'b
type Monoid with static member inline mempty  (Monoid, _: 'a*'b*'c      ) =
                    (mempty(),mempty(),mempty()                  ): 'a*'b*'c
type Monoid with static member inline mempty  (Monoid, _: 'a*'b*'c*'d   ) =
                    (mempty(),mempty(),mempty(),mempty()         ): 'a*'b*'c*'d
type Monoid with static member inline mempty  (Monoid, _: 'a*'b*'c*'d*'e) =
                    (mempty(),mempty(),mempty(),mempty(),mempty()): 'a*'b*'c*'d*'e


let inline mappend (x:^a) (y:^a) : 'a = ((^C or ^a) : (static member mappend: ^C * ^a * ^a -> _) (Monoid, x, y))

type Monoid with
    static member        mappend (Monoid,x:List<_> , y  ) = x ++ y
    static member inline mappend (Monoid,x:Maybe<_>, y  ) =
        match (x,y) with
        | (Just a , Just b ) -> Just(a </mappend/> b)
        | (Just a , Nothing) -> Just a
        | (Nothing, Just b ) -> Just b
        | _               -> None
    static member        mappend (Monoid, x:array<_> , y) = x </Array.append/> y
    static member        mappend (Monoid, x:string   , y) = x + y
    static member        mappend (Monoid, x:Ordering , y) =
        match (x,y) with
        | (LT,_) -> LT
        | (EQ,a) -> a
        | (GT,_) -> GT
    static member        mappend (Monoid, (), _:unit ) = ()


type Monoid with static member inline mappend (Monoid, (x1,x2         ), (y1,y2         )) =
                    (mappend x1 y1,mappend x2 y2                                          ) :'a*'b
type Monoid with static member inline mappend (Monoid, (x1,x2,x3      ), (y1,y2,y3      )) =
                    (mappend x1 y1,mappend x2 y2,mappend x3 y3                            ) :'a*'b*'c
type Monoid with static member inline mappend (Monoid, (x1,x2,x3,x4   ), (y1,y2,y3,y4   )) =
                    (mappend x1 y1,mappend x2 y2,mappend x3 y3,mappend x4 y4              ) :'a*'b*'c*'d
type Monoid with static member inline mappend (Monoid, (x1,x2,x3,x4,x5), (y1,y2,y3,y4,y5)) =
                    (mappend x1 y1,mappend x2 y2,mappend x3 y3,mappend x4 y4,mappend x5 y5) :'a*'b*'c*'d*'e

let inline mconcat x =
    let foldR f s lst = List.foldBack f lst s
    foldR mappend (mempty()) x


type Dual<'a> = Dual of 'a with
    static member inline mempty  (Monoid,       _:Dual<'m>) = Dual (mempty()) :Dual<'m>
    static member inline mappend (Monoid, Dual x, Dual y  ) = Dual (y </mappend/> x)
let getDual (Dual x) = x

type Endo<'a> = Endo of ('a -> 'a) with
    static member        mempty  (Monoid, _:Endo<'m>) = Endo id :Endo<'m>
    static member        mappend (Monoid,   Endo f, Endo g  ) = Endo (f << g)

let appEndo (Endo f) = f

type All = All of bool with
    static member mempty  (Monoid, _:All  ) = All true
    static member mappend (Monoid,   All x, All y) = All (x && y)

type Any = Any of bool with
    static member mempty  (Monoid, _:Any  ) = Any false
    static member mappend (Monoid,   Any x, Any y) = Any (x || y)

type Sum<'a> = Sum of 'a with
    static member inline mempty  (Monoid, _:Sum<'n>  ) = Sum 0G :Sum<'n>
    static member inline mappend (Monoid,   Sum (x:'n), Sum(y:'n)) = Sum (x + y) :Sum<'n>

type Product<'a> = Product of 'a with
    static member inline mempty  (Monoid, _:Product<'n>  ) = Product 1G :Product<'n>
    static member inline mappend (Monoid,   Product (x:'n), Product(y:'n)) = Product (x * y) :Product<'n>