Skip to content
This repository
Newer
Older
100644 260 lines (240 sloc) 11.039 kb
282793ee »
2008-03-05 added copyright header
1 (* Celf
2 * Copyright (C) 2008 Anders Schack-Nielsen and Carsten Schürmann
3 *
4 * This file is part of Celf.
5 *
6 * Celf is free software: you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation, either version 3 of the License, or
9 * (at your option) any later version.
10 *
11 * Celf is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 * GNU General Public License for more details.
15 *
16 * You should have received a copy of the GNU General Public License
17 * along with Celf. If not, see <http://www.gnu.org/licenses/>.
18 *)
19
977c2a88 »
2008-06-07 *** empty log message ***
20 signature TLU_Eta = TOP_LEVEL_UTIL
0455366b »
2007-06-14 Initial revision.
21 structure Eta :> ETA =
22 struct
23
036e3817 »
2007-10-23 *** empty log message ***
24 open Syntax infix with'ty with's
0455366b »
2007-06-14 Initial revision.
25 open Signatur
d8ffb3f9 »
2007-12-03 *** empty log message ***
26 open Context
27 open PatternBind
28
4f306304 »
2007-12-03 *** empty log message ***
29 val traceEta = ref false
30
d8ffb3f9 »
2007-12-03 *** empty log message ***
31 type context = apxAsyncType context
0455366b »
2007-06-14 Initial revision.
32
ebefc56b »
2011-10-31 Changed datatype name Context.mode -> Context.modality
33 (* etaContract : exn -> nfObj -> modality * int *)
b86428e3 »
2010-05-27 *** empty log message ***
34 (* assumes that ob does not contain _
35 * etaContract e ob = (m, n)
36 * ob == Var (m, n)
37 * or raise e if ob is not an eta-expanded var *)
38 fun etaContract e ob =
39 let datatype etaSpine = LAp of opattern | Pl | Pr
40 fun nbindsSp sp = foldl (fn (LAp p, n) => n + nbinds p | (_, n) => n) 0 sp
ebefc56b »
2011-10-31 Changed datatype name Context.mode -> Context.modality
41 fun eq ((x : modality * int), y) = if x=y then x else raise e
b86428e3 »
2010-05-27 *** empty log message ***
42 fun etaEqC (ob, x) = ignore $ eq (etaC (ob, []), x)
43 and etaC (ob, sp) = case etaShortcut ob of NONE => etaC' (ob, sp) | SOME k => k
44 and etaC' (ob, sp) = case NfObj.prj ob of
45 NfLLam (p, N) => etaC (N, (LAp p)::sp)
46 | NfAddPair (N1, N2) =>
47 eq (etaC (N1, Pl::sp), etaC (N2, Pr::sp))
48 | NfMonad E =>
49 (case Util.NfExpObjAuxDefs.prj2 E of
50 NfLet (p, N, NfMon M) =>
51 (etaP (nbinds p, p, M); etaC (NfAtomic' N, sp))
52 | _ => raise e)
53 | NfAtomic (Var (M, n), S) =>
54 let val nb = nbindsSp sp
55 val k = n - nb
56 val () = if k>0 then () else raise e
57 val () = etaSp (nb, S, rev sp)
58 in (M, k) end
59 | _ => raise e
60 and etaP (n, p, m) = case (Pattern.prj p, NfMonadObj.prj m) of
61 (PDepTensor (p1, p2), DepPair (M1, M2)) =>
62 (etaP (n, p1, M1); etaP (n - nbinds p1, p2, M2))
63 | (POne, One) => ()
64 | (PDown _, Down N) => etaEqC (N, (LIN, n))
65 | (PAffi _, Affi N) => etaEqC (N, (AFF, n))
66 | (PBang _, Bang N) => etaEqC (N, (INT, n))
67 | _ => raise e
68 and etaSp (m, Sp, sp) = case (NfSpine.prj Sp, sp) of
69 (Nil, []) => ()
70 | (LApp (M, S), (LAp p)::sp) =>
71 (etaSp (m - nbinds p, S, sp); etaP (m, p, M))
72 | (ProjLeft S, Pl::sp) => etaSp (m, S, sp)
73 | (ProjRight S, Pr::sp) => etaSp (m, S, sp)
74 | _ => raise e
75 in etaC (ob, []) end
76
77 (* etaContractLetMon : nfExpObj -> (nfHead * nfSpine) option *)
78 fun etaContractLetMon e = case Util.NfExpObjAuxDefs.prj2 e of
79 NfLet (p, hS, NfMon M) =>
80 let exception ExnNoEta
81 val v = (INT, 1) (* dummy variable *)
82 fun isV mn = if mn = v then SOME hS else raise Fail "Internal error: etaContractLetMon"
9134fbaf »
2010-06-02 it compiles
83 in isV (etaContract ExnNoEta (NfMonad' $ NfLet' (p, (Var v, NfInj.Nil'), NfMon' M)))
b86428e3 »
2010-05-27 *** empty log message ***
84 handle ExnNoEta => NONE
85 end
86 | _ => NONE
0455366b »
2007-06-14 Initial revision.
87
55bb0346 »
2010-06-09 *** empty log message ***
88 (* etaExpand : (unit -> string) -> apxAsyncType * head * spine -> obj *)
89 fun etaExpand pp (A, H, S) =
90 let fun Idx M A n = etaExpand pp (A, Var (M, n), Nil')
0455366b »
2007-06-14 Initial revision.
91 (*fun printResult ob = (print ("Eta> "^(PrettyPrint.printObj (Atomic' (H, AH, S)))^" : "^
92 (PrettyPrint.printType (asyncTypeFromApx A))^" = "^
93 (PrettyPrint.printObj ob)^"\n")
94 ; ob)*)
7cf3cc3e »
2009-02-27 clf ver 2
95 fun etaSyncType ty = case ApxSyncType.prj ty of
0455366b »
2007-06-14 Initial revision.
96 ApxTTensor (S1, S2) =>
7cf3cc3e »
2009-02-27 clf ver 2
97 let val (p2, Mf2) = etaSyncType S2
98 val (p1, Mf1) = etaSyncType S1
99 in (PDepTensor' (p1, p2), fn n => DepPair' (Mf1 (n + nbinds p2), Mf2 n)) end
100 | ApxTOne => (POne', fn _ => One')
101 | ApxTDown A => (PDown' "", fn n => Down' (Idx LIN A n))
b0db913f »
2009-02-27 *** empty log message ***
102 | ApxTAffi A => (PAffi' "", fn n => Affi' (Idx AFF A n))
7cf3cc3e »
2009-02-27 clf ver 2
103 | ApxTBang A => (PBang' "", fn n => Bang' (Idx INT A n))
0455366b »
2007-06-14 Initial revision.
104 fun addEtaSpine (n, Sf) =
7cf3cc3e »
2009-02-27 clf ver 2
105 (Subst.shiftHead (H, n),
106 appendSpine (SClos (S, Subst.shift n), Sf (1, Nil')))
0455366b »
2007-06-14 Initial revision.
107 fun eta' (ty, n, Sf) = case Util.apxTypePrjAbbrev ty of
7cf3cc3e »
2009-02-27 clf ver 2
108 ApxLolli (S, B) =>
109 let val (p, Mf) = etaSyncType S
110 val nb = nbinds p
111 in LLam' (p, eta' (B, n+nb, fn (n, S) => Sf (n+nb, LApp' (Mf n, S)))) end
0455366b »
2007-06-14 Initial revision.
112 | ApxAddProd (A, B) =>
113 AddPair' (eta' (A, n, fn (n, S) => Sf (n, ProjLeft' S)),
114 eta' (B, n, fn (n, S) => Sf (n, ProjRight' S)))
115 | ApxTMonad S =>
7cf3cc3e »
2009-02-27 clf ver 2
116 let val (p, Mf) = etaSyncType S
117 in Monad' (Let' (p, addEtaSpine (n, Sf), Mon' $ Mf 1)) end
118 | ApxTAtomic _ => Atomic' $ addEtaSpine (n, Sf)
0cbe58e0 »
2010-06-04 *** empty log message ***
119 | ApxTAbbrev _ => raise Fail "Internal error: eta': ApxTAbbrev cannot happen"
55bb0346 »
2010-06-09 *** empty log message ***
120 | ApxTLogicVar _ => raise ExnDeclError (AmbigType, pp ())
0455366b »
2007-06-14 Initial revision.
121 val etaResult = eta' (A, 0, fn (n, S) => S)
122 in case H of
977c2a88 »
2008-06-07 *** empty log message ***
123 Var mn => if Util.isNil S then EtaTag (etaResult, mn) else etaResult
0455366b »
2007-06-14 Initial revision.
124 | _ => etaResult
125 end
126
4f306304 »
2007-12-03 *** empty log message ***
127 val etaCount = ref 0
128
d8ffb3f9 »
2007-12-03 *** empty log message ***
129 (* etaExpandKind : context * kind -> kind *)
130 fun etaExpandKind (ctx, ki) = case Kind.prj ki of
0455366b »
2007-06-14 Initial revision.
131 Type => Type'
d8ffb3f9 »
2007-12-03 *** empty log message ***
132 | KPi (x, A, K) =>
133 let val A' = etaExpandType (ctx, A)
977c2a88 »
2008-06-07 *** empty log message ***
134 in KPi' (x, A', etaExpandKind (ctxCondPushINT (x, asyncTypeToApx A', ctx), K)) end
d8ffb3f9 »
2007-12-03 *** empty log message ***
135
136 (* etaExpandType : context * asyncType -> asyncType *)
4f306304 »
2007-12-03 *** empty log message ***
137 and etaExpandType (ctx, ty) =
138 if !traceEta then
139 let fun join [] = ""
140 | join [s] = s
141 | join (s::ss) = s^", "^join ss
142 val t = join (map (fn (x, A, _) =>
143 (x^":"^PrettyPrint.printType (unsafeCast A))) (ctx2list ctx))
144 val t = t^"|- "^PrettyPrint.printType ty
145 val () = etaCount := !etaCount + 1
146 val a = Int.toString (!etaCount)
147 val () = print ("Eta["^a^"]: "^t^" : Type\n")
148 val ty' = etaExpandType' (ctx, ty)
149 val () = print ("EtaDone["^a^"]: "^t^" ==> "^PrettyPrint.printType ty'^"\n")
150 in ty' end
151 else etaExpandType' (ctx, ty)
152 and etaExpandType' (ctx, ty) = case AsyncType.prj ty of
7cf3cc3e »
2009-02-27 clf ver 2
153 TLPi (p, S, B) =>
154 let val S' = etaExpandSyncType (ctx, S)
155 in TLPi' (p, S', etaExpandType (tpatBindApx (p, syncTypeToApx S) ctx, B)) end
d8ffb3f9 »
2007-12-03 *** empty log message ***
156 | AddProd (A, B) => AddProd' (etaExpandType (ctx, A), etaExpandType (ctx, B))
157 | TMonad S => TMonad' (etaExpandSyncType (ctx, S))
158 | TAtomic (a, S) => TAtomic' (a, etaExpandTypeSpine (ctx, S, kindToApx (sigLookupKind a)))
0455366b »
2007-06-14 Initial revision.
159 | TAbbrev aA => TAbbrev' aA
160
d8ffb3f9 »
2007-12-03 *** empty log message ***
161 (* etaExpandTypeSpine : context * typeSpine * apxKind -> typeSpine *)
162 and etaExpandTypeSpine (ctx, sp, ki) = case (TypeSpine.prj sp, ApxKind.prj ki) of
0455366b »
2007-06-14 Initial revision.
163 (TNil, ApxType) => TNil'
d8ffb3f9 »
2007-12-03 *** empty log message ***
164 | (TApp (N, S), ApxKPi (A, K)) =>
165 TApp' (etaExpandObj (ctx, N, A), etaExpandTypeSpine (ctx, S, K))
0cbe58e0 »
2010-06-04 *** empty log message ***
166 | _ => raise Fail "Internal error: etaExpandTypeSpine match"
0455366b »
2007-06-14 Initial revision.
167
d8ffb3f9 »
2007-12-03 *** empty log message ***
168 (* etaExpandSyncType : context * syncType -> syncType *)
169 and etaExpandSyncType (ctx, ty) = case SyncType.prj ty of
7cf3cc3e »
2009-02-27 clf ver 2
170 LExists (p, S1, S2) =>
171 let val S1' = etaExpandSyncType (ctx, S1)
172 in LExists' (p, S1', etaExpandSyncType (tpatBindApx (p, syncTypeToApx S1') ctx, S2)) end
0455366b »
2007-06-14 Initial revision.
173 | TOne => TOne'
7cf3cc3e »
2009-02-27 clf ver 2
174 | TDown A => TDown' (etaExpandType (ctx, A))
b0db913f »
2009-02-27 *** empty log message ***
175 | TAffi A => TAffi' (etaExpandType (ctx, A))
7cf3cc3e »
2009-02-27 clf ver 2
176 | TBang A => TBang' (etaExpandType (ctx, A))
0455366b »
2007-06-14 Initial revision.
177
d8ffb3f9 »
2007-12-03 *** empty log message ***
178 (* etaExpandObj : context * obj * apxAsyncType -> obj *)
4f306304 »
2007-12-03 *** empty log message ***
179 and etaExpandObj (ctx, ob, ty) =
180 ( if !traceEta then
181 ( print "Eta: "
182 ; app (fn (x, A, _) => print (x^":"^PrettyPrint.printType (unsafeCast A)^", "))
183 (ctx2list ctx)
184 ; print ("|- "^PrettyPrint.printObj ob^" : "^PrettyPrint.printType (unsafeCast ty)^"\n"))
185 else ()
186 ; etaExpandObj' (ctx, ob, ty) )
55bb0346 »
2010-06-09 *** empty log message ***
187 and etaExpandObj' (ctx, ob, ty) =
188 let fun pp () = PrettyPrint.printObj ob ^ " : " ^ PrettyPrint.printType (unsafeCast ty) ^ "\n"
189 in case (Obj.prj ob, Util.apxTypePrjAbbrev ty) of
190 (_, ApxTLogicVar _) => raise ExnDeclError (AmbigType, pp ())
7cf3cc3e »
2009-02-27 clf ver 2
191 | (LLam (p, N), ApxLolli (A, B)) =>
192 LLam' (p, etaExpandObj (opatBindApx (p, A) ctx, N, B))
0455366b »
2007-06-14 Initial revision.
193 | (AddPair (N1, N2), ApxAddProd (A, B)) =>
d8ffb3f9 »
2007-12-03 *** empty log message ***
194 AddPair' (etaExpandObj (ctx, N1, A), etaExpandObj (ctx, N2, B))
195 | (Monad E, ApxTMonad S) => Monad' (etaExpandExp (ctx, E, S))
196 | (Atomic (H, S), _) =>
197 let val (H', A) = etaExpandHead (ctx, H)
55bb0346 »
2010-06-09 *** empty log message ***
198 fun ppH () = PrettyPrint.printObj (Atomic' (H', S)) ^ " : "
199 ^ PrettyPrint.printType (unsafeCast A) ^ "\n"
200 in etaExpand pp (ty, H', #1 $ etaExpandSpine ppH (ctx, S, A)) end
201 | (Redex (N, A, S), _) =>
202 Redex' (etaExpandObj (ctx, N, A), A, #1 $ etaExpandSpine (fn () => "") (ctx, S, A))
d8ffb3f9 »
2007-12-03 *** empty log message ***
203 | (Constraint (N, A), _) => Constraint' (etaExpandObj (ctx, N, ty), etaExpandType (ctx, A))
0cbe58e0 »
2010-06-04 *** empty log message ***
204 | _ => raise Fail "Internal error: etaExpandObj match"
55bb0346 »
2010-06-09 *** empty log message ***
205 end
0455366b »
2007-06-14 Initial revision.
206
d8ffb3f9 »
2007-12-03 *** empty log message ***
207 (* etaExpandHead : context * head -> head * apxAsyncType *)
208 and etaExpandHead (ctx, h) = case h of
209 Const c => (h, asyncTypeToApx (Signatur.sigLookupType c))
977c2a88 »
2008-06-07 *** empty log message ***
210 | Var (_, n) => (h, #3 (ctxLookupNum (ctx, n)))
d8ffb3f9 »
2007-12-03 *** empty log message ***
211 | UCVar x => (h, asyncTypeToApx (ImplicitVars.ucLookup x))
212 | LogicVar X =>
0cbe58e0 »
2010-06-04 *** empty log message ***
213 let val () = if Subst.isId (#s X) then () else raise Fail "Internal error: eta lvar"
d8ffb3f9 »
2007-12-03 *** empty log message ***
214 val A = etaExpandType (ctx, #ty X)
215 in (LogicVar (X with'ty A), asyncTypeToApx A) end
0455366b »
2007-06-14 Initial revision.
216
55bb0346 »
2010-06-09 *** empty log message ***
217 (* etaExpandSpine : (unit -> string) -> context * spine * apxAsyncType -> spine * apxAsyncType *)
218 and etaExpandSpine ppH (ctx, sp, ty) = case (Spine.prj sp, Util.apxTypePrjAbbrev ty) of
219 (_, ApxTLogicVar _) => raise ExnDeclError (AmbigType, ppH ())
7cf3cc3e »
2009-02-27 clf ver 2
220 | (Nil, A) => (Nil', ApxAsyncType.inj A)
221 | (LApp (N, S), ApxLolli (A, B)) =>
55bb0346 »
2010-06-09 *** empty log message ***
222 map1 (fn sp => LApp' (etaExpandMonadObj (ctx, N, A), sp))
223 (etaExpandSpine ppH (ctx, S, B))
224 | (ProjLeft S, ApxAddProd (A, B)) => map1 ProjLeft' (etaExpandSpine ppH (ctx, S, A))
225 | (ProjRight S, ApxAddProd (A, B)) => map1 ProjRight' (etaExpandSpine ppH (ctx, S, B))
0cbe58e0 »
2010-06-04 *** empty log message ***
226 | _ => raise Fail "Internal error: etaExpandSpine match"
0455366b »
2007-06-14 Initial revision.
227
d8ffb3f9 »
2007-12-03 *** empty log message ***
228 (* etaExpandExp : context * expObj * apxSyncType -> expObj *)
229 and etaExpandExp (ctx, ex, ty) = case ExpObj.prj ex of
7cf3cc3e »
2009-02-27 clf ver 2
230 LetRedex (p, S, N, E) =>
231 LetRedex' (p, S, etaExpandObj (ctx, N, ApxTMonad' S),
232 etaExpandExp (opatBindApx (p, S) ctx, E, ty))
233 | Let (p, (H, S), E) =>
234 let val (H', A) = etaExpandHead (ctx, H)
55bb0346 »
2010-06-09 *** empty log message ***
235 fun ppH () = PrettyPrint.printObj (Atomic' (H', S)) ^ " : "
236 ^ PrettyPrint.printType (unsafeCast A) ^ "\n"
237 val (S', mTy) = etaExpandSpine ppH (ctx, S, A)
7cf3cc3e »
2009-02-27 clf ver 2
238 in case Util.apxTypePrjAbbrev mTy of
239 ApxTMonad sTy =>
240 Let' (p, (H', S'), etaExpandExp (opatBindApx (p, sTy) ctx, E, ty))
241 | _ => raise Fail "Internal error: etaExpandExp type mismatch"
242 end
d8ffb3f9 »
2007-12-03 *** empty log message ***
243 | Mon M => Mon' (etaExpandMonadObj (ctx, M, ty))
244
245 (* etaExpandMonadObj : context * monadObj * apxSyncType -> monadObj *)
246 and etaExpandMonadObj (ctx, mob, ty) = case (MonadObj.prj mob, ApxSyncType.prj ty) of
7cf3cc3e »
2009-02-27 clf ver 2
247 (DepPair (M1, M2), ApxTTensor (S1, S2)) =>
248 DepPair' (etaExpandMonadObj (ctx, M1, S1), etaExpandMonadObj (ctx, M2, S2))
0455366b »
2007-06-14 Initial revision.
249 | (One, ApxTOne) => One'
7cf3cc3e »
2009-02-27 clf ver 2
250 | (Down N, ApxTDown A) => Down' (etaExpandObj (ctx, N, A))
b0db913f »
2009-02-27 *** empty log message ***
251 | (Affi N, ApxTAffi A) => Affi' (etaExpandObj (ctx, N, A))
7cf3cc3e »
2009-02-27 clf ver 2
252 | (Bang N, ApxTBang A) => Bang' (etaExpandObj (ctx, N, A))
0cbe58e0 »
2010-06-04 *** empty log message ***
253 | _ => raise Fail "Internal error: etaExpandMonadObj match" (* includes MonUndef *)
0455366b »
2007-06-14 Initial revision.
254
d8ffb3f9 »
2007-12-03 *** empty log message ***
255 fun etaExpandKindEC ki = etaExpandKind (emptyCtx, ki)
256 fun etaExpandTypeEC ty = etaExpandType (emptyCtx, ty)
257 fun etaExpandObjEC (ob, ty) = etaExpandObj (emptyCtx, ob, ty)
0455366b »
2007-06-14 Initial revision.
258
259 end
Something went wrong with that request. Please try again.