structure MonoFooify :> MONO_FOOIFY = struct

open Mono

datatype foo_kind =
         Attr
       | Url

val nextPvar = ref 0
val pvarDefs = ref ([] : (string * int * (string * int * typ option) list) list)

structure Fm = struct

type vr = string * int * typ * exp * string

structure IM = IntBinaryMap

structure M = BinaryMapFn(struct
                          type ord_key = foo_kind
                          fun compare x =
                              case x of
                                  (Attr, Attr) => EQUAL
                                | (Attr, _) => LESS
                                | (_, Attr) => GREATER

                                | (Url, Url) => EQUAL
                          end)

structure TM = BinaryMapFn(struct
                           type ord_key = typ
                           val compare = MonoUtil.Typ.compare
                           end)

type t = {
     count : int,
     map : int IM.map M.map,
     listMap : int TM.map M.map,
     decls : vr list
}

fun empty count = {
    count = count,
    map = M.empty,
    listMap = M.empty,
    decls = []
}

fun chooseNext count =
    let
        val n = !nextPvar
    in
        if count < n then
            (count, count+1)
        else
            (nextPvar := n + 1;
             (n, n+1))
    end

fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
fun freshName {count, map, listMap, decls} =
    let
        val (next, count) = chooseNext count
    in
        (next, {count = count , map = map, listMap = listMap, decls = decls})
    end
fun decls ({decls, ...} : t) =
    case decls of
        [] => []
      | _ => [(DValRec decls, ErrorMsg.dummySpan)]

fun lookup (t as {count, map, listMap, decls}) k n thunk =
    let
        val im = Option.getOpt (M.find (map, k), IM.empty)
    in
        case IM.find (im, n) of
            NONE =>
            let
                val n' = count
                val (d, {count, map, listMap, decls}) =
                    thunk count {count = count + 1,
                                 map = M.insert (map, k, IM.insert (im, n, n')),
                                 listMap = listMap,
                                 decls = decls}
            in
                ({count = count,
                  map = map,
                  listMap = listMap,
                  decls = d :: decls}, n')
            end
          | SOME n' => (t, n')
    end

fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
    let
        val tm = Option.getOpt (M.find (listMap, k), TM.empty)
    in
        case TM.find (tm, tp) of
            NONE =>
            let
                val n' = count
                val (d, {count, map, listMap, decls}) =
                    thunk count {count = count + 1,
                                 map = map,
                                 listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
                                 decls = decls}
            in
                ({count = count,
                  map = map,
                  listMap = listMap,
                  decls = d :: decls}, n')
            end
          | SOME n' => (t, n')
    end

(* Has to be set at the end of [Monoize]. *)
val canonical = ref (empty 0 : t)

end

fun fk2s fk =
    case fk of
        Attr => "attr"
      | Url => "url"

fun capitalize s =
    if s = "" then
        s
    else
        str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)

structure E = ErrorMsg

val dummyExp = (EPrim (Prim.Int 0), E.dummySpan)

fun fooifyExp fk lookupENamed lookupDatatype =
    let
        fun fooify fm (e, tAll as (t, loc)) =
            case #1 e of
                EClosure (fnam, [(ERecord [], _)]) =>
                let
                    val (_, s) = lookupENamed fnam
                in
                    ((EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
                end
              | EClosure (fnam, args) =>
                let
                    val (ft, s) = lookupENamed fnam
                    fun attrify (args, ft, e, fm) =
                        case (args, ft) of
                            ([], _) => (e, fm)
                          | (arg :: args, (TFun (t, ft), _)) =>
                            let
                                val (arg', fm) = fooify fm (arg, t)
                            in
                                attrify (args, ft,
                                         (EStrcat (e,
                                                      (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc),
                                                                   arg'), loc)), loc),
                                         fm)
                            end
                          | _ => (E.errorAt loc "Type mismatch encoding attribute";
                                  (e, fm))
                in
                    attrify (args, ft, (EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
                end
              | _ =>
                case t of
                    TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
                  | TFfi (m, x) => ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)

                  | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
                  | TRecord ((x, t) :: xts) =>
                    let
                        val (se, fm) = fooify fm ((EField (e, x), loc), t)
                    in
                        foldl (fn ((x, t), (se, fm)) =>
                                  let
                                      val (se', fm) = fooify fm ((EField (e, x), loc), t)
                                  in
                                      ((EStrcat (se,
                                                    (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc),
                                                                 se'), loc)), loc),
                                       fm)
                                  end) (se, fm) xts
                    end

                  | TDatatype (i, ref (dk, _)) =>
                    let
                        fun makeDecl n fm =
                            let
                                val (x, xncs) =
                                    case ListUtil.search (fn (x, i', xncs) =>
                                                             if i' = i then
                                                                 SOME (x, xncs)
                                                             else
                                                                 NONE) (!pvarDefs) of
                                        NONE => lookupDatatype i
                                      | SOME v => v

                                val (branches, fm) =
                                    ListUtil.foldlMap
                                        (fn ((x, n, to), fm) =>
                                            case to of
                                                NONE =>
                                                (((PCon (dk, PConVar n, NONE), loc),
                                                  (EPrim (Prim.String (Prim.Normal, x)), loc)),
                                                 fm)
                                              | SOME t =>
                                                let
                                                    val (arg, fm) = fooify fm ((ERel 0, loc), t)
                                                in
                                                    (((PCon (dk, PConVar n, SOME (PVar ("a", t), loc)), loc),
                                                      (EStrcat ((EPrim (Prim.String (Prim.Normal, x ^ "/")), loc),
                                                                   arg), loc)),
                                                     fm)
                                                end)
                                        fm xncs

                                val dom = tAll
                                val ran = (TFfi ("Basis", "string"), loc)
                            in
                                ((fk2s fk ^ "ify_" ^ x,
                                  n,
                                  (TFun (dom, ran), loc),
                                  (EAbs ("x",
                                            dom,
                                            ran,
                                            (ECase ((ERel 0, loc),
                                                       branches,
                                                       {disc = dom,
                                                        result = ran}), loc)), loc),
                                  ""),
                                 fm)
                            end

                        val (fm, n) = Fm.lookup fm fk i makeDecl
                    in
                        ((EApp ((ENamed n, loc), e), loc), fm)
                    end

                  | TOption t =>
                    let
                        val (body, fm) = fooify fm ((ERel 0, loc), t)
                    in
                        ((ECase (e,
                                    [((PNone t, loc),
                                      (EPrim (Prim.String (Prim.Normal, "None")), loc)),

                                     ((PSome (t, (PVar ("x", t), loc)), loc),
                                      (EStrcat ((EPrim (Prim.String (Prim.Normal, "Some/")), loc),
                                                   body), loc))],
                                    {disc = tAll,
                                     result = (TFfi ("Basis", "string"), loc)}), loc),
                         fm)
                    end

                  | TList t =>
                    let
                        fun makeDecl n fm =
                            let
                                val rt = (TRecord [("1", t), ("2", (TList t, loc))], loc)
                                val (arg, fm) = fooify fm ((ERel 0, loc), rt)

                                val branches = [((PNone rt, loc),
                                                 (EPrim (Prim.String (Prim.Normal, "Nil")), loc)),
                                                ((PSome (rt, (PVar ("a", rt), loc)), loc),
                                                 (EStrcat ((EPrim (Prim.String (Prim.Normal, "Cons/")), loc),
                                                              arg), loc))]

                                val dom = tAll
                                val ran = (TFfi ("Basis", "string"), loc)
                            in
                                ((fk2s fk ^ "ify_list",
                                  n,
                                  (TFun (dom, ran), loc),
                                  (EAbs ("x",
                                            dom,
                                            ran,
                                            (ECase ((ERel 0, loc),
                                                       branches,
                                                       {disc = dom,
                                                        result = ran}), loc)), loc),
                                  ""),
                                 fm)
                            end

                        val (fm, n) = Fm.lookupList fm fk t makeDecl
                    in
                        ((EApp ((ENamed n, loc), e), loc), fm)
                    end

                  | _ => (E.errorAt loc "Don't know how to encode attribute/URL type";
                          Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
                          (dummyExp, fm))
    in
        fooify
    end

fun urlify env expTyp =
    let
        val (exp, fm) =
            fooifyExp
                Url
                (fn n =>
                    let
                        val (_, t, _, s) = MonoEnv.lookupENamed env n
                    in
                        (t, s)
                    end)
                (fn n => MonoEnv.lookupDatatype env n)
                (!Fm.canonical)
                expTyp
    in
        Fm.canonical := fm;
        exp
    end
end