Embedded sitelets

MyApplication.fs

module Embedded =

    open IntelliFactory.WebSharper.Sitelets

    type Action =
        | Action1
        | Action2

    let sitelet : Sitelet<Action> =
        Sitelet.Infer <| function
            | Action1 ->
                Content.PageContent (fun ctx ->
                    { Page.Default with
                        Body =
                            [
                                Div [
                                    A [HRef (ctx.Link Action2)] -< [Text "Go to Embedded.Action2"]
                                ]
                            ] })
            | Action2 ->
                Content.PageContent (fun ctx ->
                    { Page.Default with
                        Body =
                            [
                                Div [
                                    A [HRef (ctx.Link Action1)] -< [Text "Go to Embedded.Action1"]
                                ]
                            ] })


module Parent =

    open IntelliFactory.WebSharper.Sitelets

    type Action =
        | Home
        | Embed of Embedded.Action

    let sitelet : Sitelet<Action> =
        Sitelet.Infer <| function
            | Home ->
                Content.PageContent (fun ctx ->
                    { Page.Default with
                        Body =
                            [
                                Div [
                                    A [HRef (ctx.Link (Embed Embedded.Action1))] -< [Text "Go to Embedded.Action1"]
                                    Br []
                                    A [HRef (ctx.Link (Embed Embedded.Action2))] -< [Text "Go to Embedded.Action2"]
                                ]
                            ] })
            | Embed _ -> failwith "Not handled here"

module Global =

    let sitelet : Sitelet<Parent.Action> =
        Sitelet.Sum [
            Embedded.sitelet |> Sitelet.EmbedInUnion <@ Parent.Embed @>
            // or equivalently:
            // Embedded.Sitelet |> Sitelet.Embed Parent.Embed (function Parent.Embed x -> Some x | _ -> None)
            Parent.sitelet
        ]

Sitelet.fs

module Sitelet =

    open Microsoft.FSharp.Quotations
    open Microsoft.FSharp.Reflection
    open IntelliFactory.WebSharper.Sitelets

    let Embed (embed: 'E -> 'R) (unembed: 'R -> 'E option) (sitelet: Sitelet<'E>) : Sitelet<'R> =
        {
            Router =
                Router.New
                    (sitelet.Router.Route >> Option.map embed)
                    (unembed >> Option.bind sitelet.Router.Link)
            Controller =
                { Handle = fun a ->
                    match unembed a with
                    | Some ea -> Content.CustomContent <| fun ctx ->
                        Content.ToResponse (sitelet.Controller.Handle ea)
                            {
                                ResolveUrl = ctx.ResolveUrl
                                ApplicationPath = ctx.ApplicationPath
                                Link = embed >> ctx.Link
                                Json = ctx.Json
                                Metadata = ctx.Metadata
                                ResourceContext = ctx.ResourceContext
                                Request = ctx.Request
                                RootFolder = ctx.RootFolder
                            }

                    | None -> failwith "Invalid action in Sitelet.Embed" }
        } : Sitelet<'R>

    let EmbedInUnion (case: Expr<'E -> 'R>) (sitelet: Sitelet<'E>) : Sitelet<'R> =
        match case with
        | ExprShape.ShapeLambda(_, Patterns.NewUnionCase (uci, _)) ->
            let embed (y: 'E) = FSharpValue.MakeUnion(uci, [|box y|]) :?> 'R
            let unembed (x: 'R) =
                let uci', args' = FSharpValue.GetUnionFields(box x, uci.DeclaringType)
                if uci.Tag = uci'.Tag then
                    Some (args'.[0] :?> 'E)
                else None
            Embed embed unembed sitelet
        | _ -> failwith "Invalid union case in Sitelet.EmbedInUnionCase"