Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 189 lines (149 sloc) 6.118 kb
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
1
2 -- IO operations which read a resource
3 data Reader : Set -> Set where
4 MkReader : IO a -> Reader a;
5
6 getReader : Reader a -> IO a;
7 getReader (MkReader x) = x;
8
9 ior : IO a -> Reader a;
10 ior = MkReader;
11
12 -- IO operations which update a resource
13 data Updater : Set -> Set where
14 MkUpdater : IO a -> Updater a;
15
16 getUpdater : Updater a -> IO a;
17 getUpdater (MkUpdater x) = x;
18
19 iou : IO a -> Updater a;
20 iou = MkUpdater;
21
22 -- IO operations which create a resource
23 data Creator : Set -> Set where
24 MkCreator : IO a -> Creator a;
25
26 getCreator : Creator a -> IO a;
27 getCreator (MkCreator x) = x;
28
29 ioc : IO a -> Creator a;
30 ioc = MkCreator;
31
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
32 using (i: Fin n, gam : Vect Ty n, gam' : Vect Ty n, gam'' : Vect Ty n) {
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
33
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
34 infixr 5 :-> ;
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
35
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
36 data Ty = R Set
37 | Val Set
38 | Choice Set Set
39 | (:->) Set Ty;
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
40
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
41 interpTy : Ty -> Set;
42 interpTy (R t) = IO t;
43 interpTy (Val t) = t;
44 interpTy (Choice x y) = Either x y;
898231d7 » Edwin Brady
2011-07-12 Functions in resimp/resfile
45 interpTy (a :-> b) = a -> interpTy b;
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
46
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
47 data HasType : Vect Ty n -> Fin n -> Ty -> Set where
48 stop : HasType (a :: gam) fO a
49 | pop : HasType gam i b -> HasType (a :: gam) (fS i) b;
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
50
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
51 data Env : Vect Ty n -> Set where
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
52 Empty : Env VNil
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
53 | Extend : interpTy a -> Env gam -> Env (a :: gam);
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
54
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
55 envLookup : HasType gam i a -> Env gam -> interpTy a;
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
56 envLookup stop (Extend x xs) = x;
57 envLookup (pop k) (Extend x xs) = envLookup k xs;
58
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
59 update : (gam : Vect Ty n) -> HasType gam i b -> Ty -> Vect Ty n;
60 update (x :: xs) stop y = y :: xs;
61 update (x :: xs) (pop k) y = x :: update xs k y;
62
63 envUpdate : (p:HasType gam i a) -> (val:interpTy b) ->
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
64 Env gam -> Env (update gam p b);
65 envUpdate stop val (Extend x xs) = Extend val xs;
66 envUpdate (pop k) val (Extend x xs) = Extend x (envUpdate k val xs);
67
68 envTail : Env (a :: gam) -> Env gam;
69 envTail (Extend x xs) = xs;
70
898231d7 » Edwin Brady
2011-07-12 Functions in resimp/resfile
71 data Args : Vect Ty n -> List Set -> Set where
72 ANil : Args gam Nil
73 | ACons : HasType gam i a ->
74 Args gam as -> Args gam (Cons (interpTy a) as);
75
76 funTy : List Set -> Ty -> Ty;
77 funTy Nil t = t;
78 funTy (Cons a as) t = a :-> funTy as t;
79
80 applyArgs : Env gam -> interpTy (funTy as t) -> Args gam as -> interpTy t;
81 applyArgs env f ANil = f;
82 applyArgs env f (ACons x xs) = applyArgs env (f (envLookup x env)) xs;
83
84 data ResFn : Vect Ty n -> Ty -> Set;
85
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
86 data [noElim] Res : Vect Ty n -> Vect Ty n -> Ty -> Set where
87
88 {-- Resource creation and usage. 'Let' creates a resource - the type
89 at the end means that the resource must have been consumed by the time
90 it goes out of scope, where "consumed" simply means that it has been
91 replaced with a value of type '()'. --}
92
93 Let : Creator (interpTy a) ->
898231d7 » Edwin Brady
2011-07-12 Functions in resimp/resfile
94 Res (a :: gam) (Val () :: gam') (R t) -> Res gam gam' (R t)
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
95 | Update : (a -> Updater b) -> (p:HasType gam i (Val a)) ->
898231d7 » Edwin Brady
2011-07-12 Functions in resimp/resfile
96 Res gam (update gam p (Val b)) (R ())
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
97 | Use : (a -> Reader b) -> HasType gam i (Val a) ->
898231d7 » Edwin Brady
2011-07-12 Functions in resimp/resfile
98 Res gam gam (R b)
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
99
100 {-- Control structures --}
101
898231d7 » Edwin Brady
2011-07-12 Functions in resimp/resfile
102 | Call : ResFn gam (funTy as t) -> Args gam as -> Res gam gam t
103 | Lift' : IO a -> Res gam gam (R a)
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
104 | Check : (p:HasType gam i (Choice (interpTy a) (interpTy b))) ->
105 (failure:Res (update gam p a) (update gam p c) T) ->
106 (success:Res (update gam p b) (update gam p c) T) ->
107 Res gam (update gam p c) T
898231d7 » Edwin Brady
2011-07-12 Functions in resimp/resfile
108 | While : Res gam gam (R Bool) ->
109 Res gam gam (R ()) -> Res gam gam (R ())
110 | Return : a -> Res gam gam (R a)
111 | Bind : Res gam gam' (R a) -> (a -> Res gam' gam'' (R t)) ->
112 Res gam gam'' (R t);
113
114 data ResFn : Vect Ty n -> Ty -> Set where
115 Lam : ResFn (a :: gam) t -> ResFn gam (interpTy a :-> t)
116 | Fn : Res gam gam (R t) -> ResFn gam (R t);
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
117
118 syntax Lift x = Lift' (lazy x); -- workaround for laziness not working on cons
119
120 iofst : IO (a & b) -> IO a;
121 iofst ip = do { p <- ip;
122 return (fst p); };
123
124 interp : Env gam -> Res gam gam' t ->
125 (Env gam' -> interpTy t -> IO u) -> IO u;
898231d7 » Edwin Brady
2011-07-12 Functions in resimp/resfile
126
127 interpFn : Env gam -> ResFn gam t -> interpTy t;
128 interpFn env (Lam sc) = \x => interpFn (Extend x env) sc;
129 interpFn env (Fn b) = interp env b (\env, v => v);
130
131 interp : Env gam -> Res gam gam' t ->
132 (Env gam' -> interpTy t -> IO u) -> IO u;
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
133 interp env (Let val scope) k
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
134 = do { x <- getCreator val;
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
135 interp (Extend x env) scope
136 (\env', scope' => k (envTail env') scope');
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
137 };
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
138 interp env (Update method x) k
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
139 = do { x' <- getUpdater (method (envLookup x env));
898231d7 » Edwin Brady
2011-07-12 Functions in resimp/resfile
140 k (envUpdate x x' env) (return II);
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
141 };
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
142 interp env (Use method x) k
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
143 = do { x' <- getReader (method (envLookup x env));
898231d7 » Edwin Brady
2011-07-12 Functions in resimp/resfile
144 k env (return x');
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
145 };
898231d7 » Edwin Brady
2011-07-12 Functions in resimp/resfile
146
147 interp env (Call fn args) k
148 = k env (applyArgs env (interpFn env fn) args);
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
149 interp env (Lift' io) k
898231d7 » Edwin Brady
2011-07-12 Functions in resimp/resfile
150 = do { -- v <- io;
151 k env io; };
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
152 interp env (Check x left right) k =
153 either (envLookup x env)
154 (\a => interp (envUpdate x a env) left k)
155 (\b => interp (envUpdate x b env) right k);
156 interp env (While test body) k
157 = interp env test
158 (\env', result =>
898231d7 » Edwin Brady
2011-07-12 Functions in resimp/resfile
159 do { r <- result;
160 if (not r)
161 then (k env' (return II))
162 else (interp env' body
163 (\env'', body' =>
164 do { v <- body'; -- make sure it's evalled
165 interp env'' (While test body) k; }));
166 });
167
168 interp env (Return v) k = k env (return v);
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
169 interp env (Bind v f) k
898231d7 » Edwin Brady
2011-07-12 Functions in resimp/resfile
170 = interp env v (\env', v' => do { n <- v';
171 interp env' (f n) k; });
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
172
898231d7 » Edwin Brady
2011-07-12 Functions in resimp/resfile
173 run : Res VNil VNil (R t) -> IO t;
174 run prog = interp Empty prog (\env, res => res);
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
175
176 }
177
178 dsl res {
179 bind = Bind
180 return = Return
181 variable = id
182 let = Let
183 index_first = stop
184 index_next = pop
d3bb8811 » Edwin Brady
2011-07-11 Switched to CPS
185 outer_lambda = Lam
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
186 }
187
898231d7 » Edwin Brady
2011-07-12 Functions in resimp/resfile
188 syntax RES x = #( {gam:Vect Ty n} -> Res gam gam (R x) );
189 syntax RESFN x = #( {gam:Vect Ty n} -> ResFn gam x );
4006f11e » Edwin Brady
2011-07-07 Add resfile and resimp
190
Something went wrong with that request. Please try again.