explizit checking for pattern discipline
authorhaftmann
Thu Aug 09 15:52:57 2007 +0200 (2007-08-09)
changeset 242029e77397eba8e
parent 24201 a879b30e8e86
child 24203 a365995c043b
explizit checking for pattern discipline
src/Pure/Tools/codegen_serializer.ML
     1.1 --- a/src/Pure/Tools/codegen_serializer.ML	Thu Aug 09 15:52:56 2007 +0200
     1.2 +++ b/src/Pure/Tools/codegen_serializer.ML	Thu Aug 09 15:52:57 2007 +0200
     1.3 @@ -162,18 +162,22 @@
     1.4  
     1.5  (* generic serializer combinators *)
     1.6  
     1.7 -fun gen_pr_app pr_app' pr_term const_syntax vars fxy (app as ((c, (_, tys)), ts)) =
     1.8 +fun gen_pr_app pr_app' pr_term const_syntax labelled_name is_cons
     1.9 +      lhs vars fxy (app as ((c, (_, tys)), ts)) =
    1.10    case const_syntax c
    1.11 -   of NONE => brackify fxy (pr_app' vars app)
    1.12 +   of NONE => if lhs andalso not (is_cons c) then
    1.13 +          error ("non-constructor on left hand side of equation: " ^ labelled_name c)
    1.14 +        else brackify fxy (pr_app' lhs vars app)
    1.15      | SOME (i, pr) =>
    1.16          let
    1.17            val k = if i < 0 then length tys else i;
    1.18 -          fun pr' fxy ts = pr pr_term vars fxy (ts ~~ curry Library.take k tys);
    1.19 +          fun pr' fxy ts = pr (pr_term lhs) vars fxy (ts ~~ curry Library.take k tys);
    1.20          in if k = length ts
    1.21            then pr' fxy ts
    1.22          else if k < length ts
    1.23 -          then case chop k ts of (ts1, ts2) => brackify fxy (pr' APP ts1 :: map (pr_term vars BR) ts2)
    1.24 -          else pr_term vars fxy (CodegenThingol.eta_expand app k)
    1.25 +          then case chop k ts of (ts1, ts2) =>
    1.26 +            brackify fxy (pr' APP ts1 :: map (pr_term lhs vars BR) ts2)
    1.27 +          else pr_term lhs vars fxy (CodegenThingol.eta_expand app k)
    1.28          end;
    1.29  
    1.30  fun gen_pr_bind pr_bind' pr_term fxy ((v, pat), ty) vars =
    1.31 @@ -341,56 +345,56 @@
    1.32                  else pr pr_typ fxy tys)
    1.33        | pr_typ fxy (ITyVar v) =
    1.34            str ("'" ^ v);
    1.35 -    fun pr_term vars fxy (IConst c) =
    1.36 -          pr_app vars fxy (c, [])
    1.37 -      | pr_term vars fxy (IVar v) =
    1.38 +    fun pr_term lhs vars fxy (IConst c) =
    1.39 +          pr_app lhs vars fxy (c, [])
    1.40 +      | pr_term lhs vars fxy (IVar v) =
    1.41            str (CodegenNames.lookup_var vars v)
    1.42 -      | pr_term vars fxy (t as t1 `$ t2) =
    1.43 +      | pr_term lhs vars fxy (t as t1 `$ t2) =
    1.44            (case CodegenThingol.unfold_const_app t
    1.45 -           of SOME c_ts => pr_app vars fxy c_ts
    1.46 +           of SOME c_ts => pr_app lhs vars fxy c_ts
    1.47              | NONE =>
    1.48 -                brackify fxy [pr_term vars NOBR t1, pr_term vars BR t2])
    1.49 -      | pr_term vars fxy (t as _ `|-> _) =
    1.50 +                brackify fxy [pr_term lhs vars NOBR t1, pr_term lhs vars BR t2])
    1.51 +      | pr_term lhs vars fxy (t as _ `|-> _) =
    1.52            let
    1.53              val (binds, t') = CodegenThingol.unfold_abs t;
    1.54              fun pr ((v, pat), ty) =
    1.55                pr_bind NOBR ((SOME v, pat), ty)
    1.56                #>> (fn p => concat [str "fn", p, str "=>"]);
    1.57              val (ps, vars') = fold_map pr binds vars;
    1.58 -          in brackets (ps @ [pr_term vars' NOBR t']) end
    1.59 -      | pr_term vars fxy (ICase (cases as (_, t0))) = (case CodegenThingol.unfold_const_app t0
    1.60 +          in brackets (ps @ [pr_term lhs vars' NOBR t']) end
    1.61 +      | pr_term lhs vars fxy (ICase (cases as (_, t0))) = (case CodegenThingol.unfold_const_app t0
    1.62             of SOME (c_ts as ((c, _), _)) => if is_none (const_syntax c)
    1.63                  then pr_case vars fxy cases
    1.64 -                else pr_app vars fxy c_ts
    1.65 +                else pr_app lhs vars fxy c_ts
    1.66              | NONE => pr_case vars fxy cases)
    1.67 -    and pr_app' vars (app as ((c, (iss, tys)), ts)) =
    1.68 +    and pr_app' lhs vars (app as ((c, (iss, tys)), ts)) =
    1.69        if is_cons c then let
    1.70          val k = length tys
    1.71        in if k < 2 then 
    1.72 -        (str o deresolv) c :: map (pr_term vars BR) ts
    1.73 +        (str o deresolv) c :: map (pr_term lhs vars BR) ts
    1.74        else if k = length ts then
    1.75 -        [(str o deresolv) c, Pretty.enum "," "(" ")" (map (pr_term vars NOBR) ts)]
    1.76 -      else [pr_term vars BR (CodegenThingol.eta_expand app k)] end else
    1.77 +        [(str o deresolv) c, Pretty.enum "," "(" ")" (map (pr_term lhs vars NOBR) ts)]
    1.78 +      else [pr_term lhs vars BR (CodegenThingol.eta_expand app k)] end else
    1.79          (str o deresolv) c
    1.80 -          :: ((map (pr_dicts BR) o filter_out null) iss @ map (pr_term vars BR) ts)
    1.81 -    and pr_app vars = gen_pr_app pr_app' pr_term const_syntax vars
    1.82 +          :: (map (pr_dicts BR) o filter_out null) iss @ map (pr_term lhs vars BR) ts
    1.83 +    and pr_app lhs vars = gen_pr_app pr_app' pr_term const_syntax labelled_name is_cons lhs vars
    1.84      and pr_bind' ((NONE, NONE), _) = str "_"
    1.85        | pr_bind' ((SOME v, NONE), _) = str v
    1.86        | pr_bind' ((NONE, SOME p), _) = p
    1.87        | pr_bind' ((SOME v, SOME p), _) = concat [str v, str "as", p]
    1.88 -    and pr_bind fxy = gen_pr_bind pr_bind' pr_term fxy
    1.89 +    and pr_bind fxy = gen_pr_bind pr_bind' (pr_term false) fxy
    1.90      and pr_case vars fxy (cases as ((_, [_]), _)) =
    1.91            let
    1.92              val (binds, t') = CodegenThingol.unfold_let (ICase cases);
    1.93              fun pr ((pat, ty), t) vars =
    1.94                vars
    1.95                |> pr_bind NOBR ((NONE, SOME pat), ty)
    1.96 -              |>> (fn p => semicolon [str "val", p, str "=", pr_term vars NOBR t])
    1.97 +              |>> (fn p => semicolon [str "val", p, str "=", pr_term false vars NOBR t])
    1.98              val (ps, vars') = fold_map pr binds vars;
    1.99            in
   1.100              Pretty.chunks [
   1.101                [str ("let"), Pretty.fbrk, Pretty.chunks ps] |> Pretty.block,
   1.102 -              [str ("in"), Pretty.fbrk, pr_term vars' NOBR t'] |> Pretty.block,
   1.103 +              [str ("in"), Pretty.fbrk, pr_term false vars' NOBR t'] |> Pretty.block,
   1.104                str ("end")
   1.105              ]
   1.106            end
   1.107 @@ -400,12 +404,12 @@
   1.108                let
   1.109                  val (p, vars') = pr_bind NOBR ((NONE, SOME pat), ty) vars;
   1.110                in
   1.111 -                concat [str delim, p, str "=>", pr_term vars' NOBR t]
   1.112 +                concat [str delim, p, str "=>", pr_term false vars' NOBR t]
   1.113                end;
   1.114            in
   1.115              (Pretty.enclose "(" ")" o single o brackify fxy) (
   1.116                str "case"
   1.117 -              :: pr_term vars NOBR td
   1.118 +              :: pr_term false vars NOBR td
   1.119                :: pr "of" b
   1.120                :: map (pr "|") bs
   1.121              )
   1.122 @@ -447,8 +451,8 @@
   1.123                           then [str ":", pr_typ NOBR ty]
   1.124                           else
   1.125                             pr_tyvars vs
   1.126 -                           @ map (pr_term vars BR) ts)
   1.127 -                   @ [str "=", pr_term vars NOBR t]
   1.128 +                           @ map (pr_term true vars BR) ts)
   1.129 +                   @ [str "=", pr_term false vars NOBR t]
   1.130                      )
   1.131                    end
   1.132                in
   1.133 @@ -547,7 +551,7 @@
   1.134                  concat [
   1.135                    (str o pr_label_classop) classop,
   1.136                    str "=",
   1.137 -                  pr_term vars NOBR t
   1.138 +                  pr_term false vars NOBR t
   1.139                  ]
   1.140                end;
   1.141            in
   1.142 @@ -613,61 +617,61 @@
   1.143                  else pr pr_typ fxy tys)
   1.144        | pr_typ fxy (ITyVar v) =
   1.145            str ("'" ^ v);
   1.146 -    fun pr_term vars fxy (IConst c) =
   1.147 -          pr_app vars fxy (c, [])
   1.148 -      | pr_term vars fxy (IVar v) =
   1.149 +    fun pr_term lhs vars fxy (IConst c) =
   1.150 +          pr_app lhs vars fxy (c, [])
   1.151 +      | pr_term lhs vars fxy (IVar v) =
   1.152            str (CodegenNames.lookup_var vars v)
   1.153 -      | pr_term vars fxy (t as t1 `$ t2) =
   1.154 +      | pr_term lhs vars fxy (t as t1 `$ t2) =
   1.155            (case CodegenThingol.unfold_const_app t
   1.156 -           of SOME c_ts => pr_app vars fxy c_ts
   1.157 +           of SOME c_ts => pr_app lhs vars fxy c_ts
   1.158              | NONE =>
   1.159 -                brackify fxy [pr_term vars NOBR t1, pr_term vars BR t2])
   1.160 -      | pr_term vars fxy (t as _ `|-> _) =
   1.161 +                brackify fxy [pr_term lhs vars NOBR t1, pr_term lhs vars BR t2])
   1.162 +      | pr_term lhs vars fxy (t as _ `|-> _) =
   1.163            let
   1.164              val (binds, t') = CodegenThingol.unfold_abs t;
   1.165              fun pr ((v, pat), ty) = pr_bind BR ((SOME v, pat), ty);
   1.166              val (ps, vars') = fold_map pr binds vars;
   1.167 -          in brackets (str "fun" :: ps @ str "->" @@ pr_term vars' NOBR t') end
   1.168 -      | pr_term vars fxy (ICase (cases as (_, t0))) = (case CodegenThingol.unfold_const_app t0
   1.169 +          in brackets (str "fun" :: ps @ str "->" @@ pr_term lhs vars' NOBR t') end
   1.170 +      | pr_term lhs vars fxy (ICase (cases as (_, t0))) = (case CodegenThingol.unfold_const_app t0
   1.171             of SOME (c_ts as ((c, _), _)) => if is_none (const_syntax c)
   1.172                  then pr_case vars fxy cases
   1.173 -                else pr_app vars fxy c_ts
   1.174 +                else pr_app lhs vars fxy c_ts
   1.175              | NONE => pr_case vars fxy cases)
   1.176 -    and pr_app' vars (app as ((c, (iss, tys)), ts)) =
   1.177 +    and pr_app' lhs vars (app as ((c, (iss, tys)), ts)) =
   1.178        if is_cons c then
   1.179          if length tys = length ts
   1.180          then case ts
   1.181           of [] => [(str o deresolv) c]
   1.182 -          | [t] => [(str o deresolv) c, pr_term vars BR t]
   1.183 -          | _ => [(str o deresolv) c, Pretty.enum "," "(" ")" (map (pr_term vars NOBR) ts)]
   1.184 -        else [pr_term vars BR (CodegenThingol.eta_expand app (length tys))]
   1.185 +          | [t] => [(str o deresolv) c, pr_term lhs vars BR t]
   1.186 +          | _ => [(str o deresolv) c, Pretty.enum "," "(" ")" (map (pr_term lhs vars NOBR) ts)]
   1.187 +        else [pr_term lhs vars BR (CodegenThingol.eta_expand app (length tys))]
   1.188        else (str o deresolv) c
   1.189 -        :: ((map (pr_dicts BR) o filter_out null) iss @ map (pr_term vars BR) ts)
   1.190 -    and pr_app vars = gen_pr_app pr_app' pr_term const_syntax vars
   1.191 +        :: ((map (pr_dicts BR) o filter_out null) iss @ map (pr_term lhs vars BR) ts)
   1.192 +    and pr_app lhs vars = gen_pr_app pr_app' pr_term const_syntax labelled_name is_cons lhs vars
   1.193      and pr_bind' ((NONE, NONE), _) = str "_"
   1.194        | pr_bind' ((SOME v, NONE), _) = str v
   1.195        | pr_bind' ((NONE, SOME p), _) = p
   1.196        | pr_bind' ((SOME v, SOME p), _) = brackets [p, str "as", str v]
   1.197 -    and pr_bind fxy = gen_pr_bind pr_bind' pr_term fxy
   1.198 +    and pr_bind fxy = gen_pr_bind pr_bind' (pr_term false) fxy
   1.199      and pr_case vars fxy (cases as ((_, [_]), _)) =
   1.200            let
   1.201              val (binds, t') = CodegenThingol.unfold_let (ICase cases);
   1.202              fun pr ((pat, ty), t) vars =
   1.203                vars
   1.204                |> pr_bind NOBR ((NONE, SOME pat), ty)
   1.205 -              |>> (fn p => concat [str "let", p, str "=", pr_term vars NOBR t, str "in"])
   1.206 +              |>> (fn p => concat [str "let", p, str "=", pr_term false vars NOBR t, str "in"])
   1.207              val (ps, vars') = fold_map pr binds vars;
   1.208 -          in Pretty.chunks (ps @| pr_term vars' NOBR t') end
   1.209 +          in Pretty.chunks (ps @| pr_term false vars' NOBR t') end
   1.210        | pr_case vars fxy (((td, ty), b::bs), _) =
   1.211            let
   1.212              fun pr delim (pat, t) =
   1.213                let
   1.214                  val (p, vars') = pr_bind NOBR ((NONE, SOME pat), ty) vars;
   1.215 -              in concat [str delim, p, str "->", pr_term vars' NOBR t] end;
   1.216 +              in concat [str delim, p, str "->", pr_term false vars' NOBR t] end;
   1.217            in
   1.218              (Pretty.enclose "(" ")" o single o brackify fxy) (
   1.219                str "match"
   1.220 -              :: pr_term vars NOBR td
   1.221 +              :: pr_term false vars NOBR td
   1.222                :: pr "with" b
   1.223                :: map (pr "|") bs
   1.224              )
   1.225 @@ -698,9 +702,9 @@
   1.226                    |> CodegenNames.intro_vars ((fold o CodegenThingol.fold_unbound_varnames)
   1.227                        (insert (op =)) ts []);
   1.228                in concat [
   1.229 -                (Pretty.block o Pretty.commas) (map (pr_term vars NOBR) ts),
   1.230 +                (Pretty.block o Pretty.commas) (map (pr_term true vars NOBR) ts),
   1.231                  str "->",
   1.232 -                pr_term vars NOBR t
   1.233 +                pr_term false vars NOBR t
   1.234                ] end;
   1.235              fun pr_eqs [(ts, t)] =
   1.236                    let
   1.237 @@ -714,9 +718,9 @@
   1.238                            (insert (op =)) ts []);
   1.239                    in
   1.240                      concat (
   1.241 -                      map (pr_term vars BR) ts
   1.242 +                      map (pr_term true vars BR) ts
   1.243                        @ str "="
   1.244 -                      @@ pr_term vars NOBR t
   1.245 +                      @@ pr_term false vars NOBR t
   1.246                      )
   1.247                    end
   1.248                | pr_eqs (eqs as (eq as ([_], _)) :: eqs') =
   1.249 @@ -837,7 +841,7 @@
   1.250                  concat [
   1.251                    (str o deresolv) classop,
   1.252                    str "=",
   1.253 -                  pr_term vars NOBR t
   1.254 +                  pr_term false vars NOBR t
   1.255                  ]
   1.256                end;
   1.257            in
   1.258 @@ -872,9 +876,7 @@
   1.259    (_ : string -> class_syntax option) tyco_syntax const_syntax code =
   1.260    let
   1.261      val module_alias = if is_some module then K module else raw_module_alias;
   1.262 -    val is_cons = fn node => case CodegenThingol.get_def code node
   1.263 -     of CodegenThingol.Datatypecons _ => true
   1.264 -      | _ => false;
   1.265 +    val is_cons = CodegenThingol.is_cons code;
   1.266      datatype node =
   1.267          Def of string * ml_def option
   1.268        | Module of string * ((Name.context * Name.context) * node Graph.T);
   1.269 @@ -1077,7 +1079,8 @@
   1.270  
   1.271  in
   1.272  
   1.273 -fun pr_haskell class_syntax tyco_syntax const_syntax labelled_name init_syms deresolv_here deresolv deriving_show def =
   1.274 +fun pr_haskell class_syntax tyco_syntax const_syntax labelled_name init_syms
   1.275 +    deresolv_here deresolv is_cons deriving_show def =
   1.276    let
   1.277      fun class_name class = case class_syntax class
   1.278       of NONE => deresolv class
   1.279 @@ -1115,45 +1118,45 @@
   1.280        Pretty.block (pr_typparms tyvars vs @@ pr_tycoexpr tyvars NOBR tycoexpr);
   1.281      fun pr_typscheme tyvars (vs, ty) =
   1.282        Pretty.block (pr_typparms tyvars vs @@ pr_typ tyvars NOBR ty);
   1.283 -    fun pr_term vars fxy (IConst c) =
   1.284 -          pr_app vars fxy (c, [])
   1.285 -      | pr_term vars fxy (t as (t1 `$ t2)) =
   1.286 +    fun pr_term lhs vars fxy (IConst c) =
   1.287 +          pr_app lhs vars fxy (c, [])
   1.288 +      | pr_term lhs vars fxy (t as (t1 `$ t2)) =
   1.289            (case CodegenThingol.unfold_const_app t
   1.290 -           of SOME app => pr_app vars fxy app
   1.291 +           of SOME app => pr_app lhs vars fxy app
   1.292              | _ =>
   1.293                  brackify fxy [
   1.294 -                  pr_term vars NOBR t1,
   1.295 -                  pr_term vars BR t2
   1.296 +                  pr_term lhs vars NOBR t1,
   1.297 +                  pr_term lhs vars BR t2
   1.298                  ])
   1.299 -      | pr_term vars fxy (IVar v) =
   1.300 +      | pr_term lhs vars fxy (IVar v) =
   1.301            (str o CodegenNames.lookup_var vars) v
   1.302 -      | pr_term vars fxy (t as _ `|-> _) =
   1.303 +      | pr_term lhs vars fxy (t as _ `|-> _) =
   1.304            let
   1.305              val (binds, t') = CodegenThingol.unfold_abs t;
   1.306              fun pr ((v, pat), ty) = pr_bind BR ((SOME v, pat), ty);
   1.307              val (ps, vars') = fold_map pr binds vars;
   1.308 -          in brackets (str "\\" :: ps @ str "->" @@ pr_term vars' NOBR t') end
   1.309 -      | pr_term vars fxy (ICase (cases as (_, t0))) = (case CodegenThingol.unfold_const_app t0
   1.310 +          in brackets (str "\\" :: ps @ str "->" @@ pr_term lhs vars' NOBR t') end
   1.311 +      | pr_term lhs vars fxy (ICase (cases as (_, t0))) = (case CodegenThingol.unfold_const_app t0
   1.312             of SOME (c_ts as ((c, _), _)) => if is_none (const_syntax c)
   1.313                  then pr_case vars fxy cases
   1.314 -                else pr_app vars fxy c_ts
   1.315 +                else pr_app lhs vars fxy c_ts
   1.316              | NONE => pr_case vars fxy cases)
   1.317 -    and pr_app' vars ((c, _), ts) =
   1.318 -      (str o deresolv) c :: map (pr_term vars BR) ts
   1.319 -    and pr_app vars = gen_pr_app pr_app' pr_term const_syntax vars
   1.320 -    and pr_bind fxy = pr_bind_haskell pr_term fxy
   1.321 +    and pr_app' lhs vars ((c, _), ts) =
   1.322 +      (str o deresolv) c :: map (pr_term lhs vars BR) ts
   1.323 +    and pr_app lhs vars = gen_pr_app pr_app' pr_term const_syntax labelled_name is_cons lhs vars
   1.324 +    and pr_bind fxy = pr_bind_haskell (pr_term false) fxy
   1.325      and pr_case vars fxy (cases as ((_, [_]), _)) =
   1.326            let
   1.327              val (binds, t) = CodegenThingol.unfold_let (ICase cases);
   1.328              fun pr ((pat, ty), t) vars =
   1.329                vars
   1.330                |> pr_bind BR ((NONE, SOME pat), ty)
   1.331 -              |>> (fn p => semicolon [p, str "=", pr_term vars NOBR t])
   1.332 +              |>> (fn p => semicolon [p, str "=", pr_term false vars NOBR t])
   1.333              val (ps, vars') = fold_map pr binds vars;
   1.334            in
   1.335              Pretty.block_enclose (
   1.336                str "let {",
   1.337 -              concat [str "}", str "in", pr_term vars' NOBR t]
   1.338 +              concat [str "}", str "in", pr_term false vars' NOBR t]
   1.339              ) ps
   1.340            end
   1.341        | pr_case vars fxy (((td, ty), bs as _ :: _), _) =
   1.342 @@ -1161,10 +1164,10 @@
   1.343              fun pr (pat, t) =
   1.344                let
   1.345                  val (p, vars') = pr_bind NOBR ((NONE, SOME pat), ty) vars;
   1.346 -              in semicolon [p, str "->", pr_term vars' NOBR t] end;
   1.347 +              in semicolon [p, str "->", pr_term false vars' NOBR t] end;
   1.348            in
   1.349              Pretty.block_enclose (
   1.350 -              concat [str "(case", pr_term vars NOBR td, str "of", str "{"],
   1.351 +              concat [str "(case", pr_term false vars NOBR td, str "of", str "{"],
   1.352                str "})"
   1.353              ) (map pr bs)
   1.354            end
   1.355 @@ -1185,9 +1188,9 @@
   1.356                in
   1.357                  semicolon (
   1.358                    (str o deresolv_here) name
   1.359 -                  :: map (pr_term vars BR) ts
   1.360 +                  :: map (pr_term true vars BR) ts
   1.361                    @ str "="
   1.362 -                  @@ pr_term vars NOBR t
   1.363 +                  @@ pr_term false vars NOBR t
   1.364                  )
   1.365                end;
   1.366            in
   1.367 @@ -1276,7 +1279,7 @@
   1.368                    semicolon [
   1.369                      (str o classop_name class) classop,
   1.370                      str "=",
   1.371 -                    pr_term vars NOBR t
   1.372 +                    pr_term false vars NOBR t
   1.373                    ]
   1.374                  end;
   1.375            in
   1.376 @@ -1315,9 +1318,10 @@
   1.377  end; (*local*)
   1.378  
   1.379  fun seri_haskell module_prefix module destination string_classes labelled_name
   1.380 -  reserved_syms raw_module_alias module_prolog class_syntax tyco_syntax const_syntax code =
   1.381 +    reserved_syms raw_module_alias module_prolog class_syntax tyco_syntax const_syntax code =
   1.382    let
   1.383      val _ = Option.map File.check destination;
   1.384 +    val is_cons = CodegenThingol.is_cons code;
   1.385      val module_alias = if is_some module then K module else raw_module_alias;
   1.386      val init_names = Name.make_context reserved_syms;
   1.387      val name_modl = mk_modl_name_tab init_names module_prefix module_alias code;
   1.388 @@ -1386,7 +1390,7 @@
   1.389            | deriv' _ (ITyVar _) = true
   1.390        in deriv [] tyco end;
   1.391      fun seri_def qualified = pr_haskell class_syntax tyco_syntax const_syntax labelled_name init_syms
   1.392 -      deresolv_here (if qualified then deresolv else deresolv_here)
   1.393 +      deresolv_here (if qualified then deresolv else deresolv_here) is_cons
   1.394        (if string_classes then deriving_show else K false);
   1.395      fun write_module (SOME destination) modlname =
   1.396            let
   1.397 @@ -1458,7 +1462,7 @@
   1.398              pr_typ (INFX (1, R)) ty2
   1.399            ])
   1.400        | pr_fun _ = NONE
   1.401 -    val pr = pr_haskell (K NONE) pr_fun (K NONE) labelled_name init_names I I (K false);
   1.402 +    val pr = pr_haskell (K NONE) pr_fun (K NONE) labelled_name init_names I I (K false) (K false);
   1.403    in
   1.404      []
   1.405      |> Graph.fold (fn (name, (def, _)) => case try pr (name, def) of SOME p => cons p | NONE => I) code