Mercurial > urweb

comparison src/corify.sml @ 423:82067ea6e723

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Stop including functors in paths
author Adam Chlipala <adamc@hcoop.net>
date Fri, 24 Oct 2008 16:13:53 -0400
parents ab3177746c78
children dfc8c991abd0
comparison
equal deleted inserted replaced
422:0ce90d4d9ae7 423:82067ea6e723
107 val bindStr : t -> string -> int -> t -> t 107 val bindStr : t -> string -> int -> t -> t
108 val lookupStrById : t -> int -> t 108 val lookupStrById : t -> int -> t
109 val lookupStrByName : string * t -> t 109 val lookupStrByName : string * t -> t
110 val lookupStrByNameOpt : string * t -> t option 110 val lookupStrByNameOpt : string * t -> t option
111 111
112 val bindFunctor : t -> string list -> string -> int -> string -> int -> L.str -> t 112 val bindFunctor : t -> string -> int -> string -> int -> L.str -> t
113 val lookupFunctorById : t -> int -> string list * string * int * L.str 113 val lookupFunctorById : t -> int -> string * int * L.str
114 val lookupFunctorByName : string * t -> string list * string * int * L.str 114 val lookupFunctorByName : string * t -> string * int * L.str
115 end = struct 115 end = struct
116 116
117 datatype flattening = 117 datatype flattening =
118 FNormal of {name : string list, 118 FNormal of {name : string list,
119 cons : int SM.map, 119 cons : int SM.map,
120 constructors : L'.patCon SM.map, 120 constructors : L'.patCon SM.map,
121 vals : int SM.map, 121 vals : int SM.map,
122 strs : flattening SM.map, 122 strs : flattening SM.map,
123 funs : (string list * string * int * L.str) SM.map} 123 funs : (string * int * L.str) SM.map}
124 | FFfi of {mod : string, 124 | FFfi of {mod : string,
125 vals : L'.con SM.map, 125 vals : L'.con SM.map,
126 constructors : (string * string list * L'.con option * L'.datatype_kind) SM.map} 126 constructors : (string * string list * L'.con option * L'.datatype_kind) SM.map}
127 127
128 type t = { 128 type t = {
129 basis : int option, 129 basis : int option,
130 cons : int IM.map, 130 cons : int IM.map,
131 constructors : L'.patCon IM.map, 131 constructors : L'.patCon IM.map,
132 vals : int IM.map, 132 vals : int IM.map,
133 strs : flattening IM.map, 133 strs : flattening IM.map,
134 funs : (string list * string * int * L.str) IM.map, 134 funs : (string * int * L.str) IM.map,
135 current : flattening, 135 current : flattening,
136 nested : flattening list 136 nested : flattening list
137 } 137 }
138 138
139 val empty = { 139 val empty = {
403 | lookupStrByNameOpt _ = NONE 403 | lookupStrByNameOpt _ = NONE
404 404
405 fun bindFunctor ({basis, cons, constructors, vals, strs, funs, 405 fun bindFunctor ({basis, cons, constructors, vals, strs, funs,
406 current = FNormal {name, cons = mcons, constructors = mconstructors, 406 current = FNormal {name, cons = mcons, constructors = mconstructors,
407 vals = mvals, strs = mstrs, funs = mfuns}, nested} : t) 407 vals = mvals, strs = mstrs, funs = mfuns}, nested} : t)
408 mods x n xa na str = 408 x n xa na str =
409 {basis = basis, 409 {basis = basis,
410 cons = cons, 410 cons = cons,
411 constructors = constructors, 411 constructors = constructors,
412 vals = vals, 412 vals = vals,
413 strs = strs, 413 strs = strs,
414 funs = IM.insert (funs, n, (mods, xa, na, str)), 414 funs = IM.insert (funs, n, (xa, na, str)),
415 current = FNormal {name = name, 415 current = FNormal {name = name,
416 cons = mcons, 416 cons = mcons,
417 constructors = mconstructors, 417 constructors = mconstructors,
418 vals = mvals, 418 vals = mvals,
419 strs = mstrs, 419 strs = mstrs,
420 funs = SM.insert (mfuns, x, (mods, xa, na, str))}, 420 funs = SM.insert (mfuns, x, (xa, na, str))},
421 nested = nested} 421 nested = nested}
422 | bindFunctor _ _ _ _ _ _ _ = raise Fail "Corify.St.bindFunctor" 422 | bindFunctor _ _ _ _ _ _ = raise Fail "Corify.St.bindFunctor"
423 423
424 fun lookupFunctorById ({funs, ...} : t) n = 424 fun lookupFunctorById ({funs, ...} : t) n =
425 case IM.find (funs, n) of 425 case IM.find (funs, n) of
426 NONE => raise Fail "Corify.St.lookupFunctorById" 426 NONE => raise Fail "Corify.St.lookupFunctorById"
427 | SOME v => v 427 | SOME v => v
694 ([(L'.DValRec vis, loc)], st) 694 ([(L'.DValRec vis, loc)], st)
695 end 695 end
696 | L.DSgn _ => ([], st) 696 | L.DSgn _ => ([], st)
697 697
698 | L.DStr (x, n, _, (L.StrFun (xa, na, _, _, str), _)) => 698 | L.DStr (x, n, _, (L.StrFun (xa, na, _, _, str), _)) =>
699 ([], St.bindFunctor st (x :: mods) x n xa na str) 699 ([], St.bindFunctor st x n xa na str)
700 700
701 | L.DStr (x, n, _, (L.StrProj (str, x'), _)) => 701 | L.DStr (x, n, _, (L.StrProj (str, x'), _)) =>
702 let 702 let
703 val (ds, {inner, outer}) = corifyStr mods (str, st) 703 val (ds, {inner, outer}) = corifyStr mods (str, st)
704 704
705 val st = case St.lookupStrByNameOpt (x', inner) of 705 val st = case St.lookupStrByNameOpt (x', inner) of
706 SOME st' => St.bindStr st x n st' 706 SOME st' => St.bindStr st x n st'
707 | NONE => 707 | NONE =>
708 let 708 let
709 val (mods', x', n', str') = St.lookupFunctorByName (x', inner) 709 val (x', n', str') = St.lookupFunctorByName (x', inner)
710 in 710 in
711 St.bindFunctor st mods' x n x' n' str' 711 St.bindFunctor st x n x' n' str'
712 end 712 end
713 in 713 in
714 ([], st) 714 ([], st)
715 end 715 end
716 716
955 case str of 955 case str of
956 L.StrVar n => St.lookupFunctorById st n 956 L.StrVar n => St.lookupFunctorById st n
957 | L.StrProj (str, x) => St.lookupFunctorByName (x, unwind' str) 957 | L.StrProj (str, x) => St.lookupFunctorByName (x, unwind' str)
958 | _ => raise Fail "Corify of fancy functor application [2]" 958 | _ => raise Fail "Corify of fancy functor application [2]"
959 959
960 val (fmods, xa, na, body) = unwind str1 960 val (xa, na, body) = unwind str1
961 961
962 val (ds1, {inner = inner', outer}) = corifyStr mods (str2, st) 962 val (ds1, {inner = inner', outer}) = corifyStr mods (str2, st)
963 963
964 val mods' = case #1 str2 of 964 val (ds2, {inner, outer}) = corifyStr mods (body, St.bindStr outer xa na inner')
965 L.StrConst _ => fmods @ mods
966 | _ =>
967 let
968 val ast = unwind' str2
969 in
970 fmods @ St.name ast
971 end
972
973 val (ds2, {inner, outer}) = corifyStr mods' (body, St.bindStr outer xa na inner')
974 in 965 in
975 (ds1 @ ds2, {inner = St.bindStr inner xa na inner', outer = outer}) 966 (ds1 @ ds2, {inner = St.bindStr inner xa na inner', outer = outer})
976 end 967 end
977 968
978 fun maxName ds = foldl (fn ((d, _), n) => 969 fun maxName ds = foldl (fn ((d, _), n) =>