Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 197 lines (154 sloc) 6.184 kb
4006f11 Add resfile and resimp
Edwin Brady authored
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
d3bb881 Switched to CPS
Edwin Brady authored
32 using (i: Fin n, gam : Vect Ty n, gam' : Vect Ty n, gam'' : Vect Ty n) {
4006f11 Add resfile and resimp
Edwin Brady authored
33
d3bb881 Switched to CPS
Edwin Brady authored
34 infixr 5 :-> ;
4006f11 Add resfile and resimp
Edwin Brady authored
35
d3bb881 Switched to CPS
Edwin Brady authored
36 data Ty = R Set
37 | Val Set
38 | Choice Set Set
39 | (:->) Set Ty;
4006f11 Add resfile and resimp
Edwin Brady authored
40
d3bb881 Switched to CPS
Edwin Brady authored
41 interpTy : Ty -> Set;
42 interpTy (R t) = IO t;
43 interpTy (Val t) = t;
44 interpTy (Choice x y) = Either x y;
898231d Functions in resimp/resfile
Edwin Brady authored
45 interpTy (a :-> b) = a -> interpTy b;
4006f11 Add resfile and resimp
Edwin Brady authored
46
d3bb881 Switched to CPS
Edwin Brady authored
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;
4006f11 Add resfile and resimp
Edwin Brady authored
50
d3bb881 Switched to CPS
Edwin Brady authored
51 data Env : Vect Ty n -> Set where
4006f11 Add resfile and resimp
Edwin Brady authored
52 Empty : Env VNil
d3bb881 Switched to CPS
Edwin Brady authored
53 | Extend : interpTy a -> Env gam -> Env (a :: gam);
4006f11 Add resfile and resimp
Edwin Brady authored
54
d3bb881 Switched to CPS
Edwin Brady authored
55 envLookup : HasType gam i a -> Env gam -> interpTy a;
4006f11 Add resfile and resimp
Edwin Brady authored
56 envLookup stop (Extend x xs) = x;
57 envLookup (pop k) (Extend x xs) = envLookup k xs;
58
d3bb881 Switched to CPS
Edwin Brady authored
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) ->
4006f11 Add resfile and resimp
Edwin Brady authored
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
898231d Functions in resimp/resfile
Edwin Brady authored
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
d3bb881 Switched to CPS
Edwin Brady authored
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) ->
bcefa05 Minor tweaks
Edwin Brady authored
94 Res (a :: gam) (Val () :: gam) (R t) -> Res gam gam (R t)
d3bb881 Switched to CPS
Edwin Brady authored
95 | Update : (a -> Updater b) -> (p:HasType gam i (Val a)) ->
898231d Functions in resimp/resfile
Edwin Brady authored
96 Res gam (update gam p (Val b)) (R ())
d3bb881 Switched to CPS
Edwin Brady authored
97 | Use : (a -> Reader b) -> HasType gam i (Val a) ->
898231d Functions in resimp/resfile
Edwin Brady authored
98 Res gam gam (R b)
d3bb881 Switched to CPS
Edwin Brady authored
99
100 {-- Control structures --}
101
898231d Functions in resimp/resfile
Edwin Brady authored
102 | Call : ResFn gam (funTy as t) -> Args gam as -> Res gam gam t
103 | Lift' : IO a -> Res gam gam (R a)
d3bb881 Switched to CPS
Edwin Brady authored
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
898231d Functions in resimp/resfile
Edwin Brady authored
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);
d3bb881 Switched to CPS
Edwin Brady authored
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;
898231d Functions in resimp/resfile
Edwin Brady authored
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;
d3bb881 Switched to CPS
Edwin Brady authored
133 interp env (Let val scope) k
4006f11 Add resfile and resimp
Edwin Brady authored
134 = do { x <- getCreator val;
d3bb881 Switched to CPS
Edwin Brady authored
135 interp (Extend x env) scope
136 (\env', scope' => k (envTail env') scope');
4006f11 Add resfile and resimp
Edwin Brady authored
137 };
d3bb881 Switched to CPS
Edwin Brady authored
138 interp env (Update method x) k
4006f11 Add resfile and resimp
Edwin Brady authored
139 = do { x' <- getUpdater (method (envLookup x env));
898231d Functions in resimp/resfile
Edwin Brady authored
140 k (envUpdate x x' env) (return II);
4006f11 Add resfile and resimp
Edwin Brady authored
141 };
d3bb881 Switched to CPS
Edwin Brady authored
142 interp env (Use method x) k
4006f11 Add resfile and resimp
Edwin Brady authored
143 = do { x' <- getReader (method (envLookup x env));
898231d Functions in resimp/resfile
Edwin Brady authored
144 k env (return x');
4006f11 Add resfile and resimp
Edwin Brady authored
145 };
898231d Functions in resimp/resfile
Edwin Brady authored
146
147 interp env (Call fn args) k
148 = k env (applyArgs env (interpFn env fn) args);
d3bb881 Switched to CPS
Edwin Brady authored
149 interp env (Lift' io) k
898231d Functions in resimp/resfile
Edwin Brady authored
150 = do { -- v <- io;
151 k env io; };
d3bb881 Switched to CPS
Edwin Brady authored
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 =>
898231d Functions in resimp/resfile
Edwin Brady authored
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);
d3bb881 Switched to CPS
Edwin Brady authored
169 interp env (Bind v f) k
898231d Functions in resimp/resfile
Edwin Brady authored
170 = interp env v (\env', v' => do { n <- v';
171 interp env' (f n) k; });
d3bb881 Switched to CPS
Edwin Brady authored
172
898231d Functions in resimp/resfile
Edwin Brady authored
173 run : Res VNil VNil (R t) -> IO t;
174 run prog = interp Empty prog (\env, res => res);
4006f11 Add resfile and resimp
Edwin Brady authored
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
bcefa05 Minor tweaks
Edwin Brady authored
185 }
186
187 dsl resfn {
188 lambda = Lam
189 variable = id
190 index_first = stop
191 index_next = pop
4006f11 Add resfile and resimp
Edwin Brady authored
192 }
193
898231d Functions in resimp/resfile
Edwin Brady authored
194 syntax RES x = #( {gam:Vect Ty n} -> Res gam gam (R x) );
195 syntax RESFN x = #( {gam:Vect Ty n} -> ResFn gam x );
4006f11 Add resfile and resimp
Edwin Brady authored
196
Something went wrong with that request. Please try again.