(*
 Oukseh Lee and JungTaek Kim

 Copyright(c) 2000-2004 KAIST/SNU Research On Program Analysis System
 (National Creative Research Initiative Center 1998-2003)
 http://ropas.snu.ac.kr/n

 All rights reserved. This file is distributed under the terms of
 an Open Source License.
*)

(* ----- Absyn: typed abstract syntax tree ----- 
   
   types is annotated in exp and pat of AST.
*)
(* ----- including the following functions

   pp: topdec -> unit         pretty-printing                         
   pp_<name>: <name> -> unit  pretty-printing for each domains        

   expTy: exp -> ty 
   expLoc: exp -> Nlocation.t
   expInfo: exp -> info

   patTy: pat -> ty
   patLoc: pat -> Location.t
   patInfo: pat -> info

   typeOf: topdec -> Location.t -> ty option

*)

functor Absyn_generator
  (Idinfo :
   sig
     type varidinfo
     type tyidinfo
     type conidinfo
     type stridinfo
     type sigidinfo
     type fctidinfo
     type labelinfo
     type tyvarinfo
     val print_varidinfo : varidinfo -> unit
     val print_tyidinfo : tyidinfo -> unit
     val print_conidinfo : conidinfo -> unit
     val print_stridinfo : stridinfo -> unit
     val print_sigidinfo : sigidinfo -> unit
     val print_fctidinfo : fctidinfo -> unit
     val print_labelinfo : labelinfo -> unit
     val print_tyvarinfo : tyvarinfo -> unit
   end,
  Syninfo :
   sig
     type info
     val print : info -> unit
     val loc: info -> Location.t
   end,
  Types :
   sig
     type ty
     
     val type_int : ty
     val type_real : ty
     val type_string : ty
     val type_bool : ty
     val type_unit : ty
     val type_char : ty
     val type_exn : ty
     
     val gen_ref : ty -> ty
     val gen_list : ty -> ty
     val gen_array : ty -> ty
   end,
  PrintTypes :
   sig
     type ty = Types.ty
     val pp : ty -> unit
   end)
 =
struct
open Idinfo
open Syninfo
open Types

type varid = varidinfo * info
type tyid = tyidinfo * info
type conid = conidinfo * info
type strid = stridinfo * info
type sigid = sigidinfo * info
type fctid = fctidinfo * info
type label = labelinfo * info
type tyvar = tyvarinfo * info
type varlongid = strid list * varid * info
type tylongid = strid list * tyid * info
type conlongid = strid list * conid * info
type strlongid = strid list * strid * info

type tyexp = String_ast.Ast.ty

type typ = tyexp * ty

type rec_flag = Rec | Nonrec

type pat =
   WildPat	 of ty * info
 | UnitPat	 of info                   (* unit type *)
 | IntPat        of int * info             (* int type *)
 | StringPat     of string * info          (* string type *)
 | CharPat       of char * info            (* char type *)
 | VarPat        of varid * ty * info
 | ConPat        of conlongid * ty * info
 | AppPat        of conlongid * pat * ty * info
 | RecordPat     of labpat list * ty * info
 | SubRecordPat	 of labpat list * ty * info
 | RefPat        of pat * ty * info
 | AsPat         of varid * pat * ty * info
 | TuplePat      of pat list * ty * info
 | ListPat       of pat list * ty * info
 | ArrayPat      of pat list * ty * info
 | OrPat	 of pat list * ty * info
 | ConstraintPat of pat * tyexp * info

and labpat = label * pat * info

type exp =
   UnitExp	   of info                 (* unit type *)
 | IntExp          of int * info           (* int type *)
 | RealExp         of string * info        (* real type *)
 | StringExp       of string * info        (* string type *)
 | CharExp         of char * info          (* char type *)
 | VarExp          of varlongid * ty * info
 | ConExp          of conlongid * ty * info
 | AppExp          of exp * exp * ty * info
 | RecordExp       of (label * exp * info) list  * ty * info
 | RecordFieldExp  of exp * label * ty * info
 | ArrayFieldExp   of exp * exp * ty * info
 | UpdateArrayExp  of exp * exp * exp * ty * info
 | SubstRecordExp  of exp * label * exp * ty * info
 | TupleExp        of exp list * ty * info
 | ListExp         of exp list * ty * info
 | ArrayExp        of exp list * ty * info
 | LetExp          of dec * exp * ty * info
 | HandleExp       of exp * rule list * ty * info
 | RaiseExp        of exp * ty * info          
 | FnExp           of fnrule list * ty * info
 | AssignExp       of exp * exp * ty * info
 | RefExp          of exp * ty * info
 | DeRefExp        of exp * ty * info
 | SeqExp          of exp list * ty * info
 | CaseExp         of exp * rule list * ty * info
 | IfExp           of exp * exp * exp * ty * info
 | WhileExp        of exp * exp * ty * info
 | ForExp          of varid * exp * exp * exp * exp * ty * info
 | ConstraintExp   of exp * tyexp * info

and labexp = label * exp * info (* not used *)
and fnrule = pat list * exp * info
and rule = pat * exp * info

and vel = (varidinfo * (int * Types.ty)) list


(* ValDec, RecValDec, FunDec has value enviroment as a list:
   -- (tyidinfo * type scheme) list --
   type scheme consists of # of bound ty vars (int) and type.
   bound ty vars in type is ordered.

   ex: 'a -> 'b -> 'a * 'b is represented by
       (2, Fun(Var(Bound 0), Fun(Var(Bound 1), Tuple [Var(Bound 0), Var(Bound 1)])))
*)
 
and dec =
   ValDec       of tyvar list * valbind list * vel * info
(* | RecValDec    of tyvar list * valbind list * vel * info *)
(* | FunDec       of tyvar list * funbind list * vel * info *)
 | TypeDec      of typebind list * info
 | ExceptionDec	of exnbind list * info
 | LocalDec     of dec * dec * info
 | SeqDec       of dec list * info
 | OpenDec      of strlongid list * info

and valbind = rec_flag * pat * exp * info
(* and funbind = (varid * pat list * exp * info) list * info *)

and typebind =
   TypeBind of tyvar list * tyid * typ * info
 | DataBind of tyvar list * tyid * con list * info
and con = conid * typ option * info
and exnbind = con 
and strdec =
   SimpleDec	of dec * info
 | StrDec	of strbind list * info
 | SeqStrDec	of strdec list * info
   
and strbind = strid * (sigexp option) * strexp * info
and fctarg = strid * sigexp * info (* not used *)
and fctdec = fctid * fctarg list * sigexp option * strexp * info (* not used *)
and sigdec = sigbind list * info  (* not used *)
and sigbind = sigid * sigexp * info (* not used *)

and strexp =
   VarStr 	of strlongid * info
 | StrStr	of strdec * info
 | SigStr	of strexp * sigexp * info
 | FctAppStr	of fctid * strexp list * info

and sigexp = 
   VarSig	of sigid * info
 | SigSig	of spec * info
 | ConstraintSig of sigexp * 
                    ((tyvar list * tylongid * typ * info) list * info) * info (* where *)

and spec =         
   ValSpec	of valdesc list * info
 | TypeSpec	of typedesc list * info
 | ExnSpec	of exndesc list * info
 | IncludeSpec	of sigexp * info
 | StrSpec	of strdesc list * info
 | SeqSpec	of spec list * info

and valdesc = varid * typ * info

and typedesc =
   TypeDesc of tyvar list * tyid * info
 | TypeBindDesc of tyvar list * tyid * typ * info
 | DataDesc of tyvar list * tyid * con list * info

and exndesc = con 

and strdesc = strid * sigexp * info

and longtypebind = tyvar list * tylongid * typ * info (* not used *)

and topdec =
   Sig		of ((sigid * sigexp * info) list * info) * info
 | Fct		of (fctid * (strid * sigexp * info) list * strexp * info) * info
 | Str		of strdec * info
 | SeqTopDec	of topdec list * info


open Format

val enable_syn_info_print = ref false

fun pp_loc l =
  if !enable_syn_info_print
  then Syninfo.print l
  else ()

fun pp_realloc l = () (* 
       Syninfo.print l *)

fun pp_list f del l =
  case l of
    [] => printf "\nNull list error\n"
  | hd::tl => let fun pp_rest t = (del(); f t) in
          f hd;
          List.iter pp_rest tl
      end

fun pp_tyvar (s,loc) = (printf "'"; print_tyvarinfo s; pp_loc loc)

fun pp_tyvars l =
  case l of
    [] => ()
  | [ty] => (pp_tyvar ty; printf " ")
  | l => (printf "(";
          pp_list pp_tyvar (fn _=> printf ", ") l;
          printf ") ")

fun pp_varid (v,loc) = (print_varidinfo v; pp_loc loc)
fun pp_tyid (v,loc) = (print_tyidinfo v; pp_loc loc)
fun pp_conid (v,loc) = (print_conidinfo v; pp_loc loc)
fun pp_strid (v,loc) = (print_stridinfo v; pp_loc loc)
fun pp_sigid (v,loc) = (print_sigidinfo v; pp_loc loc)
fun pp_fctid (v,loc) = (print_fctidinfo v; pp_loc loc)
fun pp_label (v,loc) = (print_labelinfo v; pp_loc loc)

fun pp_varlongid (l,v,loc) = (
 (case l of
    [] => pp_varid v
  | l  => (pp_list pp_strid (fn _=>printf ".") l;
           printf "."; pp_varid v));
  pp_loc loc)
fun pp_tylongid (l,v,loc) = (
 (case l of
    [] => pp_tyid v
  | l  => (pp_list pp_strid (fn _=>printf ".") l;
          printf "."; pp_tyid v));
  pp_loc loc)
fun pp_conlongid (l,v,loc) = (
 (case l of
    [] => pp_conid v
  | l  => (pp_list pp_strid (fn _=>printf ".") l;
          printf "."; pp_conid v));
  pp_loc loc)
fun pp_strlongid (l,v,loc) = (
 (case l of
    [] => pp_strid v
  | l  => (pp_list pp_strid (fn _=>printf ".") l;
          printf "."; pp_strid v));
  pp_loc loc)

fun pp_ty ty = (printf "["; PrintTypes.pp ty; printf "]")

fun pp_typ(_,ty) = pp_ty ty

fun pp_con (id, tyop,loc) = (
  pp_conid id;
  (case tyop of
    None => ()
  | Some(ty) => printf " of "; pp_typ ty);
  pp_loc loc)

fun pp_patrow (l, p,loc) = (
  pp_label l; printf " = "; pp_pat p; pp_loc loc)

and pp_pat p = 
  case p of
    WildPat(ty,loc) => (printf "_"; pp_ty ty; pp_loc loc)
  | UnitPat(loc) => (printf "()"; pp_loc loc)
  | IntPat (i,loc) => (print_int i; pp_loc loc)
  | StringPat (s,loc) => (
      printf "\""; print_string (String.escaped s); printf "\""; pp_loc loc)
  | CharPat (c,loc) => (
      printf "'"; print_string (Char.escaped c); printf "'"; pp_loc loc)
  | RecordPat (l,ty,loc) => (
      printf "{";
      pp_list pp_patrow (fn () => printf ", ") l;
      printf "}"; pp_ty ty; pp_loc loc)
  | SubRecordPat (l,ty,loc) => (
      printf "{";
      pp_list pp_patrow (fn () => printf ", ") l;
      printf ", ...";
      printf "}"; pp_ty ty; pp_loc loc)
  | RefPat (p,ty,loc) => (printf "(ref "; pp_pat p; printf ")" ; pp_ty ty; pp_loc loc)
  | VarPat (l,ty,loc) => (pp_varid l; pp_ty ty; pp_realloc loc; (* debug *) pp_loc loc)
  | ConPat (l,ty,loc) => (pp_conlongid l; pp_ty ty; pp_loc loc)
  | AppPat (l, p, ty, loc) => (
      printf "("; pp_conlongid l; printf " "; pp_pat p; printf ")"; 
      pp_ty ty; pp_loc loc)
  | AsPat (id, p, ty, loc) => (
      printf "(";
      pp_varid id;
      pp_ty ty;
      printf " as ";
      pp_pat p;
      printf ")"; pp_loc loc)
  | TuplePat (l,ty,loc) => (
      printf "(";
      pp_list pp_pat (fn () => printf ", ") l;
      printf ")"; pp_ty ty; pp_loc loc)
  | ListPat ([],ty,loc) => (printf "[]"; pp_ty ty; pp_loc loc)
  | ListPat (l,ty,loc) => (
      printf "[";
      pp_list pp_pat (fn () => printf ", ") l;
      printf "]"; pp_ty ty; pp_loc loc)
  | ArrayPat (l,ty,loc) => (
      printf "[|";
      pp_list pp_pat (fn () => printf ", ") l;
      printf "|]"; pp_ty ty; pp_loc loc)
  | OrPat (l,ty, loc) => (
      pp_list pp_pat (fn () => printf " | ") l; pp_ty ty; pp_loc loc)
  | ConstraintPat(p, ty, loc) => pp_pat p

fun pp_exprow (l, e,loc) =
  (pp_label l; printf " = "; pp_exp e; pp_loc loc)

and pp_rule (p,e,loc) =
  (pp_pat p; printf " => "; pp_exp e; pp_loc loc)

and pp_fnrule (l,e,loc) =
  (pp_list pp_pat (fn () => printf " ") l;
   printf " => "; pp_exp e; pp_loc loc)

and pp_exp p =
  case p of
    UnitExp (loc) => (printf "()"; pp_loc loc)
  | IntExp (i,loc) => (print_int i; pp_loc loc)
  | RealExp (f,loc) => (print_string f; pp_loc loc)
  | StringExp (s,loc) =>
      (printf "\""; print_string (String.escaped s); printf "\""; pp_loc loc)
  | CharExp (c,loc) =>
      (printf "'"; print_string (Char.escaped c); printf "'"; pp_loc loc)
  | VarExp (l,ty,loc) => (pp_varlongid l; pp_ty ty; pp_loc loc)
  | ConExp (l,ty,loc) => (pp_conlongid l; pp_ty ty; pp_loc loc)
  | AppExp (e, a,ty,loc) => (
      printf "("; pp_exp e; printf " "; pp_exp a; printf ")"; pp_ty ty; pp_loc loc)
  | RecordExp (l,ty,loc) => (
      printf "@[<1>{";
      pp_list pp_exprow (fn () => printf ",@ ") l;
      printf "@]}"; pp_ty ty; pp_loc loc)
  | RecordFieldExp (e, l,ty,loc) => (
      printf "("; pp_exp e; printf "."; pp_label l; printf ")"; pp_ty ty;
      pp_loc loc)
  | ArrayFieldExp (e, e',ty,loc) => (
      printf "("; pp_exp e; printf ".["; pp_exp e'; printf "])";
      pp_ty ty; pp_loc loc)
  | UpdateArrayExp (e, e', e'',ty,loc) => (
      printf "("; pp_exp e; printf ".["; pp_exp e'; printf "]";
      printf " <- "; pp_exp e''; printf ")"; pp_ty ty; pp_loc loc)
  | SubstRecordExp (e, l, e',ty,loc) => (
      printf "("; pp_exp e; printf "{";
      pp_exp e'; printf "<-"; pp_label l; printf "})"; pp_ty ty; pp_loc loc)
  | TupleExp (l,ty,loc) => (
      printf "@[<1>(";
      pp_list pp_exp (fn () => printf ",@ ") l;
      printf "@])"; pp_ty ty; pp_loc loc)
  | ListExp ([],ty,loc) => (printf "[]"; pp_ty ty; pp_loc loc)
  | ListExp (l,ty,loc) => (
      printf "@[<1>[";
      pp_list pp_exp (fn () => printf ",@ ") l;
      printf "@]]"; pp_ty ty; pp_loc loc)
  | ArrayExp (l,ty,loc) => (
      printf "@[<1>[|";
      pp_list pp_exp (fn () => printf ",@ ") l;
      printf "@]|]"; pp_ty ty; pp_loc loc)
  | LetExp (d, e,ty,loc) => (
      printf "@[@[<2>let@\n";
      pp_dec d;
      printf "@]@\n@[<2>in ";
      pp_exp e;
      printf "@]@\nend@]"; pp_ty ty; pp_loc loc)
  | HandleExp (e, l,ty,loc) => (
      printf "(";
      pp_exp e;
      printf " @[<2>handle ";
      pp_list pp_rule (fn () => printf "@\n| ") l;
      printf "@])"; pp_ty ty; pp_loc loc)
  | RaiseExp (e,ty,loc) => (
      printf "@[<3>(raise@ "; pp_exp e; printf "@])"; pp_ty ty; pp_loc loc)
  | FnExp (l,ty,loc) => (
      printf "(@[<2> fn ";
      pp_list pp_fnrule (fn () => printf "@\n| ") l;
      printf "@])"; pp_ty ty; pp_loc loc)
  | AssignExp (e, e',ty,loc) => (
      printf "@[<3>("; pp_exp e; printf " :=@ "; pp_exp e';
      printf "@])"; pp_ty ty; pp_loc loc)
  | RefExp (e,ty,loc) => (
      printf "@[<3>(ref@ "; pp_exp e; printf "@])"; pp_ty ty; pp_loc loc)
  | DeRefExp (e,ty,loc) => (
      printf "(! "; pp_exp e; printf ")"; pp_ty ty; pp_loc loc)
  | SeqExp (l,ty,loc) => (
      printf "@[<1>(";
      pp_list pp_exp (fn () => printf ";@ ") l;
      printf "@])"; pp_ty ty; pp_loc loc)
  | CaseExp (e, l,ty,loc) => (
      printf "(@[<2>case ";
      pp_exp e;
      printf " of ";
      pp_list pp_rule (fn () => printf "@\n| ") l;
      printf "@])"; pp_ty ty; pp_loc loc)
  | IfExp (e, e', e'',ty,loc) => (
      printf "(@[if "; pp_exp e; printf "@ @[<2>then@ "; pp_exp e';
      printf "@]@ @[<2>else@ "; pp_exp e''; printf "@]@])" ; pp_ty ty; pp_loc loc)
  | WhileExp (e, e',ty,loc) => (
      printf "@[while "; pp_exp e; printf "@\ndo @["; pp_exp e';
      printf "@]@\nend@]" ; pp_ty ty; pp_loc loc)
  | ForExp (id, e, e', e'', e''',ty,loc) => (
      printf "@[for "; pp_varid id; printf " = "; pp_exp e;
      printf "; "; pp_exp e'; printf "; "; pp_exp e'';
      printf "@\ndo @["; pp_exp e'''; printf "@]@\nend@]"; pp_ty ty; pp_loc loc)
  | ConstraintExp(e, _, _) => pp_exp e

and pp_valbind (r, p, e, loc) = (
  printf "@[<3>"; (if r = Rec then printf "rec ");
  pp_pat p; printf " =@ ";
  pp_exp e; 
  printf "@]"; pp_loc loc)

and pp_funbind (l,loc) = (
  let
    fun pp_body (id,pl,e,loc) = (
      pp_varid id; printf " ";
      pp_list pp_pat (fn () => printf " ") pl; printf " =@ ";
      pp_exp e; pp_loc loc)
    in
      printf "@[";
      pp_list pp_body (fn () => printf "@]@ @[<2>| ") l;
      printf "@]"
  end;
  pp_loc loc)

and pp_typebind p = 
  case p of
    TypeBind (tyvs, id, ty,loc) => (
      pp_tyvars tyvs;
      pp_tyid id; printf " = "; pp_typ ty;
      pp_loc loc)
  | DataBind (tyvs, id, cl,loc) => (
      pp_tyvars tyvs;
      pp_tyid id; printf " = ";
      printf "@[";
      pp_list pp_con (fn () => printf " |@ ") cl;
      printf "@]";
      pp_loc loc)
and pp_exnbind (c) = pp_con c

and pp_dec p =
  case p of
    ValDec (tyvs, l, _, loc) => (
      printf "val ";
      pp_tyvars tyvs;
      pp_list pp_valbind (fn () => printf "@\nand ") l;
      pp_loc loc)
(*
  | RecValDec (tyvs, l, _, loc) => (
      printf "val rec ";
      pp_tyvars tyvs;
      pp_list pp_valbind (fn () => printf "@\nand ") l;
      pp_loc loc)
*)
(*  | FunDec (tyvs, l, _, loc) => (
      printf "@[<2>fun ";
      pp_tyvars tyvs;
      pp_list pp_funbind (fn () => printf "@]@\n@[<2>and ") l;
      printf "@]";
      pp_loc loc)
*)
  | TypeDec (l,loc) => (
      printf "type ";
      pp_list pp_typebind (fn () => printf "@\nand ") l;
      pp_loc loc)
  | ExceptionDec (l,loc) => (
      printf "@[<2>exception ";
      pp_list pp_exnbind (fn () => printf "@ and ") l;
      printf "@]";
      pp_loc loc)
  | LocalDec (d, d',loc) => (
      printf "@[<2>local@\n";
      pp_dec d;
      printf "@]@\n@[<2>in";
      pp_dec d';
      printf "@]@\nend";
      pp_loc loc)
  | OpenDec _
  | SeqDec([],_) => ()
  | SeqDec (l,loc) => (
      pp_list pp_dec (fn () => printf ";@ ") l;
      pp_loc loc)

fun pp_longtypebind (tyvs, l, ty,loc) = (
  pp_tyvars tyvs; printf " ";
  pp_tylongid l;
  pp_typ ty;
  pp_loc loc)

fun pp_where (l,loc) =(
  printf "@[<2> where type ";
  pp_list pp_longtypebind (fn () => printf "@, and ") l;
  printf "@]";
  pp_loc loc)

fun pp_valdesc (id, t,loc) = (
  pp_varid id; pp_typ t; pp_loc loc)

fun pp_typedesc p =
  case p of
    TypeDesc (tyvs, id,loc) => (
      pp_tyvars tyvs; printf " ";
      pp_tyid id;
      pp_loc loc)
  | TypeBindDesc (tyvs, id, ty,loc) => (
      pp_tyvars tyvs;
      pp_tyid id; pp_typ ty;
      pp_loc loc)
  | DataDesc (tyvs, id, cl, loc) => (
      pp_tyvars tyvs; printf " ";
      pp_tyid id; printf " = ";
      printf "@[";
      pp_list pp_con (fn () => printf " |@ ") cl;
      printf "@]";
      pp_loc loc)

fun pp_exndesc (c) = pp_con c

fun pp_strdesc (id, se,loc) = (
  pp_strid id; printf " : "; pp_sigexp se; pp_loc loc)

and pp_spec p =
  case p of
    ValSpec (l,loc) =>(
      printf "@[<2>val ";
      pp_list pp_valdesc (fn () => printf "@]@\n@[<2>and ") l;
      printf "@]";
      pp_loc loc)
  | TypeSpec (l,loc) => (
      printf "type ";
      pp_list pp_typedesc (fn () => printf "@\nand ") l;
      pp_loc loc)
  | ExnSpec (l,loc) => (
      printf "@[<2>exception ";
      pp_list pp_exndesc (fn () => printf "@ and ") l;
      printf "@]";
      pp_loc loc)
  | IncludeSpec (s,loc) => (
      printf "@[<2>include ";
      pp_sigexp s;
      printf "@]";
      pp_loc loc)
  | StrSpec (l,loc) => (
      printf "@[<2>structure ";
      pp_list pp_strdesc (fn () => printf "@\nand ") l;
      printf "@]";
      pp_loc loc)
  | SeqSpec (l,loc) =>(
      pp_list pp_spec (fn () => printf "@\n") l;
      pp_loc loc)

and pp_sigexp p =
  case p of
    VarSig (s,loc) => (pp_sigid s; pp_loc loc)
  | SigSig (s,loc) => (
      printf "@\n@[<2>sig @\n";
      pp_spec s;
      printf "@]@\nend";
      pp_loc loc)
  | ConstraintSig (se, wh,loc) => (
      pp_sigexp se;
      printf "@\n@  ";
      pp_where wh;
      pp_loc loc)

fun pp_sigexpop p =
  case p of
    None => ()
  | Some(s) => (printf " : "; pp_sigexp s)

fun pp_sigbind (id, s, loc) = (
  pp_sigid id ; printf " = "; pp_sigexp s; pp_loc loc)

fun pp_sigdec (l,loc) = (
  printf "@[<2>signature ";
  pp_list pp_sigbind (fn () => printf "@]@\n@[<2>and ") l;
  printf "@]";
  pp_loc loc)

fun pp_strexp p = 
  case p of
    VarStr (l,loc) => (pp_strlongid l; pp_loc loc)
  | StrStr (d,loc) => (
      printf "@\n@[<2>struct@\n";
      pp_strdec d;
      printf "@]@\nend"; pp_loc loc)
  | SigStr (ste, sie,loc) => (
      pp_strexp ste; printf " : "; pp_sigexp sie; pp_loc loc)
  | FctAppStr (id, sl,loc) => (
      pp_fctid id; printf " (";
      pp_list pp_strexp (fn () => printf ",@ ") sl;
      printf ")"; pp_loc loc)


and pp_strbind (id, sgop, se,loc) = (
  pp_strid id; pp_sigexpop sgop;
  printf " = "; pp_strexp se; pp_loc loc)

and pp_strdec p = 
  case p of
    SimpleDec (d,loc) => (pp_dec d; pp_loc loc)
  | StrDec (l,loc) => (
      printf "@[<2>structure ";
      pp_list pp_strbind (fn () => printf "@]@\n@[<2>and ") l;
      printf "@]"; pp_loc loc)
  | SeqStrDec (l,loc) => (
      pp_list pp_strdec (fn () => printf ";@\n") l; pp_loc loc)

fun pp_fctarg (id, se, loc) = (
  pp_strid id; printf " : "; pp_sigexp se; pp_loc loc)

fun pp_whereop p =
  case p of
    None => ()
  | Some(w) => (printf " "; pp_where w)

fun pp_fctdec p =
  case p of
    (id, al, se, loc) => (
      printf "@[<2>functor ";
      pp_fctid id;
      printf " (@[";
      pp_list pp_fctarg (fn () => printf ",@ ") al;
      printf "@])";
      printf " =@ ";
      pp_strexp se;
      printf "@]";
      pp_loc loc)

fun pp_topdec p =
  case p of
    Sig (d,loc) => (pp_sigdec d; pp_loc loc)
  | Fct (d,loc) => (pp_fctdec d; pp_loc loc)
  | Str (d,loc) => (pp_strdec d; pp_loc loc)
  | SeqTopDec (dl,loc) => (
      let
        fun pp_one d = (pp_topdec d; printf ";@\n")
        in printf "@[";List.iter pp_one dl;printf "@]"
      end;
      pp_loc loc)

val pp = pp_topdec

fun patTyInfo pat = case pat of 
    WildPat x => x
  | UnitPat i => (Types.type_unit,i)
  | IntPat (_,i) => (Types.type_int,i)
  | StringPat (_,i) => (Types.type_string,i)
  | CharPat (_,i) => (Types.type_char,i)
  | VarPat (_,t,i)
  | ConPat (_,t,i)
  | AppPat (_,_,t,i)
  | RecordPat (_,t,i)
  | SubRecordPat (_,t,i)
  | RefPat (_,t,i)
  | AsPat (_,_,t,i)
  | TuplePat (_,t,i)
  | ListPat (_,t,i)
  | ArrayPat (_,t,i)
  | OrPat (_,t,i) => (t,i)
  | ConstraintPat(p,_,i) => let val (t,_) = patTyInfo p in (t,i) end

fun patInfo pat = let val (t,i) = patTyInfo pat in i end
fun patTy pat = let val (t,i) = patTyInfo pat in t end
fun patLoc pat = Syninfo.loc (patInfo pat)

fun expTyInfo exp = case exp of 
    UnitExp i => (Types.type_unit,i)
  | IntExp (_,i) => (Types.type_int,i)
  | RealExp (_,i) => (Types.type_real,i)
  | StringExp (_,i) => (Types.type_string,i)
  | CharExp (_,i) => (Types.type_char,i)
  | VarExp (_,t,i)
  | ConExp (_,t,i)
  | AppExp (_,_,t,i) 
  | RecordExp (_,t,i) 
  | RecordFieldExp (_,_,t,i) 
  | ArrayFieldExp (_,_,t,i) 
  | UpdateArrayExp (_,_,_,t,i)
  | SubstRecordExp (_,_,_,t,i)
  | TupleExp (_,t,i)
  | ListExp (_,t,i)
  | ArrayExp (_,t,i)
  | LetExp (_,_,t,i)
  | HandleExp (_,_,t,i)
  | RaiseExp (_,t,i)
  | FnExp (_,t,i)
  | AssignExp (_,_,t,i)
  | RefExp (_,t,i)
  | DeRefExp (_,t,i)
  | SeqExp (_,t,i)
  | CaseExp (_,_,t,i)
  | IfExp (_,_,_,t,i)
  | WhileExp (_,_,t,i)
  | ForExp (_,_,_,_,_,t,i) => (t,i)
  | ConstraintExp(e,_,i) => let val (t,_) = expTyInfo e in (t,i) end

fun expInfo exp = let val (t,i) = expTyInfo exp in i end
fun expTy exp = let val (t,i) = expTyInfo exp in t end
fun expLoc exp = Syninfo.loc (expInfo exp)

exception Found of Types.ty option

fun type_of absyn location = let
  fun comp l = Location.loc_compare location l
  fun issub i = (comp(Syninfo.loc i) = Location.SUBSET) 
  fun dolist nil = None
    | dolist (h::t) = case h() of None => dolist t | x => x
  fun foldl f nil = None
    | foldl f (h::t) = let val a = f h in
        case a of None => foldl f t | x => x end
  fun array_foldl f a = 
        (Array.iter (fn e => (case f e of None => () | b => raise Found b)) a; None)
           handle Found x => x
  fun pat p = case comp (patLoc p) of
      Location.EQUAL => Some (patTy p)
    | Location.SUBSET => (case p of
        RefPat (p,_,_) 
      | AsPat (_,p,_,_) 
      | AppPat (_,p,_,_) => pat p
      | SubRecordPat(lpl,_,_)
      | RecordPat(lpl,_,_) => foldl (fn(_,p,_)=>pat p) lpl
      | OrPat(pl,_,_)
      | ArrayPat(pl,_,_)
      | ListPat(pl,_,_)
      | TuplePat(pl,_,_) => foldl pat pl
      | _ => None
     )
    | _ => None

  and exp e = case comp (expLoc e) of 
    Location.EQUAL => Some(expTy e)
  | Location.SUBSET => (case e of
      RecordFieldExp(e,_,_,_)
    | RaiseExp(e,_,_) 
    | RefExp(e,_,_) 
    | DeRefExp(e,_,_) => exp e
    | AppExp(e1,e2,_,_)
    | ArrayFieldExp(e1,e2,_,_)
    | AssignExp(e1,e2,_,_)
    | WhileExp(e1,e2,_,_)
    | SubstRecordExp(e1,_,e2,_,_) => foldl exp [e1,e2]
    | IfExp(e1,e2,e3,_,_) 
    | UpdateArrayExp(e1,e2,e3,_,_) => foldl exp [e1,e2,e3]
    | ForExp(_,e1,e2,e3,e4,_,_) => foldl exp [e1,e2,e3,e4]
    | TupleExp(el,_,_)
    | ListExp(el,_,_)
    | ArrayExp(el,_,_) 
    | SeqExp(el,_,_) => foldl exp el
    | RecordExp(lel,_,_) => foldl (fn(_,e,_)=>exp e) lel
    | LetExp(d,e,_,_) => dolist [fn _=>dec d, fn _=>exp e]
    | CaseExp(e,rl,_,_)
    | HandleExp(e,rl,_,_) => 
        dolist [fn _=>exp e, 
                fn _=>foldl (fn(p,e,_)=>dolist [fn _=>pat p,fn _=>exp e]) rl]
    | FnExp(fl,_,_) => 
        foldl (fn(pl,e,_)=>dolist [fn _=>foldl pat pl, fn _=>exp e]) fl     
    | _ => None
   )
  | _ => None  
  
  and dec d = case d of
      ValDec(_,vbl,_,i) => if issub i then foldl valbind vbl else None
 (*   | FunDec(_,fbl,_, i) => if issub i then foldl funbind fbl else None *)
    | LocalDec(d1,d2,i) => if issub i then foldl dec [d1,d2] else None
    | SeqDec(dl,i) => if issub i then foldl dec dl else None
    | _ => None   

  and valbind (b,p,e,i) = if issub i then dolist [fn _=>pat p,fn _=>exp e] 
                                     else None
  and funbind (bl,i) = if issub i then foldl body bl else None
  and body (_,pl,e,i) = if issub i then dolist [fn _=>foldl pat pl,fn _=>exp e] else None

  and strdec sd = case sd of
      SimpleDec(d,i) => if issub i then dec d else None
    | StrDec(sbl,i) => if issub i then foldl (fn(_,_,se,_) => strexp se) sbl else None
    | SeqStrDec(sdl,i) => if issub i then foldl strdec sdl else None

  and strexp se = case se of 
      StrStr(sd,i) => if issub i then strdec sd else None
    | SigStr(se,_,i) => if issub i then strexp se else None
    | FctAppStr(_,sel,i) => if issub i then foldl strexp sel else None
    | _ => None

  and fctdec (_,_,se,i) = if issub i then strexp se else None

  and topdec td = case td of
      Fct(fd,i) => if issub i then fctdec fd else None
    | Str(sd,i) => if issub i then strdec sd else None
    | SeqTopDec(tdl,i) => if issub i then foldl topdec tdl else None
    | _ => None
in
  topdec absyn 
end
  
end

structure Absyn = Absyn_generator
  (Info.StringInfo, Info.LocationInfo, Ty, TyPrint)

(*
 Modification history.

 2000/07/12 By Cookcu
 - Annotate "types" naively.

 2000/03/27 By Judaigi

 - Remove DataDec and merge it in TypeDec.
 - Remove DataSpec and merge it in TypeSpec.
 - Remove pec and merge it in TypeSpec.

 2000/02/24 By Judaigi

 - Remove eqtypeness from 'tyvar' def.
 - Remove 'sharing' option from 'FctDec'.
 - Add 'TypeBindSpec' to 'spec' def. 
 - Remove 'ContraintSpec' from 'spec' def.
 - Remove 'sharing' type.
 - Remove 'tylongideq' type.
*)