Scope generated opens to the tagged type's namespace block

ConsumePlugin/ConsumePlugin.fsproj

@@ -100,6 +100,10 @@
     <Compile Include="GeneratedArgParserNegationTests.fs">
       <MyriadFile>ArgParserNegationTests.fs</MyriadFile>
     </Compile>
+    <Compile Include="OpensLeakRegression.fs" />
+    <Compile Include="GeneratedOpensLeakRegression.fs">
+      <MyriadFile>OpensLeakRegression.fs</MyriadFile>
+    </Compile>
     <!-- Not compiled, because by design they *don't* compile. That makes them very hard to test in an automated way! -->
     <None Include="ArgParserConflictTests.fs" />
     <!-- To run the conflict tests:

ConsumePlugin/GeneratedOpensLeakRegression.fs

@@ -0,0 +1,156 @@
+//------------------------------------------------------------------------------
+//        This code was generated by myriad.
+//        Changes to this file will be lost when the code is regenerated.
+//------------------------------------------------------------------------------
+
+
+
+
+
+
+
+namespace ConsumePlugin.OpensLeakVictim
+
+open WoofWare.Myriad.Plugins
+
+/// Methods to parse arguments for the type LeakArgs
+[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
+module LeakArgs =
+    type private ParseState_LeakArgs =
+        /// Ready to consume a key or positional arg
+        | AwaitingKey
+        /// Waiting to receive a value for the key we've already consumed
+        | AwaitingValue of key : string
+
+    let parse' (getEnvironmentVariable : string -> string option) (args : string list) : LeakArgs =
+        let ArgParser_errors = ResizeArray ()
+
+        let helpText () =
+            [ (sprintf "%s  int32%s%s" (sprintf "--%s" "foo") "" "") ] |> String.concat "\n"
+
+        let parser_LeftoverArgs : string ResizeArray = ResizeArray ()
+        let mutable arg_0 : int option = None
+
+        /// Processes the key-value pair, returning Error if no key was matched.
+        /// If the key is an arg which can have arity 1, but throws when consuming that arg, we return Error(<the message>).
+        /// This can nevertheless be a successful parse, e.g. when the key may have arity 0.
+        let processKeyValue (key : string) (value : string) : Result<unit, string option> =
+            if System.String.Equals (key, sprintf "--%s" "foo", System.StringComparison.OrdinalIgnoreCase) then
+                match arg_0 with
+                | Some x ->
+                    sprintf
+                        "Argument '%s' was supplied multiple times: %s and %s"
+                        (sprintf "--%s" "foo")
+                        (x.ToString ())
+                        (value.ToString ())
+                    |> ArgParser_errors.Add
+
+                    Ok ()
+                | None ->
+                    try
+                        arg_0 <- value |> (fun x -> System.Int32.Parse x) |> Some
+                        Ok ()
+                    with _ as exc ->
+                        exc.Message |> Some |> Error
+            else
+                Error None
+
+        /// Returns false if we didn't set a value.
+        let setFlagValue (key : string) : bool = false
+
+        let rec go (state : ParseState_LeakArgs) (args : string list) =
+            match args with
+            | [] ->
+                match state with
+                | ParseState_LeakArgs.AwaitingKey -> ()
+                | ParseState_LeakArgs.AwaitingValue key ->
+                    if setFlagValue key then
+                        ()
+                    else
+                        sprintf
+                            "Trailing argument %s had no value. Use a double-dash to separate positional args from key-value args."
+                            key
+                        |> ArgParser_errors.Add
+            | "--" :: rest ->
+                match state with
+                | ParseState_LeakArgs.AwaitingKey -> ()
+                | ParseState_LeakArgs.AwaitingValue key ->
+                    if setFlagValue key then
+                        ()
+                    else
+                        sprintf
+                            "Trailing argument %s had no value. Use a double-dash to separate positional args from key-value args."
+                            key
+                        |> ArgParser_errors.Add
+
+                parser_LeftoverArgs.AddRange (rest |> Seq.map (fun x -> x))
+            | arg :: args ->
+                match state with
+                | ParseState_LeakArgs.AwaitingKey ->
+                    if arg.StartsWith ("--", System.StringComparison.Ordinal) then
+                        if arg = "--help" then
+                            helpText () |> failwithf "Help text requested.\n%s"
+                        else
+                            let equals = arg.IndexOf (char 61)
+
+                            if equals < 0 then
+                                args |> go (ParseState_LeakArgs.AwaitingValue arg)
+                            else
+                                let key = arg.[0 .. equals - 1]
+                                let value = arg.[equals + 1 ..]
+
+                                match processKeyValue key value with
+                                | Ok () -> go ParseState_LeakArgs.AwaitingKey args
+                                | Error x ->
+                                    match x with
+                                    | None ->
+                                        failwithf "Unable to process argument %s as key %s and value %s" arg key value
+                                    | Some msg ->
+                                        sprintf "%s (at arg %s)" msg arg |> ArgParser_errors.Add
+                                        go ParseState_LeakArgs.AwaitingKey args
+                    else
+                        arg |> (fun x -> x) |> parser_LeftoverArgs.Add
+                        go ParseState_LeakArgs.AwaitingKey args
+                | ParseState_LeakArgs.AwaitingValue key ->
+                    match processKeyValue key arg with
+                    | Ok () -> go ParseState_LeakArgs.AwaitingKey args
+                    | Error exc ->
+                        if setFlagValue key then
+                            go ParseState_LeakArgs.AwaitingKey (arg :: args)
+                        else
+                            match exc with
+                            | None ->
+                                failwithf "Unable to process supplied arg %s. Help text follows.\n%s" key (helpText ())
+                            | Some msg -> msg |> ArgParser_errors.Add
+
+        go ParseState_LeakArgs.AwaitingKey args
+
+        let parser_LeftoverArgs =
+            if 0 = parser_LeftoverArgs.Count then
+                ()
+            else
+                parser_LeftoverArgs
+                |> String.concat " "
+                |> sprintf "There were leftover args: %s"
+                |> ArgParser_errors.Add
+
+                Unchecked.defaultof<_>
+
+        let arg_0 =
+            match arg_0 with
+            | None ->
+                sprintf "Required argument '%s' received no value" (sprintf "--%s" "foo")
+                |> ArgParser_errors.Add
+
+                Unchecked.defaultof<_>
+            | Some x -> x
+
+        if 0 = ArgParser_errors.Count then
+            {
+                Foo = arg_0
+            }
+        else
+            ArgParser_errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s"
+
+    let parse (args : string list) : LeakArgs =
+        parse' (System.Environment.GetEnvironmentVariable >> Option.ofObj) args

ConsumePlugin/OpensLeakRegression.fs

@@ -0,0 +1,30 @@
+// Regression test for the opens leak: `open` declarations from one namespace block of an input
+// file must not appear in generated code for a *different* namespace block. The bait below is a
+// relative `open RelativeOpenBait`, which resolves only from within ConsumePlugin.OpensLeak; if
+// it leaked into the generated module for ConsumePlugin.OpensLeakVictim, this project would fail
+// to compile.
+namespace ConsumePlugin.OpensLeak
+
+module internal RelativeOpenBait =
+    let internal bait : int = 1
+
+namespace ConsumePlugin.OpensLeak
+
+open RelativeOpenBait
+
+type UsesTheBait =
+    {
+        Ignored : int
+    }
+
+    static member internal Use () : int = bait
+
+namespace ConsumePlugin.OpensLeakVictim
+
+open WoofWare.Myriad.Plugins
+
+[<ArgParser>]
+type LeakArgs =
+    {
+        Foo : int
+    }

WoofWare.Myriad.Plugins.Test/TestAstHelper.fs

@@ -0,0 +1,97 @@
+namespace WoofWare.Myriad.Plugins.Test
+
+open NUnit.Framework
+open FsUnitTyped
+open Fantomas.FCS.Syntax
+open WoofWare.Whippet.Fantomas
+open WoofWare.Myriad.Plugins
+
+[<TestFixture>]
+module TestAstHelper =
+
+    /// Render an open target as its dotted path, for easy comparison.
+    let private renderOpen (target : SynOpenDeclTarget) : string =
+        match target with
+        | SynOpenDeclTarget.ModuleOrNamespace (SynLongIdent.SynLongIdent (ident, _, _), _) ->
+            ident |> List.map _.idText |> String.concat "."
+        | SynOpenDeclTarget.Type _ -> failwith "open type not expected in these tests"
+
+    let private opensFor (ns : string) (source : string) : string list =
+        let ast = Ast.parse source
+        let nsIdent = ns.Split '.' |> Seq.map Ident.create |> List.ofSeq
+        AstHelper.extractOpensForNamespace nsIdent ast |> List.map renderOpen
+
+    let private source : string =
+        """namespace First
+
+open System.IO
+
+module Helpers =
+    let x = 1
+
+namespace First
+
+open Helpers
+
+namespace First.Unrelated
+
+open System.Text
+
+namespace Second
+
+open System.Collections.Generic
+"""
+
+    [<Test>]
+    let ``Exactly-matching blocks contribute their opens, in file order`` () =
+        // Both blocks named First match: same-named blocks share a resolution context.
+        opensFor "First" source |> shouldEqual [ "System.IO" ; "Helpers" ]
+
+    [<Test>]
+    let ``Opens from unrelated blocks do not leak`` () =
+        opensFor "Second" source |> shouldEqual [ "System.Collections.Generic" ]
+
+    [<Test>]
+    let ``Matching is by whole name, not by name prefix`` () =
+        // A separate top-level block `namespace First` is not lexically around a block
+        // `namespace First.Unrelated`, so its opens are not in scope there.
+        opensFor "First.Unrelated" source |> shouldEqual [ "System.Text" ]
+        opensFor "First.M" source |> shouldEqual []
+
+    // ----------------------------------------------------------------------------------------
+    // CataGenerator's type discovery descends into nested modules, so it cannot look opens up by
+    // namespace name; it tracks the lexically-enclosing opens during the descent instead.
+
+    let private nestedSource : string =
+        """namespace Outer
+
+open System.IO
+
+module Inner =
+    open System.Text
+
+    type Tree =
+        | Leaf
+        | Node of Tree * Tree
+
+namespace Outer.Sibling
+
+open System.Collections.Generic
+
+type Unrelated = { Field : int }
+"""
+
+    [<Test>]
+    let ``Cata type discovery carries the lexically enclosing opens`` () =
+        let groups =
+            CataGenerator.groupedTypeDefns (Ast.parse nestedSource)
+            |> List.map (fun (ns, opens, types) ->
+                ns |> List.map _.idText |> String.concat ".", opens |> List.map renderOpen, types |> List.length
+            )
+
+        groups
+        |> shouldEqual
+            [
+                "Outer.Inner", [ "System.IO" ; "System.Text" ], 1
+                "Outer.Sibling", [ "System.Collections.Generic" ], 1
+            ]

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

@@ -61,6 +61,7 @@
     <EmbeddedResource Include="TestSwagger\uspto.json" />
     <EmbeddedResource Include="TestSwagger\webhook-example.json" />
     <Compile Include="TestRemoveOptions.fs" />
+    <Compile Include="TestAstHelper.fs" />
     <Compile Include="TestSurface.fs" />
     <None Include="../.github/workflows/dotnet.yaml" />
   </ItemGroup>

WoofWare.Myriad.Plugins/ArgParserGenerator.fs

@@ -2148,6 +2148,7 @@ type ArgParserGenerator () =
             let modules =
                 namespaceAndTypes
                 |> List.map (fun (ns, taggedType, unions, records) ->
+                    let opens = AstHelper.extractOpensForNamespace ns ast
                     ArgParserGenerator.createModule opens ns taggedType unions records
                 )
 

WoofWare.Myriad.Plugins/AstHelper.fs

@@ -49,19 +49,49 @@ module internal AstHelper =
         |> SynTypeDefn.create name
         |> SynTypeDefn.withMemberDefns (defaultArg record.Members SynMemberDefns.Empty)
 
-    let rec private extractOpensFromDecl (moduleDecls : SynModuleDecl list) : SynOpenDeclTarget list =
+    let rec internal extractOpensFromDecl (moduleDecls : SynModuleDecl list) : SynOpenDeclTarget list =
         moduleDecls
         |> List.choose (fun moduleDecl ->
             match moduleDecl with
             | SynModuleDecl.Open (target, _) -> Some target
             | _ -> None
         )
 
-    let extractOpens (ast : ParsedInput) : SynOpenDeclTarget list =
+    /// Extract the `open` declarations which are in scope for generated code emitted into
+    /// namespace `ns`: the opens of every top-level namespace/module block of the file with
+    /// exactly that name.
+    ///
+    /// Opens from differently-named blocks must not leak in: a relative `open` which is valid in
+    /// one namespace block can be invalid (or resolve to something else) in another. Two blocks
+    /// with the same name share a resolution context, so it is sound to union their opens.
+    ///
+    /// This is the right lookup for generators whose type discovery only visits the top level of
+    /// each block (Whippet's `Ast.getTypes`): the reported namespace is always exactly a block
+    /// name. A generator which descends into nested modules (CataGenerator) must instead track
+    /// the opens which are lexically in scope at the point of the type; matching by name cannot
+    /// reconstruct that.
+    ///
+    /// (Note: this deliberately does not share a name with WoofWare.Whippet.Fantomas's
+    /// `AstHelper.extractOpens`, which shadows this module's members at generator call sites and
+    /// extracts opens from *every* block in the file.)
+    let extractOpensForNamespace (ns : LongIdent) (ast : ParsedInput) : SynOpenDeclTarget list =
+        let nsName = ns |> List.map _.idText
+
         match ast with
         | ParsedInput.ImplFile (ParsedImplFileInput (_, _, _, _, _, modules, _, _, _)) ->
             modules
-            |> List.collect (fun (SynModuleOrNamespace (_, _, _, decls, _, _, _, _, _)) -> extractOpensFromDecl decls)
+            |> List.collect (fun (SynModuleOrNamespace (longId, _, _, decls, _, _, _, _, _)) ->
+                let blockName = longId |> List.map _.idText
+
+                let sameName =
+                    List.length blockName = List.length nsName
+                    && List.forall2
+                        (fun (a : string) (b : string) -> System.String.Equals (a, b, System.StringComparison.Ordinal))
+                        blockName
+                        nsName
+
+                if sameName then extractOpensFromDecl decls else []
+            )
         | _ -> []
 
     let rec convertSigParam (ty : SynType) : ParameterInfo * bool =

WoofWare.Myriad.Plugins/CapturingInterfaceMockGenerator.fs

@@ -735,11 +735,10 @@ type CapturingInterfaceMockGenerator () =
                         | ty -> Some (ns, ty)
                 )
 
-            let opens = AstHelper.extractOpens ast
-
             let modules =
                 namespaceAndInterfaces
                 |> List.collect (fun (ns, records) ->
+                    let opens = AstHelper.extractOpensForNamespace ns ast
                     records |> List.map (CapturingInterfaceMockGenerator.createRecord ns opens)
                 )