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