(***************************************************************
 Bindex adds names to Intex:
 + number of program args is replaced by a list of formal param names;
 + argument references are replaced by variable references;
 + a bind construct allows local names.

 Still, there is only one kind of value manipulated by the language: integers. 
 ****************************************************************)

(* TO DO: 
   + fold-based version of free vars 
   + desugaring for bindpar,bindseq
 *)

module Bindex = struct

  open Sexp
  open List

  exception SyntaxError of string
  exception Unbound of string list 

  (************************************************************
   Abstract Syntax
   ************************************************************)

  type var = string

  type pgm = Pgm of string list * exp (* param names, body *)

  and exp =
      Lit of int (* integer literal with value *)
    | Var of var (* variable reference *)
    | BinApp of binop * exp * exp (* primitive application with rator, rands *)
    | Bind of var * exp * exp (* bind name to value of defn in body *)


  and binop = 
    | Add | Sub | Mul | Div | Rem (* binary arithmetic ops *)

  (************************************************************
   Folding over Bindex Expressions
   ************************************************************)

  (* val fold :
        (int -> 'a) ->
        (var -> 'a) ->
        (var -> 'a -> 'a -> 'a) -> 
        (binop -> 'a -> 'a -> 'a) 
        -> exp -> 'a *)
  let rec fold litfun varfun bindfun appfun exp = 
    match exp with 
      Lit i -> litfun i 
    | Var s -> varfun s
    | BinApp(rator, rand1, rand2) -> 
        appfun rator 
               (fold litfun varfun bindfun appfun rand1)
               (fold litfun varfun bindfun appfun rand2)
    | Bind(name,defn,body) -> 
        bindfun name 
                (fold litfun varfun bindfun appfun defn)
                (fold litfun varfun bindfun appfun body)

  (************************************************************
   Free Variables (Replaces Static Arg Checking)
   ************************************************************)

  module S = Set.Make(String) (* String Sets *)

  (* val addElts : S.elt list -> S.t -> S.t *)
  let addElts strs set = (* add a list of elements to a set *)
    List.fold_right S.add strs set

  (* val listToSet : S.elt list -> S.t *)
  let listToSet strs = addElts strs S.empty

  (* val setToList : S.t -> S.elt list *)
  let setToList set = S.elements set 

  (* val varCheck : pgm -> unit *)
  let rec varCheck pgm = 
    let unbounds = freeVarsPgm pgm 
     in if S.is_empty unbounds then
          () (* OK *)
        else 
          raise (Unbound (S.elements unbounds))

  (* val freeVarsPgm : pgm -> S.t *)
  (* Returns the free variables of a program *)
  and freeVarsPgm (Pgm(fmls,body)) = 
    S.diff (freeVarsExp body) (listToSet fmls)

  (* val freeVarsExp : exp -> S.t *)
  (* Returns the free variables of an expression *)
  (* direct version *)
  and freeVarsExp e = 
    match e with 
      Lit i -> S.empty
    | Var s -> S.singleton s
    | BinApp(_,r1,r2) -> S.union (freeVarsExp r1) (freeVarsExp r2)
    | Bind(name,defn,body) -> 
        S.union (freeVarsExp defn)
                     (S.diff (freeVarsExp body)
                                  (S.singleton name))

  (* val freeVarsExps : exp list -> S.t *)
  (* Returns the free variables of a list of expressions *)
  (* direct version *)
  and freeVarsExps es = 
    List.fold_right S.union (List.map freeVarsExp es) S.empty

  (************************************************************
   Substitution & Renaming
   ************************************************************)

  (* val subst : exp -> exp Env.env -> exp *)
  let rec subst exp env = 
    match exp with 
      Lit i -> exp
    | Var v -> (match Env.lookup v env with 
	          Some e -> e
                | None -> exp)
    | BinApp(op,r1,r2) -> BinApp(op, subst r1 env, subst r2 env)
    | Bind(name,defn,body) -> 
        (* Take the simple approach of renaming every name. 
           With more work, could avoid renaming unless absolutely necessary. *)
	let name' = StringUtils.fresh name in 
          Bind(name', subst defn env, subst (rename1 name name' body) env)
	  (* note: could be cleverer and do a single substitution/renaming *)

  (* val subst1 : var -> exp -> exp -> exp *)
  and subst1 name newexp exp = subst exp (Env.make [name] [newexp])

  (* val subst_all : string list -> exp list -> exp -> exp *)
  and subst_all names newexps exp = subst exp (Env.make names newexps)

  (* val rename1 : var -> var -> exp -> exp *)
  and rename1 oldname newname exp = subst1 oldname (Var newname) exp 

  (* val rename_all : string list -> var list -> exp -> exp *)
  and rename_all oldnames newnames exp = 
    subst_all oldnames (List.map (fun s -> Var s) newnames) exp 

  (************************************************************
   Parsing from S-Expressions 
   ************************************************************)

  (* val sexpToPgm : Sexp.sexp -> pgm *)
  let rec sexpToPgm sexp = 
    match sexp with 
      Seq [Sym "bindex"; Seq formals; body] -> 
            Pgm(List.map symToString formals, sexpToExp body)
    | Seq [Sym "intex"; Int n; body] -> 
            Pgm(List.map 
                  (fun i -> "$" ^ (string_of_int i))
                  (ListUtils.range 1 n),
                sexpToExp body)
    | _ -> raise (SyntaxError ("invalid Bindex program: " ^ (sexpToString sexp)))

  (* val symToString : Sexp.sexp -> string *)
  and symToString sexp =
    match sexp with 
      Sym s -> s
    | _ -> raise (SyntaxError ("symToString: not a string -- " ^ (sexpToString sexp)))

  (* val sexpToExp : Sexp.sexp -> exp *)
  and sexpToExp sexp = 
    match sexp with 
      Int i -> Lit i
    | Sym s -> Var s
    | Seq [Sym "bind"; Sym(name); defn; body] -> 
        Bind (name, sexpToExp defn, sexpToExp body)
    | Seq [Sym p; rand1; rand2] -> 
        BinApp(stringToBinop p, sexpToExp rand1, sexpToExp rand2)
    | _ ->  raise (SyntaxError ("invalid Bindex expression: "  
                                ^ (sexpToString sexp)))

  (* val stringToBinop : string -> binop *)
  and stringToBinop s = 
    match s with 
    | "+" -> Add
    | "-" -> Sub
    | "*" -> Mul
    | "/" -> Div
    | "%" -> Rem
    |  _ -> raise (SyntaxError ("invalid Bindex primop: " ^ s))

  (* val stringToExp : string -> exp *)
  and stringToExp s = sexpToExp (stringToSexp s) (* Desugar when possible *)

  (* val stringToPgm : string -> pgm *)
  and stringToPgm s = sexpToPgm (stringToSexp s)

  (************************************************************
   Unparsing to S-Expressions
   ************************************************************)

  (* val pgmToSexp : pgm -> Sexp.sexp *)
  let rec pgmToSexp p = 
    match p with 
      Pgm (fmls, e) -> 
        Seq [Sym "bindex"; Seq(List.map (fun s -> Sym s) fmls); expToSexp e]

  (* val expToSexp : exp -> Sexp.sexp *)
  and expToSexp e = 
    match e with 
      Lit i -> Int i
    | Var s -> Sym s
    | BinApp (rator, rand1, rand2) -> 
        Seq [Sym (binopToString rator); expToSexp rand1; expToSexp rand2]
    | Bind(n,d,b) -> Seq [Sym "bind"; Sym n; expToSexp d; expToSexp b]

  (* val binopToString : binop -> string *)
  and binopToString p = 
    match p with 
    | Add -> "+"
    | Sub -> "-" 
    | Mul -> "*" 
    | Div -> "/" 
    | Rem -> "%" 

  (* val expToString : exp -> string *)
  and expToString s = sexpToString (expToSexp s)

  (* val pgmToString : pgm -> string *)
  and pgmToString s = sexpToString (pgmToSexp s)

end