Moved dependency chasing to the loader and fixed some tests

bin/driver.ml

@@ -30,6 +30,8 @@ module Phases = struct
           Parse.program
           source_code
       in
+      let program = (ResolvePositions.resolve_positions pos_context)#program program in
+      let program = Chaser.add_dependencies "" program in
       let context' = Context.({ context with source_code = pos_context }) in
       Loader.({ program_ = program; context = context' })
 
@@ -38,6 +40,8 @@ module Phases = struct
       let program, pos_context =
         Parse.Readline.parse ps1
       in
+      let program = (ResolvePositions.resolve_positions pos_context)#sentence program in
+      let program = Chaser.add_dependencies_sentence program in
       let context' = Context.({ context with source_code = pos_context }) in
       Loader.({ program_ = program; context = context' })
   end

core/chaser.ml

@@ -85,7 +85,7 @@ let rec add_module_bindings deps dep_map =
           ~message:"Impossible pattern in add_module_bindings")
 
 
-let rec add_dependencies_inner module_name module_prog visited deps dep_map =
+let rec add_dependencies_inner root module_name module_prog visited deps dep_map =
   if StringSet.mem module_name visited then (visited, [], dep_map) else
   let visited1 = StringSet.add module_name visited in
   let dep_map1 = StringMap.add module_name module_prog dep_map in
@@ -98,20 +98,20 @@ let rec add_dependencies_inner module_name module_prog visited deps dep_map =
     fun (visited_acc, deps_acc, dep_map_acc) name ->
       (* Given the top-level module name, try and parse wrt the paths *)
       let filename = top_level_filename name in
-      let (prog, pos_ctx) = try_parse_file filename in
+      let (prog, pos_ctx) = try_parse_file ~root filename in
       let prog = (ResolvePositions.resolve_positions pos_ctx)#program prog in
       let (visited_acc', deps_acc', dep_map_acc') =
-        add_dependencies_inner name prog visited_acc [] dep_map_acc in
+        add_dependencies_inner root name prog visited_acc [] dep_map_acc in
       (visited_acc', deps_acc @ deps_acc', dep_map_acc')
   ) (visited1, (module_name, ics) :: deps, dep_map1) ics
 
 (* Top-level function: given a module name + program, return a program with
  * all necessary files added to the binding list as top-level modules. *)
-let add_dependencies module_prog =
+let add_dependencies root module_prog =
   let (bindings, phrase) = module_prog in
   (* Firstly, get the dependency graph *)
   let (_, deps, dep_binding_map) =
-    add_dependencies_inner "" module_prog (StringSet.empty) [] (StringMap.empty) in
+    add_dependencies_inner root "" module_prog (StringSet.empty) [] (StringMap.empty) in
   (* Next, do a topological sort to get the dependency graph and identify cyclic dependencies *)
   let sorted_deps = Graph.topo_sort_sccs deps in
   (* Each entry should be *precisely* one element (otherwise we have cycles) *)
@@ -124,5 +124,5 @@ let add_dependencies module_prog =
   (module_bindings @ bindings, phrase)
 
 let add_dependencies_sentence = function
-  | Definitions defs -> Definitions (fst (add_dependencies (defs, None)))
+  | Definitions defs -> Definitions (fst (add_dependencies "" (defs, None)))
   | s -> s

core/chaser.mli

@@ -1,2 +1,2 @@
-val add_dependencies : Sugartypes.program -> Sugartypes.program
+val add_dependencies : string -> Sugartypes.program -> Sugartypes.program
 val add_dependencies_sentence : Sugartypes.sentence -> Sugartypes.sentence

core/desugarModules.ml

@@ -535,8 +535,6 @@ let renamer : Epithet.t ref = ref Epithet.empty
 let desugar_program : Sugartypes.program -> Sugartypes.program
   = fun program ->
   let interacting = Basicsettings.System.is_interacting () in
-  (* TODO move to this logic to the loader. *)
-  let program = Chaser.add_dependencies program in
   let program = DesugarAlienBlocks.transform_alien_blocks program in
   (* Printf.fprintf stderr "Before elaboration:\n%s\n%!" (Sugartypes.show_program program); *)
   let renamer', scope' = if interacting then !renamer, !scope else Epithet.empty, Scope.empty in
@@ -549,7 +547,6 @@ let desugar_program : Sugartypes.program -> Sugartypes.program
 
 let desugar_sentence : Sugartypes.sentence -> Sugartypes.sentence
   = fun sentence ->
-  let sentence = Chaser.add_dependencies_sentence sentence in
   let sentence = DesugarAlienBlocks.sentence sentence in
   let visitor = desugar ~toplevel:true !renamer !scope in
   let result = visitor#sentence sentence in

core/frontend.ml

@@ -123,8 +123,7 @@ module Untyped = struct
 
   (* Collection of transformers. *)
   let transformers : transformer array
-    = [| (module ResolvePositions)
-       ; (module CheckXmlQuasiquotes)
+    = [| (module CheckXmlQuasiquotes)
        ; (module DesugarSwitchFuns)
        ; (module DesugarModules)
        ; (module Shunting)

core/loader.ml

@@ -4,12 +4,12 @@ type 'a result =
 
 let load : Context.t -> string -> Sugartypes.program result
   = fun context filename ->
+  let root = Filename.dirname filename in
   let program, pos_context =
-    ModuleUtils.try_parse_file filename
+    ModuleUtils.try_parse_file ~root:"" filename
   in
+  let program = (ResolvePositions.resolve_positions pos_context)#program program in
+  let program = Chaser.add_dependencies root program in
   let context' = Context.{ context with source_code = pos_context } in
   { context   = context';
     program_  = program }
-
-
-

core/moduleUtils.ml

@@ -34,7 +34,7 @@ type term_shadow_table = string list stringmap
 type type_shadow_table = string list stringmap
 type shadow_table = string list stringmap
 
-let try_parse_file filename =
+let try_parse_file ~root filename =
   (* First, get the list of directories, with trailing slashes stripped *)
   let check_n_chop path =
     let dir_sep = Filename.dir_sep in
@@ -57,7 +57,7 @@ let try_parse_file filename =
 
   let poss_dirs =
     let paths = Settings.get links_file_paths in
-    "" :: poss_stdlib_dir @ (List.map (check_n_chop) paths)
+    root :: poss_stdlib_dir @ (List.map (check_n_chop) paths)
   in
 
   (* Loop through, trying to open the module with each path *)

core/moduleUtils.mli

@@ -12,7 +12,7 @@ type type_shadow_table = string list stringmap
 type shadow_table = string list stringmap
 
 val module_sep : string
-val try_parse_file : string -> (Sugartypes.program * Scanner.position_context)
+val try_parse_file : root:string -> string -> (Sugartypes.program * Scanner.position_context)
 val contains_modules : Sugartypes.program -> bool
 val separate_modules : Sugartypes.binding list -> (Sugartypes.binding list * Sugartypes.binding list)
 val get_ffi_files : Sugartypes.program -> string list

examples/church.links

@@ -9,13 +9,16 @@ fun succ(n) {fun (z)(s){s(n(z)(s))}}
 sig add : (Nat) {}-> (Nat) {}-> Nat
 fun add(m)(n) {fun (z)(s) {m(n(z)(s))(s)}}
 
+sig coerceToplevel : ((a) {}-> b) -f-> ((a) -e-> b)
+fun coerceToplevel(f) {f : ((a) -e-> b) <- ((a) {}-> b)}
+
 sig two : Nat
-var two = succ(succ(zero));
+var two = coerceToplevel(succ)(coerceToplevel(succ)(zero));
 
 sig four : Nat
-var four = add(two)(two);
+var four = coerceToplevel(coerceToplevel(add)(two))(two);
 
 sig natToInt : (Nat) {}-> Int
 fun natToInt(n) {n(0)(fun (x) {x+1})}
 
-natToInt(four)
+coerceToplevel(natToInt)(four)

examples/handlers/count_web.links

@@ -1,6 +1,6 @@
 # A port of the simple counting benchmark from Kammar et al. (2013)
 
-sig evalState : (Comp({Get:s ,Put:(s) {}-> ()|e}, a)) -> # Stateful computation
+sig evalState : (Comp(a, {Get:s ,Put:(s) {}-> ()|e})) -> # Stateful computation
                 (s) {Get{_},Put{_} |e}~> a
 fun evalState(m)(st) client {
   var run =
@@ -12,7 +12,7 @@ fun evalState(m)(st) client {
   run(st)
 }
 
-sig count : Comp({Get:Int,Put:(Int) {}-> ()|e}, Int)
+sig count : Comp(Int, {Get:Int,Put:(Int) {}-> ()|e})
 fun count() client {
   var n = do Get;
   if (n == 0) n

examples/handlers/toggle.links

@@ -8,17 +8,17 @@ sig put : (s) {Put:(s) {}-> () |_}-> ()
 fun put(st) {do Put(st)}
 
 # Stateful computation
-sig toggle : Comp({Get:Bool,Put:(Bool) {}-> () |_}, Bool)
+sig toggle : Comp(Bool, {Get:Bool,Put:(Bool) {}-> () |_})
 fun toggle() client {
   var bit = get();
   put(not(bit));
   get()
 }
 
 # State handler
-sig runState : (Comp({Get:s ,Put:(s) {}-> () |e},  a  )) -> # Stateful computation
-               (s)                                       -> # Initial state
-                Comp({Get{_},Put{_}          |e}, (a,s))    # Stateless computation
+sig runState : (Comp( a   , {Get:s ,Put:(s) {}-> () |e})) -> # Stateful computation
+               (s)                                        -> # Initial state
+                Comp((a,s), {Get{_},Put{_}          |e})     # Stateless computation
 fun runState(m)(st)() client {
   var run = handle(m()) {
     case x      -> fun(ret_st) { (x,ret_st) }
@@ -41,7 +41,7 @@ fun stringToBool(s) {
   switch (s) {
     case "true"  -> true
     case "false" -> false
-    case otherwise -> error("Input '" ^^ s ^^ "' was not recognised as a boolean value.")
+    case _ -> error("Input '" ^^ s ^^ "' was not recognised as a boolean value.")
   }
 }
 

examples/handlers/toggle_web.links

@@ -8,17 +8,17 @@ sig put : (s) {Put:(s) {}-> () |_}-> ()
 fun put(st) {do Put(st)}
 
 # Stateful computation
-sig toggle : Comp({Get:Bool,Put:(Bool) {}-> () |_}, Bool)
+sig toggle : Comp(Bool, {Get:Bool,Put:(Bool) {}-> () |_})
 fun toggle() client {
   var bit = get();
   put(not(bit));
   get()
 }
 
 # State handler
-sig runState : (Comp({Get:s ,Put:(s) {}-> () |e},  a  )) -> # Stateful computation
-               (s)                                       -> # Initial state
-                Comp({Get{_},Put{_}          |e}, (a,s))    # Stateless computation
+sig runState : (Comp( a   , {Get:s ,Put:(s) {}-> () |e})) -> # Stateful computation
+               (s)                                        -> # Initial state
+                Comp((a,s), {Get{_},Put{_}          |e})     # Stateless computation
 fun runState(m)(st)() client {
   var run = handle(m()) {
     case x      -> fun(ret_st) { (x,ret_st) }
@@ -41,12 +41,12 @@ fun stringToBool(s) {
   switch (s) {
     case "true"  -> true
     case "false" -> false
-    case otherwise -> error("Input '" ^^ s ^^ "' was not recognised as a boolean value.")
+    case _ -> error("Input '" ^^ s ^^ "' was not recognised as a boolean value.")
   }
 }
 
 fun enableButton(btn) {
-  domRemoveAttributeFromRef(getNodeById(btn), "disabled");
+  ignore(domRemoveAttributeFromRef(getNodeById(btn), "disabled"))
 }
 
 fun disableButton(btn) {

examples/toggle.links

@@ -18,7 +18,7 @@ fun stringToBool(s) {
   switch (s) {
     case "true"  -> true
     case "false" -> false
-    case otherwise -> error("Input '" ^^ s ^^ "' was not recognised as a boolean value.")
+    case _ -> error("Input '" ^^ s ^^ "' was not recognised as a boolean value.")
   }
 }
 

examples/webserver/examples-nodb.links

@@ -22,10 +22,10 @@ fun main() {
   addStaticRoute("/examples/", "examples/", [("links", "text/plain")]);
   addStaticRoute("/examplessrc/", "examples/", [("links", "text/plain")]);
 
-  addRoute("/examples/draggable.links", fun(_) {Draggable.main()});
-  addRoute("/examples/progress.links", fun(_) {Progress.main()});
+  addRoute("/examples/draggable.links", fun(_) {Draggable.mainPage((), ())});
+  addRoute("/examples/progress.links", Progress.mainPage);
 
-  addRoute("/examples/buttons.links", fun(_) {Buttons.main()});
+  addRoute("/examples/buttons.links", Buttons.mainpage);
   addRoute("/examples/formsTest.links", fun(_) {FormsTest.main()});
 
   addRoute("/examples/validate.links", fun(_) {Validate.main()});

examples/webserver/examples.links

@@ -34,15 +34,15 @@ fun main() {
   addStaticRoute("/examplessrc/", "examples/", [("links", "text/plain")]);
 
   addRoute("/examples/dictionary/dictSuggestUpdate.links", fun(_){DictSuggestUpdate.main()});
-  addRoute("/examples/draggable.links", fun(_) {Draggable.main()});
-  addRoute("/examples/progress.links", fun(_) {Progress.main()});
+  addRoute("/examples/draggable.links", fun(_) {Draggable.mainPage((), ())});
+  addRoute("/examples/progress.links", Progress.mainPage);
 
   addRoute("/examples/factorial.links", fun(_) {Factorial.main()});
   addRoute("/examples/dictionary/dictSuggest.links", fun(_){DictSuggest.main()});
   addRoute("/examples/dictionary/dictSuggestLite.links", fun(_){DictSuggestLite.main()});
   addRoute("/examples/draggableDb.links", fun(_) {DraggableDb.main()});
 
-  addRoute("/examples/buttons.links", fun(_) {Buttons.main()});
+  addRoute("/examples/buttons.links", Buttons.mainpage);
   addRoute("/examples/formsTest.links", fun(_) {FormsTest.main()});
 
   addRoute("/examples/validate.links", fun(_) {Validate.main()});

test-harness

@@ -7,7 +7,7 @@ import concurrent.futures, threading, multiprocessing
 from os import path
 from subprocess import Popen, PIPE
 
-successes = failures = ignored = 0
+successes = failures = skipsuccesses = ignored = 0
 TIMEOUT = 15 # seconds before a test is timed out.
 
 the_lock = threading.Lock()
@@ -71,6 +71,11 @@ def OK(name):
     global successes
     successes+=1
     print(' SUCCESS: %s' % name)
+def OK_skip(name):
+    global successes, skipsuccesses
+    successes+=1
+    skipsuccesses+=1
+    print('?IGNORED: %s (test passed, but marked as skip)' % name)
 
 def parse(stream):
     """Read test information separated by blank lines.  The first line
@@ -180,9 +185,12 @@ def evaluate(name, code, config_file, stdout='', stderr='', exit = '0', env = No
             passed &= check_expected(name, 'stderr', str(proc.stderr.read().decode('ascii')), stderr, errors)
             if passed:
                 with the_lock:
-                    OK(name)
+                    if ignore is None:
+                        OK(name)
+                    else:
+                        OK_skip(name)
             else:
-                if ignore != None:
+                if ignore is not None:
                     global ignored
                     with the_lock:
                         ignored += 1
@@ -274,7 +282,7 @@ def main():
                               "the following exception:\n%s")
                              % (job_name, result.exception()))
 
-    print("%d failures (+%d ignored)\n%d successes\n" % (failures, ignored, successes))
+    print("%d failures (+%d ignored)\n%d successes%s\n" % (failures, ignored, successes, ("" if skipsuccesses == 0 else " (with %d ignored)" % skipsuccesses)))
     if failures > 0:
         sys.exit(1)
     else:

tests/freezeml.tests

@@ -210,7 +210,6 @@ Do not infer polymorphic arguments (3)
 tests/freezeml/session1.links
 exit : 1
 stderr : @.*Type error:.*
-ignore : Failing test case, as Mono kinds get converted to Session.
 
 Do not infer polymorphic arguments (4)
 tests/freezeml/session2.links
@@ -255,4 +254,4 @@ stdout : fun : forall a.(a) {}-> ()
 
 Freezing recursive function outside mutual block, without annotation
 mutual { fun f(x) {()} } ~f
-stdout : fun : forall a,b::Row.(a) -b-> ()
+stdout : fun : forall a,b::Row.(a) -b-> ()

tests/tuples.tests

@@ -45,5 +45,4 @@ stdout : (1 = "one") : (1:String)
 
 Quasituples
 (1="foo", 3="bar")
-stdout : (1 = "foo", 3 = "bar") : (1:String, 3:String)
-ignore : The type is currently printed as (String, String). Is this really what we want?
+stdout : (1 = "foo", 3 = "bar") : (1:String,3:String)

tests/typecheck_examples.tests

@@ -61,7 +61,6 @@ filemode : true
 Typecheck example file examples/church.links
 examples/church.links
 filemode : true
-ignore : broken example
 
 Typecheck example file examples/citations.links
 examples/citations.links
@@ -459,7 +458,6 @@ filemode : true
 Typecheck example file examples/sessions/counter.links
 examples/sessions/counter.links
 filemode : true
-ignore : broken example
 
 Typecheck example file examples/sessions/draggable-boring.links
 examples/sessions/draggable-boring.links
@@ -663,7 +661,6 @@ filemode : true
 Typecheck example file examples/toggle.links
 examples/toggle.links
 filemode : true
-ignore : broken example
 
 Typecheck example file examples/validate.links
 examples/validate.links
@@ -772,4 +769,3 @@ filemode : true
 Typecheck example file examples/mvu/changePage.links
 examples/mvu/changePage.links
 filemode : true
-