More

ConsumePlugin/Catamorphism.fs

@@ -0,0 +1,180 @@
+namespace ConsumePlugin
+
+open WoofWare.Myriad.Plugins
+
+type Const =
+    | Int of int
+    | String of string
+
+type PairOpKind =
+    | NormalSeq
+    | ThenDoSeq
+
+[<CreateCatamorphism>]
+type Expr =
+    | Const of Const
+    | Pair of Expr * Expr * PairOpKind
+    | Sequential of Expr list
+    | Builder of Expr * ExprBuilder
+
+and ExprBuilder =
+    | Child of ExprBuilder
+    | Parent of Expr
+
+// Say that CreateCatamorphism-tagged types form the set T.
+// Assert that each U in T is a discriminated union.
+// For each type U in T, assign a generic parameter 'ret<U>.
+// For each U:
+//   * Define the type [U]Cata, generic on all the parameters {'ret<U> : U in T}.
+//   * For each DU case C in type U:
+//     * create a method in [U]Cata, whose return value is 'ret<U> and whose args are the fields of the case C
+//     * any occurrence in a field of an input value of type equal to any element of T (say type V) is replaced by 'ret<V>
+// Finally, define a type Cata<{'ret<U> for U in T}>
+// with one member for each U, namely of type [U]Cata<{'ret<U> for U in T}>.
+type ExprCata<'builderRet, 'ret> =
+    abstract Const : Const -> 'ret
+    abstract Pair : 'ret -> 'ret -> PairOpKind -> 'ret
+    abstract Sequential : 'ret list -> 'ret
+    abstract Builder : 'ret -> 'builderRet -> 'ret
+
+type ExprBuilderCata<'builderRet, 'ret> =
+    abstract Child : 'builderRet -> 'builderRet
+    abstract Parent : 'ret -> 'builderRet
+
+type Cata<'bret, 'ret> =
+    {
+        Expr : ExprCata<'bret, 'ret>
+        Builder : ExprBuilderCata<'bret, 'ret>
+    }
+
+// Then we can create the noddy non-tail-rec implementation of `apply`.
+// For each U in T, define apply{U}, generic on every {'ret<U> for U in T}, taking a Cata and a U and returning a 'ret<U>.
+// The body of apply{U} is given by matching on the cases of U.
+module Cata =
+    let rec apply<'bret, 'ret> (cata : Cata<'bret, 'ret>) (e : Expr) : 'ret =
+        match e with
+        | Const c -> cata.Expr.Const c
+        | Pair (expr, expr1, pairOpKind) -> cata.Expr.Pair (apply cata expr) (apply cata expr1) pairOpKind
+        | Sequential exprs -> exprs |> List.map (apply cata) |> cata.Expr.Sequential
+        | Builder (expr, exprBuilder) -> cata.Expr.Builder (apply cata expr) (applyB cata exprBuilder)
+
+    and applyB<'bret, 'ret> (cata : Cata<'bret, 'ret>) (e : ExprBuilder) : 'bret =
+        match e with
+        | Child b -> cata.Builder.Child (applyB cata b)
+        | Parent p -> cata.Builder.Parent (apply cata p)
+
+// The tail-recursive version is harder.
+module TailRecCata =
+    [<RequireQualifiedAccess>]
+    type private Instruction =
+        | ProcessExpr of Expr
+        | ProcessBuilder of ExprBuilder
+        | Pair of PairOpKind
+        | Sequential of int
+        | Builder
+        | Child
+        | Parent
+
+    let private loop (cata : Cata<_, _>) (instructions : ResizeArray<Instruction>) =
+        let resultsStack = ResizeArray ()
+        let builderResultsStack = ResizeArray ()
+
+        while instructions.Count > 0 do
+            let currentInstruction = instructions.[instructions.Count - 1]
+            instructions.RemoveAt (instructions.Count - 1)
+
+            match currentInstruction with
+            | Instruction.ProcessBuilder builder ->
+                match builder with
+                | Child exprBuilder ->
+                    instructions.Add Instruction.Child
+                    instructions.Add (Instruction.ProcessBuilder exprBuilder)
+                | Parent expr ->
+                    instructions.Add Instruction.Parent
+                    instructions.Add (Instruction.ProcessExpr expr)
+            | Instruction.ProcessExpr currentExpr ->
+                match currentExpr with
+                | Const c -> resultsStack.Add (cata.Expr.Const c)
+                | Pair (expr, expr1, pairOpKind) ->
+                    instructions.Add (Instruction.Pair pairOpKind)
+                    instructions.Add (Instruction.ProcessExpr expr1)
+                    instructions.Add (Instruction.ProcessExpr expr)
+                | Sequential exprs ->
+                    instructions.Add (Instruction.Sequential (List.length exprs))
+
+                    for expr in exprs do
+                        instructions.Add (Instruction.ProcessExpr expr)
+                | Builder (expr, exprBuilder) ->
+                    instructions.Add Instruction.Builder
+                    instructions.Add (Instruction.ProcessExpr expr)
+                    instructions.Add (Instruction.ProcessBuilder exprBuilder)
+            | Instruction.Pair pairOpKind ->
+                let expr = resultsStack.[resultsStack.Count - 1]
+                let expr1 = resultsStack.[resultsStack.Count - 2]
+                resultsStack.RemoveRange (resultsStack.Count - 2, 2)
+                cata.Expr.Pair expr expr1 pairOpKind |> resultsStack.Add
+            | Instruction.Sequential count ->
+                let values =
+                    seq {
+                        for i = resultsStack.Count - 1 downto resultsStack.Count - count do
+                            yield resultsStack.[i]
+                    }
+                    |> Seq.toList
+
+                resultsStack.RemoveRange (resultsStack.Count - count, count)
+                cata.Expr.Sequential values |> resultsStack.Add
+            | Instruction.Builder ->
+                let expr = resultsStack.[resultsStack.Count - 1]
+                resultsStack.RemoveAt (resultsStack.Count - 1)
+                let exprBuilder = builderResultsStack.[builderResultsStack.Count - 1]
+                builderResultsStack.RemoveAt (builderResultsStack.Count - 1)
+                cata.Expr.Builder expr exprBuilder |> resultsStack.Add
+            | Instruction.Child ->
+                let exprBuilder = builderResultsStack.[builderResultsStack.Count - 1]
+                builderResultsStack.RemoveAt (builderResultsStack.Count - 1)
+                cata.Builder.Child exprBuilder |> builderResultsStack.Add
+            | Instruction.Parent ->
+                let expr = resultsStack.[resultsStack.Count - 1]
+                resultsStack.RemoveAt (resultsStack.Count - 1)
+                cata.Builder.Parent expr |> builderResultsStack.Add
+
+        resultsStack, builderResultsStack
+
+    let run (cata : Cata<'bret, 'ret>) (e : Expr) : 'ret =
+        let instructions = ResizeArray ()
+        instructions.Add (Instruction.ProcessExpr e)
+
+        let resultsStack, builderResultsStack = loop cata instructions
+
+        if builderResultsStack.Count > 0 then
+            failwith "logic error"
+
+        Seq.exactlyOne resultsStack
+
+    let runBuilder (cata : Cata<'bret, 'ret>) (e : ExprBuilder) : 'bret =
+        let instructions = ResizeArray ()
+        instructions.Add (Instruction.ProcessBuilder e)
+
+        let resultsStack, builderResultsStack = loop cata instructions
+
+        if resultsStack.Count > 0 then
+            failwith "logic error"
+
+        Seq.exactlyOne builderResultsStack
+
+module CataExample =
+    let id =
+        {
+            Expr =
+                { new ExprCata<_, _> with
+                    member _.Const x = Const x
+                    member _.Pair x y z = Pair (x, y, z)
+                    member _.Sequential xs = Sequential xs
+                    member _.Builder x b = Builder (x, b)
+                }
+            Builder =
+                { new ExprBuilderCata<_, _> with
+                    member _.Child x = Child x
+                    member _.Parent x = Parent x
+                }
+        }

ConsumePlugin/ConsumePlugin.fsproj

@@ -39,6 +39,10 @@
     <Compile Include="GeneratedSerde.fs">
       <MyriadFile>SerializationAndDeserialization.fs</MyriadFile>
     </Compile>
+    <Compile Include="Catamorphism.fs" />
+    <Compile Include="GeneratedCatamorphism.fs">
+      <MyriadFile>Catamorphism.fs</MyriadFile>
+    </Compile>
   </ItemGroup>
 
   <ItemGroup>

ConsumePlugin/GeneratedCatamorphism.fs

@@ -0,0 +1,93 @@
+//------------------------------------------------------------------------------
+//        This code was generated by myriad.
+//        Changes to this file will be lost when the code is regenerated.
+//------------------------------------------------------------------------------
+
+
+
+
+
+namespace ConsumePlugin
+
+open WoofWare.Myriad.Plugins
+
+/// Description of how to combine cases during a fold
+type ExprCata<'Expr, 'ExprBuilder> =
+    /// How to operate on the Const case
+    abstract Const : Const -> 'Expr
+    /// How to operate on the Pair case
+    abstract Pair : 'Expr -> 'Expr -> PairOpKind -> 'Expr
+    /// How to operate on the Sequential case
+    abstract Sequential : 'Expr list -> 'Expr
+    /// How to operate on the Builder case
+    abstract Builder : 'Expr -> 'ExprBuilder -> 'Expr
+
+/// Description of how to combine cases during a fold
+type ExprBuilderCata<'Expr, 'ExprBuilder> =
+    /// How to operate on the Child case
+    abstract Child : 'ExprBuilder -> 'ExprBuilder
+    /// How to operate on the Parent case
+    abstract Parent : 'Expr -> 'ExprBuilder
+
+/// Specifies how to perform a fold (catamorphism) over the type Expr.
+type Cata<'Expr, 'ExprBuilder> =
+    {
+        /// TODO: doc
+        Expr : ExprCata<'Expr, 'ExprBuilder>
+        /// TODO: doc
+        ExprBuilder : ExprBuilderCata<'Expr, 'ExprBuilder>
+    }
+
+/// Methods to perform a catamorphism over the type Expr
+[<RequireQualifiedAccess>]
+module ExprCata =
+    [<RequireQualifiedAccess>]
+    type private Instruction =
+        | Process__Expr of Expr
+        | Process__ExprBuilder of ExprBuilder
+        | Expr_Pair of PairOpKind
+        | Expr_Sequential of int
+        | Expr_Builder
+        | ExprBuilder_Child
+        | ExprBuilder_Parent
+
+    let private loop (cata : Cata<_, _>) (instructions : ResizeArray<Instruction>) =
+        let exprBuilderStack = ResizeArray ()
+        let exprStack = ResizeArray ()
+
+        while instructions.Count > 0 do
+            let currentInstruction = instructions.[instructions.Count - 1]
+            instructions.RemoveAt (instructions.Count - 1)
+
+            match currentInstruction with
+            | Instruction.Process__Expr x ->
+                match x with
+                | Expr.Const (arg0) -> cata.Expr.Const arg0 |> exprStack.Add
+                | Expr.Pair (arg0, arg1, arg2) -> ()
+                | Expr.Sequential (arg0) -> ()
+                | Expr.Builder (arg0, arg1) -> ()
+            | Instruction.Process__ExprBuilder x ->
+                match x with
+                | ExprBuilder.Child (arg0) -> ()
+                | ExprBuilder.Parent (arg0) -> ()
+            | Instruction.Expr_Pair (arg2) -> ()
+            | Instruction.Expr_Sequential (n) -> ()
+            | Instruction.Expr_Builder -> ()
+            | Instruction.ExprBuilder_Child -> ()
+            | Instruction.ExprBuilder_Parent -> ()
+
+        exprStack, exprBuilderStack
+
+    /// Execute the catamorphism.
+    let runExpr (cata : Cata<'ExprRet, 'ExprBuilderRet>) (x : Expr) : 'ExprRet =
+        let instructions = ResizeArray ()
+        instructions.Add (Instruction.Process__Expr x)
+        let exprRetStack, exprBuilderRetStack = loop cata instructions
+        Seq.exactlyOne exprRetStack
+
+    /// Execute the catamorphism.
+    let runExprBuilder (cata : Cata<'ExprRet, 'ExprBuilderRet>) (x : ExprBuilder) : 'ExprBuilderRet =
+        let instructions = ResizeArray ()
+        instructions.Add (Instruction.Process__ExprBuilder x)
+        let exprRetStack, exprBuilderRetStack = loop cata instructions
+        Seq.exactlyOne exprBuilderRetStack

WoofWare.Myriad.Plugins.Attributes/Attributes.fs

@@ -62,3 +62,8 @@ type JsonParseAttribute (isExtensionMethod : bool) =
 /// i.e. to stamp out HTTP REST clients from interfaces defining the API.
 type HttpClientAttribute () =
     inherit Attribute ()
+
+/// Attribute indicating a DU type to which the "create catamorphism" Myriad
+/// generator should apply during build.
+type CreateCatamorphismAttribute () =
+    inherit Attribute ()

WoofWare.Myriad.Plugins/AstHelper.fs

@@ -70,6 +70,18 @@ type internal RecordType =
         Accessibility : SynAccess option
     }
 
+type UnionField =
+    {
+        Type : SynType
+        Name : Ident option
+    }
+
+type UnionCase =
+    {
+        Name : SynIdent
+        Fields : UnionField list
+    }
+
 [<RequireQualifiedAccess>]
 module internal AstHelper =
 
@@ -383,6 +395,27 @@ module internal AstHelper =
             Accessibility = accessibility
         }
 
+    let getUnionCases (SynTypeDefn.SynTypeDefn (_, repr, _, _, _, _)) : UnionCase list =
+        match repr with
+        | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (_, cases, _), _) ->
+            cases
+            |> List.map (fun (SynUnionCase.SynUnionCase (_, ident, kind, _, _, _, _)) ->
+                match kind with
+                | SynUnionCaseKind.FullType _ -> failwith "FullType union cases not supported"
+                | SynUnionCaseKind.Fields fields ->
+                    {
+                        Name = ident
+                        Fields =
+                            fields
+                            |> List.map (fun (SynField.SynField (_, _, id, ty, _, _, _, _, _)) ->
+                                {
+                                    Type = ty
+                                    Name = id
+                                }
+                            )
+                    }
+            )
+        | _ -> failwithf "Failed to get union cases for type that was: %+A" repr
 
 [<AutoOpen>]
 module internal SynTypePatterns =

WoofWare.Myriad.Plugins/HttpClientGenerator.fs

@@ -756,12 +756,6 @@ module internal HttpClientGenerator =
             | _ -> None
         )
 
-    let lowerFirstLetter (x : Ident) : Ident =
-        let result = StringBuilder x.idText.Length
-        result.Append (Char.ToLowerInvariant x.idText.[0]) |> ignore
-        result.Append x.idText.[1..] |> ignore
-        Ident.Create ((result : StringBuilder).ToString ())
-
     let createModule
         (opens : SynOpenDeclTarget list)
         (ns : LongIdent)
@@ -891,7 +885,7 @@ module internal HttpClientGenerator =
                         Some (SynBindingReturnInfo.Create pi.Type),
                         SynExpr.CreateApp (
                             SynExpr.CreateLongIdent (
-                                SynLongIdent.CreateFromLongIdent [ lowerFirstLetter pi.Identifier ]
+                                SynLongIdent.CreateFromLongIdent [ Ident.lowerFirstLetter pi.Identifier ]
                             ),
                             SynExpr.CreateConst SynConst.Unit
                         ),
@@ -927,7 +921,7 @@ module internal HttpClientGenerator =
             properties
             |> List.map (fun (_, pi) ->
                 SynPat.CreateTyped (
-                    SynPat.CreateNamed (lowerFirstLetter pi.Identifier),
+                    SynPat.CreateNamed (Ident.lowerFirstLetter pi.Identifier),
                     SynType.CreateFun (SynType.CreateLongIdent "unit", pi.Type)
                 )
                 |> SynPat.CreateParen

WoofWare.Myriad.Plugins/Ident.fs

@@ -0,0 +1,14 @@
+namespace WoofWare.Myriad.Plugins
+
+open System
+open System.Text
+open Fantomas.FCS.Syntax
+open Myriad.Core
+
+[<RequireQualifiedAccess>]
+module internal Ident =
+    let lowerFirstLetter (x : Ident) : Ident =
+        let result = StringBuilder x.idText.Length
+        result.Append (Char.ToLowerInvariant x.idText.[0]) |> ignore
+        result.Append x.idText.[1..] |> ignore
+        Ident.Create ((result : StringBuilder).ToString ())

WoofWare.Myriad.Plugins/SynExpr.fs

@@ -275,3 +275,19 @@ module internal SynExpr =
                 else
                     SynLeadingKeyword.Let range0
         }
+
+    /// {ident} - {n}
+    let minusN (ident : SynLongIdent) (n : int) : SynExpr =
+        SynExpr.CreateApp (
+            SynExpr.CreateAppInfix (
+                SynExpr.CreateLongIdent (
+                    SynLongIdent.SynLongIdent (
+                        [ Ident.Create "op_Subtraction" ],
+                        [],
+                        [ Some (IdentTrivia.OriginalNotation "-") ]
+                    )
+                ),
+                SynExpr.CreateLongIdent ident
+            ),
+            SynExpr.CreateConst (SynConst.Int32 n)
+        )

WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj

@@ -25,6 +25,7 @@
 
   <ItemGroup>
     <Compile Include="List.fs"/>
+    <Compile Include="Ident.fs" />
     <Compile Include="AstHelper.fs"/>
     <Compile Include="SynExpr.fs"/>
     <Compile Include="SynType.fs"/>
@@ -34,6 +35,7 @@
     <Compile Include="JsonSerializeGenerator.fs"/>
     <Compile Include="JsonParseGenerator.fs"/>
     <Compile Include="HttpClientGenerator.fs"/>
+    <Compile Include="CataGenerator.fs" />
     <EmbeddedResource Include="version.json"/>
     <EmbeddedResource Include="SurfaceBaseline.txt"/>
     <None Include="..\README.md">