WIP: Type Tetris 2, Electric Boogaloo part 3

Author: z-silver

lib/Ast.ml

@@ -9,7 +9,7 @@ module type EXPR = sig
   val is_functor : t -> bool
 end
 
-type head = { name : string; arity : int }
+type head = { name : string; arity : int } [@@deriving show, ord]
 
 module ClauseF (Expr : EXPR) = struct
   type multi_declaration = head * decl * decl Location.with_location FT.t
@@ -48,6 +48,9 @@ module ClauseF (Expr : EXPR) = struct
   }
 
   and ('directives, 'mods) t = ('directives, 'mods) base Location.with_location
+
+  let signature_populated (s : ('directives, 'mods) signature_body) : bool =
+    not (FT.is_empty s.directives && FT.is_empty s.declarations)
 end
 
 module Expr = struct

lib/FT.ml

@@ -59,3 +59,6 @@ let group (cmp : 'a -> 'a -> int) (ft : 'a t) : 'a t t =
 let rec find_opt (f : 'a -> bool) (ft : 'a t) : 'a option =
   Option.bind (front ft) (fun (remaining, first) ->
       if f first then Some first else find_opt f remaining)
+
+let for_all (f : 'a -> bool) : 'a t -> bool =
+  Fun.compose Option.is_none (find_opt (Fun.compose not f))

lib/Preprocessor.ml

@@ -13,6 +13,22 @@ let rename_arg ({ loc; _ } as expr : Ast.Expr.t) (counter : int) :
     loc;
   }
 
+let all_atoms (args : Ast.Expr.t FT.t) : unit =
+  match
+    args
+    |> FT.find_opt
+       @@ Fun.compose
+            (function
+              | Ast.Expr.Functor { elements; _ } when FT.is_empty elements ->
+                  false
+              | _ -> true)
+            Location.strip_loc
+  with
+  | None -> ()
+  | Some { loc; _ } ->
+      Logger.error loc "Expected atom.";
+      exit 1
+
 let compare_clauses (c1 : Ast.ParserClause.t) (c2 : Ast.ParserClause.t) : int =
   match (c1, c2) with
   | ( { content = Declaration { head = h1; _ }; _ },
@@ -57,12 +73,8 @@ let rec remove_comments (clause : Ast.ParserClause.t) :
     | _ -> true
   in
   match clause with
-  | {
-   content =
-     ParserClause.Directive
-       ({ content = { name = [], { content = "comment"; _ }; _ }; _ }, _);
-   _;
-  } ->
+  | { content = ParserClause.Directive ({ content = header; _ }, _); _ }
+    when Ast.Expr.match_func header [ "comment" ] ->
       None
   | { content = ParserClause.Directive (head, body); loc } ->
       Some
@@ -72,11 +84,8 @@ let rec remove_comments (clause : Ast.ParserClause.t) :
               (head, FT.map (FT.filter_map remove_comments) body);
           loc;
         }
-  | {
-   content =
-     Declaration { head = { name = [], { content = "comment"; _ }; _ }; _ };
-   _;
-  } ->
+  | { content = Declaration { head; _ }; _ }
+    when Ast.Expr.match_func head [ "comment" ] ->
       None
   | { content = Declaration { head; body }; _ } as decl ->
       Some
@@ -93,22 +102,26 @@ let rec remove_comments (clause : Ast.ParserClause.t) :
                           (Location.fmap (fun v -> Ast.Expr.Functor v));
               };
         }
-  | { content = QueryConjunction [ _ ]; _ } as query -> Some query
-  | { content = QueryConjunction []; _ } -> None
+  | { content = QueryConjunction q; _ } as query when FT.size q = 1 ->
+      Some query
+  | { content = QueryConjunction q; _ } when FT.is_empty q -> None
   | { content = QueryConjunction queries; loc } ->
       let filtered_queries =
         FT.map
           (fun query ->
             remove_comments
             @@ {
-                 content = Ast.ParserClause.QueryConjunction [ query ];
+                 content =
+                   Ast.ParserClause.QueryConjunction (FT.singleton query);
                  loc = query.loc;
                })
           queries
       in
       filtered_queries |> FT.concat_map FT.of_option
       |> FT.map (function
-        | { content = Ast.ParserClause.QueryConjunction [ func ]; _ } -> func
+        | { content = Ast.ParserClause.QueryConjunction q; _ }
+          when FT.size q = 1 ->
+            FT.head_exn q
         | _ ->
             Logger.simply_unreachable
               "The conjunctions we constructed are guaranteed not to have this \
@@ -201,7 +214,6 @@ module DependencyGraph = struct
     graph
 
   let expand graph : t Error.attempt =
-    let module FT = BatFingerTree in
     let module Set = BatSet.String in
     let module Map = BatMap.String in
     let atom_to_filepath =
@@ -343,28 +355,26 @@ module Make (Target : TARGET) :
             (dependencies, FT.empty) grouped_body
         in
         let dependencies =
-          match
-            (fst head.content.name, Ast.Expr.func_label head.content, body)
-          with
-          | [], "import", [] -> (
-              match head.content.elements with
-              | [ singleton ] ->
+          if Ast.Expr.match_func head.content [ "import" ] then
+            if FT.is_empty body then (
+              match FT.front head.content.elements with
+              | Some (rest, singleton) when FT.is_empty rest ->
                   let external_dep =
                     Ast.Expr.extract_unqualified_atom singleton
                   in
                   DependencyGraph.add filename external_dep dependencies
-              | [] ->
+              | None ->
                   Logger.error head.loc
                     "Directive 'import' cannot be an empty functor";
                   exit 1
               | _ ->
                   Logger.error head.loc
                     "Directive 'import' cannot have multiple expressions within";
                   exit 1)
-          | [], "import", _ ->
+            else (
               Logger.error head.loc "Directive 'import' cannot have a body";
-              exit 1
-          | _ -> dependencies
+              exit 1)
+          else dependencies
         in
         {
           dependencies;

lib/compiler/Declaration.ml

@@ -12,20 +12,21 @@ let rec compile_expr (expr : Ast.Expr.t) : Beam.Builder.Expr.t =
   | Variable var -> Builder.var var
   | Nil -> Builder.nil
   | Cons (h, t) -> Builder.cons (compile_expr h) (compile_expr t)
-  | Functor ({ arity; _ } as f) when arity = 0 ->
+  | Functor ({ elements; _ } as f) when FT.size elements = 0 ->
       Builder.atom @@ Ast.Expr.extract_func_label f
   | Functor ({ elements; _ } as f) ->
       let name = Builder.atom @@ Ast.Expr.extract_func_label f in
-      Builder.tuple (name :: List.map compile_expr elements)
+      (* TODO: use finger trees in Builder *)
+      Builder.tuple @@ FT.to_list (FT.cons (FT.map compile_expr elements) name)
   | Integer number -> Builder.int number
 
 let call_with_fresh (name : string) expr =
   let open Beam in
   Ukanren.call_with_fresh @@ Builder.lambda name expr
 
 let compile_declaration_bodies { module_name; imports; _ }
-    (clauses : Ast.Clause.decl Location.with_location list) =
-  if List.is_empty clauses then (
+    (clauses : Ast.Clause.decl Location.with_location FT.t) =
+  if FT.is_empty clauses then (
     Logger.simply_unreachable "Predicates must have at least one body";
     exit 1)
   else
@@ -36,8 +37,8 @@ let compile_declaration_bodies { module_name; imports; _ }
       let find_variables call = Preprocessor.find_variables (Functor call) in
       let vars =
         content.body
-        |> List.map (Fun.compose find_variables Location.strip_loc)
-        |> List.fold_left Set.union Set.empty
+        |> FT.map (Fun.compose find_variables Location.strip_loc)
+        |> FT.fold_left Set.union Set.empty
         |> Set.filter (fun name ->
             Str.string_match (Str.regexp "^[A-Z]") name 0)
       in
@@ -46,50 +47,54 @@ let compile_declaration_bodies { module_name; imports; _ }
         (* TODO: We should use locations when calling Beam helpers. They don't use
            locations yet, hence they are not being sent as arguments *)
         let make_function { content = call; loc } =
-          let { Ast.Expr.name; elements; arity } = call in
-          let args = List.map compile_expr elements in
-          match (name, arity) with
-          | ([ { content = "karuta"; _ } ], { content = "eq"; _ }), 2 -> (
-              match args with
-              | expr1 :: expr2 :: _ -> Ukanren.eq expr1 expr2
-              | _ ->
-                  Logger.unreachable loc
-                    "Mismatch between arity and length of elements in builtin \
-                     'eq'";
-                  exit 1)
-          | ([ { content = "karuta"; _ } ], { content = "nat"; _ }), 1 -> (
-              match args with
-              | expr1 :: _ -> Ukanren.nat expr1
-              | _ ->
-                  Logger.unreachable loc
-                    "Mismatch between arity and length of elements in builtin \
-                     'nat'";
-                  exit 1)
-          | ([], _), _ ->
-              Builder.call
-                (Builder.atom @@ Ast.Expr.extract_func_label call)
-                args
-          | ((head :: _ as path), { content = fun_name; _ }), _ ->
-              Builder.call_with_module
-                (Builder.atom
-                @@ flat_module_name
-                     (let suffix = List.map Location.strip_loc path in
-                      if BatSet.String.mem head.content imports then suffix
-                      else module_name :: suffix))
-                (Builder.atom fun_name) args
+          let { Ast.Expr.name; elements } = call in
+          let arity = FT.size elements in
+          let args = FT.map compile_expr elements in
+          if Ast.Expr.match_func call [ "karuta"; "eq" ] && arity = 2 then (
+            match FT.to_list args with
+            | [ expr1; expr2 ] -> Ukanren.eq expr1 expr2
+            | _ ->
+                Logger.unreachable loc
+                  "Mismatch between arity and length of elements in builtin \
+                   'eq'";
+                exit 1)
+          else if Ast.Expr.match_func call [ "karuta"; "nat" ] && arity = 1 then (
+            match FT.to_list args with
+            | [ expr1 ] -> Ukanren.nat expr1
+            | _ ->
+                Logger.unreachable loc
+                  "Mismatch between arity and length of elements in builtin \
+                   'nat'";
+                exit 1)
+          else
+            let path, { content = fun_name; _ } = name in
+            match FT.head path with
+            | None ->
+                Builder.call (Builder.atom @@ Ast.Expr.extract_func_label call)
+                @@ FT.to_list args
+            | Some head ->
+                Builder.call_with_module
+                  (Builder.atom
+                  @@ flat_module_name
+                       (let suffix =
+                          FT.to_list @@ FT.map Location.strip_loc path
+                        in
+                        if BatSet.String.mem head.content imports then suffix
+                        else module_name :: suffix))
+                  (Builder.atom fun_name) (FT.to_list args)
         in
 
-        content.body |> List.map make_function |> Ukanren.conj
+        content.body |> FT.map make_function |> FT.to_list |> Ukanren.conj
       in
       Set.fold call_with_fresh vars body
     in
-    clauses |> List.map compile_single_body |> Ukanren.disj
+    clauses |> FT.map compile_single_body |> FT.to_list |> Ukanren.disj
 
 let compile_multi
     (({ name; arity }, first_clause, remaining_clauses) :
       Ast.head
       * Ast.Clause.decl Location.with_location
-      * Ast.Clause.decl Location.with_location list)
+      * Ast.Clause.decl Location.with_location FT.t)
     ({ env; _ } as compiler : unit t) : unit t =
   let declaration =
     let args =
@@ -98,7 +103,8 @@ let compile_multi
     in
     Beam.Builder.single_function_declaration name
       (List.map (fun v -> Beam.Builder.Pattern.Variable v) args)
-    @@ compile_declaration_bodies compiler (first_clause :: remaining_clauses)
+    @@ compile_declaration_bodies compiler
+         (FT.cons remaining_clauses first_clause)
   in
   let export = Beam.Builder.Attribute.export [ (name, arity) ] in
   {

lib/compiler/Declaration.mli

@@ -5,6 +5,6 @@ val call_with_fresh : string -> Builder.Expr.t -> Builder.Expr.t
 val compile_multi :
   Ast.head
   * Ast.Clause.decl Location.with_location
-  * Ast.Clause.decl Location.with_location list ->
+  * Ast.Clause.decl Location.with_location FT.t ->
   unit Types.t ->
   unit Types.t

lib/compiler/Lookup.ml

@@ -20,12 +20,12 @@ let (signature_select : signature selector) = function
       `UnexpectedSignature sig_loc
 
 let rec lookup_mod_sig (envs : 'a env BatLazyList.t)
-    (names : string Location.with_location list) (select : 'a selector) =
-  let rec lookup_mod_sig_qualified (rest : string Location.with_location list)
+    (names : string Location.with_location FT.t) (select : 'a selector) =
+  let rec lookup_mod_sig_qualified (rest : string Location.with_location FT.t)
       (value : 'a Location.with_location) =
-    match rest with
-    | [] -> `Ok value
-    | qualifier :: more -> (
+    match FT.front rest with
+    | None -> `Ok value
+    | Some (more, qualifier) -> (
         match select value with
         | `NestedLookup modules -> (
             match BatMap.String.find_opt qualifier.content modules with
@@ -39,11 +39,11 @@ let rec lookup_mod_sig (envs : 'a env BatLazyList.t)
             Logger.error sig_loc "Reference is here";
             unexpected)
   in
-  match names with
-  | [] ->
+  match FT.front names with
+  | None ->
       Logger.simply_unreachable "There should be names in lookup_mod_sig";
       exit 1
-  | first :: rest -> (
+  | Some (rest, first) -> (
       match Lazy.force envs with
       | BatLazyList.Cons (env, parent) -> (
           match BatMap.String.find_opt first.content env with
@@ -87,9 +87,7 @@ let ancestors_of_compiler (compiler : t) : scope =
 let signature (scope : scope)
     ((qualifiers, unqualified_name) : Ast.Expr.func_label) =
   match
-    lookup_mod_sig scope
-      (List.append qualifiers [ unqualified_name ])
-      comptime_select
+    lookup_mod_sig scope (FT.snoc qualifiers unqualified_name) comptime_select
   with
   | `Ok { content = Module m; loc } ->
       Logger.error unqualified_name.loc "Found module instead of signature";
@@ -101,9 +99,7 @@ let signature (scope : scope)
 let m0dule (scope : scope)
     ((qualifiers, unqualified_name) : Ast.Expr.func_label) =
   match
-    lookup_mod_sig scope
-      (List.append qualifiers [ unqualified_name ])
-      comptime_select
+    lookup_mod_sig scope (FT.snoc qualifiers unqualified_name) comptime_select
   with
   | `Ok { content = Module module'; loc } -> `Ok (Location.add_loc module' loc)
   | `Ok { content = Signature _; loc } ->
@@ -117,7 +113,7 @@ let nested_signature (compiled_signatures : sig_scope) (scope : scope)
     ((qualifiers, unqualified_name) as names : Ast.Expr.func_label) =
   match
     lookup_mod_sig compiled_signatures
-      (List.append qualifiers [ unqualified_name ])
+      (FT.snoc qualifiers unqualified_name)
       signature_select
   with
   | `Ok _ as ok -> ok

lib/compiler/Types.ml

@@ -1,5 +1,4 @@
 module Form = Beam.Core.Form (Beam.Core.Erlang)
-module FT = BatFingerTree
 module Set = BatSet
 
 type predicate_name = Ast.head [@@deriving show, ord]