src/Tools/Code/code_haskell.ML
author haftmann
Tue, 31 Aug 2010 13:29:38 +0200
changeset 39149 79d7f2b4cf71
parent 39142 c0b857a04758
child 39150 fcd1d0457e27
permissions -rw-r--r--
more coherent naming of syntax data structures
     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 haskell_program_of_program labelled_name module_prefix reserved module_alias program =
   265   let
   266     val reserved = Name.make_context reserved;
   267     val mk_name_module = mk_name_module reserved module_prefix module_alias program;
   268     fun add_stmt (name, (stmt, deps)) =
   269       let
   270         val (module_name, base) = dest_name name;
   271         val module_name' = mk_name_module module_name;
   272         val mk_name_stmt = yield_singleton Name.variants;
   273         fun add_fun upper (nsp_fun, nsp_typ) =
   274           let
   275             val (base', nsp_fun') =
   276               mk_name_stmt (if upper then first_upper base else base) nsp_fun
   277           in (base', (nsp_fun', nsp_typ)) end;
   278         fun add_typ (nsp_fun, nsp_typ) =
   279           let
   280             val (base', nsp_typ') = mk_name_stmt (first_upper base) nsp_typ
   281           in (base', (nsp_fun, nsp_typ')) end;
   282         val add_name = case stmt
   283          of Code_Thingol.Fun (_, (_, SOME _)) => pair base
   284           | Code_Thingol.Fun _ => add_fun false
   285           | Code_Thingol.Datatype _ => add_typ
   286           | Code_Thingol.Datatypecons _ => add_fun true
   287           | Code_Thingol.Class _ => add_typ
   288           | Code_Thingol.Classrel _ => pair base
   289           | Code_Thingol.Classparam _ => add_fun false
   290           | Code_Thingol.Classinst _ => pair base;
   291         fun add_stmt' base' = case stmt
   292          of Code_Thingol.Fun (_, (_, SOME _)) =>
   293               I
   294           | Code_Thingol.Datatypecons _ =>
   295               cons (name, (Long_Name.append module_name' base', NONE))
   296           | Code_Thingol.Classrel _ => I
   297           | Code_Thingol.Classparam _ =>
   298               cons (name, (Long_Name.append module_name' base', NONE))
   299           | _ => cons (name, (Long_Name.append module_name' base', SOME stmt));
   300       in
   301         Symtab.map_default (module_name', ([], ([], (reserved, reserved))))
   302               (apfst (fold (insert (op = : string * string -> bool)) deps))
   303         #> `(fn program => add_name ((snd o snd o the o Symtab.lookup program) module_name'))
   304         #-> (fn (base', names) =>
   305               (Symtab.map_entry module_name' o apsnd) (fn (stmts, _) =>
   306               (add_stmt' base' stmts, names)))
   307       end;
   308     val hs_program = fold add_stmt (AList.make (fn name =>
   309       (Graph.get_node program name, Graph.imm_succs program name))
   310       (Graph.strong_conn program |> flat)) Symtab.empty;
   311     fun deresolver name = (fst o the o AList.lookup (op =) ((fst o snd o the
   312       o Symtab.lookup hs_program) ((mk_name_module o fst o dest_name) name))) name
   313       handle Option => error ("Unknown statement name: " ^ labelled_name name);
   314   in (deresolver, hs_program) end;
   315 
   316 fun serialize_haskell module_prefix module_name string_classes labelled_name
   317     raw_reserved includes module_alias
   318     class_syntax tyco_syntax const_syntax program
   319     (stmt_names, presentation_stmt_names) =
   320   let
   321     val reserved = fold (insert (op =) o fst) includes raw_reserved;
   322     val (deresolver, hs_program) = haskell_program_of_program labelled_name
   323       module_prefix reserved module_alias program;
   324     val contr_classparam_typs = Code_Thingol.contr_classparam_typs program;
   325     fun deriving_show tyco =
   326       let
   327         fun deriv _ "fun" = false
   328           | deriv tycos tyco = not (tyco = Code_Thingol.fun_tyco)
   329               andalso (member (op =) tycos tyco
   330               orelse case try (Graph.get_node program) tyco
   331                 of SOME (Code_Thingol.Datatype (_, (_, cs))) => forall (deriv' (tyco :: tycos))
   332                     (maps snd cs)
   333                  | NONE => true)
   334         and deriv' tycos (tyco `%% tys) = deriv tycos tyco
   335               andalso forall (deriv' tycos) tys
   336           | deriv' _ (ITyVar _) = true
   337       in deriv [] tyco end;
   338     val reserved = make_vars reserved;
   339     fun print_stmt qualified = print_haskell_stmt labelled_name
   340       class_syntax tyco_syntax const_syntax reserved
   341       (if qualified then deresolver else Long_Name.base_name o deresolver)
   342       contr_classparam_typs
   343       (if string_classes then deriving_show else K false);
   344     fun print_module name content =
   345       (name, Pretty.chunks2 [
   346         str ("module " ^ name ^ " where {"),
   347         content,
   348         str "}"
   349       ]);
   350     fun serialize_module1 (module_name', (deps, (stmts, _))) =
   351       let
   352         val stmt_names = map fst stmts;
   353         val qualified = is_none module_name;
   354         val imports = subtract (op =) stmt_names deps
   355           |> distinct (op =)
   356           |> map_filter (try deresolver)
   357           |> map Long_Name.qualifier
   358           |> distinct (op =);
   359         fun print_import_include (name, _) = str ("import qualified " ^ name ^ ";");
   360         fun print_import_module name = str ((if qualified
   361           then "import qualified "
   362           else "import ") ^ name ^ ";");
   363         val import_ps = map print_import_include includes @ map print_import_module imports
   364         val content = Pretty.chunks2 ((if null import_ps then [] else [Pretty.chunks import_ps])
   365             @ map_filter
   366               (fn (name, (_, SOME stmt)) => SOME (print_stmt qualified (name, stmt))
   367                 | (_, (_, NONE)) => NONE) stmts
   368           );
   369       in print_module module_name' content end;
   370     fun serialize_module2 (_, (_, (stmts, _))) = Pretty.chunks2 (map_filter
   371         (fn (name, (_, SOME stmt)) => if null presentation_stmt_names
   372               orelse member (op =) presentation_stmt_names name
   373               then SOME (print_stmt false (name, stmt))
   374               else NONE
   375           | (_, (_, NONE)) => NONE) stmts);
   376     val serialize_module =
   377       if null presentation_stmt_names then serialize_module1 else pair "" o serialize_module2;
   378     fun write_module width (SOME destination) (modlname, content) =
   379           let
   380             val _ = File.check destination;
   381             val filename = case modlname
   382              of "" => Path.explode "Main.hs"
   383               | _ => (Path.ext "hs" o Path.explode o implode o separate "/"
   384                     o Long_Name.explode) modlname;
   385             val pathname = Path.append destination filename;
   386             val _ = File.mkdir_leaf (Path.dir pathname);
   387           in File.write pathname
   388             ("{-# OPTIONS_GHC -fglasgow-exts #-}\n\n"
   389               ^ string_of_pretty width content)
   390           end
   391       | write_module width NONE (_, content) = writeln_pretty width content;
   392   in
   393     Code_Target.serialization
   394       (fn width => fn destination => K () o map (write_module width destination))
   395       (fn width => rpair [] o cat_lines o map (string_of_pretty width o snd))
   396       (map (uncurry print_module) includes
   397         @ map serialize_module (Symtab.dest hs_program))
   398   end;
   399 
   400 val literals = let
   401   fun char_haskell c =
   402     let
   403       val s = ML_Syntax.print_char c;
   404     in if s = "'" then "\\'" else s end;
   405   fun numeral_haskell k = if k >= 0 then string_of_int k
   406     else Library.enclose "(" ")" (signed_string_of_int k);
   407 in Literals {
   408   literal_char = Library.enclose "'" "'" o char_haskell,
   409   literal_string = quote o translate_string char_haskell,
   410   literal_numeral = numeral_haskell,
   411   literal_positive_numeral = numeral_haskell,
   412   literal_alternative_numeral = numeral_haskell,
   413   literal_naive_numeral = numeral_haskell,
   414   literal_list = enum "," "[" "]",
   415   infix_cons = (5, ":")
   416 } end;
   417 
   418 
   419 (** optional monad syntax **)
   420 
   421 fun pretty_haskell_monad c_bind =
   422   let
   423     fun dest_bind t1 t2 = case Code_Thingol.split_pat_abs t2
   424      of SOME ((pat, ty), t') =>
   425           SOME ((SOME ((pat, ty), true), t1), t')
   426       | NONE => NONE;
   427     fun dest_monad c_bind_name (IConst (c, _) `$ t1 `$ t2) =
   428           if c = c_bind_name then dest_bind t1 t2
   429           else NONE
   430       | dest_monad _ t = case Code_Thingol.split_let t
   431          of SOME (((pat, ty), tbind), t') =>
   432               SOME ((SOME ((pat, ty), false), tbind), t')
   433           | NONE => NONE;
   434     fun implode_monad c_bind_name = Code_Thingol.unfoldr (dest_monad c_bind_name);
   435     fun print_monad print_bind print_term (NONE, t) vars =
   436           (semicolon [print_term vars NOBR t], vars)
   437       | print_monad print_bind print_term (SOME ((bind, _), true), t) vars = vars
   438           |> print_bind NOBR bind
   439           |>> (fn p => semicolon [p, str "<-", print_term vars NOBR t])
   440       | print_monad print_bind print_term (SOME ((bind, _), false), t) vars = vars
   441           |> print_bind NOBR bind
   442           |>> (fn p => semicolon [str "let", str "{", p, str "=", print_term vars NOBR t, str "}"]);
   443     fun pretty _ [c_bind'] print_term thm vars fxy [(t1, _), (t2, _)] = case dest_bind t1 t2
   444      of SOME (bind, t') => let
   445           val (binds, t'') = implode_monad c_bind' t'
   446           val (ps, vars') = fold_map (print_monad (gen_print_bind (K print_term) thm) print_term)
   447             (bind :: binds) vars;
   448         in
   449           (brackify fxy o single o enclose "do { " " }" o Pretty.breaks)
   450             (ps @| print_term vars' NOBR t'')
   451         end
   452       | NONE => brackify_infix (1, L) fxy
   453           (print_term vars (INFX (1, L)) t1, str ">>=", print_term vars (INFX (1, X)) t2)
   454   in (2, ([c_bind], pretty)) end;
   455 
   456 fun add_monad target' raw_c_bind thy =
   457   let
   458     val c_bind = Code.read_const thy raw_c_bind;
   459   in if target = target' then
   460     thy
   461     |> Code_Target.add_const_syntax target c_bind
   462         (SOME (Code_Printer.complex_const_syntax (pretty_haskell_monad c_bind)))
   463   else error "Only Haskell target allows for monad syntax" end;
   464 
   465 
   466 (** Isar setup **)
   467 
   468 fun isar_serializer module_name =
   469   Code_Target.parse_args (Scan.option (Args.$$$ "root" -- Args.colon |-- Args.name)
   470     -- Scan.optional (Args.$$$ "string_classes" >> K true) false
   471     >> (fn (module_prefix, string_classes) =>
   472       serialize_haskell module_prefix module_name string_classes));
   473 
   474 val _ =
   475   Outer_Syntax.command "code_monad" "define code syntax for monads" Keyword.thy_decl (
   476     Parse.term_group -- Parse.name >> (fn (raw_bind, target) =>
   477       Toplevel.theory  (add_monad target raw_bind))
   478   );
   479 
   480 val setup =
   481   Code_Target.add_target
   482     (target, { serializer = isar_serializer, literals = literals,
   483       check = { env_var = "EXEC_GHC", make_destination = I,
   484         make_command = fn ghc => fn module_name =>
   485           ghc ^ " -fglasgow-exts -odir build -hidir build -stubdir build -e \"\" " ^ module_name ^ ".hs" } })
   486   #> Code_Target.add_tyco_syntax target "fun" (SOME (2, fn print_typ => fn fxy => fn [ty1, ty2] =>
   487       brackify_infix (1, R) fxy (
   488         print_typ (INFX (1, X)) ty1,
   489         str "->",
   490         print_typ (INFX (1, R)) ty2
   491       )))
   492   #> fold (Code_Target.add_reserved target) [
   493       "hiding", "deriving", "where", "case", "of", "infix", "infixl", "infixr",
   494       "import", "default", "forall", "let", "in", "class", "qualified", "data",
   495       "newtype", "instance", "if", "then", "else", "type", "as", "do", "module"
   496     ]
   497   #> fold (Code_Target.add_reserved target) [
   498       "Prelude", "Main", "Bool", "Maybe", "Either", "Ordering", "Char", "String", "Int",
   499       "Integer", "Float", "Double", "Rational", "IO", "Eq", "Ord", "Enum", "Bounded",
   500       "Num", "Real", "Integral", "Fractional", "Floating", "RealFloat", "Monad", "Functor",
   501       "AlreadyExists", "ArithException", "ArrayException", "AssertionFailed", "AsyncException",
   502       "BlockedOnDeadMVar", "Deadlock", "Denormal", "DivideByZero", "DotNetException", "DynException",
   503       "Dynamic", "EOF", "EQ", "EmptyRec", "ErrorCall", "ExitException", "ExitFailure",
   504       "ExitSuccess", "False", "GT", "HeapOverflow",
   505       "IOError", "IOException", "IllegalOperation",
   506       "IndexOutOfBounds", "Just", "Key", "LT", "Left", "LossOfPrecision", "NoMethodError",
   507       "NoSuchThing", "NonTermination", "Nothing", "Obj", "OtherError", "Overflow",
   508       "PatternMatchFail", "PermissionDenied", "ProtocolError", "RecConError", "RecSelError",
   509       "RecUpdError", "ResourceBusy", "ResourceExhausted", "Right", "StackOverflow",
   510       "ThreadKilled", "True", "TyCon", "TypeRep", "UndefinedElement", "Underflow",
   511       "UnsupportedOperation", "UserError", "abs", "absReal", "acos", "acosh", "all",
   512       "and", "any", "appendFile", "asTypeOf", "asciiTab", "asin", "asinh", "atan",
   513       "atan2", "atanh", "basicIORun", "blockIO", "boundedEnumFrom", "boundedEnumFromThen",
   514       "boundedEnumFromThenTo", "boundedEnumFromTo", "boundedPred", "boundedSucc", "break",
   515       "catch", "catchException", "ceiling", "compare", "concat", "concatMap", "const",
   516       "cos", "cosh", "curry", "cycle", "decodeFloat", "denominator", "div", "divMod",
   517       "doubleToRatio", "doubleToRational", "drop", "dropWhile", "either", "elem",
   518       "emptyRec", "encodeFloat", "enumFrom", "enumFromThen", "enumFromThenTo",
   519       "enumFromTo", "error", "even", "exp", "exponent", "fail", "filter", "flip",
   520       "floatDigits", "floatProperFraction", "floatRadix", "floatRange", "floatToRational",
   521       "floor", "fmap", "foldl", "foldl'", "foldl1", "foldr", "foldr1", "fromDouble",
   522       "fromEnum", "fromEnum_0", "fromInt", "fromInteger", "fromIntegral", "fromObj",
   523       "fromRational", "fst", "gcd", "getChar", "getContents", "getLine", "head",
   524       "id", "inRange", "index", "init", "intToRatio", "interact", "ioError", "isAlpha",
   525       "isAlphaNum", "isDenormalized", "isDigit", "isHexDigit", "isIEEE", "isInfinite",
   526       "isLower", "isNaN", "isNegativeZero", "isOctDigit", "isSpace", "isUpper", "iterate", "iterate'",
   527       "last", "lcm", "length", "lex", "lexDigits", "lexLitChar", "lexmatch", "lines", "log",
   528       "logBase", "lookup", "loop", "map", "mapM", "mapM_", "max", "maxBound", "maximum",
   529       "maybe", "min", "minBound", "minimum", "mod", "negate", "nonnull", "not", "notElem",
   530       "null", "numerator", "numericEnumFrom", "numericEnumFromThen", "numericEnumFromThenTo",
   531       "numericEnumFromTo", "odd", "or", "otherwise", "pi", "pred", 
   532       "print", "product", "properFraction", "protectEsc", "putChar", "putStr", "putStrLn",
   533       "quot", "quotRem", "range", "rangeSize", "rationalToDouble", "rationalToFloat",
   534       "rationalToRealFloat", "read", "readDec", "readField", "readFieldName", "readFile",
   535       "readFloat", "readHex", "readIO", "readInt", "readList", "readLitChar", "readLn",
   536       "readOct", "readParen", "readSigned", "reads", "readsPrec", "realFloatToRational",
   537       "realToFrac", "recip", "reduce", "rem", "repeat", "replicate", "return", "reverse",
   538       "round", "scaleFloat", "scanl", "scanl1", "scanr", "scanr1", "seq", "sequence",
   539       "sequence_", "show", "showChar", "showException", "showField", "showList",
   540       "showLitChar", "showParen", "showString", "shows", "showsPrec", "significand",
   541       "signum", "signumReal", "sin", "sinh", "snd", "span", "splitAt", "sqrt", "subtract",
   542       "succ", "sum", "tail", "take", "takeWhile", "takeWhile1", "tan", "tanh", "threadToIOResult",
   543       "throw", "toEnum", "toInt", "toInteger", "toObj", "toRational", "truncate", "uncurry",
   544       "undefined", "unlines", "unsafeCoerce", "unsafeIndex", "unsafeRangeSize", "until", "unwords",
   545       "unzip", "unzip3", "userError", "words", "writeFile", "zip", "zip3", "zipWith", "zipWith3"
   546     ] (*due to weird handling of ':', we can't do anything else than to import *all* prelude symbols*);
   547 
   548 end; (*struct*)