(*
 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.
*)
	   
(* After removing records,
   there is no record in absyn:
     - no Ty.Rec type.
     - no RecordTy type expression.
     - no RecordPat, SubRecordPat pattern.
     - no RecordExp, RecordFieldExp, SubstRecordExp expression.
   Every record is translated into a tuple (orderd by labels)

   If such assumption is broken, please report to cookcu@ropas.kaist.ac.kr.
*)

structure Remove_record : 
  sig
    val topdec : Absyn.topdec -> Absyn.topdec
  end = 
struct
  structure A = String_ast.Ast
  open Absyn

  val loc = Location.none
  val map = List.map

  fun pc_handle (a,b,c,d) = HandleExp(a,b,c,d) (* .... -> exp *)
  fun pc_case (a,b,c,d) = CaseExp(a,b,c,d)     (* .... -> exp *)
  fun pc_fn (a,b,c) = FnExp(a,b,c)             (* ... -> exp *)
  fun pc_val (a,b,c,d) = ValDec(a,b,c,d)       (* .... -> dec *)
(*  fun pc_recval (a,b,c,d) = RecValDec(a,b,c,d) (* ... -> dec *) *)

  fun ty t = 
    let fun f t = case Ty.unlink t of
          Ty.Fun(t1,t2) => Ty.Fun(t1,t2)
        | Ty.Data(l,tn) => Ty.Data(map f l,tn)
        | Ty.Tuple l => Ty.Tuple(map f l)
        | Ty.Rec(r,s) => (case Ty.Row.flatten (r,s) of
            (r,None) => Ty.Tuple(map (fn(k,t)=>t) (Labm.to_list r))
          | _ => raise TyDebug.Bug "Record.ty")
        | t => t
    in  f t
    end

  fun tyexp t = 
    let fun f t = case t of
          A.ConstTy(l,i,a) => A.ConstTy(map f l,i,a)
        | A.RecordTy(l,a) =>
           let val l0 = List.sort (fn (l1,_,_) (l2,_,_) => compare l1 l2) l
               val l1 = map (fn(_,t,_) => t) l0
           in  A.TupleTy(map f l1,a)
           end 
        | A.TupleTy(l,a) => A.TupleTy(map f l,a)
        | A.FunTy(t1,t2,a) => A.FunTy(f t1,f t2,a)
        | _ => t
    in  f t 
    end

  fun typ (t,t') = (tyexp t, ty t')
  fun con (i,Some x,a) = (i,Some(typ x),a)
    | con (i,None,a) = (i,None,a)

       
  fun pat p = case p of
        WildPat(t,a) => WildPat(ty t,a)
      | VarPat(i,t,a) => VarPat(i,ty t,a)
      | ConPat(i,t,a) => ConPat(i,ty t,a)
      | AppPat(i,p,t,a) => AppPat(i,pat p,ty t,a)
      | RecordPat(l,t,a) => 
         let val l0 = List.sort (fn(l,_,_)(l',_,_)=>compare l l') l
             val l1 = map (fn (l,p,a)=>p) l0
         in  pat(TuplePat(l1,t,a))
         end
      | SubRecordPat(l,t,a) => 
         let val l0 = List.sort (fn(l,_,_)(l',_,_)=>compare l l') l
             val l1 = case Ty.unlink t of 
                        Ty.Rec(r,s) => let val (x,_) = Ty.Row.flatten (r,s) 
                                       in  x 
                                       end
                      | Ty.Tuple l => Ty.Row.of_tuple' l
                      | _ => raise TyDebug.Bug "Record.SubRecordPat.l1"
             fun f (l as (((l1,_),p,_)::t1)) ((l2,t)::t2) = 
                   if l1=l2 then p::(f t1 t2) else WildPat(t,a)::(f l t2)
               | f [] ((l2,t)::t2) = WildPat(t,a)::(f [] t2)
               | f [] [] = []
               | f (((l,_),_,_)::t) [] = 
                   raise TyDebug.Bug ("Record.SubRecordPat.f."^l)
         in  pat(TuplePat(f l0 l1,t,a))
         end
      | RefPat(p,t,a) => RefPat(pat p,ty t,a)
      | AsPat(i,p,t,a) => AsPat(i,pat p,ty t,a)
      | TuplePat([],t,a) => UnitPat a
      | TuplePat(l,t,a) => TuplePat(map pat l,ty t,a)
      | ListPat(l,t,a) => ListPat(map pat l,ty t,a)
      | ArrayPat(l,t,a) => ArrayPat(map pat l,ty t,a)
      | OrPat(l,t,a) => OrPat(map pat l,ty t,a)
      | ConstraintPat(p,t,a) => ConstraintPat(pat p, tyexp t,a)
      | p => p

  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;
        ("@rec"^string_of_int(c),loc)
    end
  fun make_letxee loc l e = 
    let val tau = expTy e
        fun f [] = e
          | f ((x,e')::t) = 
            let val tau' = expTy e'
            in  AppExp(FnExp([([VarPat(x,tau',loc)],f t,loc)], Ty.gen_fun tau' tau, loc),
                       e', tau, loc)
            end
    in  f l
    end
  fun make_tuple loc l = TupleExp(l,Ty.Tuple(map expTy l),loc)

  fun select loc e k tk =
        RecordFieldExp(e,(string_of_int k,loc),tk,loc)

(*
  fun select loc t k tk e =
    let val x = new_variable loc
        fun f _ [] = []
          | f i (h::t) = if i=k then VarPat(x,h,loc)::(f (i+1) t)
                                else WildPat(h,loc)::(f (i+1) t)
    in  AppExp(
          FnExp([([TuplePat(f 0 t, Ty.Tuple t, loc)],VarExp(([],x,loc), tk, loc),loc)],
            Ty.gen_fun (Ty.Tuple t) tk,
            loc), e, tk, loc)
    end
*)

  and exp e = case e of
        VarExp(i,t,a) => VarExp(i,ty t,a)
      | ConExp(i,t,a) => ConExp(i,ty t,a)
      | AppExp(e1,e2,t,a) => AppExp(exp e1,exp e2,ty t,a)
      | RecordExp(l,t,a) => 
          (* { b=e1, a=e2, c=e3} ==> let val x0 = e1 val x1 = e2 val x2 = e3
                                     in  (x1,x0,x2) end *)
          let val l0 = map (fn (l,e,a) => (new_variable a, l,e)) l
              val l1 = List.sort (fn(_,l,_) (_,l',_)=>Pervasives.compare l l')
                                 (map (fn(x,(l,_),e)=>(x,l,expTy e)) l0)
              val l2 = map (fn ((x,a),l,t) => VarExp(([],(x,a),a),t,a)) l1
              val tuple = make_tuple a l2
          in  exp (make_letxee a (map (fn(x,_,e) => (x,e)) l0) tuple)
          end
      | RecordFieldExp(e,(l,b),t,a) => 
          (* x.b ==> x where x's type is {a:.., b:.., c:..} *)
          let val tau = case Ty.unlink(expTy e) of 
                          Ty.Rec(r,s) => Ty.Rec(Ty.Row.flatten (r,s))
                        | tau => tau
          in  case tau of
                Ty.Tuple t' => RecordFieldExp(exp e,(l,b),ty t, a)
              | Ty.Rec(r,None) =>
                  let val r' = Labm.to_list r
                      val newtau = map (fn (l,t)=>t) r'
                      fun g _ [] = raise TyDebug.Bug "Record.exp.RecordField"
                        | g n ((l',_)::t) = if l=l' then n else g (n+1) t
                  in  select a (exp e) (g 0 r') (ty t)
                  end
              | _ => raise TyDebug.Bug "Record.exp.RecordField"
          end
      | SubstRecordExp(e1,(l,b),e2,t,a) => 
        (* e1{l<-e2} ==> (fn (x0,x1,x2) x => (x0,x,x2)) e1 e2 
           where e1's type {a:.., z:.., l:..} *) 
          let val t2 = expTy e2
              val l0 = Labm.to_list (
                         case Ty.unlink t of
                            Ty.Rec(r,s) => let val (r',_) = Ty.Row.flatten (r,s)
                                           in  r'
                                           end
                          | Ty.Tuple l => Ty.Row.of_tuple' l
                          | _ => raise TyDebug.Bug "Record.exp.SubstRecordExp")
              val x = new_variable a
              val l1 = map (fn (l,t)=>(l,new_variable a,t)) l0
              val (p1:pat) = TuplePat(map (fn (l,x,t)=>VarPat(x,t,a)) l1, t, a)
              val (p2:pat) = VarPat(x,expTy e2,a)
              val e = TupleExp(map (fn (m,y,t)=>VarExp(([],if l=m then x else y,a),
                                                       t,a)) l1,
                               t,a)
          in  exp(AppExp(AppExp(
                           FnExp([([p1,p2], e,a)], Ty.gen_fun t (Ty.gen_fun t2 t), a),
                           e1,Ty.gen_fun t2 t, a), e2, t, a))
          end
      | ArrayFieldExp(e1,e2,t,a) => ArrayFieldExp(exp e1,exp e2,ty t,a)
      | UpdateArrayExp(e1,e2,e3,t,a) => UpdateArrayExp(exp e1,exp e2,exp e3,ty t,a)
      | TupleExp(l,t,a) => TupleExp(map exp l,ty t,a)
      | ListExp(l,t,a) => ListExp(map exp l,ty t,a)
      | ArrayExp(l,t,a) => ArrayExp(map exp l,ty t,a)
      | SeqExp(l,t,a) => SeqExp(map exp l,ty t,a)
      | LetExp(d,e,t,a) => LetExp(dec d,exp e,ty t,a)
      | HandleExp(e,l,t,a) => pc_handle(exp e,map rule l,ty t,a)
      | RaiseExp(e,t,a) => RaiseExp(exp e,ty t,a)
      | FnExp(l,t,a) => pc_fn(map fnrule l, ty t,a)
      | AssignExp(e1,e2,t,a) => AssignExp(exp e1,exp e2,ty t,a)
      | RefExp(e,t,a) => RefExp(exp e,ty t,a)
      | DeRefExp(e,t,a) => DeRefExp(exp e,ty t,a)
      | CaseExp(e,l,t,a) => pc_case(exp e,map rule l,ty t,a)
      | IfExp(e1,e2,e3,t,a) => IfExp(exp e1,exp e2,exp e3,ty t,a)
      | WhileExp(e1,e2,t,a) => WhileExp(exp e1,exp e2,ty t,a)
      | ForExp(i,e1,e2,e3,e4,t,a) => ForExp(i,exp e1,exp e2,exp e3,exp e4,ty t,a)
      | ConstraintExp(e,t,a) => ConstraintExp(exp e,tyexp t,a)
      | _ => e

  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
        ValDec(l,l',l'',a) => pc_val(l,map valbind l',vel l'',a)
(*      | RecValDec(l,l',l'',a) => pc_recval(l,map valbind l',vel l'',a) *)
      | TypeDec(l,a) => TypeDec(map typebind l,a)
      | ExceptionDec(l,a) => ExceptionDec(map con l,a)
      | LocalDec(d,e,a) => LocalDec(dec d,dec e,a)
      | OpenDec(i,a) => OpenDec(i,a)
      | SeqDec(l,a) => SeqDec(map dec l,a)
  and valbind(b,p,e,a) = (b,pat p,exp e,a)
  and vel l = List.map (fn (id,(n,t)) => (id,(n,ty t))) l

  and typebind t = case t of
        TypeBind(l,i,t,a) => TypeBind(l,i,typ t,a)
      | DataBind(l,i,l',a) => DataBind(l,i,map con l',a)

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

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