xtransformer.fs

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