Skip to content

Instantly share code, notes, and snippets.

@mrange
Last active November 14, 2016 20:03
Show Gist options
  • Save mrange/552cb0b474b517b706333cebb64f44aa to your computer and use it in GitHub Desktop.
Save mrange/552cb0b474b517b706333cebb64f44aa to your computer and use it in GitHub Desktop.
module XTransformer =
open FSharp.Core.Printf
open System.Xml
type XName = string
type XPathElement = XName*int
type XPath = XPathElement list
type XError =
| AboveRootElement
| AttributeNotFound of string
| ElementNotFound of string
| Failure of string
| Warning of string
type XErrorTree =
| Empty
| Leaf of XPath*XError
| Fork of XErrorTree*XErrorTree
type XResult<'T> = XResult of 'T*XErrorTree
type XTransform<'T> = XTransform of (XmlElement -> XPath -> XResult<'T>)
type XElementQuery =
| XNameQuery of XName
| XFilterQuery of string*(XmlElement -> bool)
module Details =
let inline adapt f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt f
let inline xleaf p e = Leaf (p, e)
let inline xjoin l r =
match l, r with
| Empty , _ -> r
| _ , Empty -> l
| _ , _ -> Fork (l, r)
let inline xresult v et = XResult (v, et)
let inline xgood v = xresult v Empty
let inline xisGood et =
match et with
| Empty -> true
| _ -> false
let inline xdescribe xq =
match xq with
| XNameQuery xn -> sprintf "Expected <%s>" xn
| XFilterQuery (d, _) -> d
let inline xtestElement xeq (e : XmlElement) =
match xeq with
| XNameQuery xn -> xn = e.Name
| XFilterQuery (_, f) -> f e
open Details
module XQuery =
let inline xqhasElementName xn : XElementQuery =
XNameQuery xn
let inline xqhasAttributeValue k v : XElementQuery =
let f (e : XmlElement) =
match e.Attributes.GetNamedItem k with
| null -> false
| a -> a.Value = v
XFilterQuery (sprintf "Expected @%s='%s'" k v, f)
module XTransform =
let inline xreturn v : XTransform<'T> =
XTransform <| fun e p ->
xgood v
let inline xbind (XTransform t) (uf : 'T -> XTransform<'U>) : XTransform<'U> =
let t = adapt t
XTransform <| fun e p ->
let (XResult (tv, tet)) = t.Invoke (e, p)
let (XTransform u) = uf tv
let u = adapt u
let (XResult (uv, uet)) = u.Invoke (e, p)
xresult uv (xjoin tet uet)
let inline xpure v = xreturn v
let inline xap (XTransform tf) (XTransform u) : XTransform<_> =
let tf = adapt tf
let u = adapt u
XTransform <| fun e p ->
let (XResult (tfv, tfet)) = tf.Invoke (e, p)
let (XResult (uv, uet)) = u.Invoke (e, p)
xresult (tfv uv) (xjoin tfet uet)
let inline xmap m (XTransform t) : XTransform<'U> =
let t = adapt t
XTransform <| fun e p ->
let (XResult (tv, tet)) = t.Invoke (e, p)
xresult (m tv) tet
let inline xdebug name (XTransform t) : XTransform<'T> =
let t = adapt t
XTransform <| fun e p ->
printfn "BEFORE %s: %A - %A" name e.Name p
let (XResult (tv, tet)) as tr = t.Invoke (e, p)
match tet with
| Empty -> printfn "SUCCESS %s: %A" name tv
| _ -> printfn "FAILURE %s: %A" name tv
tr
let inline xorElse (XTransform l) (XTransform r) : XTransform<'T> =
let l = adapt l
let r = adapt r
XTransform <| fun e p ->
let (XResult (lv, let_)) as lr = l.Invoke (e, p)
match let_ with
| Empty -> lr
| _ ->
let (XResult (rv, ret)) as rr = r.Invoke (e, p)
match ret with
| Empty -> rr
| _ ->
xresult rv (xjoin let_ ret)
let inline xkeepLeft (XTransform l) (XTransform r) : XTransform<'T> =
let l = adapt l
let r = adapt r
XTransform <| fun e p ->
let (XResult (lv, let_)) as lr = l.Invoke (e, p)
let (XResult (_, ret)) as rr = r.Invoke (e, p)
xresult lv (xjoin let_ ret)
let inline xkeepRight (XTransform l) (XTransform r) : XTransform<'U> =
let l = adapt l
let r = adapt r
XTransform <| fun e p ->
let (XResult (_, let_)) as lr = l.Invoke (e, p)
let (XResult (rv, ret)) as rr = r.Invoke (e, p)
xresult rv (xjoin let_ ret)
let inline xopt (XTransform t) : XTransform<'T option> =
let t = adapt t
XTransform <| fun e p ->
let (XResult (tv, tet)) as tr = t.Invoke (e, p)
match tet with
| Empty -> xgood (Some tv)
| _ -> xgood None
let inline xpair (XTransform l) (XTransform r) : XTransform<'T*'U> =
let l = adapt l
let r = adapt r
XTransform <| fun e p ->
let (XResult (lv, let_)) as lr = l.Invoke (e, p)
let (XResult (rv, ret)) as rr = r.Invoke (e, p)
xresult (lv, rv) (xjoin let_ ret)
let inline xfailure v msg : XTransform<'T> =
XTransform <| fun e p ->
xresult v (msg |> Failure |> xleaf p)
let inline xfailuref v fmt = kprintf (xfailure v) fmt
let inline xwarning v msg : XTransform<'T> =
XTransform <| fun e p ->
xresult v (msg |> Warning |> xleaf p)
let inline xwarningf v fmt = kprintf (xwarning v) fmt
let inline xattr (xn : XName) : XTransform<string> =
XTransform <| fun e p ->
match e.Attributes.GetNamedItem xn with
| null -> xresult "" (sprintf "Expected @%s" xn |> AttributeNotFound |> xleaf p)
| a -> xgood a.Value
let inline xelement (xeq : XElementQuery) v (XTransform t) : XTransform<'T> =
let t = adapt t
XTransform <| fun e p ->
let es = e.ChildNodes
let ec = es.Count
let rec loop et i =
if i < ec then
match es.[i] with
| :? XmlElement as e ->
if xtestElement xeq e then
t.Invoke (e, (e.Name, i)::p)
else
loop et (i + 1)
| _ ->
loop et (i + 1)
else
xresult v (xeq |> xdescribe |> ElementNotFound |> xleaf p)
loop Empty 0
let inline xelements (xeq : XElementQuery) (XTransform t) : XTransform<'T []> =
let t = adapt t
XTransform <| fun e p ->
let ra = ResizeArray 16
let es = e.ChildNodes
let ec = es.Count
let rec loop et i =
if i < ec then
match es.[i] with
| :? XmlElement as e ->
if xtestElement xeq e then
let (XResult (tv, tet)) = t.Invoke (e, (e.Name, i)::p)
ra.Add tv
loop (xjoin et tet) (i + 1)
else
loop et (i + 1)
| _ ->
loop et (i + 1)
else
xresult (ra.ToArray ()) et
loop Empty 0
let inline xparent v (XTransform t) : XTransform<'T> =
let t = adapt t
XTransform <| fun e p ->
match e.ParentNode with
| :? XmlElement as parent ->
let _::p = p
t.Invoke (parent, p)
| _ ->
xresult v (AboveRootElement |> xleaf p)
let inline xfold (xeq : XElementQuery) (XTransform t) (f : 'S -> 'T -> XTransform<'S>) (z : 'S) : XTransform<'S> =
let t = adapt t
let f = adapt f
XTransform <| fun e p ->
let es = e.ChildNodes
let ec = es.Count
let rec loop s et i =
if i < ec then
match es.[i] with
| :? XmlElement as e ->
if xtestElement xeq e then
let (XResult (tv, tet)) = t.Invoke (e, (e.Name, i)::p)
let (XTransform ss) = f.Invoke (s, tv)
let ss = adapt ss
let (XResult (sv, set)) = ss.Invoke (e, (e.Name, i)::p)
loop sv (xjoin et (xjoin tet set)) (i + 1)
else
loop s et (i + 1)
| _ ->
loop s et (i + 1)
else
xresult s et
loop z Empty 0
let inline xcheck c msg : XTransform<unit> =
XTransform <| fun e p ->
if c then
xgood ()
else
xresult () (msg |> Failure |> xleaf p)
let inline xcheckf c fmt =
kprintf (xcheck c) fmt
let inline xcheckName xn : XTransform<unit> =
XTransform <| fun e p ->
if e.Name = xn then
xgood ()
else
xresult () (sprintf "Expected <%s/> element but found <%s/> element" xn e.Name |> ElementNotFound |> xleaf p)
let inline xcheckAttribute xn v : XTransform<unit> =
XTransform <| fun e p ->
match e.Attributes.GetNamedItem xn with
| null -> xresult () (sprintf "Expected @%s" xn |> AttributeNotFound |> xleaf p)
| a ->
if a.Value = v then
xresult () Empty
else
xresult () (sprintf "Expected @%s=%s" xn v |> AttributeNotFound |> xleaf p)
let xrun (XTransform t) (e : XmlElement) : 'T*XErrorTree =
let t = adapt t
let (XResult (tv, tet)) = t.Invoke (e, [e.Name, 0])
tv, tet
type XBuilder() =
member inline x.Bind (t, uf) = xbind t uf
member inline x.Return v = xreturn v
member inline x.ReturnFrom t = t
module Infixes =
let inline (>>=) t uf = XTransform.xbind t uf
let inline (<*>) tf u = XTransform.xap tf u
let inline (|>>) t m = XTransform.xmap m t
let inline (<|>) l r = XTransform.xorElse l r
let inline (.>>.) l r = XTransform.xpair l r
let inline (.>>) l r = XTransform.xkeepLeft l r
let inline (>>.) l r = XTransform.xkeepRight l r
let xtransform = XTransform.XBuilder ()
module Tests =
open System.Xml
open XTransformer
open XTransformer.XTransform
open XTransformer.XQuery
open XTransformer.Infixes
let xml = """
<Root>
<Customer id="CUSTOMER_0001" firstName="Bill" lastName="Gates">
<Orders>
<Order id="ORDER_0001" invoiceDate="2016-11-10">
<OrderRow sku="Windows95" quantity="2"/>
<OrderRow sku="WindowsME" quantity="1"/>
</Order>
<Order id="ORDER_0002" invoiceDate="2016-12-10">
<OrderRow sku="WindowsNT" quantity="1"/>
</Order>
</Orders>
</Customer>
</Root>
"""
type OrderRow =
| OrderRow of string*string
static member New sku quantity = OrderRow (sku, quantity)
type Order =
| Order of string*string*OrderRow []
static member New id invoiceDate orderRows = Order (id, invoiceDate, orderRows)
type Customer =
| Customer of string*string*string*Order []
static member New id firstName lastName orders = Customer (id, firstName, lastName, orders)
static member Zero = Customer.New "" "" "" [||]
let xorderRow =
xcheckName "OrderRow"
>>. xpure OrderRow.New
<*> xattr "sku"
<*> xattr "quantity"
let xorder =
xcheckName "Order"
>>. xpure Order.New
<*> xattr "id"
<*> xattr "invoiceDate"
<*> xelements (xqhasElementName "OrderRow") xorderRow
let xcustomer =
xcheckName "Customer"
>>. xpure Customer.New
<*> xattr "id"
<*> xattr "firstName"
<*> xattr "lastName"
<*> xelement (xqhasElementName "Orders") [||] (xelements (xqhasElementName "Order") xorder)
let xdoc =
xelement (xqhasElementName "Customer") Customer.Zero xcustomer
let run () =
let doc = XmlDocument ()
doc.LoadXml xml
let res = xrun xdoc doc.DocumentElement
printfn "%A" res
[<EntryPoint>]
let main argv =
Tests.run ()
0
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment