(*
 Oukseh Lee

 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.
*)

structure Absyn2Ast = struct
  structure I = Absyn
  structure A = String_ast.Ast

  val map = List.map
  fun typ (t,_) = ty t
  and con (i,Some(t,_),a) = (i,Some(ty t),a)
    | con (i,None,a) = (i,None,a)
  and ty t = t

  fun rec_flag I.Rec = A.Rec
    | rec_flag I.Nonrec = A.Nonrec

  fun pat p = case p of
        I.WildPat(_,a) => A.WildPat a
      | I.UnitPat a => A.UnitPat a
      | I.IntPat(i,a) => A.IntPat(i,a)
      | I.StringPat(s,a) => A.StringPat(s,a)
      | I.CharPat(c,a) => A.CharPat(c,a)
      | I.VarPat(i,_,a) => A.VarPat(i,a)
      | I.ConPat(i,_,a) => A.ConPat(i,a)
      | I.AppPat(i,p,_,a) => A.AppPat(i,pat p,a)
      | I.RecordPat(l,_,a) => A.RecordPat(map labpat l,a)
      | I.SubRecordPat(l,_,a) => A.SubRecordPat(map labpat l,a)
      | I.RefPat(p,_,a) => A.RefPat(pat p,a)
      | I.AsPat(i,p,_,a) => A.AsPat(i,None,pat p,a)
      | I.TuplePat(l,_,a) => A.TuplePat(map pat l,a)
      | I.ListPat(l,_,a) => A.ListPat(map pat l,a)
      | I.ArrayPat(l,_,a) => A.ArrayPat(map pat l,a)
      | I.OrPat(l,_,a) => A.OrPat(map pat l,a)
      | I.ConstraintPat(p,t,a) => A.ConstraintPat(pat p,ty t,a)

  and labpat(l,p,a) = (l,pat p,a)

  val count = ref 0
  fun new_variable loc = 
    let val c = !count
    in  count := !count + 1;
        ("@absyn2ast"^string_of_int(c),loc)
    end

  fun select loc e n k =
    let val x = new_variable loc
        fun f n i = if i=n then []
                    else if i=k then A.VarPat(x,loc)::(f n (i+1))
                    else A.WildPat(loc)::(f n (i+1))
    in  A.AppExp(
          A.FnExp([([A.TuplePat(f n 0, loc)], A.VarExp(([],x,loc), loc), loc)], loc),
          [e], loc)
    end 
  fun exp e = case e of
        I.UnitExp a => A.UnitExp a
      | I.IntExp(i,a) => A.IntExp(i,a)
      | I.RealExp(s,a) => A.RealExp(s,a)
      | I.StringExp(s,a) => A.StringExp(s,a)
      | I.CharExp(c,a) => A.CharExp(c,a)
      | I.VarExp(i,_,a) => A.VarExp(i,a)
      | I.ConExp(i,_,a) => A.ConExp(i,a)
      | I.AppExp(I.VarExp(i as ([],(s,a),b),_,c),e2,_,d) =>
          if List.mem s ["+","-","*","/","**","unary_minus","<",">","<=",">="] then
            A.AppExp(A.VarExp(i,c),[exp' e2],d)
          else if List.mem s ["++","--","+=","-=","*="] then
            A.AppExp(A.VarExp(i,c),[exp'' e2],d)
          else 
            A.AppExp(A.VarExp(i,c),[exp e2],d)
      | I.AppExp(e1,e2,_,a) => A.AppExp(exp e1,[exp e2],a)
      | I.RecordExp(l,_,a) => A.RecordExp(map (fn(l,e,a)=>(l,exp e,a)) l,a)
      | I.RecordFieldExp(e,(l,b),t,a) => (
          (case (Ty.unlink(I.expTy e), int_of_string l) of 
            (Ty.Tuple l, i) => select a (exp e) (List.length l) i
           | (t,i) => (TyPrint.typ t; Format.printf ", %d@." i;
                       A.RecordFieldExp(exp e,(l,b),a)))
          handle Failure "int_of_string" => A.RecordFieldExp(exp e,(l,b),a))
      | I.ArrayFieldExp(e1,e2,_,a) => A.ArrayFieldExp(exp e1,exp e2,a)
      | I.UpdateArrayExp(e1,e2,e3,_,a) => A.UpdateArrayExp(exp e1,exp e2,exp e3,a)
      | I.SubstRecordExp(e1,l,e2,_,a) => A.SubstRecordExp(exp e1,l,exp e2,a)
      | I.TupleExp(l,_,a) => A.TupleExp(map exp l,a)
      | I.ListExp(l,_,a) => A.ListExp(map exp l,a)
      | I.ArrayExp(l,_,a) => A.ArrayExp(map exp l,a)
      | I.SeqExp(l,_,a) => A.SeqExp(map exp l,a)
      | I.LetExp(d,e,_,a) => A.LetExp(dec d,exp e,a)
      | I.HandleExp(e,l,_,a) => A.HandleExp(exp e,map rule l,a)
      | I.RaiseExp(e,_,a) => A.RaiseExp(exp e,a)
      | I.FnExp(l,_,a) => A.FnExp(map fnrule l,a)
      | I.AssignExp(e1,e2,_,a) => A.AssignExp(exp e1,exp e2,a)
      | I.RefExp(e,_,a) => A.RefExp(exp e,a)
      | I.DeRefExp(e,_,a) => A.DeRefExp(exp e,a)
      | I.CaseExp(e,l,_,a) => A.CaseExp(exp e,map rule l,a)
      | I.IfExp(e1,e2,e3,_,a) => A.IfExp(exp e1,exp e2,exp e3,a)
      | I.WhileExp(e1,e2,_,a) => A.WhileExp(exp e1,exp e2,a)
      | I.ForExp(i,e1,e2,e3,e4,_,a) => A.ForExp(i,exp e1,exp e2,exp e3,exp e4,a)
      | I.ConstraintExp(e,t,a) => A.ConstraintExp(exp e,ty t,a)

  and exp' e = (* for fixing overloaded operators' types *)
    let val (tau,l) = I.expTyInfo e
        val e' = exp e
        fun atype s = A.ConstTy([],([],(s,Location.none),Location.none),Location.none)
    in  case Ty.get_predef tau of
        None => e'
      | Some "int" => A.ConstraintExp(e', atype "int", l)
      | Some "real" => A.ConstraintExp(e', atype "real", l)
      | Some "char" => A.ConstraintExp(e', atype "char", l)
      | Some "string" => A.ConstraintExp(e', atype "string", l)
      | Some _ => e'
    end
  and exp'' e = (* for fixing overloaded operator's types *)
    let val (tau,l) = I.expTyInfo e
        val e' = exp e
        fun atype s = 
              A.ConstTy(
                [A.ConstTy([],([],(s,Location.none),Location.none),Location.none)],
                ([],("ref",Location.none),Location.none),
                Location.none)
    in  case Ty.get_ref_predef tau of
        None => e'
      | Some "int" => A.ConstraintExp(e', atype "int", l)
      | Some "real" => A.ConstraintExp(e', atype "real", l)
      | Some _ => e'
    end

  and fnrule(l,e,a) = (map pat l,exp e,a)
  and rule(p,e,a) = (pat p,exp e,a)

  and dec d = case d of
        I.ValDec(l,l',_,a) => A.ValDec(l,map valbind l',a)
      | I.TypeDec(l,a) => A.TypeDec(map typebind l,a)
      | I.ExceptionDec(l,a) => A.ExceptionDec(map con l,a)
      | I.LocalDec(d,e,a) => A.LocalDec(dec d,dec e,a)
      | I.OpenDec(i,a) => A.OpenDec(i,a)
      | I.SeqDec(l,a) => A.SeqDec(map dec l,a)
  and valbind(r,p,e,a) = (rec_flag r,pat p,exp e,a)
  and funbind(l,a) = (map (fn(i,l,e,a)=>(i,map pat l,exp e,a)) l,a)
  and typebind t = case t of
        I.TypeBind(l,i,t,a) => A.TypeBind(l,i,typ t,a)
      | I.DataBind(l,i,l',a) => A.DataBind(l,i,map con l',a)

  fun spec p = case p of
        I.ValSpec(l,a) => A.ValSpec(map (fn(i,t,a)=>(i,typ t,a)) l,a)
      | I.TypeSpec(l,a) => A.TypeSpec(map typedesc l,a)
      | I.ExnSpec(l,a) => A.ExnSpec(map con l,a)
      | I.IncludeSpec(g,a) => A.IncludeSpec(sigexp g,a)
      | I.StrSpec(l,a) => A.StrSpec(map (fn(i,g,a) =>(i,sigexp g,a)) l,a)
      | I.SeqSpec(l,a) => A.SeqSpec(map spec l,a)
  and typedesc d = case d of
        I.TypeDesc(l,i,a) => A.TypeDesc(l,i,a)
      | I.TypeBindDesc(l,i,t,a) => A.TypeBindDesc(l,i,typ t,a)
      | I.DataDesc(l,i,m,a) => A.DataDesc(l,i,map con m,a)

  and strexp e = case e of
        I.StrStr(d,a) => A.StrStr(strdec d,a)
      | I.VarStr(i,a) => A.VarStr(i,a)
      | I.SigStr(s,g,a) => A.SigStr(strexp s, sigexp g, a)
      | I.FctAppStr(i,l,a) => A.FctAppStr(i, map strexp l, a)
  and sigexp g = case g of
        I.VarSig(i,a) => A.VarSig(i,a)
      | I.SigSig(p,a) => A.SigSig(spec p,a)
      | I.ConstraintSig(g,(l,b),a) =>
          A.ConstraintSig(sigexp g,
                          (map (fn(l,i,t,a) => (l,i,typ t,a)) l,b),
                          a)
  and strdec d = case d of
        I.SimpleDec(d,a) => A.SimpleDec(dec d,a)
      | I.StrDec(l,a) => 
          A.StrDec(map (fn (i,None,s,a)=>(i,None,strexp s,a)
                         | (i,Some g,s,a) => (i,Some(sigexp g),strexp s,a)) l,
                   a)
      | I.SeqStrDec(l,a) => A.SeqStrDec(map strdec l,a)
 
  fun topdec p = case p of
        I.Sig((l,a),b) =>
          A.Sig((map (fn (a,b,c) => (a,sigexp b,c)) l,a),b)
      | I.Fct((i,l,s,a),loc) => 
          A.Fct((i, map (fn(a,b,c)=>(a,sigexp b,c)) l,None,strexp s,a), loc)
      | I.Str(d,a) => A.Str(strdec d,a)
      | I.SeqTopDec(l,a) => A.SeqTopDec(map topdec l,a)
end