Wrapper struct for models of a theory

src/models/ModelInterface.jl

@@ -52,9 +52,9 @@ using ...Syntax
 using ...Util.MetaUtils
 using ...Util.MetaUtils: JuliaFunctionSigNoWhere
 
-import ...Syntax.TheoryMaps: migrator 
 using ...Syntax.TheoryMaps: dom, codom
 using ...Syntax.TheoryInterface: GAT_MODULE_LOOKUP, Dispatch
+import ...Syntax.TheoryInterface: implements, impl_type 
 
 using MLStyle
 using DataStructures: DefaultDict, OrderedDict

src/nonstdlib/module.jl

@@ -4,12 +4,8 @@ using Reexport
 
 include("theories/module.jl")
 include("models/module.jl")
-# include("theorymaps/module.jl")
-# include("derivedmodels/module.jl")
 
 @reexport using .NonStdTheories
 @reexport using .NonStdModels
-# @reexport using .StdTheoryMaps
-# @reexport using .StdDerivedModels
 
 end

src/stdlib/theories/algebra.jl

@@ -1,6 +1,9 @@
-export ThEmpty, ThSet, ThMagma, ThSemiGroup, ThMonoid, ThGroup, ThCMonoid, ThAb, ThSemiRing, ThRing, ThCommRing, ThDiffRing, ThBooleanRing, ThDivisionRing, ThCRig, ThElementary, ThPreorder, ThLeftModule, ThRightModule, ThModule, ThCommRModule
+export ThEmpty, ThSet, ThMagma, ThSemiGroup, ThMonoid, ThGroup, ThCMonoid, ThAb, 
+       ThSemiRing, ThRing, ThCommRing, ThDiffRing, ThBooleanRing, ThDivisionRing, 
+       ThCRig, ThElementary, ThPreorder, ThLeftModule, ThRightModule, ThModule, 
+       ThCommRModule
 
-import Base: +, *, zero, one, -
+import Base: +, *, zero, one, -, inv
 
 @theory ThEmpty begin
 end

src/syntax/Scopes.jl

@@ -849,7 +849,11 @@ hastag(hsl::HasScopeList, t::ScopeTag) =
 hasname(hsl::HasScopeList, name::Symbol) =
   haskey(getscopelist(hsl).namelookup, name)
 
-getidents(hsl::HasScopeList; kw...) = vcat(getidents.(getscopelist(hsl); kw...)...)
+getidents(hsl::HasScopeList; kw...) = 
+  vcat(getidents.(getscopelist(hsl); kw...)...)
+
+identvalues(hsl::HasScopeList) = 
+  vcat(identvalues.(getscopelist(hsl))...)
 
 alltags(hsl::HasScopeList) = Set(gettag.(getscopelist(hsl).scopes))
 

src/syntax/TheoryInterface.jl

@@ -1,13 +1,3 @@
-module TheoryInterface
-export @theory, @signature, invoke_term
-
-using ..Scopes, ..GATs, ..ExprInterop, GATlab.Util
-
-using MLStyle, StructEquality, Markdown
-
-@struct_hash_equal struct WithModel{M}
-  model::M
-end
 
 """
 Each theory corresponds to a module, which has the following items.
@@ -29,7 +19,35 @@
 A macro called `@theory` which expands to the `GAT` data structure for the module.
 
 A constant called `Meta.theory` which is the `GAT` data structure.
+
+A struct called `Meta.Wrapper` which is a smart constructor for Julia types 
+which implement the theory.
 """
+module TheoryInterface
+export @theory, @signature, invoke_term, wrapper, ModelWrapper
+
+using ..Scopes, ..GATs, ..ExprInterop, GATlab.Util
+
+using MLStyle, StructEquality, Markdown
+import AlgebraicInterfaces: getvalue
+
+@struct_hash_equal struct WithModel{M}
+  model::M
+end
+
+getvalue(m::WithModel) = m.model
+
+function implements end # implemented in ModelInterface
+
+function impl_type end # implemented in ModelInterface
+
+""" Parse markdown coming out of @doc programatically. """
+mdp(::Nothing) = ""
+mdp(x::Markdown.MD) = x
+function mdp(x::Base.Docs.DocStr)
+  Markdown.parse(only(x.text))
+end
+
 
 # TODO is every contribution to a theory a new segment, or can a new theory introduce multiple segments? 
 """
@@ -150,17 +168,16 @@
   end
 
   doctarget = gensym()
-  mdp(::Nothing) = []
-  mdp(x::Markdown.MD) = x
-  mdp(x::Base.Docs.DocStr) = Markdown.parse(x.text...)
-
+  wrapper_expr = wrapper(name, theory, fqmn(__module__))
   push!(modulelines, Expr(:toplevel, :(module Meta
     struct T end
 
     const theory = $theory
 
     macro theory() $theory end
     macro theory_module() parentmodule(@__MODULE__) end
+
+    $wrapper_expr
   end)))
 
   # XXX
@@ -175,8 +192,8 @@
       :(Core.@__doc__ $(doctarget)),
       :(
         module $name
-        $(modulelines...)
         $(structlines...)
+        $(modulelines...)
         end
       ),
       :(@doc ($(Markdown.MD)($mdp(@doc $doctarget), $docstr)) $name)
@@ -250,4 +267,118 @@
   end
 end
 
+# Wrapper type 
+##############
+
+
+function wrapper(name::Symbol, t::GAT, mod)
+  use = Expr(:using, Expr(:., :., :., name))
+  quote
+    $use
+    macro wrapper(n)
+      x, y = $(parse_wrapper_input)(n)
+      esc(:($($(name)).Meta.@wrapper $x $y))
+    end
+
+    macro typed_wrapper(n)
+      x, y = $(parse_wrapper_input)(n)
+      esc(:($($(name)).Meta.@typed_wrapper $x $y))
+    end
+
+    macro wrapper(n, abs)
+      doctarget = gensym()
+      esc(quote 
+        # Catch any potential docs above the macro call
+        const $(doctarget) = nothing
+        Core.@__doc__ $(doctarget)
+
+        # Declare the wrapper struct
+        struct $n <: $abs
+          val::Any
+          function $n(x::Any)
+            $($(GlobalRef(TheoryInterface, :implements)))(x, $($name)) || error(
+              "Invalid $($($(name))) model: $x")
+            new(x)
+          end
+        end
+        # Apply the caught documentation to the new struct
+        @doc $($(mdp))(@doc $doctarget) $n
+
+        # Define == and hash
+        $(Expr(:macrocall, $(GlobalRef(StructEquality, Symbol("@struct_hash_equal"))), $(mod), $(:n)))
+
+        # GlobalRef doesn't work: "invalid function name".
+        GATlab.getvalue(x::$n) = x.val 
+        GATlab.impl_type(x::$n, o::Symbol) = GATlab.impl_type(x.val, $($name), o)
+
+        # Dispatch on model value for all declarations in theory
+        $(map(filter(x->x[2] isa $AlgDeclaration, $(identvalues(t)))) do (x,j)
+          if j isa $(AlgDeclaration) 
+            op = nameof(x)
+            :($($(name)).$op(x::$(($(:n))), args...; kw...) = 
+              $($(name)).$op[x.val](args...; kw...))
+          end
+      end...)
+      nothing
+      end)
+    end
+
+    macro typed_wrapper(n, abs)
+      doctarget = gensym()
+      Ts = nameof.($(sorts)($t))
+      Xs = map(Ts) do s 
+        :($(GlobalRef($(TheoryInterface), :impl_type))(x, $($(name)), $($(Meta.quot)(s))))
+      end
+      XTs = map(zip(Ts,Xs)) do (T,X)
+        :($X <: $T || error("Mismatch $($($(Meta.quot)(T))): $($X) ⊄ $($T)"))
+      end
+      esc(quote 
+        # Catch any potential docs above the macro call
+        const $(doctarget) = nothing
+        Core.@__doc__ $(doctarget)
+
+        # Declare the wrapper struct
+        struct $n{$(Ts...)} <: $abs
+          val::Any
+          function $n{$(Ts...)}(x::Any) where {$(Ts...)}
+            $($(GlobalRef(TheoryInterface, :implements)))(x, $($name)) || error(
+              "Invalid $($($(name))) model: $x")
+            $(XTs...)
+            # CHECK THAT THE GIVEN PARAMETERS MATCH Xs
+            new{$(Ts...)}(x)
+          end
+
+          function $n(x::Any)
+            $($(GlobalRef(TheoryInterface, :implements)))(x, $($name)) || error(
+              "Invalid $($($(name))) model: $x")
+            new{$(Xs...)}(x)
+          end
+        end
+        # Apply the caught documentation to the new struct
+        @doc $($(mdp))(@doc $doctarget) $n
+
+        # Define == and hash
+        $(Expr(:macrocall, $(GlobalRef(StructEquality, Symbol("@struct_hash_equal"))), $(mod), $(:n)))
+
+        # GlobalRef doesn't work: "invalid function name".
+        GATlab.getvalue(x::$n) = x.val 
+        GATlab.impl_type(x::$n, o::Symbol) = GATlab.impl_type(x.val, $($name), o)
+
+        # Dispatch on model value for all declarations in theory
+        $(map(filter(x->x[2] isa $AlgDeclaration, $(identvalues(t)))) do (x,j)
+          if j isa $(AlgDeclaration) 
+            op = nameof(x)
+            :($($(name)).$op(x::$(($(:n))), args...; kw...) = 
+              $($(name)).$op[x.val](args...; kw...))
+          end
+      end...)
+      nothing
+      end)
+    end
+  end
 end
+
+parse_wrapper_input(n::Symbol) = n, Any
+parse_wrapper_input(n::Expr) = n.head == :<: ? n.args : error("Bad input for wrapper")
+
+end # module

src/syntax/TheoryMaps.jl

@@ -418,7 +418,4 @@ macro theorymap(head, body)
   )
 end
 
-function migrator end
-
-
 end # module

test/models/ModelInterface.jl

@@ -229,4 +229,47 @@ d = Dispatch(ThCategory.Meta.theory, [Int, Vector{Int}])
 @test id(2) == [1,2] == ThCategory.id[d](2)
 @test compose([1,2,3], [2,1,3]) == [2,1,3]
 
+# Test wrapper structs
+######################
+"""Cat"""
+ThCategory.Meta.@wrapper Cat
+
+c = Cat(FinSetC());
+c2 = Cat(FinMatC{Int}());
+@test_throws ErrorException Cat(MyVect([1,2,3])) # can't construct
+
+@test getvalue(c) == FinSetC()
+@test impl_type(c, :Ob) == Int == impl_type(c2, :Ob)
+
+@test Ob(c, 2) == 2
+@test_throws MethodError Hom(c2, [1,2])
+
+function id2(c::Cat)
+  ThCategory.id(c, 2)
+end
+
+@test id2(c) == [1,2]
+@test id2(c2) == [1 0; 0 1]
+@test_throws MethodError id2(FinSetC())
+
+abstract type MyAbsType end
+ThCategory.Meta.@wrapper Cat2 <: MyAbsType 
+@test Cat2 <: MyAbsType
+
+# Typed wrappers
+#----------------
+"""Typed Cat"""
+ThCategory.Meta.@typed_wrapper TCat
+
+c = TCat(FinSetC())
+@test c == TCat{Int,Vector{Int}}(FinSetC())
+@test_throws ErrorException TCat{Bool,Symbol}(FinSetC()) # Ob: Int ⊄ Bool
+@test c isa TCat{Int, Vector{Int}}
+@test id(c, 2) == [1,2]
+
+c2 = TCat(FinMatC{Int}());
+@test c2 isa TCat{Int, Matrix{Int}}
+
+@test id(c2, 2) == [1 0; 0 1]
+
 end # module