1 module Edlib where 2 3 import Type_defs 4 5 import Core_datatype 6 7 infixr 9 <: 8 9 infixl 8 /// , />/ , /:>/ , /./ , /.>/, /.:>/, |||, |>|, |@|, |.| 10 11 infixl 8 ..., ./., \\\ 12 13 infixl 1 `handle`, `ihandle` 14 15 -- infixl 8 >>, >>>, *>>, *>>>, >>+, >>>+, *>>+, *>>>+, >>^, >>>^, *>>^, *>>>^ 16 17 18 19 20 21 -- type Xin = ( String , [Response] , [Int]) 22 type Xin = ( String , [Int] , [Int]) 23 24 type Xout = String 25 -- type Xout = [Request] 26 27 type Xio = ( Xin , Xout ) 28 29 type Xio_fn = Xin -> Xio 30 31 type Xst a = ( Xin , a , Xout ) 32 33 type Xst_fn a = ( Xin , a ) -> ( Xin , a , Xout ) 34 35 36 --partain: id x = x 37 38 39 40 41 42 43 (\\\) :: Xio -> Xio_fn -> Xio 44 45 ( xin , xout ) \\\ g 46 = ( xin2 , xout ++ xout2 ) 47 where 48 ( xin2, xout2 ) = g xin 49 50 51 (...) :: Xio_fn -> Xio_fn -> Xin -> Xio 52 53 (...) f g xin 54 = f xin \\\ g 55 56 57 58 59 (./.) :: Xio_fn -> ( Xin -> Xst ( MayBe a b )) -> Xin -> Xst ( MayBe a b ) 60 61 (./.) f g xin 62 = ( xin2 , st, xout' ++ xout2 ) 63 where 64 ( xin', xout' ) = f xin 65 ( xin2, st, xout2 ) = g xin' 66 67 68 69 70 app :: [ Xin -> Xio ] -> Xin -> Xio 71 72 app ( fn : fns ) = fn ... app fns 73 74 app [] = \ xin -> ( xin , [] ) 75 76 77 78 79 --partain: (|||) :: MayBe a b -> ( a -> MayBe c d ) -> MayBe c d 80 (|||) :: MayBe a b -> ( a -> MayBe c b ) -> MayBe c b 81 82 ( Ok s ) ||| f 83 = f s 84 85 ( Bad mesg ) ||| f = Bad mesg 86 87 88 89 90 91 92 93 94 s |.| f 95 = case s of 96 Ok t -> f t 97 Bad err -> return_err err 98 99 100 101 102 103 104 ( Ok ( s , u )) |@| f 105 = f s u 106 107 ( Bad mesg ) |@| f = Bad mesg 108 109 110 111 112 ( Ok ( s , u )) |>| f 113 = case f u of 114 Ok t -> Ok (( s , t ) , u ) 115 Bad err -> Bad err 116 117 118 119 120 121 122 123 (///) :: Xst (MayBe a b) -> ( a -> Xin -> Xst (MayBe c b)) -> Xst (MayBe c b) 124 125 x@( xin , st , xout ) /// f 126 = sendout x x' 127 where 128 x' = case st of 129 Ok val -> f val xin 130 Bad mesg -> ( xin , Bad mesg , [] ) 131 132 133 134 135 136 137 (/./) :: (Xin -> Xst (MayBe a b)) -> ( a -> Xin -> Xst (MayBe c b)) 138 -> Xin -> Xst (MayBe c b) 139 140 (/./) f g xin 141 = f xin /// g 142 143 144 145 146 (/>/) :: Xst (MayBe a b) -> ( Xin -> Xst (MayBe c b)) -> Xst (MayBe (a,c) b) 147 148 x1@( xin , st , xout ) />/ f 149 = sendout x1 x1' 150 where 151 x1' = case st of 152 Ok val -> ( xin2, st2', xout2 ) 153 where 154 st2' = case st2 of 155 Ok val2 -> Ok ( val, val2 ) 156 Bad mesg -> Bad mesg 157 Bad mesg -> ( xin, Bad mesg, [] ) 158 ( xin2, st2, xout2 ) = f xin 159 160 161 162 163 164 (/.>/) :: (Xin -> Xst (MayBe a b)) -> ( Xin -> Xst (MayBe c b)) 165 -> Xin -> Xst (MayBe (a,c) b) 166 167 (/.>/) f g xin 168 = f xin />/ g 169 170 171 172 173 174 175 176 x1@( xin , st , xout ) /:>/ f 177 = sendout x1 x1' 178 where 179 x1' = case st of 180 Ok val -> ( xin2, st2', xout2 ) 181 where 182 st2' = case st2 of 183 Ok val2 -> Ok ( val : val2 ) 184 Bad mesg -> Bad mesg 185 Bad mesg -> ( xin, Bad mesg, [] ) 186 ( xin2, st2, xout2 ) = f xin 187 188 189 190 (/.:>/) :: (Xin -> Xst (MayBe a b)) -> ( Xin -> Xst (MayBe [a] b)) 191 -> Xin -> Xst (MayBe [a] b) 192 193 (/.:>/) f g xin 194 = f xin /:>/ g 195 196 197 198 199 handle f handler xin 200 = f xin `ihandle` handler 201 202 ihandle x@( xin , st , _ ) handler 203 = sendout x x' 204 where 205 x' = case st of 206 Ok val -> ( xin, Ok val, [] ) 207 Bad mesg -> handler mesg xin 208 209 210 211 212 213 214 215 216 217 mk_ok x_fn arg 218 = Ok ( x_fn arg ) 219 220 221 222 223 224 split :: ( Eq a ) => a -> [a] -> [[a]] 225 226 split c ( a : x ) 227 | a == c = [] : split c x 228 | a /= c = case split c x of 229 b : y -> ( a : b ) : y 230 [] -> [[a]] 231 232 split _ [] = [] 233 234 235 236 237 238 (<:) :: [a] -> a -> [a] 239 240 l <: c = l ++ [c] 241 242 243 244 245 246 247 sendout ( _, _, xout ) x 248 = ( xin, st, xout ++ xout2 ) 249 where 250 ( xin, st, xout2 ) = x 251 252 253 254 return_val st xin = ( xin , st , [] ) 255 256 return_err st xin = ( xin, Bad st , [] ) 257 258 reTurn st xin = ( xin, Ok st, [] ) 259 260 261 262 genuid ( ins , rsps , ( gno : gnoL ) ) 263 = ( ( ins , rsps , gnoL ) , Ok ( show gno ) , [] ) 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 {- 280 281 ( f >> g ) 282 = next_tk f /./ ( next_tk . g ) 283 284 ( f >>> g) 285 = next_tk f /:>/ next_tk g 286 287 288 ( f *>> g ) 289 = f >> ( g . discard_tk ) 290 291 ( f *>>> g) 292 = f >>> ( g . discard_tk ) 293 294 295 296 297 ( f >>+ g ) 298 = ( \ tk -> f tk /./ pst_extend ) >> g 299 300 ( f >>>+ g ) 301 = ( \ tk -> f tk /./ pst_extend ) >>> g 302 303 ( f *>>+ g ) 304 = ( \ tk -> f tk /./ pst_extend ) *>> g 305 306 ( f *>>>+ g ) 307 = ( \ tk -> f tk /./ pst_extend ) *>>> g 308 309 310 311 312 313 ( f >>^ g ) 314 = f >> ( g . pst_retract ) 315 316 ( f >>>^ g ) 317 = f >>> ( g . pst_retract ) 318 319 ( f *>>^ g ) 320 = f *>> ( g . pst_retract ) 321 322 ( f *>>>^ g ) 323 = f *>>> ( g . pst_retract ) 324 325 326 327 328 329 next_tk f ( tk : tkL, pst, xin ) 330 = f tk ( tkL, pst, xin ) 331 332 next_tk _ st@( [] , _ , _ ) 333 = return_err "Unexpected end of input" st 334 335 336 337 338 339 340 discard_tk ( _ : tkL , pst , xin ) 341 = ( tkL , pst , xin ) 342 343 discard_tk st@( [] , _ , _ ) = st 344 345 346 347 348 349 pst_retract ( tkL , (tgL, Extend _ isg _ ), xin ) 350 = ( tkL, (tgL, isg), xin ) 351 352 pst_retract _ = error "pst_retract on empty sg -- impossible" 353 354 355 356 357 358 359 pst_extend resL st 360 = pst_extend' resL st ./. 361 return resL 362 363 364 365 366 pst_extend' ( Opnd ( Idec idc ) : _ ) ( tkL, ( tgL, isg ), xin ) 367 = ( tkL, ( tgL, Extend idc isg [] ), xin ) 368 369 pst_extend' ( _ : resL ) 370 = pst_extend' resL 371 372 pst_extend' [] 373 = return_err "No dc with which to extend sg" 374 375 376 377 378 -}