Added support for behavioral programming.

9 files changed, 168 insertions, 11 deletions

diff --git a/stdlib/source/library/lux/control/concurrency/async.lux b/stdlib/source/library/lux/control/concurrency/async.lux
index 6a4f582de..75bec2d4b 100644
--- a/stdlib/source/library/lux/control/concurrency/async.lux
+++ b/stdlib/source/library/lux/control/concurrency/async.lux
@@ -30,7 +30,7 @@
   (template (_ a)
     [(-> a (IO Any))]))
 
-(primitive .public (Async'' a)
+(primitive (Async'' a)
   (Atom [(Value a) (List (Handler a))])
 
   (type .public (Async' r w)
diff --git a/stdlib/source/library/lux/control/concurrency/atom.lux b/stdlib/source/library/lux/control/concurrency/atom.lux
index 2a7fec64c..f6229b7f0 100644
--- a/stdlib/source/library/lux/control/concurrency/atom.lux
+++ b/stdlib/source/library/lux/control/concurrency/atom.lux
@@ -27,7 +27,7 @@
        @.jvm <jvm>
        (these)))
 
-(primitive .public (Atom'' a)
+(primitive (Atom'' a)
   (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference a)]
     (for @.old <jvm>
          @.jvm <jvm>
diff --git a/stdlib/source/library/lux/control/concurrency/behavioral.lux b/stdlib/source/library/lux/control/concurrency/behavioral.lux
new file mode 100644
index 000000000..1865558aa
--- /dev/null
+++ b/stdlib/source/library/lux/control/concurrency/behavioral.lux
@@ -0,0 +1,50 @@
+(.require
+ [library
+  [lux (.except)]]
+ [//
+  ["[0]" async (.only Async) (.use "[1]#[0]" monad)]
+  ["[0]" frp (.only Channel)]])
+
+(def <Event>
+  (template (_ Constructor data)
+    [[(Constructor data) data]]))
+
+(type .public (Constructor data)
+  (-> data (<Event> Constructor data)))
+
+(type .public Event
+  (Ex (_ data)
+    (<Event> Constructor data)))
+
+(def .public (event constructor)
+  (All (_ data)
+    (-> (-> data data)
+        (Constructor data)))
+  (exec
+    [] ... This was added to avoid having auto-currying to fuse the "event" and "self" functions.
+    ... Otherwise, the "same?" comparison done later would fail.
+    (function (self data)
+      [self (constructor data)])))
+
+(def .public (event? expected it)
+  (All (_ data)
+    (-> (Constructor data) Event
+        (Maybe data)))
+  (let [[actual data] it]
+    (if (same? expected actual)
+      {.#Some (as_expected data)}
+      {.#None})))
+
+(def .public (scenario events expected initial behavior)
+  (All (_ state data)
+    (-> (Channel Event) (Constructor data) state (-> data state (Async state))
+        (Async state)))
+  (frp.mix (function (_ event state)
+             (when (event? expected event)
+               {.#Some data}
+               (behavior data state)
+               
+               {.#None}
+               (async#in state)))
+           initial
+           events))
diff --git a/stdlib/source/library/lux/control/concurrency/stm.lux b/stdlib/source/library/lux/control/concurrency/stm.lux
index 280c0dee8..2b6118575 100644
--- a/stdlib/source/library/lux/control/concurrency/stm.lux
+++ b/stdlib/source/library/lux/control/concurrency/stm.lux
@@ -27,7 +27,7 @@
 (type (Observer a)
   (-> a (IO Any)))
 
-(primitive .public (Var'' a)
+(primitive (Var'' a)
   (Atom [a (List (Sink a))])
 
   (type .public (Var' r w)
diff --git a/stdlib/source/library/lux/control/function/polymorphism/type.lux b/stdlib/source/library/lux/control/function/polymorphism/type.lux
index 1159bc488..ffa657330 100644
--- a/stdlib/source/library/lux/control/function/polymorphism/type.lux
+++ b/stdlib/source/library/lux/control/function/polymorphism/type.lux
@@ -6,13 +6,14 @@
    [control
     ["?" parser (.use "[1]#[0]" monad)]]
    [data
-    ["[0]" text (.use "[1]#[0]" equivalence)]
+    ["[0]" text (.use "[1]#[0]" equivalence)
+     ["%" \\format]]
     [collection
      ["[0]" list (.use "[1]#[0]" functor)]]]
    ["[0]" meta (.only)
     ["[0]" code (.only)
      ["?[1]" \\parser (.only Parser)]]
-    [macro (.only with_symbols)
+    ["[0]" macro (.only with_symbols)
      ["[0]" context]
      [syntax (.only syntax)
       ["[0]" export]]]
@@ -22,6 +23,7 @@
 (type Polymorphism
   (Record
    [#name Text
+    #export_policy Code
     #interface Code
     #method Code]))
 
@@ -35,8 +37,12 @@
                     (?code.tuple (?.many ?code.local))
                     ?code.any
                     (?.many ?code.any)))])
-    (<| (with_symbols [g!_ g!interface g!method g!inputs])
-        (..declaration [#name name #interface g!interface #method g!method])
+    (<| (do meta.monad
+          [@ meta.current_module_name
+           g!interface (macro.symbol (%.symbol [@ name]))
+           g!method (macro.symbol (%.symbol [@ name]))])
+        (with_symbols [g!_ g!inputs])
+        (..declaration [#name name #export_policy export_policy #interface g!interface #method g!method])
         (let [name (code.local name)
               parameters (list#each code.local parameters)])
         (` (these (type (, export_policy) (, g!interface)
@@ -65,7 +71,7 @@
       [it (context.search (|>> (the #name) (text#= name)) ..stack)
        .let [name (code.local name)]]
       (with_symbols [g!self]
-        (in (list (` (.def .public (, g!self)
+        (in (list (` (.def (, (the #export_policy it)) (, g!self)
                        ((, (the #interface it)) (,* specialization))
                        (implementation
                         (.def ((, (the #method it)) (,* inputs))
diff --git a/stdlib/source/library/lux/control/thread.lux b/stdlib/source/library/lux/control/thread.lux
index 665db5232..dd7b6208c 100644
--- a/stdlib/source/library/lux/control/thread.lux
+++ b/stdlib/source/library/lux/control/thread.lux
@@ -20,7 +20,7 @@
 (type .public (Thread ! a)
   (-> ! a))
 
-(primitive .public (Box'' t a)
+(primitive (Box'' t a)
   (Array a)
 
   (type .public (Box' t r w)
diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux
index 18ab1d19d..a53c174d5 100644
--- a/stdlib/source/test/lux/control.lux
+++ b/stdlib/source/test/lux/control.lux
@@ -17,7 +17,8 @@
    ["[1]/[0]" event]
    ["[1]/[0]" cps]
    ["[1]/[0]" incremental]
-   ["[1]/[0]" structured]]
+   ["[1]/[0]" structured]
+   ["[1]/[0]" behavioral]]
   ["[1][0]" continuation]
   ["[1][0]" exception]
   ["[1][0]" function]
@@ -52,6 +53,7 @@
        /concurrency/cps.test
        /concurrency/incremental.test
        /concurrency/structured.test
+       /concurrency/behavioral.test
        ))
 
 (def security
diff --git a/stdlib/source/test/lux/control/concurrency/behavioral.lux b/stdlib/source/test/lux/control/concurrency/behavioral.lux
new file mode 100644
index 000000000..6728ad266
--- /dev/null
+++ b/stdlib/source/test/lux/control/concurrency/behavioral.lux
@@ -0,0 +1,85 @@
+(.require
+ [library
+  [lux (.except)
+   [abstract
+    [monad (.only do)]]
+   [control
+    ["|" pipe]
+    ["[0]" maybe (.use "[1]#[0]" functor)]]
+   [math
+    ["[0]" random (.only Random)]
+    [number
+     ["n" nat]]]
+   [test
+    ["_" property (.only Test)]
+    ["[0]" unit]]]]
+ [\\library
+  ["[0]" / (.only)
+   [//
+    ["[0]" atom (.only Atom)]
+    ["[0]" async]
+    ["[0]" frp]]]])
+
+(def .public test
+  Test
+  (<| (_.covering /._)
+      (do [! random.monad]
+        [expected random.nat
+         shift (random.only (n.> 0) random.nat)])
+      (all _.and
+           (_.coverage [/.Constructor /.event]
+             (let [left (is (/.Constructor Nat)
+                            (/.event (|>>)))
+                   right (is (/.Constructor Nat)
+                             (/.event (|>>)))]
+               (not (same? left right))))
+           (_.coverage [/.Event /.event?]
+             (let [left (is (/.Constructor Nat)
+                            (/.event (|>>)))
+                   right (is (/.Constructor Nat)
+                             (/.event (|>>)))]
+               (`` (and (,, (with_template [<correct> <incorrect>]
+                              [(|> (<correct> expected)
+                                   (/.event? <correct>)
+                                   (maybe#each (same? expected))
+                                   (maybe.else false))
+                               (|> (<correct> expected)
+                                   (/.event? <incorrect>)
+                                   (|.when
+                                     {.#None} true
+                                     {.#Some _} false))]
+
+                              [left right]
+                              [right left]
+                              ))))))
+           (in (let [increase (is (/.Constructor Any)
+                                  (/.event (|>>)))
+                     decrease (is (/.Constructor Any)
+                                  (/.event (|>>)))
+                     counter (is (Atom Nat)
+                                 (atom.atom expected))
+                     [events feed!] (is [(frp.Channel /.Event) (frp.Sink /.Event)]
+                                        (frp.channel []))
+                     scenario/+ (<| (/.scenario events increase expected)
+                                    (function (_ _ so_far)
+                                      (do async.monad
+                                        [[old new] (async.future (atom.update! (n.+ shift) counter))]
+                                        (in new))))
+                     scenario/- (<| (/.scenario events decrease expected)
+                                    (function (_ _ so_far)
+                                      (do async.monad
+                                        [[old new] (async.future (atom.update! (n.- shift) counter))]
+                                        (in new))))]
+                 (do async.monad
+                   [_ (async.future (at feed! feed (increase [])))
+                    _ (async.future (at feed! feed (increase [])))
+                    _ (async.future (at feed! feed (decrease [])))
+                    _ (async.future (at feed! close))
+                    scenario/+ scenario/+
+                    scenario/- scenario/-
+                    count (async.future (atom.read! counter))]
+                   (unit.coverage [/.scenario]
+                     (and (n.= (all n.+ shift expected) count)
+                          (n.= (all n.+ shift shift expected) scenario/+)
+                          (n.= (all n.+ shift expected) scenario/-))))))
+           )))
diff --git a/stdlib/source/test/lux/control/function/contract.lux b/stdlib/source/test/lux/control/function/contract.lux
index 44666a08d..e24d6f52f 100644
--- a/stdlib/source/test/lux/control/function/contract.lux
+++ b/stdlib/source/test/lux/control/function/contract.lux
@@ -21,7 +21,8 @@
   Test
   (<| (_.covering /._)
       (do [! random.monad]
-        [expected random.nat])
+        [expected random.nat
+         error_message (random.upper_case 5)])
       (all _.and
            (_.coverage [/.pre /.pre_condition_failed]
              (when (try (/.pre (n.even? expected)
@@ -43,4 +44,17 @@
                (and (text.contains? (the exception.#label /.post_condition_failed)
                                     error)
                     (not (n.odd? expected)))))
+           (_.coverage [/.assert!]
+             (and (when (try (/.assert! error_message true))
+                    {try.#Success actual}
+                    true
+                    
+                    {try.#Failure error}
+                    false)
+                  (when (try (/.assert! error_message false))
+                    {try.#Success actual}
+                    false
+                    
+                    {try.#Failure error}
+                    (text.contains? error_message error))))
            )))