src/Tools/Code/code_haskell.ML
author haftmann
Thu Sep 02 13:43:38 2010 +0200 (2010-09-02)
changeset 39055 81e0368812ad
parent 39034 ebeb48fd653b
child 39056 fa197571676b
permissions -rw-r--r--
removed namespace stuff from code_printer
     1 (*  Title:      Tools/Code/code_haskell.ML
     2     Author:     Florian Haftmann, TU Muenchen
     3 
     4 Serializer for Haskell.
     5 *)
     6 
     7 signature CODE_HASKELL =
     8 sig
     9   val target: string
    10   val setup: theory -> theory
    11 end;
    12 
    13 structure Code_Haskell : CODE_HASKELL =
    14 struct
    15 
    16 val target = "Haskell";
    17 
    18 open Basic_Code_Thingol;
    19 open Code_Printer;
    20 
    21 infixr 5 @@;
    22 infixr 5 @|;
    23 
    24 
    25 (** Haskell serializer **)
    26 
    27 fun print_haskell_stmt labelled_name class_syntax tyco_syntax const_syntax
    28     reserved deresolve contr_classparam_typs deriving_show =
    29   let
    30     val deresolve_base = Long_Name.base_name o deresolve;
    31     fun class_name class = case class_syntax class
    32      of NONE => deresolve class
    33       | SOME class => class;
    34     fun print_typcontext tyvars vs = case maps (fn (v, sort) => map (pair v) sort) vs
    35      of [] => []
    36       | constraints => enum "," "(" ")" (
    37           map (fn (v, class) =>
    38             str (class_name class ^ " " ^ lookup_var tyvars v)) constraints)
    39           @@ str " => ";
    40     fun print_typforall tyvars vs = case map fst vs
    41      of [] => []
    42       | vnames => str "forall " :: Pretty.breaks
    43           (map (str o lookup_var tyvars) vnames) @ str "." @@ Pretty.brk 1;
    44     fun print_tyco_expr tyvars fxy (tyco, tys) =
    45       brackify fxy (str tyco :: map (print_typ tyvars BR) tys)
    46     and print_typ tyvars fxy (tycoexpr as tyco `%% tys) = (case tyco_syntax tyco
    47          of NONE => print_tyco_expr tyvars fxy (deresolve tyco, tys)
    48           | SOME (i, print) => print (print_typ tyvars) fxy tys)
    49       | print_typ tyvars fxy (ITyVar v) = (str o lookup_var tyvars) v;
    50     fun print_typdecl tyvars (vs, tycoexpr) =
    51       Pretty.block (print_typcontext tyvars vs @| print_tyco_expr tyvars NOBR tycoexpr);
    52     fun print_typscheme tyvars (vs, ty) =
    53       Pretty.block (print_typforall tyvars vs @ print_typcontext tyvars vs @| print_typ tyvars NOBR ty);
    54     fun print_term tyvars some_thm vars fxy (IConst c) =
    55           print_app tyvars some_thm vars fxy (c, [])
    56       | print_term tyvars some_thm vars fxy (t as (t1 `$ t2)) =
    57           (case Code_Thingol.unfold_const_app t
    58            of SOME app => print_app tyvars some_thm vars fxy app
    59             | _ =>
    60                 brackify fxy [
    61                   print_term tyvars some_thm vars NOBR t1,
    62                   print_term tyvars some_thm vars BR t2
    63                 ])
    64       | print_term tyvars some_thm vars fxy (IVar NONE) =
    65           str "_"
    66       | print_term tyvars some_thm vars fxy (IVar (SOME v)) =
    67           (str o lookup_var vars) v
    68       | print_term tyvars some_thm vars fxy (t as _ `|=> _) =
    69           let
    70             val (binds, t') = Code_Thingol.unfold_pat_abs t;
    71             val (ps, vars') = fold_map (print_bind tyvars some_thm BR o fst) binds vars;
    72           in brackets (str "\\" :: ps @ str "->" @@ print_term tyvars some_thm vars' NOBR t') end
    73       | print_term tyvars some_thm vars fxy (ICase (cases as (_, t0))) =
    74           (case Code_Thingol.unfold_const_app t0
    75            of SOME (c_ts as ((c, _), _)) => if is_none (const_syntax c)
    76                 then print_case tyvars some_thm vars fxy cases
    77                 else print_app tyvars some_thm vars fxy c_ts
    78             | NONE => print_case tyvars some_thm vars fxy cases)
    79     and print_app_expr tyvars some_thm vars ((c, (_, function_typs)), ts) = case contr_classparam_typs c
    80      of [] => (str o deresolve) c :: map (print_term tyvars some_thm vars BR) ts
    81       | fingerprint => let
    82           val ts_fingerprint = ts ~~ take (length ts) fingerprint;
    83           val needs_annotation = forall (fn (_, NONE) => true | (t, SOME _) =>
    84             (not o Code_Thingol.locally_monomorphic) t) ts_fingerprint;
    85           fun print_term_anno (t, NONE) _ = print_term tyvars some_thm vars BR t
    86             | print_term_anno (t, SOME _) ty =
    87                 brackets [print_term tyvars some_thm vars NOBR t, str "::", print_typ tyvars NOBR ty];
    88         in
    89           if needs_annotation then
    90             (str o deresolve) c :: map2 print_term_anno ts_fingerprint (take (length ts) function_typs)
    91           else (str o deresolve) c :: map (print_term tyvars some_thm vars BR) ts
    92         end
    93     and print_app tyvars = gen_print_app (print_app_expr tyvars) (print_term tyvars) const_syntax
    94     and print_bind tyvars some_thm fxy p = gen_print_bind (print_term tyvars) some_thm fxy p
    95     and print_case tyvars some_thm vars fxy (cases as ((_, [_]), _)) =
    96           let
    97             val (binds, body) = Code_Thingol.unfold_let (ICase cases);
    98             fun print_match ((pat, ty), t) vars =
    99               vars
   100               |> print_bind tyvars some_thm BR pat
   101               |>> (fn p => semicolon [p, str "=", print_term tyvars some_thm vars NOBR t])
   102             val (ps, vars') = fold_map print_match binds vars;
   103           in brackify_block fxy (str "let {")
   104             ps
   105             (concat [str "}", str "in", print_term tyvars some_thm vars' NOBR body])
   106           end
   107       | print_case tyvars some_thm vars fxy (((t, ty), clauses as _ :: _), _) =
   108           let
   109             fun print_select (pat, body) =
   110               let
   111                 val (p, vars') = print_bind tyvars some_thm NOBR pat vars;
   112               in semicolon [p, str "->", print_term tyvars some_thm vars' NOBR body] end;
   113           in Pretty.block_enclose
   114             (concat [str "(case", print_term tyvars some_thm vars NOBR t, str "of", str "{"], str "})")
   115             (map print_select clauses)
   116           end
   117       | print_case tyvars some_thm vars fxy ((_, []), _) =
   118           (brackify fxy o Pretty.breaks o map str) ["error", "\"empty case\""];
   119     fun print_stmt (name, Code_Thingol.Fun (_, (((vs, ty), raw_eqs), _))) =
   120           let
   121             val tyvars = intro_vars (map fst vs) reserved;
   122             fun print_err n =
   123               semicolon (
   124                 (str o deresolve_base) name
   125                 :: map str (replicate n "_")
   126                 @ str "="
   127                 :: str "error"
   128                 @@ (str o ML_Syntax.print_string
   129                     o Long_Name.base_name o Long_Name.qualifier) name
   130               );
   131             fun print_eqn ((ts, t), (some_thm, _)) =
   132               let
   133                 val consts = fold Code_Thingol.add_constnames (t :: ts) [];
   134                 val vars = reserved
   135                   |> intro_base_names
   136                       (is_none o const_syntax) deresolve consts
   137                   |> intro_vars ((fold o Code_Thingol.fold_varnames)
   138                       (insert (op =)) ts []);
   139               in
   140                 semicolon (
   141                   (str o deresolve_base) name
   142                   :: map (print_term tyvars some_thm vars BR) ts
   143                   @ str "="
   144                   @@ print_term tyvars some_thm vars NOBR t
   145                 )
   146               end;
   147           in
   148             Pretty.chunks (
   149               semicolon [
   150                 (str o suffix " ::" o deresolve_base) name,
   151                 print_typscheme tyvars (vs, ty)
   152               ]
   153               :: (case filter (snd o snd) raw_eqs
   154                of [] => [print_err ((length o fst o Code_Thingol.unfold_fun) ty)]
   155                 | eqs => map print_eqn eqs)
   156             )
   157           end
   158       | print_stmt (name, Code_Thingol.Datatype (_, (vs, []))) =
   159           let
   160             val tyvars = intro_vars (map fst vs) reserved;
   161           in
   162             semicolon [
   163               str "data",
   164               print_typdecl tyvars (vs, (deresolve_base name, map (ITyVar o fst) vs))
   165             ]
   166           end
   167       | print_stmt (name, Code_Thingol.Datatype (_, (vs, [((co, _), [ty])]))) =
   168           let
   169             val tyvars = intro_vars (map fst vs) reserved;
   170           in
   171             semicolon (
   172               str "newtype"
   173               :: print_typdecl tyvars (vs, (deresolve_base name, map (ITyVar o fst) vs))
   174               :: str "="
   175               :: (str o deresolve_base) co
   176               :: print_typ tyvars BR ty
   177               :: (if deriving_show name then [str "deriving (Read, Show)"] else [])
   178             )
   179           end
   180       | print_stmt (name, Code_Thingol.Datatype (_, (vs, co :: cos))) =
   181           let
   182             val tyvars = intro_vars (map fst vs) reserved;
   183             fun print_co ((co, _), tys) =
   184               concat (
   185                 (str o deresolve_base) co
   186                 :: map (print_typ tyvars BR) tys
   187               )
   188           in
   189             semicolon (
   190               str "data"
   191               :: print_typdecl tyvars (vs, (deresolve_base name, map (ITyVar o fst) vs))
   192               :: str "="
   193               :: print_co co
   194               :: map ((fn p => Pretty.block [str "| ", p]) o print_co) cos
   195               @ (if deriving_show name then [str "deriving (Read, Show)"] else [])
   196             )
   197           end
   198       | print_stmt (name, Code_Thingol.Class (_, (v, (super_classes, classparams)))) =
   199           let
   200             val tyvars = intro_vars [v] reserved;
   201             fun print_classparam (classparam, ty) =
   202               semicolon [
   203                 (str o deresolve_base) classparam,
   204                 str "::",
   205                 print_typ tyvars NOBR ty
   206               ]
   207           in
   208             Pretty.block_enclose (
   209               Pretty.block [
   210                 str "class ",
   211                 Pretty.block (print_typcontext tyvars [(v, map fst super_classes)]),
   212                 str (deresolve_base name ^ " " ^ lookup_var tyvars v),
   213                 str " where {"
   214               ],
   215               str "};"
   216             ) (map print_classparam classparams)
   217           end
   218       | print_stmt (_, Code_Thingol.Classinst ((class, (tyco, vs)), (_, (classparam_instances, _)))) =
   219           let
   220             val tyvars = intro_vars (map fst vs) reserved;
   221             fun requires_args classparam = case const_syntax classparam
   222              of NONE => 0
   223               | SOME (Code_Printer.Plain_const_syntax _) => 0
   224               | SOME (Code_Printer.Complex_const_syntax (k,_ )) => k;
   225             fun print_classparam_instance ((classparam, const), (thm, _)) =
   226               case requires_args classparam
   227                of 0 => semicolon [
   228                       (str o deresolve_base) classparam,
   229                       str "=",
   230                       print_app tyvars (SOME thm) reserved NOBR (const, [])
   231                     ]
   232                 | k =>
   233                     let
   234                       val (c, (_, tys)) = const;
   235                       val (vs, rhs) = (apfst o map) fst
   236                         (Code_Thingol.unfold_abs (Code_Thingol.eta_expand k (const, [])));
   237                       val s = if (is_some o const_syntax) c
   238                         then NONE else (SOME o Long_Name.base_name o deresolve) c;
   239                       val vars = reserved
   240                         |> intro_vars (map_filter I (s :: vs));
   241                       val lhs = IConst (classparam, (([], []), tys)) `$$ map IVar vs;
   242                         (*dictionaries are not relevant at this late stage*)
   243                     in
   244                       semicolon [
   245                         print_term tyvars (SOME thm) vars NOBR lhs,
   246                         str "=",
   247                         print_term tyvars (SOME thm) vars NOBR rhs
   248                       ]
   249                     end;
   250           in
   251             Pretty.block_enclose (
   252               Pretty.block [
   253                 str "instance ",
   254                 Pretty.block (print_typcontext tyvars vs),
   255                 str (class_name class ^ " "),
   256                 print_typ tyvars BR (tyco `%% map (ITyVar o fst) vs),
   257                 str " where {"
   258               ],
   259               str "};"
   260             ) (map print_classparam_instance classparam_instances)
   261           end;
   262   in print_stmt end;
   263 
   264 fun mk_name_module reserved module_prefix module_alias program =
   265   let
   266     fun mk_alias name = case module_alias name
   267      of SOME name' => name'
   268       | NONE => name
   269           |> Long_Name.explode
   270           |> map (fn name => (the_single o fst) (Name.variants [name] reserved))
   271           |> Long_Name.implode;
   272     fun mk_prefix name = case module_prefix
   273      of SOME module_prefix => Long_Name.append module_prefix name
   274       | NONE => name;
   275     val tab =
   276       Symtab.empty
   277       |> Graph.fold ((fn name => Symtab.default (name, (mk_alias #> mk_prefix) name))
   278            o fst o Code_Namespace.dest_name o fst)
   279              program
   280   in the o Symtab.lookup tab end;
   281 
   282 fun haskell_program_of_program labelled_name module_prefix reserved module_alias program =
   283   let
   284     val reserved = Name.make_context reserved;
   285     val mk_name_module = mk_name_module reserved module_prefix module_alias program;
   286     fun add_stmt (name, (stmt, deps)) =
   287       let
   288         val (module_name, base) = Code_Namespace.dest_name name;
   289         val module_name' = mk_name_module module_name;
   290         val mk_name_stmt = yield_singleton Name.variants;
   291         fun add_fun upper (nsp_fun, nsp_typ) =
   292           let
   293             val (base', nsp_fun') =
   294               mk_name_stmt (if upper then first_upper base else base) nsp_fun
   295           in (base', (nsp_fun', nsp_typ)) end;
   296         fun add_typ (nsp_fun, nsp_typ) =
   297           let
   298             val (base', nsp_typ') = mk_name_stmt (first_upper base) nsp_typ
   299           in (base', (nsp_fun, nsp_typ')) end;
   300         val add_name = case stmt
   301          of Code_Thingol.Fun (_, (_, SOME _)) => pair base
   302           | Code_Thingol.Fun _ => add_fun false
   303           | Code_Thingol.Datatype _ => add_typ
   304           | Code_Thingol.Datatypecons _ => add_fun true
   305           | Code_Thingol.Class _ => add_typ
   306           | Code_Thingol.Classrel _ => pair base
   307           | Code_Thingol.Classparam _ => add_fun false
   308           | Code_Thingol.Classinst _ => pair base;
   309         fun add_stmt' base' = case stmt
   310          of Code_Thingol.Fun (_, (_, SOME _)) =>
   311               I
   312           | Code_Thingol.Datatypecons _ =>
   313               cons (name, (Long_Name.append module_name' base', NONE))
   314           | Code_Thingol.Classrel _ => I
   315           | Code_Thingol.Classparam _ =>
   316               cons (name, (Long_Name.append module_name' base', NONE))
   317           | _ => cons (name, (Long_Name.append module_name' base', SOME stmt));
   318       in
   319         Symtab.map_default (module_name', ([], ([], (reserved, reserved))))
   320               (apfst (fold (insert (op = : string * string -> bool)) deps))
   321         #> `(fn program => add_name ((snd o snd o the o Symtab.lookup program) module_name'))
   322         #-> (fn (base', names) =>
   323               (Symtab.map_entry module_name' o apsnd) (fn (stmts, _) =>
   324               (add_stmt' base' stmts, names)))
   325       end;
   326     val hs_program = fold add_stmt (AList.make (fn name =>
   327       (Graph.get_node program name, Graph.imm_succs program name))
   328       (Graph.strong_conn program |> flat)) Symtab.empty;
   329     fun deresolver name = (fst o the o AList.lookup (op =) ((fst o snd o the
   330       o Symtab.lookup hs_program) ((mk_name_module o fst o Code_Namespace.dest_name) name))) name
   331       handle Option => error ("Unknown statement name: " ^ labelled_name name);
   332   in (deresolver, hs_program) end;
   333 
   334 fun serialize_haskell module_prefix string_classes { labelled_name,
   335     reserved_syms, includes, module_alias,
   336     class_syntax, tyco_syntax, const_syntax, program,
   337     names, presentation_names } =
   338   let
   339     val reserved = fold (insert (op =) o fst) includes reserved_syms;
   340     val (deresolver, hs_program) = haskell_program_of_program labelled_name
   341       module_prefix reserved module_alias program;
   342     val contr_classparam_typs = Code_Thingol.contr_classparam_typs program;
   343     fun deriving_show tyco =
   344       let
   345         fun deriv _ "fun" = false
   346           | deriv tycos tyco = not (tyco = Code_Thingol.fun_tyco)
   347               andalso (member (op =) tycos tyco
   348               orelse case try (Graph.get_node program) tyco
   349                 of SOME (Code_Thingol.Datatype (_, (_, cs))) => forall (deriv' (tyco :: tycos))
   350                     (maps snd cs)
   351                  | NONE => true)
   352         and deriv' tycos (tyco `%% tys) = deriv tycos tyco
   353               andalso forall (deriv' tycos) tys
   354           | deriv' _ (ITyVar _) = true
   355       in deriv [] tyco end;
   356     val reserved = make_vars reserved;
   357     fun print_stmt qualified = print_haskell_stmt labelled_name
   358       class_syntax tyco_syntax const_syntax reserved
   359       (if qualified then deresolver else Long_Name.base_name o deresolver)
   360       contr_classparam_typs
   361       (if string_classes then deriving_show else K false);
   362     fun print_module name content =
   363       (name, Pretty.chunks2 [
   364         str ("module " ^ name ^ " where {"),
   365         content,
   366         str "}"
   367       ]);
   368     fun serialize_module1 (module_name', (deps, (stmts, _))) =
   369       let
   370         val stmt_names = map fst stmts;
   371         val qualified = null presentation_names;
   372         val imports = subtract (op =) stmt_names deps
   373           |> distinct (op =)
   374           |> map_filter (try deresolver)
   375           |> map Long_Name.qualifier
   376           |> distinct (op =);
   377         fun print_import_include (name, _) = str ("import qualified " ^ name ^ ";");
   378         fun print_import_module name = str ((if qualified
   379           then "import qualified "
   380           else "import ") ^ name ^ ";");
   381         val import_ps = map print_import_include includes @ map print_import_module imports
   382         val content = Pretty.chunks2 ((if null import_ps then [] else [Pretty.chunks import_ps])
   383             @ map_filter
   384               (fn (name, (_, SOME stmt)) => SOME (print_stmt qualified (name, stmt))
   385                 | (_, (_, NONE)) => NONE) stmts
   386           );
   387       in print_module module_name' content end;
   388     fun serialize_module2 (_, (_, (stmts, _))) = Pretty.chunks2 (map_filter
   389         (fn (name, (_, SOME stmt)) => if null presentation_names
   390               orelse member (op =) presentation_names name
   391               then SOME (print_stmt false (name, stmt))
   392               else NONE
   393           | (_, (_, NONE)) => NONE) stmts);
   394     val serialize_module =
   395       if null presentation_names then serialize_module1 else pair "" o serialize_module2;
   396     fun write_module width (SOME destination) (modlname, content) =
   397           let
   398             val _ = File.check destination;
   399             val filename = case modlname
   400              of "" => Path.explode "Main.hs"
   401               | _ => (Path.ext "hs" o Path.explode o implode o separate "/"
   402                     o Long_Name.explode) modlname;
   403             val pathname = Path.append destination filename;
   404             val _ = File.mkdir_leaf (Path.dir pathname);
   405           in File.write pathname
   406             ("{-# OPTIONS_GHC -fglasgow-exts #-}\n\n"
   407               ^ format false width content)
   408           end
   409       | write_module width NONE (_, content) = writeln (format false width content);
   410   in
   411     Code_Target.serialization
   412       (fn width => fn destination => K () o map (write_module width destination))
   413       (fn present => fn width => rpair [] o format present width o Pretty.chunks o map snd)
   414       (map (uncurry print_module) includes
   415         @ map serialize_module (Symtab.dest hs_program))
   416   end;
   417 
   418 val serializer : Code_Target.serializer =
   419   Code_Target.parse_args (Scan.option (Args.$$$ "root" -- Args.colon |-- Args.name)
   420     -- Scan.optional (Args.$$$ "string_classes" >> K true) false
   421     >> (fn (module_prefix, string_classes) =>
   422       serialize_haskell module_prefix string_classes));
   423 
   424 val literals = let
   425   fun char_haskell c =
   426     let
   427       val s = ML_Syntax.print_char c;
   428     in if s = "'" then "\\'" else s end;
   429   fun numeral_haskell k = if k >= 0 then string_of_int k
   430     else Library.enclose "(" ")" (signed_string_of_int k);
   431 in Literals {
   432   literal_char = Library.enclose "'" "'" o char_haskell,
   433   literal_string = quote o translate_string char_haskell,
   434   literal_numeral = numeral_haskell,
   435   literal_positive_numeral = numeral_haskell,
   436   literal_alternative_numeral = numeral_haskell,
   437   literal_naive_numeral = numeral_haskell,
   438   literal_list = enum "," "[" "]",
   439   infix_cons = (5, ":")
   440 } end;
   441 
   442 
   443 (** optional monad syntax **)
   444 
   445 fun pretty_haskell_monad c_bind =
   446   let
   447     fun dest_bind t1 t2 = case Code_Thingol.split_pat_abs t2
   448      of SOME ((pat, ty), t') =>
   449           SOME ((SOME ((pat, ty), true), t1), t')
   450       | NONE => NONE;
   451     fun dest_monad c_bind_name (IConst (c, _) `$ t1 `$ t2) =
   452           if c = c_bind_name then dest_bind t1 t2
   453           else NONE
   454       | dest_monad _ t = case Code_Thingol.split_let t
   455          of SOME (((pat, ty), tbind), t') =>
   456               SOME ((SOME ((pat, ty), false), tbind), t')
   457           | NONE => NONE;
   458     fun implode_monad c_bind_name = Code_Thingol.unfoldr (dest_monad c_bind_name);
   459     fun print_monad print_bind print_term (NONE, t) vars =
   460           (semicolon [print_term vars NOBR t], vars)
   461       | print_monad print_bind print_term (SOME ((bind, _), true), t) vars = vars
   462           |> print_bind NOBR bind
   463           |>> (fn p => semicolon [p, str "<-", print_term vars NOBR t])
   464       | print_monad print_bind print_term (SOME ((bind, _), false), t) vars = vars
   465           |> print_bind NOBR bind
   466           |>> (fn p => semicolon [str "let", str "{", p, str "=", print_term vars NOBR t, str "}"]);
   467     fun pretty _ [c_bind'] print_term thm vars fxy [(t1, _), (t2, _)] = case dest_bind t1 t2
   468      of SOME (bind, t') => let
   469           val (binds, t'') = implode_monad c_bind' t'
   470           val (ps, vars') = fold_map (print_monad (gen_print_bind (K print_term) thm) print_term)
   471             (bind :: binds) vars;
   472         in
   473           (brackify fxy o single o enclose "do { " " }" o Pretty.breaks)
   474             (ps @| print_term vars' NOBR t'')
   475         end
   476       | NONE => brackify_infix (1, L) fxy
   477           (print_term vars (INFX (1, L)) t1, str ">>=", print_term vars (INFX (1, X)) t2)
   478   in (2, ([c_bind], pretty)) end;
   479 
   480 fun add_monad target' raw_c_bind thy =
   481   let
   482     val c_bind = Code.read_const thy raw_c_bind;
   483   in if target = target' then
   484     thy
   485     |> Code_Target.add_const_syntax target c_bind
   486         (SOME (Code_Printer.complex_const_syntax (pretty_haskell_monad c_bind)))
   487   else error "Only Haskell target allows for monad syntax" end;
   488 
   489 
   490 (** Isar setup **)
   491 
   492 val _ =
   493   Outer_Syntax.command "code_monad" "define code syntax for monads" Keyword.thy_decl (
   494     Parse.term_group -- Parse.name >> (fn (raw_bind, target) =>
   495       Toplevel.theory  (add_monad target raw_bind))
   496   );
   497 
   498 val setup =
   499   Code_Target.add_target
   500     (target, { serializer = serializer, literals = literals,
   501       check = { env_var = "EXEC_GHC", make_destination = I,
   502         make_command = fn ghc => fn module_name =>
   503           ghc ^ " -fglasgow-exts -odir build -hidir build -stubdir build -e \"\" " ^ module_name ^ ".hs" } })
   504   #> Code_Target.add_tyco_syntax target "fun" (SOME (2, fn print_typ => fn fxy => fn [ty1, ty2] =>
   505       brackify_infix (1, R) fxy (
   506         print_typ (INFX (1, X)) ty1,
   507         str "->",
   508         print_typ (INFX (1, R)) ty2
   509       )))
   510   #> fold (Code_Target.add_reserved target) [
   511       "hiding", "deriving", "where", "case", "of", "infix", "infixl", "infixr",
   512       "import", "default", "forall", "let", "in", "class", "qualified", "data",
   513       "newtype", "instance", "if", "then", "else", "type", "as", "do", "module"
   514     ]
   515   #> fold (Code_Target.add_reserved target) [
   516       "Prelude", "Main", "Bool", "Maybe", "Either", "Ordering", "Char", "String", "Int",
   517       "Integer", "Float", "Double", "Rational", "IO", "Eq", "Ord", "Enum", "Bounded",
   518       "Num", "Real", "Integral", "Fractional", "Floating", "RealFloat", "Monad", "Functor",
   519       "AlreadyExists", "ArithException", "ArrayException", "AssertionFailed", "AsyncException",
   520       "BlockedOnDeadMVar", "Deadlock", "Denormal", "DivideByZero", "DotNetException", "DynException",
   521       "Dynamic", "EOF", "EQ", "EmptyRec", "ErrorCall", "ExitException", "ExitFailure",
   522       "ExitSuccess", "False", "GT", "HeapOverflow",
   523       "IOError", "IOException", "IllegalOperation",
   524       "IndexOutOfBounds", "Just", "Key", "LT", "Left", "LossOfPrecision", "NoMethodError",
   525       "NoSuchThing", "NonTermination", "Nothing", "Obj", "OtherError", "Overflow",
   526       "PatternMatchFail", "PermissionDenied", "ProtocolError", "RecConError", "RecSelError",
   527       "RecUpdError", "ResourceBusy", "ResourceExhausted", "Right", "StackOverflow",
   528       "ThreadKilled", "True", "TyCon", "TypeRep", "UndefinedElement", "Underflow",
   529       "UnsupportedOperation", "UserError", "abs", "absReal", "acos", "acosh", "all",
   530       "and", "any", "appendFile", "asTypeOf", "asciiTab", "asin", "asinh", "atan",
   531       "atan2", "atanh", "basicIORun", "blockIO", "boundedEnumFrom", "boundedEnumFromThen",
   532       "boundedEnumFromThenTo", "boundedEnumFromTo", "boundedPred", "boundedSucc", "break",
   533       "catch", "catchException", "ceiling", "compare", "concat", "concatMap", "const",
   534       "cos", "cosh", "curry", "cycle", "decodeFloat", "denominator", "div", "divMod",
   535       "doubleToRatio", "doubleToRational", "drop", "dropWhile", "either", "elem",
   536       "emptyRec", "encodeFloat", "enumFrom", "enumFromThen", "enumFromThenTo",
   537       "enumFromTo", "error", "even", "exp", "exponent", "fail", "filter", "flip",
   538       "floatDigits", "floatProperFraction", "floatRadix", "floatRange", "floatToRational",
   539       "floor", "fmap", "foldl", "foldl'", "foldl1", "foldr", "foldr1", "fromDouble",
   540       "fromEnum", "fromEnum_0", "fromInt", "fromInteger", "fromIntegral", "fromObj",
   541       "fromRational", "fst", "gcd", "getChar", "getContents", "getLine", "head",
   542       "id", "inRange", "index", "init", "intToRatio", "interact", "ioError", "isAlpha",
   543       "isAlphaNum", "isDenormalized", "isDigit", "isHexDigit", "isIEEE", "isInfinite",
   544       "isLower", "isNaN", "isNegativeZero", "isOctDigit", "isSpace", "isUpper", "iterate", "iterate'",
   545       "last", "lcm", "length", "lex", "lexDigits", "lexLitChar", "lexmatch", "lines", "log",
   546       "logBase", "lookup", "loop", "map", "mapM", "mapM_", "max", "maxBound", "maximum",
   547       "maybe", "min", "minBound", "minimum", "mod", "negate", "nonnull", "not", "notElem",
   548       "null", "numerator", "numericEnumFrom", "numericEnumFromThen", "numericEnumFromThenTo",
   549       "numericEnumFromTo", "odd", "or", "otherwise", "pi", "pred", 
   550       "print", "product", "properFraction", "protectEsc", "putChar", "putStr", "putStrLn",
   551       "quot", "quotRem", "range", "rangeSize", "rationalToDouble", "rationalToFloat",
   552       "rationalToRealFloat", "read", "readDec", "readField", "readFieldName", "readFile",
   553       "readFloat", "readHex", "readIO", "readInt", "readList", "readLitChar", "readLn",
   554       "readOct", "readParen", "readSigned", "reads", "readsPrec", "realFloatToRational",
   555       "realToFrac", "recip", "reduce", "rem", "repeat", "replicate", "return", "reverse",
   556       "round", "scaleFloat", "scanl", "scanl1", "scanr", "scanr1", "seq", "sequence",
   557       "sequence_", "show", "showChar", "showException", "showField", "showList",
   558       "showLitChar", "showParen", "showString", "shows", "showsPrec", "significand",
   559       "signum", "signumReal", "sin", "sinh", "snd", "span", "splitAt", "sqrt", "subtract",
   560       "succ", "sum", "tail", "take", "takeWhile", "takeWhile1", "tan", "tanh", "threadToIOResult",
   561       "throw", "toEnum", "toInt", "toInteger", "toObj", "toRational", "truncate", "uncurry",
   562       "undefined", "unlines", "unsafeCoerce", "unsafeIndex", "unsafeRangeSize", "until", "unwords",
   563       "unzip", "unzip3", "userError", "words", "writeFile", "zip", "zip3", "zipWith", "zipWith3"
   564     ] (*due to weird handling of ':', we can't do anything else than to import *all* prelude symbols*);
   565 
   566 end; (*struct*)