Skip to content

Instantly share code, notes, and snippets.

@mrange
Created June 6, 2017 18:52
Show Gist options
  • Star 1 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save mrange/de820274cad0aad62a31b967f8a9a813 to your computer and use it in GitHub Desktop.
Save mrange/de820274cad0aad62a31b967f8a9a813 to your computer and use it in GitHub Desktop.
// ----------------------------------------------------------------------------------------------
// Copyright 2017 Mårten Rånge
//
// Licensed under the Apache License, Version 2.0 (the "License");
// you may not use this file except in compliance with the License.
// You may obtain a copy of the License at
//
// http://www.apache.org/licenses/LICENSE-2.0
//
// Unless required by applicable law or agreed to in writing, software
// distributed under the License is distributed on an "AS IS" BASIS,
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
// See the License for the specific language governing permissions and
// limitations under the License.
// ----------------------------------------------------------------------------------------------
module MightyTransformers.Any.AnyTransformer
[<Struct>]
type Maybe<'T> =
| Just of 'T
| Nothing
[<NoEquality>]
[<NoComparison>]
type MaybeKleisli<'T, 'U> = MaybeKleisli of ('T -> Maybe<'U>)
module Maybe =
// Monad
let inline mreturn v : Maybe<_> = Just v
[<GeneralizableValue>]
let mempty<'T> = Nothing
let inline mbind t uf : Maybe<_> =
match t with
| Just tv -> uf tv
| Nothing -> Nothing
// Kleisli
let inline marr f : MaybeKleisli<_, _> = MaybeKleisli <| fun v -> mreturn (f v)
let inline mkleisli tf uf : MaybeKleisli<_, _> = MaybeKleisli <| fun v -> mbind (tf v) uf
// Applicative
let inline mpure v = mreturn v
let inline mapply f t : Maybe<_> =
match f, t with
| Just fv, Just tv -> fv tv |> Just
| _ , _ -> Nothing
// Functor
let inline mmap m t : Maybe<_> =
match t with
| Just tv -> m tv |> Just
| Nothing -> Nothing
// Combinators
let inline mand t u : Maybe<_*_> =
match t, u with
| Just tv, Just uv -> (tv, uv) |> Just
| _ , _ -> Nothing
let inline mor t u : Maybe<_> =
match t with
| Just _ -> t
| Nothing -> u
[<NoEquality>]
[<NoComparison>]
type MaybeBuilder () =
member inline x.Bind (t, uf) = mbind t uf
member inline x.Return v = mreturn v
member inline x.ReturnFrom t = t : Maybe<_>
member inline x.Zero () = mempty
type Maybe<'T> with
static member inline (>>=) (t , uf) = Maybe.mbind t uf
static member inline (<*>) (tf, u) = Maybe.mapply tf u
static member inline (|>>) (t , m) = Maybe.mmap m t
static member inline (<&>) (l , r) = Maybe.mand l r
static member inline (<|>) (l , r) = Maybe.mor l r
type MaybeKleisli<'T, 'U> with
static member inline (>=>) (tf, uf) = Maybe.mkleisli tf uf
let maybe = Maybe.MaybeBuilder ()
[<Struct>]
[<NoEquality>]
[<NoComparison>]
type AnyIndexer<'T> = AnyIndexer of (int -> Maybe<'T>)
[<Struct>]
[<NoEquality>]
[<NoComparison>]
type AnyLookup<'T> = AnyLookup of (string -> Maybe<'T>)
[<Struct>]
[<NoEquality>]
[<NoComparison>]
type AnyIterator<'T> = AnyIterator of (unit -> Maybe<'T>)
open System
open System.Collections.Generic
open System.Globalization
[<Struct>]
[<NoEquality>]
[<NoComparison>]
type AnyAdapter = AnyAdapter of (obj -> obj)
[<Struct>]
[<NoEquality>]
[<NoComparison>]
type AnyAdapterGen = AnyAdapterGen of (obj -> Maybe<AnyAdapter>)
[<NoEquality>]
[<NoComparison>]
type AnyAdapterRepository() =
let indexerGens = ResizeArray<AnyAdapterGen> 16
let lookupGens = ResizeArray<AnyAdapterGen> 16
let iteratorGens = ResizeArray<AnyAdapterGen> 16
let indexers = Dictionary<Type, AnyAdapter> ()
let lookups = Dictionary<Type, AnyAdapter> ()
let iterators = Dictionary<Type, AnyAdapter> ()
let lookup (fs : Dictionary<Type, AnyAdapter>) (gs : ResizeArray<AnyAdapterGen>) (o : obj) : Maybe<'T> =
if o <> null then
let t = o.GetType ()
match fs.TryGetValue t with
| true , (AnyAdapter f) -> f o :?> 'T |> Just
| false , _ ->
let rec loop i =
if i < gs.Count then
let (AnyAdapterGen g) = gs.[i]
match g o with
| Just f ->
fs.[t] <- f
let (AnyAdapter f) = f
f o :?> 'T |> Just
| Nothing -> loop (i + 1)
else
Nothing
loop 0
else
Nothing
let add (fs : Dictionary<Type, AnyAdapter>) t f = fs.[t] <- f
let addGen (gs : ResizeArray<AnyAdapterGen>) g = gs.Add g
let adapt f = (fun (o : obj)-> f (o :?> 'T) :> obj) |> AnyAdapter
member x.Indexer<'T> (o : obj) : Maybe<AnyIndexer<'T>> = lookup indexers indexerGens o
member x.Lookup<'T> (o : obj) : Maybe<AnyLookup<'T>> = lookup lookups lookupGens o
member x.Iterator<'T> (o : obj) : Maybe<AnyIterator<'T>> = lookup iterators iteratorGens o
//member x.AddIndexer (t : Type) (f : obj -> obj) : unit = add indexers t f
//member x.AddLookup (t : Type) (f : obj -> obj) : unit = add lookups t f
//member x.AddIterator (t : Type) (f : obj -> obj) : unit = add iterators t f
member x.AddIndexer<'T, 'U> (f : 'T -> AnyIndexer<'U>) = add indexers typeof<'T> (adapt f)
member x.AddLookup<'T, 'U> (f : 'T -> AnyLookup<'U>) = add lookups typeof<'T> (adapt f)
member x.AddIterator<'T, 'U> (f : 'T -> AnyIterator<'U>) = add iterators typeof<'T> (adapt f)
member x.AddIndexerGen (g : AnyAdapterGen) : unit = addGen indexerGens g
member x.AddLookupGen (g : AnyAdapterGen) : unit = addGen lookupGens g
member x.AddIteratorGen (g : AnyAdapterGen) : unit = addGen iteratorGens g
module AnyAdapter =
let arrayIterator (a : 'T []) : AnyIterator<'T> =
let mutable i = 0
AnyIterator <| fun () ->
if i < a.Length then
let v = Just a.[i]
i <- i + 1
v
else
Nothing
let arrayIndexer (a : 'T []) : AnyIndexer<'T> =
AnyIndexer <| fun i ->
if i < a.Length then
Just a.[i]
else
Nothing
let mapLookup (m : Map<string, 'T>) : AnyLookup<'T> =
AnyLookup <| fun name ->
match m |> Map.tryFind name with
| Some v -> v |> Just
| None -> Nothing
let mapIterator (m : Map<string, 'T>) : AnyIterator<'T> =
let e = (m :> IEnumerable<KeyValuePair<string, 'T>>)
let e = e.GetEnumerator ()
AnyIterator <| fun () ->
if e.MoveNext () then
Just e.Current.Value
else
e.Dispose ()
Nothing
(*
let mapLookupGen : AnyAdapterGen =
let genMap = typeof<Map<_, _>>.GetGenericTypeDefinition ()
AnyAdapterGen <| fun o ->
if o <> null then
let t = o.GetType ()
if t.IsGenericType && t.GetGenericTypeDefinition () = genMap then
Nothing
else
Nothing
else
Nothing
*)
[<RequireQualifiedAccess>]
type AnyContextElement =
| Member of string
| Index of int
| Named of string
[<Struct>]
type AnyContext = AnyContext of AnyContextElement list
[<RequireQualifiedAccess>]
type AnyError =
| CanNotConvertTo of obj*Type*Type
| IndexOutOfRange of int
| MemberNotFound of string
| NotIndexable of Type
| NotLookupable of Type
| NotIterable of Type
| Message of string
[<RequireQualifiedAccess>]
type AnyErrorTree =
| Empty
| Leaf of AnyContext*AnyError
| Suppress of AnyErrorTree
| Fork of AnyErrorTree*AnyErrorTree
[<Struct>]
type AnyResult<'T> =
| AnyResult of 'T*AnyErrorTree
member x.Value =
let (AnyResult (v, _)) = x
v
member x.ErrorTree =
let (AnyResult (_, et)) = x
et
[<Struct>]
type AnyErrorItem =
{
IsSuppressed : bool
Path : string
Error : AnyError
}
static member New i p e : AnyErrorItem = { IsSuppressed = i; Path = p; Error = e }
//
[<NoEquality>]
[<NoComparison>]
[<Struct>]
type AnyTransform<'T> = AnyTransform of OptimizedClosures.FSharpFunc<obj, AnyContext, AnyAdapterRepository, AnyResult<'T>>
[<NoEquality>]
[<NoComparison>]
type AnyTransformKleisli<'T, 'U> = AnyTransformKleisli of ('T -> AnyTransform<'U>)
module AnyTransform =
open FSharp.Core.Printf
module Details =
open System.Text
let defaultSize = 16
let defaultCulture = CultureInfo.InvariantCulture
module TypeMapper =
type Mapper<'From, 'To> = ('From -> Maybe<'To>)
type TypeMapper<'T> =
{
Zero : 'T
AsString : 'T -> string
FromString : Mapper<string , 'T>
FromByte : Mapper<byte , 'T>
FromChar : Mapper<char , 'T>
FromDecimal : Mapper<decimal , 'T>
FromFloat : Mapper<float , 'T>
FromFloat32 : Mapper<float32 , 'T>
FromInt16 : Mapper<int16 , 'T>
FromInt32 : Mapper<int32 , 'T>
FromInt64 : Mapper<int64 , 'T>
FromSByte : Mapper<sbyte , 'T>
FromUInt16 : Mapper<uint16 , 'T>
FromUInt32 : Mapper<uint32 , 'T>
FromUInt64 : Mapper<uint64 , 'T>
}
static member New zero asString fromString fromByte fromChar fromDecimal fromFloat fromFloat32 fromInt16 fromInt32 fromInt64 fromSByte fromUInt16 fromUInt32 fromUInt64 =
{
Zero = zero
AsString = asString
FromString = fromString
FromByte = fromByte
FromChar = fromChar
FromDecimal = fromDecimal
FromFloat = fromFloat
FromFloat32 = fromFloat32
FromInt16 = fromInt16
FromInt32 = fromInt32
FromInt64 = fromInt64
FromSByte = fromSByte
FromUInt16 = fromUInt16
FromUInt32 = fromUInt32
FromUInt64 = fromUInt64
} : TypeMapper<_>
let parseDecimal s =
let ns = NumberStyles.Float
match Decimal.TryParse(s, ns, defaultCulture) with
| true, v -> v |> Just
| _ , _ -> Nothing
let parseFloat m s =
let ns = NumberStyles.Float
match Double.TryParse(s, ns, defaultCulture) with
| true, v -> v |> m |> Just
| _ , _ -> Nothing
let parseInt m s =
let ns = NumberStyles.Integer
match Int64.TryParse(s, ns, defaultCulture) with
| true, v -> v |> m |> Just
| _ , _ -> Nothing
let parseUInt m s =
let ns = NumberStyles.Integer
match UInt64.TryParse(s, ns, defaultCulture) with
| true, v -> v |> m |> Just
| _ , _ -> Nothing
let asString (v : #IFormattable) = v.ToString("", defaultCulture)
let fromString v = Nothing
let doMap t f v =
let tv = t v
let ftv = f tv
if ftv = v then Just tv else Nothing
let mdtoc, mctod =
let dtoc d = d |> int |> char
let ctod c = c |> int |> decimal
doMap dtoc ctod, doMap ctod dtoc
let ctos (c : char) = c.ToString ()
let tm_byte = let inline m m = doMap byte m in TypeMapper<_>.New (byte 0) asString (parseUInt byte ) (m byte) (m char) (m decimal) (m float) (m float32) (m int16) (m int32) (m int64) (m sbyte) (m uint16) (m uint32) (m uint64)
let tm_char = let inline m m = doMap char m in TypeMapper<_>.New (char 0) ctos (parseInt char ) (m byte) (m char) (mdtoc ) (m float) (m float32) (m int16) (m int32) (m int64) (m sbyte) (m uint16) (m uint32) (m uint64)
let tm_decimal = let inline m m = doMap decimal m in TypeMapper<_>.New (decimal 0) asString (parseDecimal ) (m byte) (mctod ) (m decimal) (m float) (m float32) (m int16) (m int32) (m int64) (m sbyte) (m uint16) (m uint32) (m uint64)
let tm_float = let inline m m = doMap float m in TypeMapper<_>.New (float 0) asString (parseFloat float ) (m byte) (m char) (m decimal) (m float) (m float32) (m int16) (m int32) (m int64) (m sbyte) (m uint16) (m uint32) (m uint64)
let tm_float32 = let inline m m = doMap float32 m in TypeMapper<_>.New (float32 0) asString (parseFloat float32) (m byte) (m char) (m decimal) (m float) (m float32) (m int16) (m int32) (m int64) (m sbyte) (m uint16) (m uint32) (m uint64)
let tm_int16 = let inline m m = doMap int16 m in TypeMapper<_>.New (int16 0) asString (parseInt int16 ) (m byte) (m char) (m decimal) (m float) (m float32) (m int16) (m int32) (m int64) (m sbyte) (m uint16) (m uint32) (m uint64)
let tm_int32 = let inline m m = doMap int32 m in TypeMapper<_>.New (int32 0) asString (parseInt int32 ) (m byte) (m char) (m decimal) (m float) (m float32) (m int16) (m int32) (m int64) (m sbyte) (m uint16) (m uint32) (m uint64)
let tm_int64 = let inline m m = doMap int64 m in TypeMapper<_>.New (int64 0) asString (parseInt int64 ) (m byte) (m char) (m decimal) (m float) (m float32) (m int16) (m int32) (m int64) (m sbyte) (m uint16) (m uint32) (m uint64)
let tm_sbyte = let inline m m = doMap sbyte m in TypeMapper<_>.New (sbyte 0) asString (parseInt sbyte ) (m byte) (m char) (m decimal) (m float) (m float32) (m int16) (m int32) (m int64) (m sbyte) (m uint16) (m uint32) (m uint64)
let tm_uint16 = let inline m m = doMap uint16 m in TypeMapper<_>.New (uint16 0) asString (parseUInt uint16 ) (m byte) (m char) (m decimal) (m float) (m float32) (m int16) (m int32) (m int64) (m sbyte) (m uint16) (m uint32) (m uint64)
let tm_uint32 = let inline m m = doMap uint32 m in TypeMapper<_>.New (uint32 0) asString (parseUInt uint32 ) (m byte) (m char) (m decimal) (m float) (m float32) (m int16) (m int32) (m int64) (m sbyte) (m uint16) (m uint32) (m uint64)
let tm_uint64 = let inline m m = doMap uint64 m in TypeMapper<_>.New (uint64 0) asString (parseUInt uint64 ) (m byte) (m char) (m decimal) (m float) (m float32) (m int16) (m int32) (m int64) (m sbyte) (m uint16) (m uint32) (m uint64)
let inline atrans f = AnyTransform(OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt f)
let inline zero () = LanguagePrimitives.GenericZero<_>
let inline getType o= if o <> null then o.GetType () else typeof<Void>
let inline leaf c e = AnyErrorTree.Leaf (c, e)
let empty = AnyErrorTree.Empty
let inline isGood e=
match e with
| AnyErrorTree.Empty
| AnyErrorTree.Suppress _ -> true
| _ -> false
let inline supp e =
match e with
| AnyErrorTree.Empty
| AnyErrorTree.Suppress _ -> e
| _ -> AnyErrorTree.Suppress e
let inline join l r =
match l, r with
| AnyErrorTree.Empty , _ -> r
| _ , AnyErrorTree.Empty -> l
| AnyErrorTree.Suppress l , AnyErrorTree.Suppress r -> AnyErrorTree.Fork (l, r) |> AnyErrorTree.Suppress
| _ , _ -> AnyErrorTree.Fork (l, r)
let inline invoke (AnyTransform f) o c r = f.Invoke (o, c, r)
let pathToString (AnyContext p) =
// Verified that call to private pathToString don't do "funny" stuff
let rec pathToString (sb : StringBuilder) p =
match p with
| [] -> sb.Append "json" |> ignore
| h::t ->
pathToString sb t
match h with
| AnyContextElement.Member n -> sb.Append (sprintf ".%s" n) |> ignore
| AnyContextElement.Index i -> sb.Append (sprintf ".[%d]" i) |> ignore
| AnyContextElement.Named n -> sb.Append (sprintf "(%s)" n) |> ignore
let sb = System.Text.StringBuilder defaultSize
pathToString sb p
sb.ToString ()
let collapse (et : AnyErrorTree) =
// Verified that call to private collapse don't do "funny" stuff
let rec collapse suppress (result : ResizeArray<_>) et =
match et with
| AnyErrorTree.Empty -> ()
| AnyErrorTree.Leaf (c, e) -> AnyErrorItem.New suppress (pathToString c) e |> result.Add
| AnyErrorTree.Suppress e -> collapse true result e
| AnyErrorTree.Fork (l, r) -> collapse suppress result l; collapse suppress result r
let result = ResizeArray defaultSize
collapse false result et
result.ToArray ()
let inline result v et = AnyResult (v, et)
let inline good v = result v empty
module Loops =
let rec amany t c r (ra : ResizeArray<_>) iterator et i =
let (AnyContext p) = c
let (AnyIterator getter) = iterator
match getter () with
| Just v ->
let ic = (AnyContextElement.Index i)::p |> AnyContext
let tr = invoke t v ic r
if isGood tr.ErrorTree then
ra.Add tr.Value
amany t c r ra iterator (join et tr.ErrorTree) (i + 1)
| Nothing ->
et
open Details
// Monad
let inline areturn v : AnyTransform<'T> =
atrans <| fun o c r ->
good v
let inline abind (t : AnyTransform<'T>) (uf : 'T -> AnyTransform<'U>) : AnyTransform<'U> =
atrans <| fun o c r->
let tr = invoke t o c r
let u = uf tr.Value
let ur = invoke u o c r
result ur.Value (join tr.ErrorTree ur.ErrorTree)
// Kleisli
let inline aarr f = AnyTransformKleisli <| fun v -> areturn (f v)
let inline akleisli tf uf = AnyTransformKleisli <| fun v -> abind (tf v) uf
// Applicative
let inline apure v = areturn v
let inline aapply (t : AnyTransform<'U -> 'V>) (u : AnyTransform<'U>) : AnyTransform<'V> =
atrans <| fun o c r ->
let tr = invoke t o c r
let ur = invoke u o c r
result (tr.Value ur.Value) (join tr.ErrorTree ur.ErrorTree)
// Functor
let inline amap m (t : AnyTransform<'T>) : AnyTransform<'U> =
atrans <| fun o c r->
let tr = invoke t o c r
result (m tr.Value) tr.ErrorTree
// Combinators
let inline aand (lt : AnyTransform<'T>) (rt : AnyTransform<'U>) : AnyTransform<'T*'U> =
atrans <| fun o c r ->
let lr = invoke lt o c r
let rr = invoke rt o c r
result (lr.Value, rr.Value) (join lr.ErrorTree rr.ErrorTree)
let inline aor (lt : AnyTransform<'T>) (rt : AnyTransform<'T>) : AnyTransform<'T> =
atrans <| fun o c r ->
let lr = invoke lt o c r
if isGood lr.ErrorTree then
lr
else
let rr = invoke rt o c r
if isGood rr.ErrorTree then
rr
else
result rr.Value (join lr.ErrorTree rr.ErrorTree)
let inline akeepLeft (lt : AnyTransform<'T>) (rt : AnyTransform<_>) : AnyTransform<'T> =
atrans <| fun o c r ->
let lr = invoke lt o c r
let rr = invoke rt o c r
result lr.Value (join lr.ErrorTree rr.ErrorTree)
let inline akeepRight (lt : AnyTransform<_>) (rt : AnyTransform<'T>) : AnyTransform<'T> =
atrans <| fun o c r ->
let lr = invoke lt o c r
let rr = invoke rt o c r
result rr.Value (join lr.ErrorTree rr.ErrorTree)
let inline asuppress (t : AnyTransform<'T>) : AnyTransform<'T> =
atrans <| fun o c r ->
let tr = invoke t o c r
let e =
if isGood tr.ErrorTree then
tr.ErrorTree
else
tr.ErrorTree |> supp
result tr.Value e
let inline atoMaybe (t : AnyTransform<'T>) : AnyTransform<Maybe<'T>> =
atrans <| fun o c r ->
let tr = invoke t o c r
if isGood tr.ErrorTree then
good (Just tr.Value)
else
good Nothing
let inline atoOption (t : AnyTransform<'T>) : AnyTransform<'T option> =
atrans <| fun o c r ->
let tr = invoke t o c r
if isGood tr.ErrorTree then
good (Some tr.Value)
else
good None
#if !FSHARP_41
let inline atoResult (t : AnyTransform<'T>) : AnyTransform<Result<'T, AnyErrorItem []>> =
atrans <| fun o c r ->
let tr = invoke t o c r
if isGood tr.ErrorTree then
good (Ok tr.Value)
else
good (Error (collapse tr.ErrorTree))
#endif
let inline aunpack (ok : 'T -> AnyTransform<'U>) (bad : AnyErrorItem [] -> AnyTransform<'U>) (t : AnyTransform<'T>) =
atrans <| fun o c r ->
let tr = invoke t o c r
if isGood tr.ErrorTree then
let tok = ok tr.Value
invoke tok o c r
else
let tbad = bad (collapse tr.ErrorTree)
invoke tbad o c r
// Failures
let inline afailure v msg : AnyTransform<'T> =
atrans <| fun o c r ->
result v (msg |> AnyError.Message |> leaf c)
let inline afailuref v fmt = kprintf (afailure v) fmt
let inline awarning v msg : AnyTransform<'T> =
atrans <| fun o c r ->
result v (msg |> AnyError.Message |> leaf c |> supp)
let inline awarningf v fmt = kprintf (awarning v) fmt
// Misc
let inline awithContext name (t : AnyTransform<'T>) : AnyTransform<'T> =
atrans <| fun o (AnyContext p) r ->
let nc = (AnyContextElement.Named name)::p |> AnyContext
invoke t o nc r
let inline adebug name (t : AnyTransform<'T>) : AnyTransform<'T> =
atrans <| fun o c r ->
printfn "BEFORE %s: %A(%A)" name o c
let tr = invoke t o c r
if isGood tr.ErrorTree then
printfn "SUCCESS %s: %A(%A)" name tr.Value tr.ErrorTree
else
printfn "FAILURE %s: %A(%A)" name tr.Value tr.ErrorTree
tr
let arun (t : AnyTransform<'T>) (root : obj) (repo : AnyAdapterRepository): 'T*AnyErrorItem [] =
let tr = invoke t root ([] |> AnyContext) repo
tr.Value, collapse tr.ErrorTree
// Extractors
let aextract (tm : TypeMapper.TypeMapper<'T>) : AnyTransform<'T> =
atrans <| fun o c r ->
let mv =
match o with
| null -> Nothing
| (:? string as v) -> tm.FromString v
| (:? byte as v) -> tm.FromByte v
| (:? char as v) -> tm.FromChar v
| (:? decimal as v) -> tm.FromDecimal v
| (:? float as v) -> tm.FromFloat v
| (:? float32 as v) -> tm.FromFloat32 v
| (:? int16 as v) -> tm.FromInt16 v
| (:? int32 as v) -> tm.FromInt32 v
| (:? int64 as v) -> tm.FromInt64 v
| (:? sbyte as v) -> tm.FromSByte v
| (:? uint16 as v) -> tm.FromUInt16 v
| (:? uint32 as v) -> tm.FromUInt32 v
| (:? uint64 as v) -> tm.FromUInt64 v
| (:? IFormattable as f) -> tm.FromString (f.ToString ("", defaultCulture))
| _ -> tm.FromString (o.ToString ())
match mv with
| Just v -> v |> good
| Nothing -> result tm.Zero (AnyError.CanNotConvertTo (o, getType o, typeof<'T>)|> leaf c)
let aasByte = aextract TypeMapper.tm_byte
let aasChar = aextract TypeMapper.tm_char
let aasDecimal = aextract TypeMapper.tm_decimal
let aasFloat = aextract TypeMapper.tm_float
let aasFloat32 = aextract TypeMapper.tm_float32
let aasInt16 = aextract TypeMapper.tm_int16
let aasInt32 = aextract TypeMapper.tm_int32
let aasInt64 = aextract TypeMapper.tm_int64
let aasSByte = aextract TypeMapper.tm_sbyte
let aasUInt16 = aextract TypeMapper.tm_uint16
let aasUInt32 = aextract TypeMapper.tm_uint32
let aasUInt64 = aextract TypeMapper.tm_uint64
let aasString : AnyTransform<string> =
atrans <| fun o c r ->
match o with
| (:? string as v) -> v |> good
| (:? IFormattable as f) -> f.ToString ("", defaultCulture) |> good
| _ -> o |> string |> good
// Queries
let inline aindex idx v (t : AnyTransform<'T>) : AnyTransform<'T> =
atrans <| fun o c r ->
match r.Indexer o with
| Just indexer ->
let (AnyContext p) = c
let (AnyIndexer indexer) = indexer
match indexer idx with
| Just v ->
let ic = (AnyContextElement.Index idx)::p |> AnyContext
invoke t v ic r
| Nothing ->
result v (idx |> AnyError.IndexOutOfRange |> leaf c)
| Nothing ->
result v (o |> getType |> AnyError.NotIndexable |> leaf c)
let inline aindexz idx t =
aindex idx (zero ()) t
let inline amany (t : AnyTransform<'T>) : AnyTransform<'T []> =
atrans <| fun o c r ->
let ra = ResizeArray defaultSize
match r.Iterator o with
| Just iterator ->
let et = Loops.amany t c r ra iterator empty 0
result (ra.ToArray ()) et
| Nothing ->
result [||] (o |> getType |> AnyError.NotIterable |> leaf c)
let inline amember name v (t : AnyTransform<'T>) : AnyTransform<'T> =
atrans <| fun o c r ->
match r.Lookup o with
| Just lookup ->
let (AnyContext p) = c
let (AnyLookup getter) = lookup
match getter name with
| Just v ->
let ic = (AnyContextElement.Member name)::p |> AnyContext
invoke t v ic r
| Nothing ->
result v (name |> AnyError.MemberNotFound |> leaf c)
| Nothing ->
result v (o |> getType |> AnyError.NotLookupable |> leaf c)
let inline amemberz name t =
amember name (zero ()) t
type AnyBuilder () =
member inline x.Bind (t, uf) = abind t uf
member inline x.Combine (t, u) = akeepRight t u
member inline x.Return v = areturn v
member inline x.ReturnFrom t = t : AnyTransform<'T>
member inline x.Zero () = areturn (zero ())
type AnyTransform<'T> with
static member inline (>>=) (t , uf) = AnyTransform.abind t uf
static member inline (<*>) (tf, u) = AnyTransform.aapply tf u
static member inline (|>>) (t , m) = AnyTransform.amap m t
static member inline (<&>) (l , r) = AnyTransform.aand l r
static member inline (<|>) (l , r) = AnyTransform.aor l r
static member inline (.>>) (l , r) = AnyTransform.akeepLeft l r
static member inline (>>.) (l , r) = AnyTransform.akeepRight l r
type AnyTransformKleisli<'T, 'U> with
static member inline (>=>) (tf, uf) = AnyTransform.akleisli tf uf
let anyTransform = AnyTransform.AnyBuilder ()
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment