Fix #1529

CHANGES.md

@@ -11,6 +11,9 @@ next
 - Add `binaries` field to the `(env ..)` stanza. This field sets and overrides
   binaries for rules defined in a directory. (#1521, @rgrinberg)
 
+- Fix a crash caused by using an extension in a project without
+  dune-project file (#...., fix #1529, @diml)
+
 1.5.1 (7/11/2018)
 -----------------
 

src/dune_project.ml

@@ -6,12 +6,6 @@ module Kind = struct
   type t =
     | Dune
     | Jbuilder
-
-  let to_sexp t =
-    Sexp.Atom
-      (match t with
-       | Dune -> "dune"
-       | Jbuilder -> "jbuilder")
 end
 
 module Name : sig
@@ -141,8 +135,7 @@ module Project_file = struct
 end
 
 type t =
-  { kind            : Kind.t
-  ; name            : Name.t
+  { name            : Name.t
   ; root            : Path.Local.t
   ; version         : string option
   ; packages        : Package.t Package.Name.Map.t
@@ -308,23 +301,70 @@ module Extension = struct
         acc)
 end
 
-let make_parsing_context ~(lang : Lang.Instance.t) ~extensions =
-  let acc = Univ_map.singleton (Syntax.key lang.syntax) lang.version in
-  List.fold_left extensions ~init:acc
-    ~f:(fun acc ((ext : Extension.instance), _) ->
-      Univ_map.add acc (Syntax.key (Extension.syntax ext.extension)) ext.version)
+let interpret_lang_and_extensions ~(lang : Lang.Instance.t)
+      ~explicit_extensions ~project_file =
+  match
+    String.Map.of_list
+      (List.map explicit_extensions ~f:(fun (e : Extension.instance) ->
+           (Syntax.name (Extension.syntax e.extension), e.loc)))
+  with
+  | Error (name, _, loc) ->
+     Errors.fail loc "Extension %S specified for the second time." name
+  | Ok map ->
+     let implicit_extensions =
+       Extension.automatic ~project_file
+         ~f:(fun name -> not (String.Map.mem map name))
+     in
+     let extensions =
+       List.map ~f:(fun e -> (e, true)) explicit_extensions @
+       List.map ~f:(fun e -> (e, false)) implicit_extensions
+     in
+     let acc = Univ_map.singleton (Syntax.key lang.syntax) lang.version in
+     let parsing_context =
+       List.fold_left extensions ~init:acc
+         ~f:(fun acc ((ext : Extension.instance), _) ->
+           Univ_map.add acc (Syntax.key (Extension.syntax ext.extension))
+             ext.version)
+     in
+     let extension_args, extension_stanzas =
+       List.fold_left
+         extensions
+         ~init:(Univ_map.empty, [])
+         ~f:(fun (args_acc, stanzas_acc)
+              ((instance : Extension.instance), is_explicit) ->
+              let extension = instance.extension in
+              let Extension.Extension e = extension in
+              let args =
+                let%map (arg, stanzas) =
+                  Dune_lang.Decoder.set_many parsing_context e.stanzas
+                in
+                let new_args_acc =
+                  if is_explicit then
+                    Univ_map.add args_acc e.key arg
+                  else
+                    args_acc
+                in
+                (new_args_acc, stanzas)
+              in
+              let (new_args_acc, stanzas) = instance.parse_args args in
+              (new_args_acc, stanzas::stanzas_acc))
+     in
+     let stanzas = List.concat (lang.data :: extension_stanzas) in
+     let stanza_parser =
+       Dune_lang.Decoder.(set_many parsing_context (sum stanzas))
+     in
+     (parsing_context, stanza_parser, extension_args)
 
 let key =
   Univ_map.Key.create ~name:"dune-project"
-    (fun { name; root; version; project_file; kind
+    (fun { name; root; version; project_file
          ; stanza_parser = _; packages = _ ; extension_args = _
          ; parsing_context } ->
       Sexp.Encoder.record
         [ "name", Name.to_sexp name
         ; "root", Path.Local.to_sexp root
         ; "version", Sexp.Encoder.(option string) version
         ; "project_file", Project_file.to_sexp project_file
-        ; "kind", Kind.to_sexp kind
         ; "parsing_context", Univ_map.to_sexp parsing_context
         ])
 
@@ -345,16 +385,19 @@ let get_local_path p =
 
 let anonymous = lazy (
   let lang = Lang.get_exn "dune" in
-  let parsing_context = make_parsing_context ~lang ~extensions:[] in
-  { kind          = Dune
-  ; name          = Name.anonymous_root
+  let project_file =
+    { Project_file.file = Path.relative Path.root filename; exists = false }
+  in
+  let parsing_context, stanza_parser, extension_args =
+    interpret_lang_and_extensions ~lang ~explicit_extensions:[] ~project_file
+  in
+  { name          = Name.anonymous_root
   ; packages      = Package.Name.Map.empty
   ; root          = get_local_path Path.root
   ; version       = None
-  ; stanza_parser =
-      Dune_lang.Decoder.(set_many parsing_context (sum lang.data))
-  ; project_file  = { file = Path.relative Path.root filename; exists = false }
-  ; extension_args = Univ_map.empty
+  ; stanza_parser
+  ; project_file
+  ; extension_args
   ; parsing_context
   })
 
@@ -400,72 +443,39 @@ let parse ~dir ~lang ~packages ~file =
           Extension.instantiate ~loc ~parse_args name ver)
      and () = Versioned_file.no_more_lang
      in
-     match
-       String.Map.of_list
-         (List.map explicit_extensions ~f:(fun (e : Extension.instance) ->
-            (Syntax.name (Extension.syntax e.extension), e.loc)))
-     with
-     | Error (name, _, loc) ->
-       Errors.fail loc "Extension %S specified for the second time." name
-     | Ok map ->
-       let project_file : Project_file.t = { file; exists = true } in
-       let implicit_extensions =
-         Extension.automatic ~project_file
-           ~f:(fun name -> not (String.Map.mem map name))
-       in
-       let extensions =
-         List.map ~f:(fun e -> (e, true)) explicit_extensions @
-         List.map ~f:(fun e -> (e, false)) implicit_extensions
-       in
-       let parsing_context = make_parsing_context ~lang ~extensions in
-       let extension_args, extension_stanzas =
-         List.fold_left
-           extensions
-           ~init:(Univ_map.empty, [])
-           ~f:(fun (args_acc, stanzas_acc) ((instance : Extension.instance), is_explicit) ->
-             let extension = instance.extension in
-             let Extension.Extension e = extension in
-             let args =
-               let%map (arg, stanzas) = Dune_lang.Decoder.set_many parsing_context e.stanzas in
-               let new_args_acc =
-                 if is_explicit then
-                   Univ_map.add args_acc e.key arg
-                 else
-                   args_acc
-               in
-               (new_args_acc, stanzas)
-             in
-             let (new_args_acc, stanzas) = instance.parse_args args in
-             (new_args_acc, stanzas::stanzas_acc))
-       in
-       let stanzas = List.concat (lang.data :: extension_stanzas) in
-       { kind = Dune
-       ; name
-       ; root = get_local_path dir
-       ; version
-       ; packages
-       ; stanza_parser = Dune_lang.Decoder.(set_many parsing_context (sum stanzas))
-       ; project_file
-       ; extension_args
-       ; parsing_context
-       })
+     let project_file : Project_file.t = { file; exists = true } in
+     let parsing_context, stanza_parser, extension_args =
+       interpret_lang_and_extensions ~lang ~explicit_extensions ~project_file
+     in
+     { name
+     ; root = get_local_path dir
+     ; version
+     ; packages
+     ; stanza_parser
+     ; project_file
+     ; extension_args
+     ; parsing_context
+     })
 
 let load_dune_project ~dir packages =
   let file = Path.relative dir filename in
   load file ~f:(fun lang -> parse ~dir ~lang ~packages ~file)
 
 let make_jbuilder_project ~dir packages =
   let lang = Lang.get_exn "dune" in
-  let parsing_context = make_parsing_context ~lang ~extensions:[] in
-  { kind = Jbuilder
-  ; name = default_name ~dir ~packages
+  let project_file =
+    { Project_file.file = Path.relative dir filename; exists = false }
+  in
+  let parsing_context, stanza_parser, extension_args =
+    interpret_lang_and_extensions ~lang ~explicit_extensions:[] ~project_file
+  in
+  { name = default_name ~dir ~packages
   ; root = get_local_path dir
   ; version = None
   ; packages
-  ; stanza_parser =
-      Dune_lang.Decoder.(set_many parsing_context (sum lang.data))
-  ; project_file = { file = Path.relative dir filename; exists = false }
-  ; extension_args = Univ_map.empty
+  ; stanza_parser
+  ; project_file
+  ; extension_args
   ; parsing_context
   }
 

test/blackbox-tests/dune.inc

@@ -407,6 +407,14 @@
    test-cases/github1395
    (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))
 
+(alias
+ (name github1529)
+ (deps (package dune) (source_tree test-cases/github1529))
+ (action
+  (chdir
+   test-cases/github1529
+   (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))
+
 (alias
  (name github20)
  (deps (package dune) (source_tree test-cases/github20))
@@ -1155,6 +1163,7 @@
   (alias github1342)
   (alias github1372)
   (alias github1395)
+  (alias github1529)
   (alias github20)
   (alias github24)
   (alias github25)
@@ -1290,6 +1299,7 @@
   (alias github1342)
   (alias github1372)
   (alias github1395)
+  (alias github1529)
   (alias github20)
   (alias github24)
   (alias github25)

test/blackbox-tests/test-cases/github1529/dune

@@ -0,0 +1,2 @@
+(menhir (modules parser))
+(library (name foo))

test/blackbox-tests/test-cases/github1529/run.t

@@ -0,0 +1,6 @@
+Reproduction case for #1529: using an extension when no dune-project
+file is present.
+
+  $ dune build
+  Info: creating file dune-project with this contents: (lang dune 1.6)
+  Info: appending this line to dune-project: (using menhir 2.0)