Skip to content

Commit

Permalink
+ Default method technique !!!
Browse files Browse the repository at this point in the history 
Implemented in Functor.fs for:
. Map based on Apply.
. Apply Based on Pure + Bind.
. Join based on Bind.
. Duplicate based on Extract.
  • Loading branch information
@gusty
gusty committed Nov 7, 2013
1 parent 1552ecd commit d4e4f42
Show file tree
Hide file tree
Showing 11 changed files with 112 additions and 65 deletions.
4 changes: 2 additions & 2 deletions FsControl.Core/Cont.fs
View file
Expand Up @@ -11,7 +11,7 @@ module Cont =
let callCC (f:(_->Cont<'r,'b>)->_) = Cont <| fun k -> run (f (fun a -> Cont(fun _ -> k a))) k

type Cont<'R,'A> with
static member instance (Functor.Map, Cont m:Cont<'r,'a>, _) = fun (f:_->'b) -> Cont(fun c -> m (c << f))
static member instance (_:Functor.Map, Cont m:Cont<'r,'a>, _) = fun (f:_->'b) -> Cont(fun c -> m (c << f))
static member instance (Applicative.Pure, _:Cont<'r,'a> ) = fun n -> Cont(fun k -> k n) :Cont<'r,'a>
static member instance (Monad.Bind , Cont m, _:Cont<'r,'b>) = fun f -> Cont(fun k -> m (fun a -> Cont.run(f a) k)) :Cont<'r,'b>
static member instance (Applicative.Apply, f:Cont<'r,_>, x:Cont<'r,'a>, _:Cont<'r,'b>) = fun () -> DefaultImpl.ApplyFromMonad f x :Cont<'r,'b>
static member instance (_:Applicative.Apply, f:Cont<'r,_>, x:Cont<'r,'a>, _:Cont<'r,'b>) = fun () -> DefaultImpl.ApplyFromMonad f x :Cont<'r,'b>
2 changes: 1 addition & 1 deletion FsControl.Core/ContT.fs
View file
Expand Up @@ -15,7 +15,7 @@ module ContT =
let map f (ContT m) = ContT(f << m)

type ContT<'Mr,'A> with
static member instance (Functor.Map, ContT m, _) = fun f -> ContT(fun c -> m (c << f))
static member instance (_:Functor.Map, ContT m, _) = fun f -> ContT(fun c -> m (c << f))

static member instance (Applicative.Pure, _:ContT<'mr,'a> ) = fun a -> ContT((|>) a) :ContT<'mr,'a>
static member instance (Monad.Bind , ContT m, _:ContT<'mr,'b>) = fun k -> ContT(fun c -> m (fun a -> ContT.run(k a) c)) :ContT<'mr,'b>
Expand Down
4 changes: 2 additions & 2 deletions FsControl.Core/ErrorT.fs
View file
Expand Up @@ -17,10 +17,10 @@ module ErrorT =
let map f (ErrorT m) = ErrorT(f m)

type ErrorT<'R> with
static member inline instance (Functor.Map, ErrorT x :ErrorT<'ma>, _) = fun (f) -> ErrorT (Functor.fmap (Error.map f) x) :ErrorT<'mb>
static member inline instance (_:Functor.Map, ErrorT x :ErrorT<'ma>, _) = fun (f) -> ErrorT (Functor.fmap (Error.map f) x) :ErrorT<'mb>

static member inline instance (Applicative.Pure, _:ErrorT<'ma>) = ErrorT << return' << Choice1Of2 :'a -> ErrorT<'ma>
static member inline instance (Applicative.Apply, ErrorT(f:'ma_b), ErrorT(x:'ma), _:ErrorT<'mb>) = fun () ->
static member inline instance (_:Applicative.Apply, ErrorT(f:'ma_b), ErrorT(x:'ma), _:ErrorT<'mb>) = fun () ->
ErrorT(fmap (<*>) f <*> x) :ErrorT<'mb>
static member inline instance (Monad.Bind , ErrorT x :ErrorT<'ma>, _:ErrorT<'mb>) =
fun (f: 'a -> ErrorT<'mb>) -> (ErrorT <| do'() {
Expand Down
133 changes: 90 additions & 43 deletions FsControl.Core/Functor.fs
View file
Expand Up @@ -31,6 +31,21 @@ module Monad =
let inline internal (>>=) x (f:_->'R) : 'R = Inline.instance (Bind, x) f


type JoinDefault() =
static member inline instance (_:JoinDefault, x:#obj, _:#obj) = fun () -> x >>= id :#obj

type Join() =
inherit JoinDefault()
static member instance (_:Join, x:option<option<'a>> , _:option<'a> ) = fun () -> Option.bind id x
static member instance (_:Join, x:List<_> , _:List<'b> ) = fun () -> List.collect id x
static member instance (_:Join, x:'b [] [] , _:'b [] ) = fun () -> Array.collect id x

let Join = Join()

let inline internal join (x:'Monad'Monad'a) : 'Monad'a = Inline.instance (Join, x) ()



open Monad

module Applicative =
Expand Down Expand Up @@ -58,37 +73,41 @@ module Applicative =
type DefaultImpl =
static member inline ApplyFromMonad f x = f >>= fun x1 -> x >>= fun x2 -> pure'(x1 x2)

type Apply = Apply with
static member instance (Apply, f:List<_> , x:List<'a> , _:List<'b> ) = fun () -> DefaultImpl.ApplyFromMonad f x :List<'b>
static member instance (Apply, f:_ [] , x:'a [] , _:'b [] ) = fun () -> DefaultImpl.ApplyFromMonad f x :'b []
static member instance (Apply, f:'r -> _ , g: _ -> 'a , _: 'r -> 'b ) = fun () -> fun x -> f x (g x) :'b
static member inline instance (Apply, (a:'m, f) , (b:'m, x:'a) , _:'m * 'b ) = fun () -> (mappend a b, f x) :'m *'b
static member instance (Apply, f:Async<_> , x:Async<'a> , _:Async<'b> ) = fun () -> DefaultImpl.ApplyFromMonad f x :Async<'b>
type ApplyDefault() =
static member inline instance (_:ApplyDefault, f:#obj , x, _:#obj) = fun () -> (f >>= fun x1 -> x >>= fun x2 -> pure'(x1 x2))

static member instance (Apply, f:option<_> , x:option<'a> , _:option<'b> ) = fun () ->
type Apply() =
inherit ApplyDefault()
static member instance (_:Apply, f:List<_> , x:List<'a> , _:List<'b> ) = fun () -> DefaultImpl.ApplyFromMonad f x :List<'b>
static member instance (_:Apply, f:_ [] , x:'a [] , _:'b [] ) = fun () -> DefaultImpl.ApplyFromMonad f x :'b []
static member instance (_:Apply, f:'r -> _ , g: _ -> 'a , _: 'r -> 'b ) = fun () -> fun x -> f x (g x) :'b
static member inline instance (_:Apply, (a:'m, f) , (b:'m, x:'a) , _:'m * 'b ) = fun () -> (mappend a b, f x) :'m *'b
static member instance (_:Apply, f:Async<_> , x:Async<'a> , _:Async<'b> ) = fun () -> DefaultImpl.ApplyFromMonad f x :Async<'b>

static member instance (_:Apply, f:option<_> , x:option<'a> , _:option<'b> ) = fun () ->
match (f,x) with
| Some f, Some x -> Some (f x)
| _ -> None :option<'b>

static member instance (Apply, f:Choice<_,'e>, x:Choice<'a,'e>, _:Choice<'b,'e>) = fun () ->
static member instance (_:Apply, f:Choice<_,'e>, x:Choice<'a,'e>, _:Choice<'b,'e>) = fun () ->
match (f,x) with
| (Choice1Of2 a, Choice1Of2 b) -> Choice1Of2 (a b)
| (Choice2Of2 a, _) -> Choice2Of2 a
| (_, Choice2Of2 b) -> Choice2Of2 b :Choice<'b,'e>

static member instance (Apply, KeyValue(k:'k,f), KeyValue(k:'k,x:'a), _:keyValue<'k,'b>) :unit->keyValue<'k,'b> = fun () -> keyValue(k, f x)
static member instance (Apply, f:Map<'k,_> , x:Map<'k,'a> , _:Map<'k,'b> ) :unit->Map<'k,'b> = fun () -> Map (seq {
static member instance (_:Apply, KeyValue(k:'k,f), KeyValue(k:'k,x:'a), _:keyValue<'k,'b>) :unit->keyValue<'k,'b> = fun () -> keyValue(k, f x)
static member instance (_:Apply, f:Map<'k,_> , x:Map<'k,'a> , _:Map<'k,'b> ) :unit->Map<'k,'b> = fun () -> Map (seq {
for KeyValue(k, vf) in f do
match Map.tryFind k x with
| Some vx -> yield k, vf vx
| _ -> () })

static member instance (Apply, f:_ Expr , x:'a Expr , _:'b Expr ) = fun () -> <@ (%f) %x @> :'b Expr
static member instance (_:Apply, f:_ Expr , x:'a Expr , _:'b Expr ) = fun () -> <@ (%f) %x @> :'b Expr

static member instance (Apply, f:('a->'b) ResizeArray, x:'a ResizeArray, _:'b ResizeArray) = fun () ->
static member instance (_:Apply, f:('a->'b) ResizeArray, x:'a ResizeArray, _:'b ResizeArray) = fun () ->
new ResizeArray<'b>(Seq.collect (fun x1 -> Seq.collect (fun x2 -> Seq.singleton (x1 x2)) x) f) :'b ResizeArray

let Apply = Apply()

let inline internal (<*>) x y = Inline.instance (Apply, x, y) ()

Expand All @@ -114,31 +133,37 @@ module Functor =
static member inline MapFromApplicative f x = pure' f <*> x
static member inline MapFromMonad f x = x >>= (pure' << f)

type Map = Map with
static member instance (Map, x:option<_> , _) = fun f -> Option.map f x
static member instance (Map, x:List<_> , _:List<'b>) = fun f -> List.map f x :List<'b>
static member instance (Map, g:_->_ , _) = (>>) g
static member instance (Map, (m,a) , _) = fun f -> (m, f a)
static member instance (Map, x:_ [] , _) = fun f -> Array.map f x
static member instance (Map, x:_ [,] , _) = fun f -> Array2D.map f x
static member instance (Map, x:_ [,,] , _) = fun f -> Array3D.map f x
static member instance (Map, x:_ [,,,] , _) = fun f ->
type MapDefault() =
static member inline instance (_:MapDefault, x:'f when 'f :> obj, _:'r when 'r :> obj) = fun (f:'a->'b) -> pure' f <*> x :'r

type Map() =
inherit MapDefault()
static member instance (_:Map, x:option<_> , _) = fun f -> Option.map f x
static member instance (_:Map, x:List<_> , _:List<'b>) = fun f -> List.map f x :List<'b>
static member instance (_:Map, g:_->_ , _) = (>>) g
static member instance (_:Map, (m,a) , _) = fun f -> (m, f a)
static member instance (_:Map, x:_ [] , _) = fun f -> Array.map f x
static member instance (_:Map, x:_ [,] , _) = fun f -> Array2D.map f x
static member instance (_:Map, x:_ [,,] , _) = fun f -> Array3D.map f x
static member instance (_:Map, x:_ [,,,] , _) = fun f ->
Array4D.init (x.GetLength 0) (x.GetLength 1) (x.GetLength 2) (x.GetLength 3) (fun a b c d -> f x.[a,b,c,d])
static member instance (Map, x:Async<_> , _) = fun f -> DefaultImpl.MapFromMonad f x
static member instance (Map, x:Choice<_,_> , _) = fun f -> Error.map f x
static member instance (Map, KeyValue(k, x) , _) = fun (f:'b->'c) -> keyValue(k, f x)
static member instance (Map, x:Map<'a,'b> , _) = fun (f:'b->'c) -> Map.map (const' f) x : Map<'a,'c>
static member instance (Map, x:Expr<_> , _) = fun f -> <@ f %x @>
static member instance (Map, x:_ ResizeArray, _) = fun f -> new ResizeArray<'b>(Seq.map f x)
static member instance (Map, x:_ IObservable, _) = fun f -> Observable.map f x
static member instance (_:Map, x:Async<_> , _) = fun f -> DefaultImpl.MapFromMonad f x
static member instance (_:Map, x:Choice<_,_> , _) = fun f -> Error.map f x
static member instance (_:Map, KeyValue(k, x) , _) = fun (f:'b->'c) -> keyValue(k, f x)
static member instance (_:Map, x:Map<'a,'b> , _) = fun (f:'b->'c) -> Map.map (const' f) x : Map<'a,'c>
static member instance (_:Map, x:Expr<_> , _) = fun f -> <@ f %x @>
static member instance (_:Map, x:_ ResizeArray, _) = fun f -> new ResizeArray<'b>(Seq.map f x)
static member instance (_:Map, x:_ IObservable, _) = fun f -> Observable.map f x

// Restricted
static member instance (Map, x:Nullable<_> , _) = fun f -> if x.HasValue then Nullable(f x.Value) else Nullable()
static member instance (Map, x:string , _) = fun f -> String.map f x
static member instance (Map, x:StringBuilder, _) = fun f -> new StringBuilder(String.map f (x.ToString()))
static member instance (Map, x:Set<_> , _) = fun f -> Set.map f x
static member instance (_:Map, x:Nullable<_> , _) = fun f -> if x.HasValue then Nullable(f x.Value) else Nullable()
static member instance (_:Map, x:string , _) = fun f -> String.map f x
static member instance (_:Map, x:StringBuilder, _) = fun f -> new StringBuilder(String.map f (x.ToString()))
static member instance (_:Map, x:Set<_> , _) = fun f -> Set.map f x


let Map = Map()

let inline internal fmap f x = Inline.instance (Map, x) f


Expand Down Expand Up @@ -183,20 +208,42 @@ module Comonad =
let inline internal extract x = Inline.instance (Extract, x) ()


type Duplicate = Duplicate with
static member instance (Duplicate, (w:'w, a:'a), _:'w * ('w*'a)) = fun () -> (w,(w,a))
static member inline instance (Duplicate, f:'m->'a, _:'m->'m->'a) = fun () a b -> f (mappend a b)
type Extend = Extend with
static member instance (Extend, (w:'w, a:'a), _:'w *'b) = fun (f:_->'b) -> (w, f (w,a))
static member inline instance (Extend, (g:'m -> 'a), _:'m->'b) = fun (f:_->'b) a -> f (fun b -> g (mappend a b))

// Restricted
static member instance (Duplicate, s:List<'a>, _:List<List<'a>>) = fun () ->
static member instance (Extend, s:List<'a>, _:List<'b>) = fun g ->
let rec tails = function [] -> [] | x::xs as s -> s::(tails xs)
tails s
List.map g (tails s)

let inline internal duplicate x = Inline.instance (Duplicate, x) ()
static member instance (Extend, s:'a [], _:'b []) = fun g ->
let rec tails = function [] -> [] | x::xs as s -> s::(tails xs)
Array.map g (s |> Array.toList |> tails |> List.toArray |> Array.map List.toArray)

let inline internal extend g s = Inline.instance (Extend, s) g
let inline internal (=>>) s g = extend g s

type DuplicateDefault() =
static member inline instance (_:DuplicateDefault, x:#obj, _:#obj) = fun () -> extend id x :#obj

let inline internal extend g s = fmap g (duplicate s)
let inline internal (=>>) s g = fmap g (duplicate s)
type Duplicate() =
inherit DuplicateDefault()
static member instance (_:Duplicate, (w:'w, a:'a), _:'w * ('w*'a)) = fun () -> (w, (w, a))
static member inline instance (_:Duplicate, f:'m -> 'a , _:'m->'m->'a ) = fun () a b -> f (mappend a b)

// Restricted
static member instance (_:Duplicate, s:List<'a>, _:List<List<'a>>) = fun () ->
let rec tails = function [] -> [] | x::xs as s -> s::(tails xs)
tails s

static member instance (_:Duplicate, s: array<'a>, _: array<array<'a>>) = fun () ->
let rec tails = function [] -> [] | x::xs as s -> s::(tails xs)
s |> Array.toList |> tails |> List.toArray |> Array.map List.toArray

let Duplicate = Duplicate()

let inline internal duplicate x = Inline.instance (Duplicate, x) ()


// MonadPlus class ------------------------------------------------------------
Expand All @@ -212,4 +259,4 @@ module MonadPlus =
static member instance (Mplus, x:_ [] , _) = fun y -> Array.append x y

let inline internal mzero () = Inline.instance Mzero ()
let inline internal mplus (x:'a) (y:'a) : 'a = Inline.instance (Mplus, x) y
let inline internal mplus (x:'a) (y:'a) : 'a = Inline.instance (Mplus, x) y
10 changes: 5 additions & 5 deletions FsControl.Core/MonadTrans.fs
View file
Expand Up @@ -14,9 +14,9 @@ module OptionT =
let map f (OptionT m) = OptionT (f m)

type OptionT<'Ma> with
static member inline instance (Functor.Map, OptionT x :OptionT<'ma>, _) = fun (f:'a->'b) -> OptionT (fmap (Option.map f) x) :OptionT<'mb>
static member inline instance (_:Functor.Map , OptionT x :OptionT<'ma>, _) = fun (f:'a->'b) -> OptionT (fmap (Option.map f) x) :OptionT<'mb>
static member inline instance (Applicative.Pure, _:OptionT<'ma>) = OptionT << return' << Some :'a -> OptionT<'ma>
static member inline instance (Applicative.Apply, OptionT(f), OptionT(x), _:OptionT<'r>) = fun () ->
static member inline instance (_:Applicative.Apply, OptionT(f), OptionT(x), _:OptionT<'r>) = fun () ->
OptionT(fmap (<*>) f <*> x) :OptionT<'r>
static member inline instance (Monad.Bind , OptionT x :OptionT<'ma>, _:OptionT<'mb>) =
fun (f: 'a -> OptionT<'mb>) -> (OptionT <| do'() {
Expand All @@ -36,9 +36,9 @@ module ListT =
let map f (ListT m) = ListT (f m)

type ListT<'Ma> with
static member inline instance (Functor.Map , ListT x:ListT<'ma>, _) = fun (f:'a->'b) -> ListT (fmap (List.map f) x):ListT<'mb>
static member inline instance (Applicative.Pure, _:ListT<'ma>) = ListT << return' << singleton :'a -> ListT<'ma>
static member inline instance (Applicative.Apply, ListT(f), ListT(x), _:ListT<'r>) = fun () ->
static member inline instance (_:Functor.Map , ListT x:ListT<'ma>, _) = fun (f:'a->'b) -> ListT (fmap (List.map f) x):ListT<'mb>
static member inline instance (Applicative.Pure, _:ListT<'ma>) = ListT << return' << singleton :'a -> ListT<'ma>
static member inline instance (_:Applicative.Apply, ListT(f), ListT(x), _:ListT<'r>) = fun () ->
ListT(fmap (<*>) f <*> x) :ListT<'r>
static member inline instance (Monad.Bind , ListT x:ListT<'ma>, _:ListT<'mb>) =
fun (k: 'a -> ListT<'mb>) ->
Expand Down
4 changes: 2 additions & 2 deletions FsControl.Core/Reader.fs
View file
Expand Up @@ -13,7 +13,7 @@ module Reader =
let ask() = Reader id

type Reader<'R,'A> with
static member instance (Functor.Map , Reader m:Reader<'r,'a>, _) = fun (f:_->'b) -> Reader(fun r -> f (m r))
static member instance (_:Functor.Map, Reader m:Reader<'r,'a>, _) = fun (f:_->'b) -> Reader(fun r -> f (m r))
static member instance (Applicative.Pure, _:Reader<'r,'a> ) = fun a -> Reader(fun _ -> a) :Reader<'r,'a>
static member instance (Monad.Bind , Reader m, _:Reader<'r,'b>) = fun k -> Reader(fun r -> Reader.run(k (m r)) r) :Reader<'r,'b>
static member instance (Applicative.Apply, f:Reader<'r,_>, x:Reader<'r,'a>, _:Reader<'r,'b>) = fun () -> DefaultImpl.ApplyFromMonad f x :Reader<'r,'b>
static member instance (_:Applicative.Apply, f:Reader<'r,_>, x:Reader<'r,'a>, _:Reader<'r,'b>) = fun () -> DefaultImpl.ApplyFromMonad f x :Reader<'r,'b>
2 changes: 1 addition & 1 deletion FsControl.Core/ReaderT.fs
View file
Expand Up @@ -17,7 +17,7 @@ module ReaderT =
let map f (ReaderT m) = ReaderT(f << m)

type ReaderT<'R,'Ma> with
static member inline instance (Functor.Map , ReaderT m , _) = fun f -> ReaderT <| fun r -> do'(){
static member inline instance (_:Functor.Map , ReaderT m , _) = fun f -> ReaderT <| fun r -> do'(){
let! a = m r
return (f a)}

Expand Down
6 changes: 3 additions & 3 deletions FsControl.Core/State.fs
View file
Expand Up @@ -15,7 +15,7 @@ module State =
let put x = State (fun _ -> ((), x)) :State<'s,_>

type State<'S,'A> with
static member instance (Functor.Map , State m, _) = fun f -> State(fun s -> let (a, s') = m s in (f a, s')) :State<'s,_>
static member instance (_:Functor.Map , State m, _) = fun f -> State(fun s -> let (a, s') = m s in (f a, s')) :State<'s,_>
static member instance (Applicative.Pure, _:State<'s,'a> ) = fun a -> State(fun s -> (a, s)) :State<'s,'a>
static member instance (Monad.Bind , State m, _:State<'s,'b>) = fun k -> State(fun s -> let (a, s') = m s in State.run(k a) s') :State<'s,'b>
static member instance (Applicative.Apply, f:State<'s,_>, x:State<'s,'a>, _:State<'s,'b>) = fun () -> DefaultImpl.ApplyFromMonad f x :State<'s,'b>
static member instance (Monad.Bind , State m, _:State<'s,'b>) = fun k -> State(fun s -> let (a, s') = m s in State.run(k a) s') :State<'s,'b>
static member instance (_:Applicative.Apply, f:State<'s,_>, x:State<'s,'a>, _:State<'s,'b>) = fun () -> DefaultImpl.ApplyFromMonad f x :State<'s,'b>
2 changes: 1 addition & 1 deletion FsControl.Core/StateT.fs
View file
Expand Up @@ -17,7 +17,7 @@ module StateT =
let map f (StateT m) = StateT(f << m)

type StateT<'S,'MaS> with
static member inline instance (Functor.Map, StateT m, _) = fun f -> StateT <| fun s -> do'(){
static member inline instance (_:Functor.Map, StateT m, _) = fun f -> StateT <| fun s -> do'(){
let! (x, s') = m s
return (f x, s')}

Expand Down

0 comments on commit d4e4f42

Please sign in to comment.