Assembly tagging

docs/content/tagging.md

@@ -0,0 +1,36 @@
+# Tagging
+
+Tags are terms within namespaces that can be associated with assemblies using the `tag` pragma.
+
+```GSL
+// Example tag pragma, term red in the color namespace
+#tag color:red
+pTDH3>gERG10
+```
+
+Tags are transient pragmas that associate with the next emitted assembly.  Each tag consists of a namespace and term.  More than one namespace pair can be specified with each `#tag`.
+
+```GSL
+// Multiple tags for one assembly
+#tag color:red flavor:vanilla
+pTDH3>gERG10
+```
+
+Multiple tags may be specified on different lines leading up to an assembly.  Tags accumulate till an assembly is emitted.
+
+```GSL
+#tag color:red 
+#tag flavor:vanilla
+pTDH3>gERG10
+```
+
+Tags may be emitted in various output formats.  For example, the flatfile output emits tags using the `TA` line.
+
+```
+// GSL compiler version 0.4.32
+##### Assembly 0 #######
+A# 0
+NA basic_delete
+TA color:yellow id:123
+NP 7
+```

src/GslCore/CommonTypes.fs

@@ -218,7 +218,9 @@ type DnaAssembly =
     pragmas: PragmaCollection;
     designParams: DesignParams;
     docStrings: string list;
-    materializedFrom: Assembly}
+    materializedFrom: Assembly
+    tags:Set<AssemblyTag>
+    }
     with
     member x.Sequence() =
         x.dnaParts

src/GslCore/DnaCreation.fs

@@ -583,4 +583,6 @@ let expandAssembly
      pragmas = a.pragmas;
      designParams = a.designParams;
      docStrings = a.docStrings;
-     materializedFrom = a}
+     materializedFrom = a
+     tags=Set.empty
+     }

src/GslCore/DumpFlat.fs

@@ -45,6 +45,8 @@ let dumpFlat (outFile:string) (assembliesIn : DnaAssembly list) =
         sprintf "##### Assembly %s #######" aId |> w
         sprintf "A# %s" aId |> w
         sprintf "NA %s" a.name |> w
+        if not a.tags.IsEmpty then
+            sprintf "TA %s" (String.Join(" ",[for tag in a.tags -> sprintf "%s:%s" tag.nameSpace tag.tag])) |> w
         match a.uri with Some(u) -> sprintf "NU %s" u |> w | None -> ()
         sprintf "NP %d" (a.dnaParts.Length) |> w
         sprintf "AS %s" (a.Sequence().str) |> w

src/GslCore/GslCore.fsproj

@@ -101,6 +101,7 @@
     <Compile Include="ProcessCmdLineArgs.fs" />
     <Compile Include="LexAndParse.fs" />
     <Compile Include="AstExpansion.fs" />
+    <Compile Include="TaggingProvider.fs" />
     <Compile Include="GslcProcess.fs" />
     <Compile Include="SeamlessPlugin.fs" />
     <Compile Include="Gslc.fs" />
@@ -2400,4 +2401,4 @@
     </When>
   </Choose>
   <Import Project="..\..\packages\FsLexYacc\build\FsLexYacc.targets" Condition="Exists('..\..\packages\FsLexYacc\build\FsLexYacc.targets')" Label="Paket" />
-</Project>
+</Project>

src/GslCore/LegacyParseTypes.fs

@@ -67,6 +67,9 @@ type Part =
 /// Part plus a Pragma
 and PPP = { part : Part ; pr : PragmaCollection ; fwd: bool}
 
+/// Namespace bounded tag for an assembly (Used in DnaAssembly)
+type AssemblyTag = {nameSpace:string ; tag : string}
+
 type Assembly =
    {parts: PPP list; 
     name: string option;

src/GslCore/PragmaTypes.fs

@@ -23,7 +23,7 @@ type PragmaArgShape =
 
 type PragmaValidationResult = Result<unit,string>
 
-type PragmaPersistence = | Persistent | Transient
+type PragmaPersistence = | Persistent | Transient | TransientCumulative
 ///<summary>
 /// Pragmas are scoped within a GSL document.  Some pragmas
 /// are somewhat "scope-polymorphic" and have different
@@ -423,7 +423,22 @@ type PragmaCollection = PragmaCollection of Map<string,Pragma>
     with
     member x.pmap = match x with PragmaCollection(pc) -> pc
     /// Add a Pragma to this collection.
-    member x.Add(p:Pragma) = PragmaCollection (x.pmap.Add(p.name, p))
+    member x.Add(p:Pragma) = 
+        PragmaCollection (
+            match p.definition.scope with 
+            | BlockOnly(TransientCumulative) 
+            | BlockOrPart(TransientCumulative) ->
+                match x.pmap.TryFind(p.name) with
+                | None -> x.pmap.Add(p.name, p)
+                | Some(existing) -> 
+                    let newArgs = existing.args@p.args // new args go on the end
+                    match buildPragmaFromDef existing.definition  newArgs with
+                    | Ok (newPragma,_messages) ->
+                        x.pmap.Add(p.name, newPragma)
+                    | Bad messages -> failwithf "%s" (String.Join(";",messages))
+            | _ -> 
+                x.pmap.Add(p.name, p)
+        )
     /// Add a pragma to this collection using string name.
     member x.Add(pName:string) = x.Add(pName, [])
     /// Add a pragma to this collection using string name and single value.

src/GslCore/TaggingProvider.fs

@@ -0,0 +1,90 @@
+/// Assembly transforming plugin that implements seamless part assembly.
+module TaggingPlugin
+
+open System
+open LegacyParseTypes
+open commonTypes
+open commandConfig
+open pragmaTypes
+open PluginTypes
+open Amyris.ErrorHandling
+
+let taggingArg = 
+   {name = "tag";
+    param = ["namespace:value"];
+    alias = [];
+    desc = "Add default tag to every assembly."
+   }
+
+let parseTag (single:string) state =
+    match single.IndexOf(":") with
+        | -1 -> fail (sprintf "--tag value %s missing expected colon" single)
+        | colonPosition ->
+            ok  ({  nameSpace=single.[..colonPosition-1].Trim()
+                    tag=single.[colonPosition+1..].Trim()
+                }::state)
+
+let parseTags (args:string list) =
+    args |> 
+        List.fold (
+            fun (state:Result<_,_>) (arg:string) -> 
+                state >>= (parseTag arg)
+        ) (ok [])
+
+/// do a trial parse and return ok unit if successful
+let validateTag args =
+    parseTags args 
+    >>= (fun _ -> ok ())
+
+let tagPragmaDef =
+    {name = "tag"; argShape = AtLeast 1; scope = BlockOnly(TransientCumulative);
+     desc = "tag assemblies with terms from a namespace.";
+     invertsTo = None; validate = validateTag} 
+
+/// Take previous #tag namespace:tagvalue  lines and fold into the assembly structure
+let foldInTags (cmdlineTags:AssemblyTag list) (_at:ATContext) (a:DnaAssembly) =
+    match a.pragmas.TryFind("tag") with
+    | None -> ok a
+    | Some pragma ->
+        match parseTags pragma.args with
+        | Ok(newTags,_) ->
+            ok {a with tags = cmdlineTags@newTags |> List.fold (fun tags tag -> tags.Add(tag)) a.tags}
+        | Bad msg -> fail {msg = String.Join(";",msg) ; kind = ATError ; assembly = a ; stackTrace = None ; fromException = None}
+
+type TaggingProvider = {
+    cmdlineTags:AssemblyTag list
+    /// Optionally attach a function to this plugin behavior to permit its operation to be
+    /// configured by command line arguments injected by other plugins.  This is necessary because
+    /// seamless assembly can alter a lot of expectations of downstream processing steps.
+    processExtraArgs: ParsedCmdLineArg -> TaggingProvider -> TaggingProvider}
+    with
+    interface IAssemblyTransform with
+        member __.ProvidedArgs() = [taggingArg]
+        member x.Configure(arg) =
+            if arg.spec = taggingArg then
+                match parseTags arg.values with
+                | Ok(v,_) ->
+                    {x with cmdlineTags = v@x.cmdlineTags}
+                | Result.Bad messages ->
+                    failwithf "%s" (String.Join("; ",messages))
+
+            else x
+            |> x.processExtraArgs arg
+            :> IAssemblyTransform
+        member x.ConfigureFromOptions(_opts) =
+            x :> IAssemblyTransform
+        member x.TransformAssembly context assembly =
+            foldInTags x.cmdlineTags context assembly
+
+/// Produce an instance of the seamless assembly plugin with the provided extra argument processor.
+let createTaggingPlugin extraArgProcessor =
+   {name = "assembly tagging support"
+    description = Some "Allow tagging of assemblies with #tag namespace:tag"
+    behaviors =
+      [{name = None;
+        description = None;
+        behavior = AssemblyTransform({cmdlineTags = []; processExtraArgs = extraArgProcessor})}]
+    providesPragmas = [tagPragmaDef];
+    providesCapas = []}
+
+let taggingPlugin = createTaggingPlugin (fun _ x -> x)

tests/GslCore.Tests/GslCore.Tests.fsproj

@@ -85,6 +85,7 @@
     <Compile Include="TestSliceAnnotations.fs" />
     <Compile Include="TestSeamlessPrimers.fs" />
     <Compile Include="TestDnaAssemblyTransformation.fs" />
+    <Compile Include="TestTagging.fs" />
   </ItemGroup>
   <ItemGroup>
     <Reference Include="mscorlib" />
@@ -1507,4 +1508,4 @@
       <Paket>True</Paket>
     </Reference>
   </ItemGroup>
-</Project>
+</Project>

tests/GslCore.Tests/TestDnaAssemblyTransformation.fs

@@ -61,6 +61,7 @@ type Test() =
         designParams = DesignParams.initialDesignParams
         docStrings = []
         materializedFrom = emptyAssembly
+        tags = Set.empty
     }
 
     let runTest assembly expectedSource =