Test imports for circular dependencies.

5 files changed, 215 insertions, 90 deletions

diff --git a/stdlib/source/lux/data/env.lux b/stdlib/source/lux/data/env.lux
deleted file mode 100644
index 7e4265e6a..000000000
--- a/stdlib/source/lux/data/env.lux
+++ /dev/null
@@ -1,25 +0,0 @@
-(.module:
-  [lux #*
-   [abstract
-    [functor (#+ Functor)]
-    comonad]])
-
-(type: #export (Env e a)
-  {#env e
-   #value a})
-
-(structure: #export functor (All [e] (Functor (Env e)))
-  (def: (map f fa)
-    (update@ #value f fa)))
-
-(structure: #export comonad (All [e] (CoMonad (Env e)))
-  (def: &functor ..functor)
-
-  (def: unwrap (get@ #value))
-
-  (def: (split wa)
-    (set@ #value wa wa)))
-
-(def: #export (local change env)
-  (All [e a] (-> (-> e e) (Env e a) (Env e a)))
-  (update@ #env change env))
diff --git a/stdlib/source/lux/data/identity.lux b/stdlib/source/lux/data/identity.lux
index 412103987..ce0476d8a 100644
--- a/stdlib/source/lux/data/identity.lux
+++ b/stdlib/source/lux/data/identity.lux
@@ -11,20 +11,27 @@
 (type: #export (Identity a)
   a)
 
-(structure: #export functor (Functor Identity)
+(structure: #export functor
+  (Functor Identity)
+
   (def: map function.identity))
 
-(structure: #export apply (Apply Identity)
+(structure: #export apply
+  (Apply Identity)
+
   (def: &functor ..functor)
-  (def: (apply ff fa)
-    (ff fa)))
+  (def: (apply ff fa) (ff fa)))
 
-(structure: #export monad (Monad Identity)
+(structure: #export monad
+  (Monad Identity)
+  
   (def: &functor ..functor)
   (def: wrap function.identity)
   (def: join function.identity))
 
-(structure: #export comonad (CoMonad Identity)
+(structure: #export comonad
+  (CoMonad Identity)
+  
   (def: &functor ..functor)
   (def: unwrap function.identity)
   (def: split function.identity))
diff --git a/stdlib/source/lux/target/jvm/bytecode.lux b/stdlib/source/lux/target/jvm/bytecode.lux
index e1c19c55d..c46b5bf1f 100644
--- a/stdlib/source/lux/target/jvm/bytecode.lux
+++ b/stdlib/source/lux/target/jvm/bytecode.lux
@@ -456,7 +456,11 @@
       (#try.Failure _)
       (..bytecode $0 $1 @_ _.ldc-w/string [index]))))
 
-(import: #long java/lang/Float)
+(import: #long java/lang/Float
+  (#static floatToRawIntBits #manual [float] int))
+
+(import: #long java/lang/Double
+  (#static doubleToRawLongBits #manual [double] int))
 
 (template [<name> <type> <constructor> <constant> <wide> <to-lux> <specializations>]
   [(def: #export (<name> value)
@@ -484,13 +488,42 @@
     [+3 _.iconst-3]
     [+4 _.iconst-4]
     [+5 _.iconst-5])]
-  [float java/lang/Float //constant.float //constant/pool.float _.ldc-w/float
-   (<| (:coerce Frac) host.float-to-double)
-   ([+0.0 _.fconst-0]
-    [+1.0 _.fconst-1]
-    [+2.0 _.fconst-2])]
   )
 
+(def: (arbitrary-float value)
+  (-> java/lang/Float (Bytecode Any))
+  (do ..monad
+    [index (..lift (//constant/pool.float (//constant.float value)))]
+    (case (|> index //index.value //unsigned.value //unsigned.u1)
+      (#try.Success index)
+      (..bytecode $0 $1 @_ _.ldc [index])
+
+      (#try.Failure _)
+      (..bytecode $0 $1 @_ _.ldc-w/float [index]))))
+
+(def: float-bits
+  (-> java/lang/Float Int)
+  (|>> java/lang/Float::floatToRawIntBits
+       host.int-to-long
+       (:coerce Int)))
+
+(def: negative-zero-float-bits
+  (|> -0.0 host.double-to-float ..float-bits))
+
+(def: #export (float value)
+  (-> java/lang/Float (Bytecode Any))
+  (if (i.= ..negative-zero-float-bits
+           (..float-bits value))
+    (..arbitrary-float value)
+    (case (|> value host.float-to-double (:coerce Frac))
+      (^template [<special> <instruction>]
+        <special> (..bytecode $0 $1 @_ <instruction> []))
+      ([+0.0 _.fconst-0]
+       [+1.0 _.fconst-1]
+       [+2.0 _.fconst-2])
+      
+      _ (..arbitrary-float value))))
+
 (template [<name> <type> <constructor> <constant> <wide> <to-lux> <specializations>]
   [(def: #export (<name> value)
      (-> <type> (Bytecode Any))
@@ -507,12 +540,35 @@
    (<|)
    ([+0 _.lconst-0]
     [+1 _.lconst-1])]
-  [double Frac //constant.double //constant/pool.double _.ldc2-w/double
-   (<|)
-   ([+0.0 _.dconst-0]
-    [+1.0 _.dconst-1])]
   )
 
+(def: (arbitrary-double value)
+  (-> java/lang/Double (Bytecode Any))
+  (do ..monad
+    [index (..lift (//constant/pool.double (//constant.double value)))]
+    (..bytecode $0 $2 @_ _.ldc2-w/double [index])))
+
+(def: double-bits
+  (-> java/lang/Double Int)
+  (|>> java/lang/Double::doubleToRawLongBits
+       (:coerce Int)))
+
+(def: negative-zero-double-bits
+  (..double-bits -0.0))
+
+(def: #export (double value)
+  (-> java/lang/Double (Bytecode Any))
+  (if (i.= ..negative-zero-double-bits
+           (..double-bits value))
+    (..arbitrary-double value)
+    (case value
+      (^template [<special> <instruction>]
+        <special> (..bytecode $0 $2 @_ <instruction> []))
+      ([+0.0 _.dconst-0]
+       [+1.0 _.dconst-1])
+      
+      _ (..arbitrary-double value))))
+
 (exception: #export (invalid-register {id Nat})
   (exception.report
    ["ID" (%.nat id)]))
diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux
index 2d005d450..d15bec236 100644
--- a/stdlib/source/lux/tool/compiler/default/platform.lux
+++ b/stdlib/source/lux/tool/compiler/default/platform.lux
@@ -5,6 +5,7 @@
    [abstract
     ["." monad (#+ Monad do)]]
    [control
+    ["." function]
     ["." try (#+ Try)]
     ["." exception (#+ exception:)]
     [concurrency
@@ -14,12 +15,13 @@
     ["." binary (#+ Binary)]
     ["." bit]
     ["." product]
+    ["." maybe]
     ["." text ("#@." equivalence)
      ["%" format (#+ format)]]
     [collection
      ["." dictionary (#+ Dictionary)]
      ["." row (#+ Row) ("#@." fold)]
-     ["." set]
+     ["." set (#+ Set)]
      ["." list ("#@." monoid functor fold)]]
     [format
      ["_" binary (#+ Writer)]]]
@@ -240,12 +242,94 @@
            #///generation.log]
           row.empty))
 
+  (def: empty
+    (Set Module)
+    (set.new text.hash))
+
+  (type: Mapping
+    (Dictionary Module (Set Module)))
+
+  (type: Dependence
+    {#depends-on Mapping
+     #depended-by Mapping})
+
+  (def: independence
+    Dependence
+    (let [empty (dictionary.new text.hash)]
+      {#depends-on empty
+       #depended-by empty}))
+
+  (def: (depend module import dependence)
+    (-> Module Module Dependence Dependence)
+    (let [transitive-dependency (: (-> (-> Dependence Mapping) Module (Set Module))
+                                   (function (_ lens module)
+                                     (|> dependence
+                                         lens
+                                         (dictionary.get module)
+                                         (maybe.default ..empty))))
+          transitive-depends-on (transitive-dependency (get@ #depends-on) import)
+          transitive-depended-by (transitive-dependency (get@ #depended-by) module)
+          update-dependence (: (-> [Module (Set Module)] [Module (Set Module)]
+                                   (-> Mapping Mapping))
+                               (function (_ [source forward] [target backward])
+                                 (function (_ mapping)
+                                   (let [with-dependence+transitives
+                                         (|> mapping
+                                             (dictionary.upsert source ..empty (set.add target))
+                                             (dictionary.update source (set.union forward)))]
+                                     (list@fold (function (_ previous)
+                                                  (dictionary.upsert previous ..empty (set.add target)))
+                                                with-dependence+transitives
+                                                (set.to-list backward))))))]
+      (|> dependence
+          (update@ #depends-on
+                   (update-dependence
+                    [module transitive-depends-on]
+                    [import transitive-depended-by]))
+          (update@ #depended-by
+                   ((function.flip update-dependence)
+                    [module transitive-depends-on]
+                    [import transitive-depended-by])))))
+
+  (def: (circular-dependency? module import dependence)
+    (-> Module Module Dependence Bit)
+    (let [dependence? (: (-> Module (-> Dependence Mapping) Module Bit)
+                         (function (_ from relationship to)
+                           (let [targets (|> dependence
+                                             relationship
+                                             (dictionary.get from)
+                                             (maybe.default ..empty))]
+                             (set.member? targets to))))]
+      (or (dependence? import (get@ #depends-on) module)
+          (dependence? module (get@ #depended-by) import))))
+
+  (exception: #export (module-cannot-import-itself {module Module})
+    (exception.report
+     ["Module" (%.text module)]))
+
+  (exception: #export (cannot-import-circular-dependency {importer Module}
+                                                         {importee Module})
+    (exception.report
+     ["Importer" (%.text importer)]
+     ["importee" (%.text importee)]))
+
+  (def: (verify-dependencies importer importee dependence)
+    (-> Module Module Dependence (Try Any))
+    (cond (text@= importer importee)
+          (exception.throw ..module-cannot-import-itself [importer])
+
+          (..circular-dependency? importer importee dependence)
+          (exception.throw ..cannot-import-circular-dependency [importer importee])
+
+          ## else
+          (#try.Success [])))
+
   (with-expansions [<Context> (as-is [Archive <State+>])
                     <Result> (as-is (Try <Context>))
                     <Return> (as-is (Promise <Result>))
                     <Signal> (as-is (Resolver <Result>))
                     <Pending> (as-is [<Return> <Signal>])
-                    <Importer> (as-is (-> Module <Return>))
+                    <Importer> (as-is (-> Module Module <Return>))
                     <Compiler> (as-is (-> <Importer> archive.ID <Context> Module <Return>))]
     (def: (parallel initial)
       (All [<type-vars>]
@@ -256,9 +340,11 @@
                             {<Context>
                              initial}
                             {(Var (Dictionary Module <Pending>))
-                             (:assume (stm.var (dictionary.new text.hash)))})]
+                             (:assume (stm.var (dictionary.new text.hash)))})
+            dependence (: (Var Dependence)
+                          (stm.var ..independence))]
         (function (_ compile)
-          (function (import! module)
+          (function (import! importer module)
             (do {@ promise.monad}
               [[return signal] (:share [<type-vars>]
                                        {<Context>
@@ -269,40 +355,52 @@
                                         (:assume
                                          (stm.commit
                                           (do {@ stm.monad}
-                                            [[archive state] (stm.read current)]
-                                            (if (archive.archived? archive module)
-                                              (wrap [(promise@wrap (#try.Success [archive state]))
+                                            [dependence (if (text@= archive.runtime-module importer)
+                                                          (stm.read dependence)
+                                                          (do @
+                                                            [[_ dependence] (stm.update (..depend importer module) dependence)]
+                                                            (wrap dependence)))]
+                                            (case (..verify-dependencies importer module dependence)
+                                              (#try.Failure error)
+                                              (wrap [(promise.resolved (#try.Failure error))
                                                      #.None])
+
+                                              (#try.Success _)
                                               (do @
-                                                [@pending (stm.read pending)]
-                                                (case (dictionary.get module @pending)
-                                                  (#.Some [return signal])
-                                                  (wrap [return
+                                                [[archive state] (stm.read current)]
+                                                (if (archive.archived? archive module)
+                                                  (wrap [(promise@wrap (#try.Success [archive state]))
                                                          #.None])
-                                                  
-                                                  #.None
-                                                  (case (if (archive.reserved? archive module)
-                                                          (do try.monad
-                                                            [module-id (archive.id module archive)]
-                                                            (wrap [module-id archive]))
-                                                          (archive.reserve module archive))
-                                                    (#try.Success [module-id archive])
-                                                    (do @
-                                                      [_ (stm.write [archive state] current)
-                                                       #let [[return signal] (:share [<type-vars>]
-                                                                                     {<Context>
-                                                                                      initial}
-                                                                                     {<Pending>
-                                                                                      (promise.promise [])})]
-                                                       _ (stm.update (dictionary.put module [return signal]) pending)]
+                                                  (do @
+                                                    [@pending (stm.read pending)]
+                                                    (case (dictionary.get module @pending)
+                                                      (#.Some [return signal])
                                                       (wrap [return
-                                                             (#.Some [[archive state]
-                                                                      module-id
-                                                                      signal])]))
-                                                    
-                                                    (#try.Failure error)
-                                                    (wrap [(promise@wrap (#try.Failure error))
-                                                           #.None]))))))))})
+                                                             #.None])
+                                                      
+                                                      #.None
+                                                      (case (if (archive.reserved? archive module)
+                                                              (do try.monad
+                                                                [module-id (archive.id module archive)]
+                                                                (wrap [module-id archive]))
+                                                              (archive.reserve module archive))
+                                                        (#try.Success [module-id archive])
+                                                        (do @
+                                                          [_ (stm.write [archive state] current)
+                                                           #let [[return signal] (:share [<type-vars>]
+                                                                                         {<Context>
+                                                                                          initial}
+                                                                                         {<Pending>
+                                                                                          (promise.promise [])})]
+                                                           _ (stm.update (dictionary.put module [return signal]) pending)]
+                                                          (wrap [return
+                                                                 (#.Some [[archive state]
+                                                                          module-id
+                                                                          signal])]))
+                                                        
+                                                        (#try.Failure error)
+                                                        (wrap [(promise@wrap (#try.Failure error))
+                                                               #.None]))))))))))})
                _ (case signal
                    #.None
                    (wrap [])
@@ -363,16 +461,6 @@
           try.assume
           product.left))
 
-    (exception: #export (module-cannot-import-itself {module Module})
-      (exception.report
-       ["Module" (%.text module)]))
-
-    (def: (verify-no-self-import! module dependencies)
-      (-> Module (List Module) (Try Any))
-      (if (list.any? (text@= module) dependencies)
-        (exception.throw ..module-cannot-import-itself [module])
-        (#try.Success [])))
-
     (def: #export (compile import static expander platform compilation context)
       (All [<type-vars>]
         (-> Import Static Expander <Platform> Compilation <Context> <Return>))
@@ -413,9 +501,8 @@
 
                                                    (#.Cons _)
                                                    (do @
-                                                     [_ (:: promise.monad wrap (verify-no-self-import! module new-dependencies))
-                                                      archive,document+ (|> new-dependencies
-                                                                            (list@map import!)
+                                                     [archive,document+ (|> new-dependencies
+                                                                            (list@map (import! module))
                                                                             (monad.seq ..monad))
                                                       #let [archive (|> archive,document+
                                                                         (list@map product.left)
@@ -452,5 +539,5 @@
                                   (do @
                                     [_ (ioW.freeze (get@ #&file-system platform) static archive)]
                                     (promise@wrap (#try.Failure error))))))))))]
-        (compiler compilation-module)))
+        (compiler archive.runtime-module compilation-module)))
     ))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/directive.lux b/stdlib/source/lux/tool/compiler/language/lux/directive.lux
index 8a5e0172a..11dc98bef 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/directive.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/directive.lux
@@ -73,7 +73,7 @@
   )
 
 (def: #export (set-current-module module)
-  (All [anchor expression directive output]
+  (All [anchor expression directive]
     (-> Module (Operation anchor expression directive Any)))
   (do phase.monad
     [_ (..lift-analysis