Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 161 lines (126 sloc) 5.067 kb
64e33f6 New notation
Edwin Brady authored
1 module resimp
2
3 -- IO operations which read a resource
4 data Reader : Set -> Set where
5 MkReader : IO a -> Reader a
6
7 getReader : Reader a -> IO a
8 getReader (MkReader x) = x
9
10 ior : IO a -> Reader a
11 ior = MkReader
12
13 -- IO operations which update a resource
14 data Updater : Set -> Set where
15 MkUpdater : IO a -> Updater a
16
17 getUpdater : Updater a -> IO a
18 getUpdater (MkUpdater x) = x
19
20 iou : IO a -> Updater a
21 iou = MkUpdater
22
23 -- IO operations which create a resource
24 data Creator : Set -> Set where
25 MkCreator : IO a -> Creator a
26
27 getCreator : Creator a -> IO a
28 getCreator (MkCreator x) = x
29
30 ioc : IO a -> Creator a
31 ioc = MkCreator
32
33 infixr 5 :->
34
35 using (i: Fin n, gam : Vect Ty n, gam' : Vect Ty n, gam'' : Vect Ty n)
36
37 data Ty = R Set
38 | Val Set
39 | Choice Set Set
40 | (:->) Set Ty
41
42 interpTy : Ty -> Set
43 interpTy (R t) = IO t
44 interpTy (Val t) = t
45 interpTy (Choice x y) = Either x y
46 interpTy (a :-> b) = a -> interpTy b
47
48 data HasType : Vect Ty n -> Fin n -> Ty -> Set where
49 stop : HasType (a :: gam) fO a
50 pop : HasType gam i b -> HasType (a :: gam) (fS i) b
51
52 data Env : Vect Ty n -> Set where
53 Nil : Env Nil
54 (::) : interpTy a -> Env gam -> Env (a :: gam)
55
56 envLookup : HasType gam i a -> Env gam -> interpTy a
57 envLookup stop (x :: xs) = x
58 envLookup (pop k) (x :: xs) = envLookup k xs
59
60 update : (gam : Vect Ty n) -> HasType gam i b -> Ty -> Vect Ty n
61 update (x :: xs) stop y = y :: xs
62 update (x :: xs) (pop k) y = x :: update xs k y
63
64 envUpdate : (p:HasType gam i a) -> (val:interpTy b) ->
65 Env gam -> Env (update gam p b)
66 envUpdate stop val (x :: xs) = val :: xs
67 envUpdate (pop k) val (x :: xs) = x :: envUpdate k val xs
68
69 envTail : Env (a :: gam) -> Env gam
70 envTail (x :: xs) = xs
71
72 data Args : Vect Ty n -> List Set -> Set where
73 ANil : Args gam []
74 ACons : HasType gam i a ->
75 Args gam as -> Args gam (interpTy a :: as)
76
77 funTy : List Set -> Ty -> Ty
78 funTy list.Nil t = t
79 funTy (a :: as) t = a :-> funTy as t
80
81 -- applyArgs : {as : List Set} ->
82 -- Env gam -> interpTy (funTy as t) -> Args gam as -> interpTy t
83 -- -- applyArgs env f ANil = f
84 -- applyArgs env f (ACons x xs) = ?appArgs --applyArgs env (f (envLookup x env)) xs
85
86 data 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) ->
94 Res (a :: gam) (Val () :: gam') (R t) ->
95 Res gam gam' (R t)
96 Update : (a -> Updater b) -> (p:HasType gam i (Val a)) ->
97 Res gam (update gam p (Val b)) (R ())
98 Use : (a -> Reader b) -> HasType gam i (Val a) ->
99 Res gam gam (R b)
100
101 {-- Control structures --}
102
103 Lift : IO a -> Res gam gam (R a)
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
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 (>>=) : Res gam gam' (R a) -> (a -> Res gam' gam'' (R t)) ->
112 Res gam gam'' (R t)
113
114
115 interp : Env gam -> Res gam gam' t ->
116 (Env gam' -> interpTy t -> IO u) -> IO u
117
118 interp env (Let val scope) k
119 = do x <- getCreator val;
120 interp (x :: env) scope
121 (\env', scope' => k (envTail env') scope')
122 interp env (Update method x) k
123 = do x' <- getUpdater (method (envLookup x env))
124 k (envUpdate x x' env) (return ())
125 interp env (Use method x) k
126 = do x' <- getReader (method (envLookup x env))
127 k env (return x')
128 interp env (Lift io) k
129 = k env io
130 interp env (Check x left right) k =
131 either (envLookup x env)
132 (\a => interp (envUpdate x a env) left k)
133 (\b => interp (envUpdate x b env) right k)
134 interp env (While test body) k
135 = interp env test
136 (\env', result =>
137 do r <- result;
138 if (not r)
139 then (k env' (return ()))
140 else (interp env' body
141 (\env'', body' =>
142 do v <- body' -- make sure it's evalled
143 interp env'' (While test body) k ))
144 )
145 interp env (Return v) k = k env (return v)
146 interp env (v >>= f) k
147 = interp env v (\env', v' => do n <- v'
148 interp env' (f n) k)
149
150 run : Res [] [] (R t) -> IO t
151 run prog = interp [] prog (\env, res => res)
152
153 dsl res
154 variable = id
155 let = Let
156 index_first = stop
157 index_next = pop
158
159 syntax RES [x] = {gam:Vect Ty n} -> Res gam gam (R x)
160
Something went wrong with that request. Please try again.