From 58521e6066974833bb83e98a6bb17feb0c1fee90 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 21 Mar 2015 09:45:57 +0100 Subject: Do not revert parameter lists when extracting singleton types to Haskell. (Fix for bugs #3470 and #3694) --- plugins/extraction/haskell.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'plugins') diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 5e08fef5fe..d8eda87d60 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -243,12 +243,12 @@ let pp_logical_ind packet = prvect_with_sep spc pr_id packet.ip_consnames) let pp_singleton kn packet = + let name = pp_global Type (IndRef (kn,0)) in let l = rename_tvars keywords packet.ip_vars in - let l' = List.rev l in - hov 2 (str "type " ++ pp_global Type (IndRef (kn,0)) ++ spc () ++ + hov 2 (str "type " ++ name ++ spc () ++ prlist_with_sep spc pr_id l ++ (if not (List.is_empty l) then str " " else mt ()) ++ str "=" ++ spc () ++ - pp_type false l' (List.hd packet.ip_types.(0)) ++ fnl () ++ + pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ pp_comment (str "singleton inductive, whose constructor was " ++ pr_id packet.ip_consnames.(0))) -- cgit v1.2.3 From 21771adc7454ae186823b3f30d43c2fb80d70fc2 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 21 Mar 2015 13:54:46 +0100 Subject: Properly capitalize filenames when extracting to Haskell. (Fix for bug #3221) --- plugins/extraction/extract_env.ml | 3 ++- plugins/extraction/haskell.ml | 1 + plugins/extraction/miniml.mli | 1 + plugins/extraction/ocaml.ml | 1 + plugins/extraction/scheme.ml | 1 + 5 files changed, 6 insertions(+), 1 deletion(-) (limited to 'plugins') diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 90ee6d0ef1..5ea4fb763e 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -440,7 +440,8 @@ let mono_filename f = let module_filename mp = let f = file_of_modfile mp in let d = descr () in - Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, Id.of_string f + let p = d.file_naming mp ^ d.file_suffix in + Some p, Option.map ((^) f) d.sig_suffix, Id.of_string f (*s Extraction of one decl to stdout. *) diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index d8eda87d60..3e5a90efed 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -360,6 +360,7 @@ let pp_struct = let haskell_descr = { keywords = keywords; file_suffix = ".hs"; + file_naming = string_of_modfile; preamble = preamble; pp_struct = pp_struct; sig_suffix = None; diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index 1e491d36f7..b7dee6cb14 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -197,6 +197,7 @@ type language_descr = { (* Concerning the source file *) file_suffix : string; + file_naming : module_path -> string; (* the second argument is a comment to add to the preamble *) preamble : Id.t -> std_ppcmds option -> module_path list -> unsafe_needs -> diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 85f18a0933..8c482b4b1d 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -746,6 +746,7 @@ let pp_decl d = try pp_decl d with Failure "empty phrase" -> mt () let ocaml_descr = { keywords = keywords; file_suffix = ".ml"; + file_naming = file_of_modfile; preamble = preamble; pp_struct = pp_struct; sig_suffix = Some ".mli"; diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index 69dea25aac..99b4fd448d 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -225,6 +225,7 @@ let pp_struct = let scheme_descr = { keywords = keywords; file_suffix = ".scm"; + file_naming = file_of_modfile; preamble = preamble; pp_struct = pp_struct; sig_suffix = None; -- cgit v1.2.3 From 84c2433aef0b3c2d3b8a9106d8c4f0e02891f4ed Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 21 Mar 2015 14:23:35 +0100 Subject: Avoid segfault from code extracted to ghc. (Fix for bug #1257) --- plugins/extraction/haskell.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'plugins') diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 3e5a90efed..52459f78eb 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -26,7 +26,7 @@ let pr_upper_id id = str (String.capitalize (Id.to_string id)) let keywords = List.fold_right (fun s -> Id.Set.add (Id.of_string s)) - [ "case"; "class"; "data"; "default"; "deriving"; "do"; "else"; + [ "Any"; "case"; "class"; "data"; "default"; "deriving"; "do"; "else"; "if"; "import"; "in"; "infix"; "infixl"; "infixr"; "instance"; "let"; "module"; "newtype"; "of"; "then"; "type"; "where"; "_"; "__"; "as"; "qualified"; "hiding" ; "unit" ; "unsafeCoerce" ] @@ -56,11 +56,14 @@ let preamble mod_name comment used_modules usf = else str "\ \n#ifdef __GLASGOW_HASKELL__\ \nimport qualified GHC.Base\ +\nimport qualified GHC.Prim\ +\ntype Any = GHC.Prim.Any\ \nunsafeCoerce :: a -> b\ \nunsafeCoerce = GHC.Base.unsafeCoerce#\ \n#else\ \n-- HUGS\ \nimport qualified IOExts\ +\ntype Any = ()\ \nunsafeCoerce :: a -> b\ \nunsafeCoerce = IOExts.unsafeCoerce\ \n#endif" ++ fnl2 ()) @@ -102,7 +105,7 @@ let rec pp_type par vl t = pp_par par (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) | Tdummy _ -> str "()" - | Tunknown -> str "()" + | Tunknown -> str "Any" | Taxiom -> str "() -- AXIOM TO BE REALIZED\n" in hov 0 (pp_rec par t) -- cgit v1.2.3