eulerfx · June 23, 2014 21:51 · Jun 23, 2014 · Jun 23, 2014
diff --git a/JsonValueCodecSyntax.fs b/JsonValueCodecSyntax.fs
@@ -1,3 +1,5 @@
+/// port of https://github.com/mausch/Fleece
+
 type ToJsonClass = ToJsonClass
 
 type FromJsonClass = FromJsonClass

diff --git a/JsonValueCodecSyntax.fs b/JsonValueCodecSyntax.fs
@@ -0,0 +1,232 @@
+type ToJsonClass = ToJsonClass
+
+type FromJsonClass = FromJsonClass
+
+type ParseResult<'a> = Choice<'a, string>
+
+module ParseResult =
+
+    let inline unit a : ParseResult<'a> = Choice1Of2 a
+
+    let inline error err : ParseResult<'a> = Choice2Of2 err
+
+    let get<'a> (r:ParseResult<'a>) : 'a = 
+        match r with
+        | Success r -> r
+        | Failure err -> failwith (sprintf "parse failed=%s" err)
+
+    let tryGetOpt<'a> (r:ParseResult<'a option>) : 'a option = 
+        match r with
+        | Success r -> r
+        | _ -> None
+
+    let map f (r:ParseResult<'a>) : ParseResult<'b> = 
+        match r with
+        | Success a -> unit (f a)
+        | Failure err -> error err
+
+    let bind f (r:ParseResult<'a>) : ParseResult<'b> =
+        match r with
+        | Success a -> f a
+        | Failure err -> error err
+
+    let traverseA (f:'a -> ParseResult<'b>) (xs:'a[]) : ParseResult<'b[]> =
+        let length = Array.length xs
+        let acc : 'b[] = Array.zeroCreate length
+        let rec go i = 
+            if i = length then null
+            else
+                match f xs.[i] with
+                | Success a -> 
+                    acc.[i] <- a
+                    go (i + 1)
+                | Failure err -> err
+        let err = go 0
+        if err = null then unit acc
+        else error err        
+
+    type JsonParserBuilder() =
+        member x.Return a = unit a
+        member x.ReturnFrom r = r
+        member x.Bind (inp:ParseResult<'a>, body:'a -> ParseResult<'b>) : ParseResult<'b> = bind body inp
+
+
+
+[<AutoOpen>]
+module Helpers =
+
+    let jsonParse = new ParseResult.JsonParserBuilder()
+
+
+    let inline toJson_ (a: ^a, b: ^b) = ((^a or ^b) : (static member ToJson: ^b -> JsonValue) b)
+
+    /// Encodes a value of a type containing a ToJson function into a JsonValue.
+    let inline toJson x : JsonValue = toJson_ (ToJsonClass, x)    
+
+    /// Encodes a value into a JSON string.
+    let inline toJsonString x : string = x |> toJson |> JsonValue.toString
+
+    /// Encodes a value into a JSON byte array.
+    let inline toJsonBytes x : byte[] = x |> toJson |> JsonValue.toString |> Encoding.UTF8.GetBytes
+
+    /// Creates a JSON property.
+    let inline jprop (name:string) (x:'a) = (name,toJson x)
+
+    /// Creates a JSON object.
+    let inline jobj (props:(string * JsonValue)[]) = props |> JsonValue.Record
+
+
+    /// Creates a successful ParseResult.
+    let succeed x = ParseResult.unit x
+
+    /// Creates a failed ParseResult.
+    let fail err = ParseResult.error err
+
+
+    let inline private fromJson_ (a:^a, b:^b) = ((^a or ^b) : (static member FromJson:^b -> (JsonValue -> ^b ParseResult)) b)
+
+    /// Parses a JsonValue into a specified type containing a FromJson function.
+    let inline fromJson (json:JsonValue) = fromJson_ (FromJsonClass, Unchecked.defaultof<'a>) json
+
+    /// Parse a JsonValue into a specified type and applies a mapping.
+    let inline fromJsonTo (json:JsonValue) (f:'a -> 'b) = fromJson json |> ParseResult.map f
+
+    /// Parses a JSON string.
+    let inline parseJson (json:string) = JsonValue.Parse json |> fromJson
+
+    /// Parses a byte array.
+    let inline parseJsonBytes (json:byte[]) = Encoding.UTF8.GetString(json) |> JsonValue.Parse |> fromJson
+
+    /// Parses a JSON property into a specified type.
+    let inline jget (json:JsonValue) key = 
+        let prop = json.TryGetProperty key
+        match prop with
+        | Some prop -> fromJson prop
+        | None -> fail (sprintf "can't find key '%s'" key)
+
+    /// Optionally parses a JSON property into a specified type.
+    let inline jgetopt (json:JsonValue) key = 
+        let prop = json.TryGetProperty key
+        match prop with
+        | Some prop -> fromJson prop |> ParseResult.map Some
+        | None -> succeed None
+
+    let parseObj (f:JsonValue -> ParseResult<'a>) (json:JsonValue) : ParseResult<'a> =
+        match json with
+        | JsonValue.Record _ as json -> f json
+        | _ -> fail "JSON object expected."
+
+
+
+
+type ToJsonClass with
+
+    static member inline ToJson (x:JsonValue) = x
+    static member inline ToJson (x:(string * JsonValue)[]) = JsonValue.Record x
+    static member inline ToJson (x:int) = JsonValue.Number (decimal x)
+    static member inline ToJson (x:int64) = JsonValue.Number (decimal x)
+    static member inline ToJson (x:int16) = JsonValue.Number (decimal x)
+    static member inline ToJson (x:bool) = JsonValue.Boolean x
+    static member inline ToJson (x:float) = JsonValue.Float x
+    static member inline ToJson (x:single) = JsonValue.Float (float x)
+    static member inline ToJson (x:char) = JsonValue.String (x.ToString())
+    static member inline ToJson (x:decimal) = JsonValue.Number x
+    static member inline ToJson (x:string) = if x = null then JsonValue.Null else JsonValue.String x
+    static member inline ToJson (x:DateTime) = JsonValue.String (x.ToString("yyyy-MM-ddTHH:mm:ssZ"))
+    static member inline ToJson (x:DateTimeOffset) = JsonValue.String (x.ToString("yyyy-MM-ddTHH:mm:ssK"))    
+
+    static member inline ToJson (x:'a array) = x |> Array.map toJson |> JsonValue.Array
+    //static member inline ToJson (x:System.Collections.Generic.IEnumerable<'a>) = x |> Seq.toArray |> ToJsonClass.ToJson    
+    static member inline ToJson (x:'a list) = x |> List.toArray |> ToJsonClass.ToJson    
+    static member inline ToJson (x:'a Set) = x |> Set.toArray |> ToJsonClass.ToJson
+    static member inline ToJson (x:Map<string, 'a>) = x |> Map.map (fun _ v -> toJson v) |> Map.toArray |> jobj
+    static member inline ToJson (x:'a option) = match x with Some x -> toJson x | None -> JsonValue.Null
+
+    static member inline ToJson (x:Choice<_,_>) = 
+        match x with
+        | Choice1Of2 a -> jobj [| "left"  .= a |]
+        | Choice2Of2 b -> jobj [| "right" .= b |]
+
+
+
+
+type FromJsonClass with
+
+    static member FromJson (_:string) = function
+        | JsonValue.String s -> succeed s
+        | JsonValue.Null -> succeed null
+        | _ -> fail "string"
+
+    static member FromJson (_:int) = function
+        | JsonValue.Number _ as j -> j.AsInteger() |> succeed
+        | JsonValue.Float _ as j -> j.AsInteger() |> succeed
+        | _ -> fail "int"
+
+    static member FromJson (_:decimal) = function
+        | JsonValue.Number _ as j -> j.AsDecimal() |> succeed
+        | JsonValue.Float _ as j -> j.AsDecimal() |> succeed
+        | _ -> fail "decimal"
+
+    static member FromJson (_:float) = function
+        | JsonValue.Number _ as j -> j.AsFloat() |> succeed
+        | JsonValue.Float _ as j -> j.AsFloat() |> succeed
+        | _ -> fail "float"
+
+    static member FromJson (_:bool) = function
+        | JsonValue.Boolean b -> b |> succeed
+        | _ -> fail "bool"
+
+    static member FromJson (_:DateTime) = function
+        | JsonValue.String s ->
+            match DateTime.TryParseExact(s, "yyyy-MM-ddTHH:mm:ssZ", null, DateTimeStyles.RoundtripKind) with
+            | true,dt -> succeed dt
+            | _ -> fail "datetime"
+        | _ -> fail "datetime"       
+
+    static member FromJson (_:DateTimeOffset) = function
+        | JsonValue.String s ->
+            match DateTimeOffset.TryParseExact(s, "yyyy-MM-ddTHH:mm:ssK", null, DateTimeStyles.RoundtripKind) with
+            | true,dt -> succeed dt
+            | _ -> fail "datetime"
+        | _ -> fail "datetime"
+
+    static member inline FromJson (_:'a option) = function
+        | JsonValue.Null -> succeed None
+        | json -> 
+            let a : ParseResult<'a> = fromJson json
+            a |> ParseResult.map Some
+
+    static member inline FromJson (_:'a[]) = function
+        | JsonValue.Array xs ->            
+            let xs : ParseResult<'a[]> = xs |> ParseResult.traverseA fromJson
+            xs
+        | _ -> fail "array"
+
+    static member inline FromJson (_:list<'a>) = function
+        | JsonValue.Array xs ->            
+            let xs : ParseResult<'a[]> = xs |> ParseResult.traverseA fromJson
+            xs |> ParseResult.map List.ofArray
+        | _ -> fail "list"
+
+    static member inline FromJson (_:Set<'a>) = function
+        | JsonValue.Array xs ->            
+            let xs : ParseResult<'a[]> = xs |> ParseResult.traverseA fromJson
+            xs |> ParseResult.map Set.ofArray
+        | _ -> fail "list"
+
+    static member inline FromJson (_:Choice<'a, 'b>) = function
+        | JsonValue.Record [| "left"  , json |] -> let r : ParseResult<'a> = json |> fromJson in r |> ParseResult.map Choice1Of2
+        | JsonValue.Record [| "right" , json |] -> let r : ParseResult<'b> = json |> fromJson in r |> ParseResult.map Choice2Of2
+        | _ -> fail "choice"
+
+[<AutoOpen>]
+module Ops =
+
+    /// Creates a JSON property given a key (property name) and corresponding value.
+    let inline (.=) key value = jprop key value
+
+    /// Parses a property from a JSON value.
+    let inline (.@) json key = jget json key
+
+    /// Parses a property from a JSON value, which may be absent.
+    let inline (.@?) json key = jgetopt json key
No results found