adamc@110: (* Copyright (c) 2008, Adam Chlipala
adamc@110:  * All rights reserved.
adamc@110:  *
adamc@110:  * Redistribution and use in source and binary forms, with or without
adamc@110:  * modification, are permitted provided that the following conditions are met:
adamc@110:  *
adamc@110:  * - Redistributions of source code must retain the above copyright notice,
adamc@110:  *   this list of conditions and the following disclaimer.
adamc@110:  * - Redistributions in binary form must reproduce the above copyright notice,
adamc@110:  *   this list of conditions and the following disclaimer in the documentation
adamc@110:  *   and/or other materials provided with the distribution.
adamc@110:  * - The names of contributors may not be used to endorse or promote products
adamc@110:  *   derived from this software without specific prior written permission.
adamc@110:  *
adamc@110:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@110:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@110:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@110:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@110:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adamc@110:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@110:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@110:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@110:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@110:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@110:  * POSSIBILITY OF SUCH DAMAGE.
adamc@110:  *)
adamc@110: 
adamc@110: structure Tag :> TAG = struct
adamc@110: 
adamc@110: open Core
adamc@110: 
adamc@110: structure U = CoreUtil
adamc@110: structure E = CoreEnv
adamc@110: 
adamc@110: structure IM = IntBinaryMap
adamc@112: structure SM = BinaryMapFn(struct
adamc@112:                            type ord_key = string
adamc@112:                            val compare = String.compare
adamc@112:                            end)
adamc@110: 
adamc@110: fun kind (k, s) = (k, s)
adamc@110: fun con (c, s) = (c, s)
adamc@110: 
adamc@112: fun exp env (e, s) =
adamc@110:     case e of
adamc@110:         EApp (
adamc@110:         (EApp (
adamc@110:          (EApp (
adamc@110:           (ECApp (
adamc@110:            (ECApp (
adamc@110:             (ECApp (
adamc@110:              (ECApp (
adamc@140:               (ECApp (
adamc@140:                (ECApp (
adamc@140:                 (ECApp (
adamc@140:                  (ECApp (
adamc@140:                   (EFfi ("Basis", "tag"),
adamc@140:                    loc), given), _), absent), _), outer), _), inner), _),
adamc@140:               useOuter), _), useInner), _), bindOuter), _), bindInner), _),
adamc@110:           attrs), _),
adamc@110:          tag), _),
adamc@110:         xml) =>
adamc@110:         (case attrs of
adamc@110:              (ERecord xets, _) =>
adamc@110:              let
adamc@110:                  val (xets, s) =
adamc@112:                      ListUtil.foldlMap (fn ((x, e, t), (count, tags, byTag, newTags)) =>
adamc@143:                                            let
adamc@144:                                                fun tagIt (ek, newAttr) =
adamc@143:                                                    let
adamc@143:                                                        fun unravel (e, _) =
adamc@143:                                                            case e of
adamc@143:                                                                ENamed n => (n, [])
adamc@143:                                                              | EApp (e1, e2) =>
adamc@143:                                                                let
adamc@143:                                                                    val (n, es) = unravel e1
adamc@143:                                                                in
adamc@143:                                                                    (n, es @ [e2])
adamc@143:                                                                end
adamc@143:                                                              | _ => (ErrorMsg.errorAt loc "Invalid link expression";
adamc@143:                                                                      (0, []))
adamc@110: 
adamc@110: 
adamc@110: 
adamc@143:                                                        val (f, args) = unravel e
adamc@112: 
adamc@143:                                                        val (cn, count, tags, newTags) =
adamc@143:                                                            case IM.find (tags, f) of
adamc@143:                                                                NONE =>
adamc@143:                                                                (count, count + 1, IM.insert (tags, f, count),
adamc@144:                                                                 (ek, f, count) :: newTags)
adamc@143:                                                              | SOME cn => (cn, count, tags, newTags)
adamc@143:                                                                           
adamc@143:                                                        val (_, _, _, s) = E.lookupENamed env f
adamc@112: 
adamc@143:                                                        val byTag = case SM.find (byTag, s) of
adamc@144:                                                                        NONE => SM.insert (byTag, s, (ek, f))
adamc@144:                                                                      | SOME (ek', f') =>
adamc@143:                                                                        (if f = f' then
adamc@143:                                                                             ()
adamc@143:                                                                         else
adamc@143:                                                                             ErrorMsg.errorAt loc 
adamc@143:                                                                                              ("Duplicate HTTP tag "
adamc@143:                                                                                               ^ s);
adamc@144:                                                                         if ek = ek' then
adamc@144:                                                                             ()
adamc@144:                                                                         else
adamc@144:                                                                             ErrorMsg.errorAt loc 
adamc@144:                                                                                              "Function needed as both a link and a form ";
adamc@143:                                                                         byTag)
adamc@143: 
adamc@143:                                                        val e = (EClosure (cn, args), loc)
adamc@143:                                                        val t = (CFfi ("Basis", "string"), loc)
adamc@143:                                                    in
adamc@143:                                                        (((CName newAttr, loc), e, t),
adamc@143:                                                         (count, tags, byTag, newTags))
adamc@143:                                                    end
adamc@143:                                            in
adamc@143:                                                case x of
adamc@144:                                                    (CName "Link", _) => tagIt (Link, "Href")
adamc@144:                                                  | (CName "Action", _) => tagIt (Action, "Action")
adamc@143:                                                  | _ => ((x, e, t), (count, tags, byTag, newTags))
adamc@143:                                            end)
adamc@110:                      s xets
adamc@110:              in
adamc@110:                  (EApp (
adamc@110:                   (EApp (
adamc@110:                    (EApp (
adamc@110:                     (ECApp (
adamc@110:                      (ECApp (
adamc@110:                       (ECApp (
adamc@110:                        (ECApp (
adamc@140:                         (ECApp (
adamc@140:                          (ECApp (
adamc@140:                           (ECApp (
adamc@140:                            (ECApp (
adamc@140:                             (EFfi ("Basis", "tag"),
adamc@140:                              loc), given), loc), absent), loc), outer), loc), inner), loc),
adamc@140:                         useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc),
adamc@110:                     (ERecord xets, loc)), loc),
adamc@110:                    tag), loc),
adamc@110:                   xml), s)
adamc@110:              end
adamc@110:            | _ => (ErrorMsg.errorAt loc "Attribute record is too complex";
adamc@110:                    (e, s)))
adamc@110: 
adamc@110:       | _ => (e, s)
adamc@110: 
adamc@110: fun decl (d, s) = (d, s)
adamc@110: 
adamc@110: fun tag file =
adamc@110:     let
adamc@110:         val count = foldl (fn ((d, _), count) =>
adamc@110:                               case d of
adamc@110:                                   DCon (_, n, _, _) => Int.max (n, count)
adamc@163:                                 | DDatatype (_, n, _) => Int.max (n, count)
adamc@110:                                 | DVal (_, n, _, _, _) => Int.max (n, count)
adamc@125:                                 | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis
adamc@110:                                 | DExport _ => count) 0 file
adamc@110: 
adamc@112:         fun doDecl (d as (d', loc), (env, count, tags, byTag)) =
adamc@112:             case d' of
adamc@144:                 DExport (ek, n) =>
adamc@112:                 let
adamc@112:                     val (_, _, _, s) = E.lookupENamed env n
adamc@112:                 in
adamc@112:                     case SM.find (byTag, s) of
adamc@112:                         NONE => ([d], (env, count, tags, byTag))
adamc@144:                       | SOME (ek', n') =>
adamc@144:                         (if ek = ek' then
adamc@144:                              ()
adamc@144:                          else
adamc@144:                              ErrorMsg.errorAt loc "Function needed for both a link and a form";
adamc@144:                          ([], (env, count, tags, byTag)))
adamc@112:                 end
adamc@112:               | _ =>
adamc@112:                 let
adamc@126:                     val env' = E.declBinds env d
adamc@126:                     val env'' = case d' of
adamc@126:                                     DValRec _ => env'
adamc@126:                                   | _ => env
adamc@126: 
adamc@112:                     val (d, (count, tags, byTag, newTags)) =
adamc@112:                         U.Decl.foldMap {kind = kind,
adamc@112:                                         con = con,
adamc@126:                                         exp = exp env'',
adamc@112:                                         decl = decl}
adamc@112:                                        (count, tags, byTag, []) d
adamc@110: 
adamc@126:                     val env = env'
adamc@110: 
adamc@126:                     val newDs = map
adamc@144:                                     (fn (ek, f, cn) =>
adamc@112:                                         let
adamc@112:                                             fun unravel (all as (t, _)) =
adamc@112:                                                 case t of
adamc@112:                                                     TFun (dom, ran) =>
adamc@112:                                                     let
adamc@112:                                                         val (args, result) = unravel ran
adamc@112:                                                     in
adamc@112:                                                         (dom :: args, result)
adamc@112:                                                     end
adamc@112:                                                   | _ => ([], all)
adamc@110: 
adamc@112:                                             val (fnam, t, _, tag) = E.lookupENamed env f
adamc@112:                                             val (args, result) = unravel t
adamc@110: 
adamc@112:                                             val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
adamc@119: 
adamc@119:                                             val (abs, t) =
adamc@119:                                                 case args of
adamc@119:                                                     [] =>
adamc@119:                                                     let
adamc@119:                                                         val body = (EWrite (ENamed f, loc), loc)
adamc@119:                                                     in
adamc@119:                                                         ((EAbs ("x", unit, unit, body), loc),
adamc@119:                                                          (TFun (unit, unit), loc))
adamc@119:                                                     end
adamc@119:                                                   | _ =>
adamc@119:                                                     let
adamc@119:                                                         val (app, _) = foldl (fn (t, (app, n)) =>
adamc@119:                                                                                  ((EApp (app, (ERel n, loc)), loc),
adamc@119:                                                                                   n - 1))
adamc@119:                                                                              ((ENamed f, loc), length args - 1) args
adamc@119:                                                         val body = (EWrite app, loc)
adamc@119:                                                         val (abs, _, t) = foldr (fn (t, (abs, n, rest)) =>
adamc@119:                                                                                     ((EAbs ("x" ^ Int.toString n,
adamc@119:                                                                                             t,
adamc@119:                                                                                             rest,
adamc@119:                                                                                             abs), loc),
adamc@119:                                                                                      n + 1,
adamc@119:                                                                                      (TFun (t, rest), loc)))
adamc@119:                                                                                 (body, 0, unit) args
adamc@119:                                                     in
adamc@119:                                                         (abs, t)
adamc@119:                                                     end
adamc@112:                                         in
adamc@126:                                             (("wrap_" ^ fnam, cn, t, abs, tag),
adamc@144:                                              (DExport (ek, cn), loc))
adamc@112:                                         end) newTags
adamc@126: 
adamc@126:                     val (newVals, newExports) = ListPair.unzip newDs
adamc@126: 
adamc@126:                     val ds = case d of
adamc@126:                                  (DValRec vis, _) => [(DValRec (vis @ newVals), loc)]
adamc@126:                                | _ => map (fn vi => (DVal vi, loc)) newVals @ [d]
adamc@112:                 in
adamc@126:                     (ds @ newExports, (env, count, tags, byTag))
adamc@112:                 end
adamc@110: 
adamc@112:         val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count+1, IM.empty, SM.empty) file
adamc@110:     in
adamc@110:         file
adamc@110:     end
adamc@110: 
adamc@110: end