Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 155 lines (122 sloc) 4.824 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;
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
d3bb881 Switched to CPS
Edwin Brady authored
71 data [noElim] Res : Vect Ty n -> Vect Ty n -> Ty -> Set where
72
73 {-- Resource creation and usage. 'Let' creates a resource - the type
74 at the end means that the resource must have been consumed by the time
75 it goes out of scope, where "consumed" simply means that it has been
76 replaced with a value of type '()'. --}
77
78 Let : Creator (interpTy a) ->
79 Res (a :: gam) (Val () :: gam') t -> Res gam gam' t
80 | App : Res gam gam (a :-> t) -> HasType gam i (Val a) -> Res gam gam t
81 | Update : (a -> Updater b) -> (p:HasType gam i (Val a)) ->
82 Res gam (update gam p (Val b)) (Val ())
83 | Use : (a -> Reader b) -> HasType gam i (Val a) ->
84 Res gam gam (Val b)
85
86 {-- Control structures --}
87
88 | Lift' : IO a -> Res gam gam (Val a)
89 | Check : (p:HasType gam i (Choice (interpTy a) (interpTy b))) ->
90 (failure:Res (update gam p a) (update gam p c) T) ->
91 (success:Res (update gam p b) (update gam p c) T) ->
92 Res gam (update gam p c) T
93 | While : Res gam gam (Val Bool) ->
94 Res gam gam (Val ()) -> Res gam gam (Val ())
95 | Return : a -> Res gam gam (Val a)
96 | Bind : Res gam gam' a -> (interpTy a -> Res gam' gam'' t) ->
97 Res gam gam'' t;
98
99 syntax Lift x = Lift' (lazy x); -- workaround for laziness not working on cons
100
101 iofst : IO (a & b) -> IO a;
102 iofst ip = do { p <- ip;
103 return (fst p); };
104
105 interp : Env gam -> Res gam gam' t ->
106 (Env gam' -> interpTy t -> IO u) -> IO u;
107 interp env (Let val scope) k
4006f11 Add resfile and resimp
Edwin Brady authored
108 = do { x <- getCreator val;
d3bb881 Switched to CPS
Edwin Brady authored
109 interp (Extend x env) scope
110 (\env', scope' => k (envTail env') scope');
4006f11 Add resfile and resimp
Edwin Brady authored
111 };
d3bb881 Switched to CPS
Edwin Brady authored
112 interp env (Update method x) k
4006f11 Add resfile and resimp
Edwin Brady authored
113 = do { x' <- getUpdater (method (envLookup x env));
d3bb881 Switched to CPS
Edwin Brady authored
114 k (envUpdate x x' env) II;
4006f11 Add resfile and resimp
Edwin Brady authored
115 };
d3bb881 Switched to CPS
Edwin Brady authored
116 interp env (Use method x) k
4006f11 Add resfile and resimp
Edwin Brady authored
117 = do { x' <- getReader (method (envLookup x env));
d3bb881 Switched to CPS
Edwin Brady authored
118 k env x';
4006f11 Add resfile and resimp
Edwin Brady authored
119 };
d3bb881 Switched to CPS
Edwin Brady authored
120 interp env (Lift' io) k
121 = do { v <- io;
122 k env v; };
123 interp env (Check x left right) k =
124 either (envLookup x env)
125 (\a => interp (envUpdate x a env) left k)
126 (\b => interp (envUpdate x b env) right k);
127 interp env (While test body) k
128 = interp env test
129 (\env', result =>
130 if (not result)
131 then (k env' II)
132 else (interp env' body
133 (\env'', body' => interp env'' (While test body) k)));
134 interp env (Return v) k = k env v;
135 interp env (Bind v f) k
136 = interp env v (\env', v' => interp env' (f v') k);
137
138 run : Res VNil VNil (Val t) -> IO t;
139 run prog = interp Empty prog (\env, res => return res);
4006f11 Add resfile and resimp
Edwin Brady authored
140
141 }
142
143 dsl res {
144 bind = Bind
145 return = Return
146 variable = id
147 let = Let
148 index_first = stop
149 index_next = pop
d3bb881 Switched to CPS
Edwin Brady authored
150 outer_lambda = Lam
4006f11 Add resfile and resimp
Edwin Brady authored
151 }
152
d3bb881 Switched to CPS
Edwin Brady authored
153 syntax RES x = #( {gam:Vect Ty n} -> Res gam gam (Val x) );
4006f11 Add resfile and resimp
Edwin Brady authored
154
Something went wrong with that request. Please try again.