├── .gitignore ├── README.md ├── _tags ├── compile-untyped.sh ├── compile.sh ├── docs └── PROGRESS ├── eval ├── frankInterpreter.ml ├── midEvaluator.ml ├── midEvaluator.mli └── ufker.ml ├── mid ├── midTranslate.ml ├── midTranslate.mli ├── midTree.ml ├── midTree.mli ├── patternMatching.ml ├── patternMatching.mli ├── patternMatchingUnitTest.ml └── typingPatternMatching.ml ├── parsing ├── errorHandling.ml ├── errorHandling.mli ├── lexer.mll ├── parseTree.ml ├── parseTree.mli ├── parseTreeBuilder.ml ├── parseTreeBuilder.mli ├── parser.mly ├── parser.mly.diff ├── parser.mly.orig ├── parser.mly.rej └── test.ml ├── pattern-matching-compilation ├── run_tests.sh ├── tests ├── should-fail │ └── typing │ │ ├── inst_match.fk │ │ ├── no_such_interface.fk │ │ ├── no_such_interface_arg.fk │ │ └── pat_match_dup.fk └── should-pass │ ├── eval │ ├── blame.fk │ ├── coins.fk │ ├── console.fk │ ├── delimited-continuations.fk │ ├── gt.fk │ ├── let.fk │ ├── nim.fk │ ├── pat_match_anon.fk │ ├── pipe.fk │ ├── pipe_with_let.fk │ ├── print_map.fk │ ├── state.fk │ └── thrice_manual.fk │ ├── parsing │ ├── comment.fk │ ├── hello.fk │ └── string.fk │ └── typing │ ├── bind-eff.fk │ ├── does_sub.fk │ ├── dup_ref_ambient.fk │ ├── inst_ambient.fk │ ├── map.fk │ ├── map2.fk │ └── unify_matching.fk ├── typing ├── midTyping.ml ├── midTyping.mli ├── unionfind.ml └── unionfind.mli └── util ├── debug.ml ├── debug.mli ├── listUtils.ml ├── listUtils.mli ├── monad.mli ├── show.ml ├── show.mli ├── utility.ml └── utility.mli /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Frankly Frank 2 | ============= 3 | 4 | This is a prototype implementation of the Frank programming language. 5 | 6 | See the draft paper by Sam Lindley and Conor McBride 7 | (http://homepages.inf.ed.ac.uk/slindley/papers/frankly-draft-march2014.pdf) 8 | for details on the language. 9 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | or or or or : include 2 | true: use_menhir 3 | true: syntax(camlp4o) 4 | true: package(deriving), package(deriving.syntax) 5 | -------------------------------------------------------------------------------- /compile-untyped.sh: -------------------------------------------------------------------------------- 1 | ocamlbuild -use-ocamlfind -cflag -g -lflag -g eval/ufker.native 2 | -------------------------------------------------------------------------------- /compile.sh: -------------------------------------------------------------------------------- 1 | ocamlbuild -use-ocamlfind -cflag -g -lflag -g eval/frankInterpreter.byte 2 | -------------------------------------------------------------------------------- /docs/PROGRESS: -------------------------------------------------------------------------------- 1 | Current status: ALL tests do the right thing; either pass if they 2 | "should-pass" or fail if they "should-fail". 3 | 4 | Parser 5 | ------ 6 | 7 | The parser is a kludge. The dream is to have Haskell-like syntax but this is 8 | only possible with some egregious delimiters strewn about the source. 9 | 10 | Typechecker 11 | ----------- 12 | 13 | Uses unionfind structure to perform instantiation and unification. The 14 | implementation differs from the draft paper presentation in that instantiation 15 | and unification is performed in several places rather than just one place 16 | (inferring a polymorphic variable for the case of instantiation, and inferring 17 | an inferable value in the case of unification). 18 | 19 | It would be interesting to code up an alternative typechecker to see if it 20 | could be made cleaner. The style I have in mind follows Gundry's thesis of a 21 | type inference algorithm for Hindley-Milner which uses ordered contexts to 22 | capture the metavariables and their dependencies. I believe McBride's initial 23 | implementation of Frank in Haskell follows this approach. 24 | 25 | Evaluator 26 | --------- 27 | 28 | A denotational semantics written in monadic style. 29 | -------------------------------------------------------------------------------- /eval/frankInterpreter.ml: -------------------------------------------------------------------------------- 1 | (** Untyped Frank Evaluator *) 2 | open Lexer 3 | open Lexing 4 | open Printf 5 | open ParseTree 6 | open MidTree 7 | open MidTranslate 8 | open MidTyping 9 | open MidEvaluator 10 | open ErrorHandling 11 | 12 | let print_position outx lexbuf = 13 | let pos = lexbuf.lex_curr_p in 14 | fprintf outx "%s:%d:%d" pos.pos_fname 15 | pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) 16 | 17 | let parse_with_error lexbuf = 18 | try Parser.program Lexer.token lexbuf with 19 | | SyntaxError msg -> 20 | fprintf stderr "%a:%s\n" print_position lexbuf msg; [] 21 | | Parser.Error -> 22 | fprintf stderr "%a: syntax error\n" print_position lexbuf; 23 | exit (-1) 24 | 25 | let translate_with_error prog = 26 | let ext = function Merr_not_comp msg 27 | | Merr_inv_clause msg 28 | | Merr_inv_ctr msg 29 | | Merr_no_main msg 30 | | Merr_duplicate_tvar msg 31 | | Merr_shadowing_builtin msg -> msg in 32 | try translate prog with 33 | | MidTranslate.Error err 34 | -> fprintf stderr "Translation error: %s\n" (ext err); 35 | exit (-1) 36 | 37 | let type_with_error prog = 38 | try type_prog prog with 39 | | TypeError s -> fprintf stderr "Type error: %s\n" s; exit (-1) 40 | 41 | let rec parse_file lexbuf = 42 | match parse_with_error lexbuf with 43 | | [] -> ([], HandlerMap.empty, CtrSet.empty, CmdSet.empty) 44 | | prog -> translate_with_error prog 45 | 46 | let preprocess_lines inx = 47 | let last buf = Buffer.length buf - 1 in 48 | let nth buf n = Buffer.nth buf n in 49 | (* Make it optional to include the dot at the end of a sentence and 50 | also guard against special cases e.g. line ends in a comment or we 51 | encountered a blank line. *) 52 | let last_cond buf = 53 | nth buf (last buf) != '.' && 54 | (nth buf ((last buf) - 1) != '-' && nth buf (last buf) != '}') && 55 | nth buf (last buf) != '\n' in 56 | let rec process_char_until c buf = 57 | let c' = input_char inx in 58 | if c' = c then c 59 | else if c' = '{' then (* Multi-line comment encountered. *) 60 | let d = input_char inx in 61 | Buffer.add_char buf c'; Buffer.add_char buf d; 62 | (* Eat entire comment. *) 63 | (if d = '-' then Buffer.add_char buf (process_char_until '}' buf)); 64 | process_char_until c buf 65 | else if c' = '"' then (* String encountered. *) 66 | (Buffer.add_char buf c'; 67 | (* Eat entire string. *) 68 | Buffer.add_char buf (process_char_until '"' buf); 69 | process_char_until c buf) 70 | else (Buffer.add_char buf c'; process_char_until c buf) in 71 | let rec process_lines buf = 72 | let nl = process_char_until '\n' buf in 73 | let c = try input_char inx with 74 | | End_of_file -> '\n' in 75 | (if c != ' ' && c != '\t' && last_cond buf then 76 | Buffer.add_char buf '.'); 77 | Buffer.add_char buf nl; Buffer.add_char buf c; 78 | process_lines buf in 79 | let buf = Buffer.create 10 in 80 | try process_lines buf with 81 | | End_of_file -> Buffer.contents buf 82 | 83 | let loop filename = 84 | let inx = open_in filename in 85 | let buf = preprocess_lines inx in 86 | let lexbuf = Lexing.from_string buf in 87 | let () = lexbuf.lex_curr_p <- { 88 | lexbuf.lex_curr_p with pos_fname = filename 89 | } in 90 | let (mtree, hmap, ctrs, cmds) = parse_file lexbuf in 91 | Debug.print "%s" (ShowMidProg.show mtree); 92 | let (t, env) = type_with_error mtree in 93 | Debug.print "Program typechecked with main : %s" (ShowSrcType.show t); 94 | let res = EvalComp.eval hmap mtree in 95 | Debug.print "%s\n" (EvalComp.show res); 96 | close_in inx 97 | 98 | let () = 99 | let flags = [("-debug", 100 | Arg.Unit (fun () -> Debug.debug_flag true), 101 | "Enable debugging information")] in 102 | Arg.parse flags loop "Frank Parser:" 103 | 104 | -------------------------------------------------------------------------------- /eval/midEvaluator.ml: -------------------------------------------------------------------------------- 1 | (*********************************************************************** 2 | * Evaluate the mid-level language. 3 | * 4 | * 5 | * Created by Craig McLaughlin on 21/07/2015. 6 | *********************************************************************** 7 | *) 8 | 9 | open MidTranslate 10 | open MidTree 11 | open MidTyping 12 | open Monad 13 | open ParseTree 14 | open ParseTreeBuilder 15 | open PatternMatching 16 | open Printf 17 | open ListUtils 18 | 19 | module type EVALCOMP = sig 20 | include MONAD 21 | 22 | type comp = value t 23 | and value = 24 | | VBool of bool 25 | | VInt of int 26 | | VFloat of float 27 | | VStr of string 28 | | VCon of string * value list 29 | | VMultiHandler of (comp list -> comp) 30 | 31 | module type EVALENVT = sig 32 | include Map.S with type key := string 33 | type mt = comp t 34 | end 35 | 36 | module ENV : EVALENVT 37 | 38 | val (>=>) : (value -> 'a t) -> ('a -> 'b t) -> value -> 'b t 39 | val sequence : ('a t) list -> ('a list) t 40 | val command : string -> value list -> comp 41 | val show : comp -> string 42 | val vshow : value -> string 43 | 44 | val eval_dtree : ENV.mt -> comp list -> dtree -> comp 45 | (** [eval_dtree cs t] evaluates the decision tree [t] w.r.t the stack of 46 | computations [cs] returning a computaton. The stack is assumed to 47 | initially hold the subject value. *) 48 | 49 | val eval : MidTranslate.HandlerMap.mt -> MidTree.prog -> comp 50 | end 51 | 52 | module EvalComp : EVALCOMP = struct 53 | exception UserDefShadowingBuiltin of string 54 | 55 | type 'a t = 56 | | Command of string * value list * (value -> 'a t) 57 | | Return of 'a 58 | 59 | and comp = value t 60 | 61 | and value = 62 | | VBool of bool 63 | | VInt of int 64 | | VFloat of float 65 | | VStr of string 66 | | VCon of string * value list 67 | | VMultiHandler of (comp list -> comp) 68 | 69 | module type EVALENVT = sig 70 | include Map.S with type key := string 71 | type mt = comp t 72 | end 73 | 74 | module ENV = struct 75 | module M = Map.Make(String) 76 | include M 77 | type mt = comp M.t 78 | end 79 | 80 | (** Monadic operations *) 81 | let return v = Return v 82 | 83 | let rec (>=>) f g x = f x >>= g 84 | and (>>=) m k = 85 | match m with 86 | | Command (c, vs, r) -> Command (c, vs, r >=> k) 87 | | Return v -> k v 88 | 89 | let lift : (value -> comp) -> value = fun f -> 90 | VMultiHandler (fun [m] -> m >>= f) 91 | 92 | let rec sequence = function 93 | | [] -> return [] 94 | | m :: ms -> m >>= (fun x -> sequence ms >>= (fun xs -> return (x :: xs))) 95 | 96 | let command c vs = Command (c, vs, return) 97 | 98 | let rec vshow v = 99 | match v with 100 | | VBool b -> string_of_bool b 101 | | VInt n -> string_of_int n 102 | | VFloat f -> string_of_float f 103 | | VStr s -> "\"" ^ (String.escaped s) ^ "\"" 104 | | VCon ("Nil", []) -> "[]" 105 | | VCon ("Cons", vs) -> 106 | let rec show_vs = 107 | function 108 | | [v; VCon ("Nil", [])] -> vshow v 109 | | [v; VCon ("Cons", vs)] -> vshow v ^ ", " ^ show_vs vs 110 | in 111 | "[" ^ show_vs vs ^ "]" 112 | | VCon (k, []) -> k 113 | | VCon (k, vs) -> "(" ^ k ^ (string_of_args " " vshow vs) ^ ")" 114 | | VMultiHandler _ -> "MULTIHANDLER" 115 | 116 | let show c = 117 | match c with 118 | | Command (c, vs, _) 119 | -> "Command (" ^ c ^ (string_of_args " " vshow vs) ^ ")" 120 | | Return v 121 | -> "Return (" ^ vshow v ^ ")" 122 | 123 | let is_some ox = match ox with Some _ -> true | _ -> false 124 | 125 | let len_cmp vs vs' = List.length vs = List.length vs' 126 | let foldr = List.fold_right 127 | 128 | (** match a value against a type signature and return the updated value and 129 | any child values. *) 130 | let match_value_sig env v tsg = 131 | match v, tsg with 132 | | _, TSAllValues None -> Some (env, []) 133 | | _, TSAllValues (Some x) -> Some (ENV.add x (return v) env, []) 134 | | VBool b, TSBool b' -> if b = b' then Some (env, []) else None 135 | | VInt n, TSInt n' -> if n = n' then Some (env, []) else None 136 | | VFloat f, TSFloat f' -> if f = f' then Some (env, []) else None 137 | | VStr s, TSStr s' -> if s = s' then Some (env, []) else None 138 | | VCon (k, vs), TSCtr (k', n) 139 | -> if k = k' && length vs = n then 140 | Some (env, map return vs) 141 | else None 142 | | _ , _ -> None 143 | 144 | let match_cmd_sig env (c, vs, r) tsg = 145 | match tsg with 146 | | TSCmd (c', n) 147 | -> if c = c' then Some (env, map return (vs ++ [(lift r)])) else None 148 | | _ -> None 149 | 150 | (** Top-level matching procedure which will return None or a pair of an 151 | updated environment and any child values to be matched. *) 152 | let match_sig env c tsg = 153 | match c with 154 | | Return v -> match_value_sig env v tsg 155 | | Command (cmd, vs, r) -> match_cmd_sig env (cmd, vs, r) tsg 156 | 157 | (* Return v is matched by x 158 | * Return (suc v) is matched by suc x and x *) 159 | let rec match_value (v, p) oenv = 160 | match oenv with 161 | | None -> None 162 | | Some env -> 163 | begin 164 | match v, p with 165 | | _, Svpat_any -> Some env 166 | | _, Svpat_var x -> if ENV.mem x env then None 167 | else Some (ENV.add x (return v) env) 168 | | VBool b, Svpat_bool b' -> if b = b' then Some env else None 169 | | VInt n, Svpat_int n' -> if n = n' then Some env else None 170 | | VFloat f, Svpat_float f' -> if f = f' then Some env else None 171 | | VStr s, Svpat_str s' -> if s = s' then Some env else None 172 | | VCon (k, vs), Svpat_ctr (k', vs') 173 | -> if k = k' && len_cmp vs vs' then 174 | let oenv = foldr match_value (zip vs vs') (Some env) in 175 | begin 176 | match oenv with 177 | | None -> None 178 | | Some env -> Some (ENV.add k (return (VCon (k, vs))) env) 179 | end 180 | else None 181 | | _ -> None 182 | end 183 | 184 | (* Command ("put", [v], r) is matched by [put x -> k] and [?c -> k] and 185 | [t] *) 186 | let match_command (c, vs, r) p env = 187 | match p with 188 | | Scpat_request (c', vs', r') 189 | -> if c = c' && c' <> r' && len_cmp vs vs' then 190 | let oenv = foldr match_value (zip vs vs') (Some env) in 191 | begin 192 | match oenv with 193 | | None -> None 194 | | Some env -> if ENV.mem c env then None (*uniq cond*) 195 | else Some (ENV.add r' (return (lift r)) 196 | (ENV.add c (Command (c, vs, r)) env)) 197 | end 198 | else None 199 | 200 | let match_pair (c, p) oenv = 201 | match oenv with 202 | | None -> None 203 | | Some env -> 204 | begin 205 | match c, p.spat_desc with 206 | (* NOTE: this is where the problem of forwarding lies. We are not 207 | checking the command; these patterns only match if the command is 208 | in the type signature of this argument. Is this information 209 | available here? I guess this point is moot now that we are doing 210 | compilation in separate steps. *) 211 | | _ , Spat_any -> Some env 212 | | _ , Spat_thunk thk -> 213 | (* Return a suspended computation that will just perform the inner 214 | computation when forced. *) 215 | Some (ENV.add thk (return (VMultiHandler (fun cs -> c))) env) 216 | | Command (c', vs, r), Spat_comp cp 217 | -> match_command (c', vs, r) cp env 218 | | Return v, Spat_value vp 219 | -> match_value (v, vp) (Some env) 220 | | _ -> None 221 | end 222 | 223 | let pat_matches cs ps = 224 | if List.length cs > List.length ps then 225 | raise (invalid_arg "too many arguments") 226 | else if List.length cs < List.length ps then 227 | raise (invalid_arg "too few arguments") 228 | else 229 | List.fold_right match_pair (List.combine cs ps) (Some ENV.empty) 230 | 231 | let just_hdrs = function Mtld_handler hdr -> Some hdr | _ -> None 232 | 233 | (** Anonymous handler counter *) 234 | let anonhdr = ref 0 235 | 236 | (** Builtin functions *) 237 | let gtdef env [cx; cy] = cx >>= 238 | function (VInt x) -> cy >>= 239 | (function (VInt y) -> return (VBool (x > y)) 240 | | _ as vy -> invalid_arg ("second_arg:" ^ vshow vy)) 241 | | _ as vx -> invalid_arg ("first arg:" ^ vshow vx) 242 | 243 | let gtfdef env [cx; cy] = cx >>= 244 | function (VFloat x) -> cy >>= 245 | (function (VFloat y) -> return (VBool (x > y)) 246 | | _ as vy -> invalid_arg ("second_arg:" ^ vshow vy)) 247 | | _ as vx -> invalid_arg ("first arg:" ^ vshow vx) 248 | 249 | let minusdef env [cx; cy] = cx >>= 250 | function (VInt x) -> cy >>= 251 | (function (VInt y) -> return (VInt (x - y)) 252 | | _ as vy -> invalid_arg ("second_arg:" ^ vshow vy)) 253 | | _ as vx -> invalid_arg ("first arg:" ^ vshow vx) 254 | 255 | let plusdef env [cx; cy] = cx >>= 256 | function (VInt x) -> cy >>= 257 | (function (VInt y) -> return (VInt (x + y)) 258 | | _ as vy -> invalid_arg ("second_arg:" ^ vshow vy)) 259 | | _ as vx -> invalid_arg ("first arg:" ^ vshow vx) 260 | 261 | let strcatdef env [cx; cy] = cx >>= 262 | function (VStr x) -> cy >>= 263 | (function (VStr y) -> return (VStr (x ^ y)) 264 | | _ as vy -> invalid_arg ("second arg:" ^ vshow vy)) 265 | | _ as vx -> invalid_arg ("first arg:" ^ vshow vx) 266 | 267 | (** Create the builtin environment. *) 268 | let get_builtins () = 269 | let blts = [("gt", gtdef); ("gtf", gtfdef); ("minus", minusdef); 270 | ("plus", plusdef); ("strcat", strcatdef)] in 271 | let add_blt (n,d) env = ENV.add n d env in 272 | List.fold_right add_blt blts ENV.empty 273 | 274 | let rec eval hmap prog = 275 | let blt_env = get_builtins () in 276 | let hdrs = List.map (fun (k, h) -> h) (HandlerMap.bindings hmap) in 277 | let pre_env = List.fold_right construct_env_entry hdrs blt_env in 278 | let rec env' = 279 | lazy (ENV.map (fun f -> 280 | return (VMultiHandler (fun cs -> f (Lazy.force env') cs))) pre_env) in 281 | let env = Lazy.force env' in 282 | let main = ENV.find "main" env in 283 | main >>= function VMultiHandler f -> rts (f []) 284 | | _ -> not_hdr ~desc:"main" () 285 | 286 | (* The runtime system handles some commands such as I/O. *) 287 | and rts m = 288 | match m with 289 | | Command _ -> rts (handle_builtin_cmds m) 290 | | Return v -> m 291 | 292 | and handle_builtin_cmds m = 293 | match m with 294 | | Command ("random", [], r) -> r (VFloat (Random.float 1.0)) 295 | | Command ("putStr", [VStr s], r) -> print_string s; 296 | r (VCon ("Unit", [])) 297 | | Command ("putStrLn", [VStr s], r) -> print_endline s; 298 | r (VCon ("Unit", [])) 299 | | Command ("getStr", [], r) -> r (VStr (read_line ())) 300 | | Command (c, _, _) -> failwith ("Command: " ^ c ^ " not handled") 301 | | _ -> assert false (* Command not handled *) 302 | 303 | and construct_env_entry hdr env = 304 | if ENV.mem hdr.mhdr_name env then 305 | raise (UserDefShadowingBuiltin hdr.mhdr_name) 306 | else 307 | ENV.add hdr.mhdr_name (fun env cs -> 308 | Debug.print "Evaluating handler %s...\n" hdr.mhdr_name; 309 | eval_tlhdrs env hdr cs) env 310 | 311 | (* Give precedence to ob. *) 312 | and extend_env name oa ob = 313 | match ob with 314 | | Some _ -> ob 315 | | None -> oa 316 | 317 | and eval_tlhdrs env hdr cs = 318 | let cls = hdr.mhdr_defs in 319 | match List.fold_left (eval_clause env cs) None cls with 320 | | None -> fwd_clauses env hdr cs 321 | | Some c -> c 322 | 323 | and eval_clause env cs res (ps, cc) = 324 | match res with 325 | | Some _ -> res 326 | | None 327 | -> begin 328 | Debug.print "%s with %s..." 329 | (string_of_args ", " ~bbegin:false show cs) 330 | (string_of_args ", " ~bbegin:false ShowPattern.show ps); 331 | match pat_matches cs ps with 332 | | Some env' 333 | -> (* Extend env with shadowing environment env'. *) 334 | let env'' = ENV.merge extend_env env env' in 335 | Debug.print "true\n"; Some (eval_ccomp env'' cc) 336 | | None -> Debug.print "false\n"; None 337 | end 338 | 339 | and fwd_clauses env hdr cs = 340 | List.fold_right (fwd_cls env hdr) (diag (gen_cpats cs)) pat_match_fail 341 | 342 | and repeat x n = if n <= 0 then [] else x :: (repeat x (n-1)) 343 | 344 | and gen_cpats xs = 345 | let n = List.length xs in 346 | List.combine (repeat [] n) (repeat xs n) 347 | 348 | and diag = function 349 | | (ys, x :: xs) :: xss -> (ys, x, xs) :: diag (List.map shift xss) 350 | | _ -> [] 351 | 352 | and shift = function 353 | | (ys, x :: xs) -> (x :: ys, xs) 354 | | _ as p -> p 355 | 356 | and fwd_cls env hdr (cs1, c, cs2) acc = 357 | match c with 358 | | Command (s, vs, r) 359 | -> command s vs >>= 360 | fun z -> let cs = (List.rev cs1) @ [r z] @ cs2 in 361 | eval_tlhdrs env hdr cs 362 | | _ -> acc 363 | 364 | and pat_match_fail = command "PatternMatchFail" [] 365 | 366 | and app_if_ne s t = 367 | s ^ (if t <> "" then " : " ^ t else t) 368 | 369 | and unhandled_comp ?(desc = "") () = 370 | command (app_if_ne "UnhandledComputation" desc) [] 371 | 372 | and not_hdr ?(desc = "") () = 373 | command (app_if_ne "NotAHandler" desc) [] 374 | 375 | and eval_ccomp env cc = 376 | match cc with 377 | | Mccomp_cvalue cv -> eval_cvalue env cv 378 | | Mccomp_clauses [] -> command "NoClausesProbablyShouldNotGetHere" [] 379 | | Mccomp_clauses cls 380 | -> return (VMultiHandler (fun cs -> eval_mid_clauses env cls cs)) 381 | 382 | and eval_mid_clauses env cls cs = 383 | let t = TypExp.fresh_rigid_tvar "AnonMH" in 384 | let n = 385 | match t.styp_desc with 386 | | Styp_rtvar (_, n) -> n 387 | | _ -> assert false in 388 | let hdr = 389 | { 390 | mhdr_name = "AnonMH" ^ (string_of_int n); 391 | mhdr_type = t; 392 | mhdr_defs = cls 393 | } 394 | in eval_tlhdrs env hdr cs 395 | 396 | and eval_cvalue env cv = 397 | match cv with 398 | | Mcvalue_ivalue iv -> eval_ivalue env iv 399 | | Mcvalue_ctr (k, vs) 400 | -> sequence (List.map (eval_cvalue env) vs) >>= 401 | fun vs -> return (VCon (k, vs)) 402 | | Mcvalue_thunk (Mccomp_cvalue cv) -> 403 | return (VMultiHandler (fun [] -> eval_cvalue env cv)) 404 | | Mcvalue_thunk cc -> 405 | eval_ccomp env cc 406 | 407 | and eval_ivalue env iv = 408 | match iv with 409 | | Mivalue_var v -> ENV.find v env 410 | | Mivalue_cmd c -> eval_cmd env c 411 | | Mivalue_int n -> return (VInt n) 412 | | Mivalue_float f -> return (VFloat f) 413 | | Mivalue_bool b -> return (VBool b) 414 | | Mivalue_str s -> return (VStr s) 415 | | Mivalue_icomp ic -> eval_icomp env ic 416 | 417 | and eval_icomp env ic = 418 | match ic with 419 | | Micomp_app (iv, cs) -> eval_app env iv cs 420 | | Micomp_let (x, cc1, cc2) 421 | -> eval_ccomp env cc1 >>= 422 | fun v -> let env' = ENV.add x (return v) env in 423 | eval_ccomp env' cc2 424 | 425 | and eval_app env u cs = 426 | let mhdr cs = eval_ivalue env u >>= 427 | function VMultiHandler f -> f cs 428 | | _ as v -> not_hdr ~desc:(vshow v) () in 429 | mhdr (List.map (eval_ccomp env) cs) 430 | 431 | and eval_cmd env c = 432 | return (VMultiHandler 433 | (fun cs -> sequence cs >>= fun vs -> command c vs)) 434 | 435 | let rec eval_dtree env cs t = 436 | (* Mccomp_cvalue (Mcvalue_ivalue (Mivalue_int 0)) *) 437 | let rec eval_case c cses = 438 | match cses with 439 | | (CseSig (tsg, t) as cse) :: cses' 440 | -> begin match match_sig env c tsg with 441 | | Some (env', args) -> (env', args, cse) 442 | | None -> eval_case c cses' 443 | end 444 | | (CseDefault t as cse) :: cses' -> (env, [], cse) 445 | | _ -> failwith "No default case in switch cases list" in 446 | match t with 447 | | Leaf k -> eval_ccomp env k 448 | | Swap (i, t) -> eval_dtree env (swap cs 0 i) t 449 | | Switch cases -> let (c, cs') = (List.hd cs, List.tl cs) in 450 | begin 451 | match eval_case c cases with 452 | | (env', args, CseSig (_, t)) 453 | -> eval_dtree env' (args ++ cs') t 454 | | (env', [], CseDefault t) -> eval_dtree env cs' t 455 | | _ -> assert false 456 | end 457 | | Fail -> failwith "Decision tree evaluation unexpectedly failed" 458 | 459 | 460 | 461 | 462 | end 463 | 464 | -------------------------------------------------------------------------------- /eval/midEvaluator.mli: -------------------------------------------------------------------------------- 1 | (*********************************************************************** 2 | * Evaluator defined in terms of a denotational semantics for the 3 | * mid-level language. 4 | * 5 | * 6 | * Created by Craig McLaughlin on 21/07/2015. 7 | *********************************************************************** 8 | *) 9 | 10 | open Monad 11 | open ParseTree 12 | open PatternMatching 13 | 14 | (*i | k vs 15 | | command 16 | | top-level-handler (name) 17 | | built-in-handler (name) 18 | | local-handler (handler-def, locals) 19 | | continuation *) 20 | 21 | module type EVALCOMP = sig 22 | include MONAD 23 | 24 | type comp = value t 25 | and value = 26 | | VBool of bool 27 | | VInt of int 28 | | VFloat of float 29 | | VStr of string 30 | | VCon of string * value list 31 | | VMultiHandler of (comp list -> comp) 32 | 33 | module type EVALENVT = sig 34 | include Map.S with type key := string 35 | type mt = comp t 36 | end 37 | 38 | module ENV : EVALENVT 39 | 40 | val (>=>) : (value -> 'a t) -> ('a -> 'b t) -> value -> 'b t 41 | (** Kleisli composition of computations *) 42 | 43 | val sequence : ('a t) list -> ('a list) t 44 | val command : string -> value list -> comp 45 | val show : comp -> string 46 | val vshow : value -> string 47 | 48 | val eval_dtree : ENV.mt -> comp list -> dtree -> comp 49 | (** [eval_dtree cs t] evaluates the decision tree [t] w.r.t the stack of 50 | computations [cs] returning a computaton. The stack is assumed to 51 | initially hold the subject value. *) 52 | 53 | val eval : MidTranslate.HandlerMap.mt -> MidTree.prog -> comp 54 | (** Evaluation function *) 55 | end 56 | 57 | module EvalComp : EVALCOMP 58 | (** Module representing evaluation of mid-level tree to monadic computation 59 | trees. *) 60 | 61 | (* increment function *) 62 | (* command "get" [] >>= (fun (Int x) -> *) 63 | (* command "put" [return (Int (x+1))]) *) 64 | -------------------------------------------------------------------------------- /eval/ufker.ml: -------------------------------------------------------------------------------- 1 | (** Untyped Frank Evaluator *) 2 | open Lexer 3 | open Lexing 4 | open Printf 5 | open ParseTree 6 | open MidTree 7 | open MidTranslate 8 | open MidEvaluator 9 | open ErrorHandling 10 | 11 | let print_position outx lexbuf = 12 | let pos = lexbuf.lex_curr_p in 13 | fprintf outx "%s:%d:%d" pos.pos_fname 14 | pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) 15 | 16 | let parse_with_error lexbuf = 17 | try Parser.program Lexer.token lexbuf with 18 | | SyntaxError msg -> 19 | fprintf stderr "%a:%s\n" print_position lexbuf msg; [] 20 | | Parser.Error -> 21 | fprintf stderr "%a: syntax error\n" print_position lexbuf; 22 | exit (-1) 23 | 24 | let translate_with_error prog = 25 | let ext = function Merr_not_comp msg -> msg 26 | | Merr_inv_clause msg -> msg 27 | | Merr_inv_ctr msg -> msg 28 | | Merr_no_main msg -> msg 29 | | Merr_duplicate_tvar msg -> msg in 30 | try translate prog with 31 | | MidTranslate.Error err 32 | -> fprintf stderr "Translation error: %s\n" (ext err); 33 | exit (-1) 34 | 35 | let rec parse_file lexbuf = 36 | match parse_with_error lexbuf with 37 | | [] -> ([], HandlerMap.empty, CtrSet.empty, CmdSet.empty) 38 | | prog -> translate_with_error prog 39 | 40 | let loop filename = 41 | let inx = open_in filename in 42 | let lexbuf = Lexing.from_channel inx in 43 | let () = lexbuf.lex_curr_p <- { 44 | lexbuf.lex_curr_p with pos_fname = filename 45 | } in 46 | let (mtree, hmap, ctrs, cmds) = parse_file lexbuf in 47 | Debug.debug_flag true; 48 | Debug.print "%s" (ShowMidProg.show mtree); 49 | let res = EvalComp.eval hmap mtree in 50 | Debug.print "%s\n" (EvalComp.show res); 51 | close_in inx 52 | 53 | let () = Arg.parse [] loop "Frank Parser:" 54 | 55 | -------------------------------------------------------------------------------- /mid/midTranslate.ml: -------------------------------------------------------------------------------- 1 | open MidTree 2 | open ParseTree 3 | open ParseTreeBuilder 4 | open ListUtils 5 | open Utility 6 | 7 | type mid_error = 8 | | Merr_not_comp of string 9 | | Merr_inv_clause of string 10 | | Merr_inv_ctr of string 11 | | Merr_no_main of string 12 | | Merr_duplicate_tvar of string 13 | | Merr_shadowing_builtin of string 14 | 15 | exception Error of mid_error 16 | 17 | let invalid_clause_error def = 18 | raise (Error 19 | (Merr_inv_clause 20 | ("Invalid pattern matching computation when parsing " ^ def))) 21 | 22 | let invalid_constructor k def = 23 | raise (Error (Merr_inv_ctr 24 | ("No such constructor " ^ k ^ " when parsing " ^ def))) 25 | 26 | let not_comp k = 27 | raise (Error 28 | (Merr_not_comp 29 | (k ^ " does not have a computation type"))) 30 | 31 | 32 | let no_main () = raise (Error (Merr_no_main "No main function defined.")) 33 | 34 | let duplicate_tvar msg = 35 | raise (Error (Merr_duplicate_tvar 36 | ("Duplicate type variable detected:" ^ msg))) 37 | 38 | let shadowing_builtin msg = 39 | raise (Error (Merr_shadowing_builtin (msg ^ " shadows builtin."))) 40 | 41 | module type HMS = sig 42 | include Map.S with type key := string 43 | type mt = handler_definition t 44 | end 45 | 46 | module type NS = sig 47 | type t 48 | val empty : t 49 | (** Return an empty set. *) 50 | val mem : string -> t -> bool 51 | (** Return true if the set contains the specified string false 52 | otherwise. *) 53 | end 54 | 55 | module HandlerMap = struct 56 | module M = Map.Make(String) 57 | include M 58 | type mt = handler_definition M.t 59 | end 60 | 61 | module CtrSet = struct 62 | module M = Set.Make(String) 63 | type t = M.t 64 | let empty = M.empty 65 | let mem = M.mem 66 | end 67 | 68 | module CmdSet = struct 69 | module M = Set.Make(String) 70 | type t = M.t 71 | let empty = M.empty 72 | let mem = M.mem 73 | end 74 | 75 | type prog_state = 76 | { 77 | mutable def_name : string; 78 | ctrs : CtrSet.t; 79 | cmds : CmdSet.t 80 | } 81 | 82 | let just_datatype = function Sterm_datatype dt -> Some dt | _ -> None 83 | let just_effin = function Sterm_effin ei -> Some ei | _ -> None 84 | let just_decl = function Sterm_vdecl vd -> Some vd | _ -> None 85 | let just_def = function Sterm_vdefn vd -> Some vd | _ -> None 86 | 87 | let partition prog = 88 | let dts = ListUtils.filter_map just_datatype prog in 89 | let eis = ListUtils.filter_map just_effin prog in 90 | let decls = ListUtils.filter_map just_decl prog in 91 | let defs = ListUtils.filter_map just_def prog in 92 | (dts, eis, decls, defs) 93 | 94 | let add_ctr set ctr = CtrSet.M.add ctr.sctr_name set 95 | 96 | let add_cmd set cmd = CmdSet.M.add cmd.scmd_name set 97 | 98 | let add_def map def = HandlerMap.add def.mhdr_name def map 99 | 100 | (** Functions for refining the pattern matching of handlers. *) 101 | let rec refine_vpat st vp = 102 | match vp with 103 | | Svpat_var v (** Probe constructor environment; return ctr if found. *) 104 | -> if CtrSet.mem v st.ctrs then Svpat_ctr (v, []) else vp 105 | | Svpat_ctr (k, ps) 106 | -> let ps' = List.map (refine_vpat st) ps in Svpat_ctr (k, ps') 107 | | Svpat_any | Svpat_int _ | Svpat_float _ | Svpat_bool _ | Svpat_str _ -> vp 108 | 109 | let refine_cpat st cp = 110 | match cp with 111 | | Scpat_request (s, ps, k) 112 | -> let ps' = List.map (refine_vpat st) ps in Scpat_request (s, ps', k) 113 | 114 | (** Using the constructor set, reconstruct the pattern lists 115 | to rectify any constructors incorrectly identified as variables. *) 116 | let refine_pat st pat = 117 | match pat.spat_desc with 118 | | Spat_value vp -> Pattern.vpat(refine_vpat st vp) 119 | | Spat_comp cp -> Pattern.cpat(refine_cpat st cp) 120 | | Spat_any 121 | | Spat_thunk _ -> pat 122 | 123 | (** Functions for translating the computation of a handler clause. *) 124 | 125 | let rec translate_ccomp st cc = 126 | match cc with 127 | | CComp_cvalue cv -> Mccomp_cvalue (translate_cvalue st cv) 128 | | _ -> translate_clause st cc 129 | 130 | and translate_icomp st ic = 131 | match ic with 132 | | IComp_app (iv, cs) -> let iv' = translate_ivalue st iv in 133 | let cs' = List.map (translate_ccomp st) cs in 134 | Micomp_app (iv', cs') 135 | | IComp_let (x, cc1, cc2) -> let cc1' = translate_ccomp st cc1 in 136 | let cc2' = translate_ccomp st cc2 in 137 | Micomp_let (x, cc1', cc2') 138 | 139 | and translate_ivalue st iv = 140 | match iv with 141 | | IValue_ident v 142 | -> if CmdSet.mem v st.cmds then 143 | Mivalue_cmd v 144 | else 145 | Mivalue_var v 146 | | IValue_int n -> Mivalue_int n 147 | | IValue_float f -> Mivalue_float f 148 | | IValue_bool b -> Mivalue_bool b 149 | | IValue_str s -> Mivalue_str s 150 | | IValue_icomp ic 151 | -> Mivalue_icomp (translate_icomp st ic) 152 | 153 | and tryn_make_constructor st iv = 154 | match iv with 155 | | IValue_ident v -> if CtrSet.mem v st.ctrs then Some (Mcvalue_ctr (v, [])) 156 | else None 157 | | _ -> None 158 | 159 | and translate_cvalue st cv = 160 | match cv with 161 | | CValue_ivalue iv 162 | -> begin 163 | match tryn_make_constructor st iv with 164 | | Some cv' -> cv' 165 | | None -> Mcvalue_ivalue (translate_ivalue st iv) 166 | end 167 | | CValue_ctr (k, vs) 168 | -> if CtrSet.mem k st.ctrs then 169 | Mcvalue_ctr (k, List.map (translate_cvalue st) vs) 170 | else 171 | invalid_constructor k st.def_name 172 | | CValue_thunk cc 173 | -> st.def_name <- "thunk inside " ^ st.def_name; 174 | Mcvalue_thunk (translate_ccomp st cc) 175 | 176 | and translate_hdr_cse st (ps, cc) = 177 | let ps' = List.map (refine_pat st) ps in 178 | let cc' = translate_ccomp st cc in (ps', cc') 179 | 180 | and translate_clause st cse = 181 | match cse with 182 | | CComp_hdr_clause (ps, cc) 183 | -> Mccomp_clauses [translate_hdr_cse st (ps, cc)] 184 | | CComp_compose cs 185 | -> let f = 186 | function CComp_hdr_clause (ps, cc) -> translate_hdr_cse st (ps, cc) 187 | | _ -> invalid_clause_error st.def_name 188 | in Mccomp_clauses (List.map f cs) 189 | | _ -> invalid_clause_error st.def_name 190 | 191 | let translate_hdr st def = 192 | let rpat = List.map (refine_pat st) def.vdef_args in 193 | let midcomp = translate_ccomp st def.vdef_comp in 194 | (rpat, midcomp) 195 | 196 | (** Functions to construct mid-level handlers of a program from 197 | the declaration and clause fragments. *) 198 | 199 | (* Environment for mapping tvars to rigid tvars. *) 200 | module ENV = Map.Make(String) 201 | 202 | (* Collect the names of the free type variables. *) 203 | let rec free_tvars t = 204 | match t.styp_desc with 205 | | Styp_datatype (_, ts) 206 | | Styp_effin (_, ts) -> List.flatten (map free_tvars ts) 207 | 208 | | Styp_thunk t -> free_tvars t 209 | 210 | | Styp_comp (ts, t) 211 | | Styp_ret (ts, t) -> (List.flatten (map free_tvars ts)) ++ free_tvars t 212 | 213 | | Styp_tvar v -> [v] 214 | 215 | | _ -> [] 216 | 217 | (* Return [true] if [t] has a unique set of type variables, 218 | [false] otherwise. *) 219 | let uniq_tvars ts = 220 | let xs = List.flatten (map free_tvars ts) in 221 | let ys = List.sort_uniq String.compare xs in 222 | (List.length xs - List.length ys) == 0 223 | 224 | (* Perform some desugaring of the type: 225 | 226 | * Append a singleton set containing the effect variable to each effect set 227 | * Convert builtins that are parsed as datatypes to their corresponding 228 | builtin types 229 | * Ensure uniqueness of type variables within a particular scope 230 | * Convert user provided type variables to rigid type variables. *) 231 | let rec desugar_type' env t = 232 | match t.styp_desc with 233 | | Styp_tvar v -> begin 234 | try env, ENV.find v env with 235 | | Not_found -> (* Generate fresh rigid tvar *) 236 | let rtvar = TypExp.fresh_rigid_tvar v in 237 | ENV.add v rtvar env, rtvar 238 | end 239 | | Styp_datatype ("Int", []) -> env, TypExp.int () 240 | | Styp_datatype ("Float", []) -> env, TypExp.float () 241 | | Styp_datatype ("Bool", []) -> env, TypExp.bool () 242 | | Styp_datatype ("String", []) -> env, TypExp.str () 243 | | Styp_datatype (d, ps) 244 | -> let (env, ps) = map_accum desugar_type' env ps in 245 | env, TypExp.datatype d ps 246 | | Styp_thunk c -> 247 | let (env, c) = desugar_type' env c in 248 | env, TypExp.sus_comp c 249 | | Styp_comp (ts, r) 250 | -> let (env, ts) = map_accum desugar_type' env ts in 251 | let (env, r) = desugar_type' env r in 252 | env, TypExp.comp ~args:ts r 253 | | Styp_ret (es, v) 254 | -> let (env, es) = map_accum desugar_type' env es in 255 | let (env, v) = desugar_type' env v in 256 | let evar = TypExp.effect_var_set in 257 | env, TypExp.returner v ~effs:(evar ++ es) () 258 | | Styp_effin (ei, ps) -> 259 | let (env, ps) = map_accum desugar_type' env ps in 260 | env, TypExp.effin ei ~params:ps () 261 | | _ -> env, t 262 | 263 | let desugar_datatype dt = 264 | let desugar_ctr env ctr = 265 | let (env, ts) = map_accum desugar_type' env ctr.sctr_args in 266 | let (env, r) = desugar_type' env ctr.sctr_res in 267 | env, { ctr with sctr_args = ts; sctr_res = r } in 268 | let ps = dt.sdt_parameters in 269 | if uniq_tvars ps then 270 | let (env, ps) = map_accum desugar_type' ENV.empty ps in 271 | let (_, ctrs) = map_accum desugar_ctr env dt.sdt_constructors in 272 | { dt with sdt_parameters = ps; sdt_constructors = ctrs } 273 | else 274 | let d = dt.sdt_name in 275 | duplicate_tvar ("in parameter list of datatype " ^ d) 276 | 277 | let desugar_effect_interface ei = 278 | let desugar_cmd env cmd = 279 | let (env, ts) = map_accum desugar_type' env cmd.scmd_args in 280 | let (env, r) = desugar_type' env cmd.scmd_res in 281 | env, { cmd with scmd_args = ts; scmd_res = r } in 282 | let ps = ei.sei_parameters in 283 | if uniq_tvars ps then 284 | let (env, ps) = map_accum desugar_type' ENV.empty ps in 285 | let (_, cmds) = map_accum desugar_cmd env ei.sei_commands in 286 | {ei with sei_parameters = ps; sei_commands = cmds } 287 | else 288 | let e = ei.sei_name in 289 | duplicate_tvar ("in parameter list of effect interface " ^ e) 290 | 291 | let desugar_hdr t = snd (desugar_type' ENV.empty t) 292 | 293 | let make_hdr st (defs, hs) d = 294 | st.def_name <- d.svdecl_name; 295 | let name_eq def = def.vdef_name = d.svdecl_name in 296 | let (hdr_defs, defs) = List.partition name_eq defs in 297 | let hdr_clauses = List.map (translate_hdr st) hdr_defs in 298 | let h = 299 | { 300 | mhdr_name = d.svdecl_name; 301 | mhdr_type = desugar_hdr d.svdecl_type; 302 | mhdr_defs = hdr_clauses 303 | } 304 | in (defs, h :: hs) 305 | 306 | let make_hdr_defs st decls defs = 307 | let acc = (defs, []) in 308 | let (_, hdrs) = List.fold_left (make_hdr st) acc decls in 309 | hdrs 310 | 311 | (** Functions to compose the components of a mid-level tree into 312 | a complete list representing the program. *) 313 | 314 | let get_hdrs hmap = 315 | let bindings = HandlerMap.bindings hmap in 316 | List.map (fun (k,hdr) -> Mtld_handler hdr) bindings 317 | 318 | let merge dts eis hmap = 319 | List.map (fun dt -> Mtld_datatype dt) dts ++ 320 | List.map (fun ei -> Mtld_effin ei) eis ++ 321 | get_hdrs hmap 322 | 323 | let disjoint_from_builtin_datatypes dt = 324 | let module M = Set.Make(String) in 325 | let env = M.add "Unit" M.empty in 326 | let name = dt.sdt_name in 327 | if M.mem name env then shadowing_builtin ("datatype " ^ name) 328 | else () 329 | 330 | let disjoint_from_builtin_interfaces ei = 331 | let module M = Set.Make(String) in 332 | let env = M.add "Random" (M.add "Console" M.empty) in 333 | let name = ei.sei_name in 334 | if M.mem name env then shadowing_builtin ("effect interface " ^ name) 335 | else () 336 | 337 | (* Builtin constructors *) 338 | let builtin_ctrs = CtrSet.M.add "Unit" CtrSet.empty 339 | 340 | (* Builtin commands *) 341 | let builtin_cmds = 342 | CmdSet.M.add "random" 343 | (CmdSet.M.add "putStr" 344 | (CmdSet.M.add "putStrLn" (CmdSet.M.add "getStr" CmdSet.empty))) 345 | 346 | (** Main translation function. *) 347 | 348 | let translate prog = 349 | let (dts, eis, decls, defs) = partition prog in 350 | let _ = List.iter disjoint_from_builtin_datatypes dts in 351 | let _ = List.iter disjoint_from_builtin_interfaces eis in 352 | let dts = map desugar_datatype dts in 353 | let eis = map desugar_effect_interface eis in 354 | let ctrs = List.flatten (List.map (fun dt -> dt.sdt_constructors) dts) in 355 | let cmds = List.flatten (List.map (fun ei -> ei.sei_commands) eis) in 356 | let ctrs = List.fold_left add_ctr builtin_ctrs ctrs in 357 | let cmds = List.fold_left add_cmd builtin_cmds cmds in 358 | let state = { def_name = ""; ctrs; cmds } in 359 | let defs = make_hdr_defs state decls defs in 360 | let hmap = List.fold_left add_def HandlerMap.empty defs in 361 | if HandlerMap.mem "main" hmap then 362 | let mtree = merge dts eis hmap in 363 | (mtree, hmap, ctrs, cmds) 364 | else no_main () 365 | -------------------------------------------------------------------------------- /mid/midTranslate.mli: -------------------------------------------------------------------------------- 1 | (*********************************************************************** 2 | * Translate the untyped abstract syntax tree of the source language 3 | * into a mid-level language. It performs some processing on the AST to 4 | * distinguish handlers, constructors and commands from each other. It 5 | * also combines a handler's type declaration with its clauses. 6 | * 7 | * 8 | * Created by Craig McLaughlin on 21/07/2015. 9 | *********************************************************************** 10 | *) 11 | 12 | open MidTree 13 | 14 | type mid_error = 15 | | Merr_not_comp of string 16 | | Merr_inv_clause of string 17 | | Merr_inv_ctr of string 18 | | Merr_no_main of string 19 | | Merr_duplicate_tvar of string 20 | | Merr_shadowing_builtin of string 21 | 22 | exception Error of mid_error 23 | 24 | module type HMS = sig 25 | include Map.S with type key := string 26 | type mt = handler_definition t 27 | end 28 | 29 | module type NS = sig 30 | type t 31 | val empty : t 32 | (** Return an empty set. *) 33 | val mem : string -> t -> bool 34 | (** Return true if the set contains the specified string false 35 | otherwise. *) 36 | end 37 | 38 | module HandlerMap : HMS 39 | (** Map handler names to the corresponding definition. *) 40 | 41 | module CtrSet : NS 42 | (** Store for identifiers representing constructors. *) 43 | 44 | module CmdSet : NS 45 | (** Store for identifiers representing commands of effect interfaces. *) 46 | 47 | val translate : ParseTree.prog -> 48 | MidTree.prog * HandlerMap.mt * CtrSet.t * CmdSet.t 49 | (** Process the parse tree and return the mid-level tree and its associated 50 | mappings for global names (handlers), constructors and commands. *) 51 | -------------------------------------------------------------------------------- /mid/midTree.ml: -------------------------------------------------------------------------------- 1 | open ParseTree 2 | open Show 3 | 4 | type prog = tld list 5 | 6 | and tld = 7 | | Mtld_datatype of datatype_declaration 8 | | Mtld_effin of effect_interface 9 | | Mtld_handler of handler_definition 10 | 11 | and datatype_declaration = ParseTree.datatype_declaration 12 | 13 | and effect_interface = ParseTree.effect_interface 14 | 15 | and pattern = ParseTree.pattern 16 | 17 | and src_type = ParseTree.src_type 18 | 19 | and handler_definition = 20 | { 21 | mhdr_name : string; 22 | mhdr_type : src_type; 23 | mhdr_defs : handler_clause list 24 | } 25 | 26 | and handler_clause = pattern list * mid_ccomputation 27 | 28 | and mid_ccomputation = 29 | | Mccomp_cvalue of mid_cvalue 30 | | Mccomp_clauses of handler_clause list 31 | 32 | and mid_cvalue = 33 | | Mcvalue_ivalue of mid_ivalue 34 | | Mcvalue_ctr of string * mid_cvalue list 35 | | Mcvalue_thunk of mid_ccomputation 36 | 37 | and mid_ivalue = 38 | | Mivalue_var of string 39 | | Mivalue_cmd of string 40 | | Mivalue_int of int 41 | | Mivalue_float of float 42 | | Mivalue_bool of bool 43 | | Mivalue_str of string 44 | | Mivalue_icomp of mid_icomputation 45 | 46 | and mid_icomputation = 47 | | Micomp_app of mid_ivalue * mid_ccomputation list 48 | | Micomp_let of string * mid_ccomputation * mid_ccomputation 49 | deriving (Show) 50 | 51 | module rec ShowMidProg : SHOW 52 | with type t = prog = ShowList(ShowMidTLD) 53 | 54 | and ShowMidTLD : SHOW with type t = tld = struct 55 | type t = tld 56 | let show d = match d with 57 | | Mtld_datatype dt -> ShowDatatype.show dt 58 | | Mtld_effin ei -> ShowEffin.show ei 59 | | Mtld_handler hdr -> ShowMidHandler.show hdr 60 | end 61 | 62 | and ShowMidHandler : SHOW with type t = handler_definition = struct 63 | type t = handler_definition 64 | 65 | let show_cse name (ps, cc) = 66 | name ^ (string_of_args " " ShowPattern.show ps) ^ " = " ^ 67 | ShowMidCComp.show cc 68 | 69 | let show h = 70 | "{- START OF HANDLER " ^ h.mhdr_name ^ " DEFINITION -}\n" ^ 71 | h.mhdr_name ^ " : " ^ (ShowSrcType.show h.mhdr_type) ^ "\n" ^ 72 | (String.concat "\n" (List.map (show_cse h.mhdr_name) h.mhdr_defs)) ^ 73 | "\n{- END OF HANDLER " ^ h.mhdr_name ^ " DEFINITION -}\n" 74 | end 75 | 76 | and ShowHdrClause : SHOW with type t = handler_clause = struct 77 | type t = handler_clause 78 | let show (ps, cc) = 79 | String.concat " " (List.map ShowPattern.show ps) ^ " = " ^ 80 | ShowMidCComp.show cc 81 | end 82 | 83 | and ShowMidCComp : SHOW with type t = mid_ccomputation = struct 84 | type t = mid_ccomputation 85 | let show c = match c with 86 | | Mccomp_cvalue cv -> ShowMidCValue.show cv 87 | | Mccomp_clauses cses -> if cses = [] then "()" else ShowClauses.show cses 88 | end 89 | 90 | and ShowMidCValue : SHOW with type t = mid_cvalue = struct 91 | type t = mid_cvalue 92 | let rec show cv = match cv with 93 | | Mcvalue_ivalue iv -> ShowMidIValue.show iv 94 | | Mcvalue_ctr (k, vs) 95 | -> "(" ^ k ^ (string_of_args " " ShowMidCValue.show vs) ^ ")" 96 | | Mcvalue_thunk cc -> "{" ^ ShowMidCComp.show cc ^ "}" 97 | end 98 | 99 | and ShowMidIValue : SHOW with type t = mid_ivalue = struct 100 | type t = mid_ivalue 101 | let show iv = match iv with 102 | | Mivalue_var v -> "({-VAR-} " ^ v ^ ")" 103 | | Mivalue_cmd c -> "({-CMD-} " ^ c ^ ")" 104 | | Mivalue_int n -> "({-INT-} " ^ string_of_int n ^ ")" 105 | | Mivalue_float f -> "({-FLOAT-} " ^ string_of_float f ^ ")" 106 | | Mivalue_bool b -> "({-BOOL-} " ^ string_of_bool b ^ ")" 107 | | Mivalue_str s -> "({-STRING-} \"" ^ (String.escaped s) ^ "\")" 108 | | Mivalue_icomp ic -> ShowMidIComp.show ic 109 | end 110 | 111 | and ShowMidIComp : SHOW with type t = mid_icomputation = struct 112 | type t = mid_icomputation 113 | let show ic = match ic with 114 | | Micomp_app (iv, xs) 115 | -> "({-APP-}" ^ (ShowMidIValue.show iv) ^ "!" ^ 116 | (string_of_args " " ShowMidCComp.show xs) ^ ")" 117 | | Micomp_let (x, cc1, cc2) 118 | -> "(let " ^ x ^ " = " ^ (ShowMidCComp.show cc1) ^ " in " ^ 119 | (ShowMidCComp.show cc2) ^ ")" 120 | end 121 | 122 | and ShowClauses : SHOW 123 | with type t = handler_clause list = ShowList(ShowHdrClause) 124 | -------------------------------------------------------------------------------- /mid/midTree.mli: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | (*********************************************************************** 3 | * Translate the untyped abstract syntax tree of the source language 4 | * into a untyped mid-level tree. The mid-level tree does not 5 | * distinguish between inferable and checkable values/computations. 6 | * 7 | * 8 | * Created by Craig McLaughlin on 21/07/2015. 9 | *********************************************************************** 10 | *) 11 | 12 | open Show 13 | 14 | type prog = tld list 15 | 16 | and tld = 17 | | Mtld_datatype of datatype_declaration 18 | | Mtld_effin of effect_interface 19 | | Mtld_handler of handler_definition 20 | 21 | and datatype_declaration = ParseTree.datatype_declaration 22 | 23 | and effect_interface = ParseTree.effect_interface 24 | 25 | and pattern = ParseTree.pattern 26 | 27 | and src_type = ParseTree.src_type 28 | 29 | and handler_definition = 30 | { 31 | mhdr_name : string; 32 | mhdr_type : src_type; 33 | mhdr_defs : handler_clause list 34 | } 35 | 36 | and handler_clause = pattern list * mid_ccomputation 37 | 38 | and mid_ccomputation = 39 | | Mccomp_cvalue of mid_cvalue 40 | | Mccomp_clauses of handler_clause list 41 | 42 | and mid_cvalue = 43 | | Mcvalue_ivalue of mid_ivalue 44 | | Mcvalue_ctr of string * mid_cvalue list 45 | | Mcvalue_thunk of mid_ccomputation 46 | 47 | and mid_ivalue = 48 | | Mivalue_var of string 49 | | Mivalue_cmd of string 50 | | Mivalue_int of int 51 | | Mivalue_float of float 52 | | Mivalue_bool of bool 53 | | Mivalue_str of string 54 | | Mivalue_icomp of mid_icomputation 55 | 56 | and mid_icomputation = 57 | | Micomp_app of mid_ivalue * mid_ccomputation list 58 | | Micomp_let of string * mid_ccomputation * mid_ccomputation 59 | deriving (Show) 60 | 61 | (** Show functions for the tree (see also ParseTree module) *) 62 | module ShowMidProg : SHOW with type t = prog 63 | 64 | module ShowMidTLD : SHOW with type t = tld 65 | 66 | module ShowMidHandler : SHOW with type t = handler_definition 67 | 68 | module ShowHdrClause : SHOW with type t = handler_clause 69 | 70 | module ShowMidCComp : SHOW with type t = mid_ccomputation 71 | 72 | module ShowMidCValue : SHOW with type t = mid_cvalue 73 | 74 | module ShowMidIValue : SHOW with type t = mid_ivalue 75 | 76 | module ShowMidIComp : SHOW with type t = mid_icomputation 77 | -------------------------------------------------------------------------------- /mid/patternMatching.ml: -------------------------------------------------------------------------------- 1 | open List 2 | open MidTree 3 | open MidTyping 4 | open ParseTree 5 | open ParseTreeBuilder 6 | open ListUtils 7 | open Utility 8 | 9 | type 'a vector = 'a list 10 | type 'a matrix = 'a vector vector 11 | type action = MidTree.mid_ccomputation deriving (Show) 12 | type pattern = MidTree.pattern 13 | type value = MidTree.mid_cvalue 14 | (** Helpful synonyms. *) 15 | 16 | type clause = pattern vector * action 17 | type pmatrix = pattern matrix 18 | type cmatrix = clause vector 19 | (** Shorthands. *) 20 | 21 | type dtree = 22 | Fail 23 | | Leaf of action 24 | | Swap of int * dtree (* Subterm to be inspected w.r.t the decision tree. *) 25 | | Switch of case list 26 | (** Representation for decision trees the target of pattern matching 27 | compilation. *) 28 | 29 | and case = 30 | CseDefault of dtree 31 | | CseSig of MidTyping.type_sig * dtree 32 | deriving (Show) 33 | (** Cases which occur at multi-way test nodes within a decision tree. *) 34 | 35 | let foldmapb f xs = fold_left (&&) true (map f xs) 36 | 37 | let rec is_inst p v = 38 | match p.spat_desc, v with 39 | | Spat_value vp, Mcvalue_ivalue _ 40 | | Spat_value vp, Mcvalue_ctr _ -> is_value_inst vp v 41 | | _, _ -> false (* Computations not supported yet. *) 42 | 43 | and is_value_inst vp cv = 44 | match vp, cv with 45 | | Svpat_any, _ 46 | | Svpat_var _, _ -> true 47 | | Svpat_ctr (k, ps), Mcvalue_ctr (k', vs) when k = k' 48 | -> foldmapb (uncurry is_value_inst) (combine ps vs) 49 | | _, Mcvalue_ivalue iv 50 | -> begin 51 | match vp, iv with 52 | | Svpat_int x, Mivalue_int y -> x = y 53 | | Svpat_float x, Mivalue_float y -> x = y 54 | | Svpat_bool x, Mivalue_bool y -> x = y 55 | | Svpat_str x, Mivalue_str y -> x = y 56 | | _ -> false 57 | end 58 | | _ -> false 59 | 60 | and is_inst_vec ps vs = foldmapb (uncurry is_inst) (combine ps vs) 61 | 62 | let not_inst p v = not (is_inst p v) 63 | 64 | let string_of_pattern = ShowPattern.show 65 | 66 | let string_of_patterns = string_of_args ", " ~bbegin:false string_of_pattern 67 | 68 | let to_columns m = 69 | let cons = fun p ps -> p :: ps in 70 | let colgen (ps, a) (css, rs) = 71 | (map (uncurry cons) (combine ps css), a :: rs) in 72 | let rowlen = if length m > 0 then length (fst (hd m)) else 0 in 73 | fold_right colgen m (repeat [] rowlen,[]) 74 | 75 | let of_columns ps rs = combine (transpose ps) rs 76 | 77 | let get_pmatrix = transpose @ fst @ to_columns 78 | 79 | let prpatmatrix m = 80 | iter (fun ps -> print_endline (string_of_patterns ps)) m 81 | 82 | let prmatrix m = 83 | let string_of_clause (ps, a) = 84 | (string_of_patterns ps) ^ " -> " ^ (ShowMidCComp.show a) in 85 | iter (fun c -> print_endline (string_of_clause c)) m 86 | 87 | (** Specialises the matrix [m] using the specialisation function [specf]. If 88 | [specf] returns [(true, xs)] for some list [xs] then the function 89 | generates a row with [xs] prepended to the remaining patterns of the 90 | row. If [specf] returns [(false, xs)] for some list [xs] the list is 91 | ignored and no row is produced. *) 92 | let specialise_using_fun specf m = 93 | let clausegen (ps, a) = 94 | match ps with 95 | | p :: ps -> let (b, xs) = specf p in 96 | if b then [(xs ++ ps, a)] else [] 97 | | [] -> [] in 98 | flatten (map clausegen m) 99 | 100 | let specialise tsg m = 101 | (* The following conditions are true for all value type signatures with 102 | arity n. *) 103 | let defaults_for_values p n = 104 | match p.spat_desc with 105 | | Spat_value Svpat_any 106 | | Spat_value (Svpat_var _) 107 | | Spat_any 108 | | Spat_thunk _ -> (true, repeat (Pattern.vpat (Pattern.any_value ())) n) 109 | | _ -> (false, []) in 110 | match tsg with 111 | | TSAmbientCmds -> assert false (* We never specialise for ambient cmds. *) 112 | | TSAllValues _ -> let val_spec p = defaults_for_values p 0 in 113 | specialise_using_fun val_spec m 114 | | TSBool b -> let bool_spec p = 115 | match p.spat_desc with 116 | | Spat_value (Svpat_bool b') -> (b = b', []) 117 | | _ -> defaults_for_values p 0 in 118 | specialise_using_fun bool_spec m 119 | | TSFloat f -> let float_spec p = 120 | match p.spat_desc with 121 | | Spat_value (Svpat_float f') -> (f = f', []) 122 | | _ -> defaults_for_values p 0 in 123 | specialise_using_fun float_spec m 124 | | TSInt n -> let int_spec p = 125 | match p.spat_desc with 126 | | Spat_value (Svpat_int n') -> (n = n', []) 127 | | _ -> defaults_for_values p 0 in 128 | specialise_using_fun int_spec m 129 | | TSStr s -> let str_spec p = 130 | match p.spat_desc with 131 | | Spat_value (Svpat_str s') -> (s = s', []) 132 | | _ -> defaults_for_values p 0 in 133 | specialise_using_fun str_spec m 134 | | TSCtr (k, n) -> let ctr_spec p = 135 | match p.spat_desc with 136 | | Spat_value (Svpat_ctr (k', ps)) 137 | -> (k = k', map Pattern.vpat ps) 138 | | _ -> defaults_for_values p n in 139 | specialise_using_fun ctr_spec m 140 | | TSCmd (c, n) -> let cmd_spec p = 141 | match p.spat_desc with 142 | | Spat_comp (Scpat_request (c', vs, r)) 143 | -> let p = Pattern.vpat (Pattern.var r) in 144 | let vs' = map Pattern.vpat vs in 145 | (c = c', vs' ++ [p]) 146 | | _ -> (false, []) in 147 | specialise_using_fun cmd_spec m 148 | 149 | let default m = 150 | let clausegen (ps, a) = 151 | match ps with 152 | | p :: ps 153 | -> begin match p.spat_desc with 154 | | Spat_value _ 155 | | Spat_comp _ -> [] 156 | | Spat_any 157 | | Spat_thunk _ -> [(ps, a)] 158 | end 159 | | [] -> [] in 160 | flatten (map clausegen m) 161 | 162 | let rec all_wild ps = 163 | match ps with 164 | | p :: ps -> begin match p.spat_desc with 165 | | Spat_any 166 | | Spat_thunk _ -> all_wild ps 167 | | _ -> false 168 | end 169 | | [] -> true (* No columns case *) 170 | 171 | (* Pick the first column which has a pattern that is not a wildcard. 172 | Return both the column number, the column and the remaining columns. *) 173 | let pick_column css = 174 | let rec pick n css = 175 | match css with 176 | | [] -> failwith "invariant invalidated" 177 | | cs :: css -> if not (all_wild cs) then (n, cs) 178 | else pick (n+1) css in 179 | pick 0 css 180 | 181 | (** Compute head type signatures in patterns [ps]. *) 182 | let compute_heads ps = 183 | let compute_hd p = 184 | match p.spat_desc with 185 | | Spat_value vp -> begin 186 | match vp with 187 | | Svpat_any 188 | -> TypeSigSet.singleton (TSAllValues None) 189 | | Svpat_var x 190 | -> TypeSigSet.singleton (TSAllValues (Some x)) 191 | | Svpat_ctr (k, vs) 192 | -> TypeSigSet.singleton (TSCtr (k, length vs)) 193 | | Svpat_int n -> TypeSigSet.singleton (TSInt n) 194 | | Svpat_float f -> TypeSigSet.singleton (TSFloat f) 195 | | Svpat_str s -> TypeSigSet.singleton (TSStr s) 196 | | Svpat_bool b -> TypeSigSet.singleton (TSBool b) 197 | end 198 | | Spat_comp (Scpat_request (c, vs, _)) 199 | -> TypeSigSet.singleton (TSCmd (c, length vs + 1)) 200 | | _ -> TypeSigSet.empty in 201 | foldl TypeSigSet.union TypeSigSet.empty (map compute_hd ps) 202 | 203 | let matches vs m = 204 | let matches_row j vs ps = 205 | if is_inst_vec ps vs then Some j else None in 206 | let find_match a ps = 207 | match a with 208 | | (Some _, _) -> a (* Exit as soon as a match is found. *) 209 | | (None, j) -> (matches_row j vs ps, j+1) in 210 | match foldl find_match (None, 0) m with 211 | | (Some j, _) -> Some j 212 | | (None, _) -> None 213 | 214 | let rec compile env ts m = 215 | let make_case t ts' tsg = 216 | let ts = compute_arg_types env t tsg in 217 | let tree = compile env (ts++ts') (specialise tsg m) in 218 | CseSig (tsg, tree) in 219 | match m with 220 | | [] -> Fail (* No row case *) 221 | | (ps, a) :: m' when all_wild ps -> Leaf a (* Default case is first row *) 222 | | _ 223 | -> let (css, _) = to_columns m in 224 | let (i, cs) = pick_column css in 225 | if i != 0 then 226 | let (pm,rs) = split m in 227 | let pm' = swap (transpose pm) 0 i in 228 | let ts' = swap ts 0 i in 229 | let m' = combine (transpose pm') rs in 230 | Swap (i, compile env ts' m') 231 | else 232 | let hs = compute_heads cs in 233 | print_endline "---hs---"; 234 | print_endline (Show.show (TypeSigSet.elements hs)); 235 | let (t,ts) = hd ts, tl ts in 236 | let tsg = compute_signature env t in 237 | print_endline "---tsg---"; 238 | print_endline (Show.show (TypeSigSet.elements tsg)); 239 | (* Compute decision tree for each signature appearing in column. *) 240 | let cases = map (make_case t ts) (TypeSigSet.elements hs) in 241 | (* Check whether or not we need a default case. *) 242 | let diff = TypeSigSet.diff tsg hs in 243 | print_endline "---diff---"; 244 | print_endline (Show.show (TypeSigSet.elements diff)); 245 | if TypeSigSet.is_ambient diff then 246 | (* compute forwarding commands *) 247 | Switch cases 248 | else if TypeSigSet.all_cmds diff then 249 | let dm = default m in 250 | (* Expect at least one row for the default case. *) 251 | if length dm = 0 then 252 | let es = TypeSigSet.elements diff in 253 | let es = filter (function TSCmd _ -> true | _ -> false) es in 254 | let TSCmd (cmd, _) = hd es in 255 | print_endline (Show.show es); 256 | type_error ("Unhandled pattern(s) e.g. [" ^ cmd ^ " _ -> _]") 257 | else Switch (cases ++ [CseDefault (compile env ts dm)]) 258 | else if TypeSigSet.is_empty diff then 259 | Switch cases 260 | else 261 | type_error ("Unhandled patterns.") 262 | -------------------------------------------------------------------------------- /mid/patternMatching.mli: -------------------------------------------------------------------------------- 1 | (* Pattern matching compilation module. 2 | 3 | *) 4 | 5 | type 'a vector = 'a list 6 | type 'a matrix = 'a vector vector 7 | type action = MidTree.mid_ccomputation deriving (Show) 8 | type pattern = MidTree.pattern 9 | type value = MidTree.mid_cvalue 10 | (** Helpful synonyms. *) 11 | 12 | type clause = pattern vector * action 13 | type pmatrix = pattern matrix 14 | type cmatrix = clause vector 15 | (** Shorthands. *) 16 | 17 | type dtree = 18 | Fail 19 | | Leaf of action 20 | | Swap of int * dtree (* Subterm to be inspected w.r.t the decision tree. *) 21 | | Switch of case list 22 | (** Representation for decision trees the target of pattern matching 23 | compilation. *) 24 | 25 | and case = 26 | CseDefault of dtree 27 | | CseSig of MidTyping.type_sig * dtree 28 | deriving (Show) 29 | (** Cases which occur at multi-way test nodes within a decision tree. *) 30 | 31 | (* Pattern and value operations. *) 32 | 33 | val is_inst : pattern -> value -> bool 34 | val is_inst_vec : pattern vector -> value vector -> bool 35 | (** [is_inst p v] returns [true] ([false] otherwise) if [v] is an instance 36 | of pattern [p]. Defined as (NB: infix notation "<=" for is_instance): 37 | * _ <= v 38 | * c(p1,...,pN) <= c(v1,...,vN) iff (p1,...,pN) <= (v1,...,vN) 39 | * [c (p1,...pN) -> k] <= c v1,...,vN iff (p1,...,pN) <= (v1,...,vN) 40 | * Other cases for builtins: bool, float, int, etc. 41 | * (p1,...,pN) <= (v1,...,vN) iff for all i, pi <= vi 42 | The last case is on sequences of patterns (a pattern vector). 43 | *) 44 | 45 | val not_inst : pattern -> value -> bool 46 | (** [not_inst p v] returns [true] ([false] otherwise) if [v] is not an 47 | instance of pattern [p]. For the time being, this is simply the negation 48 | of [is_inst] but I am reliably informed this will not remain so. *) 49 | 50 | val string_of_pattern : pattern -> string 51 | val string_of_patterns : pattern vector -> string 52 | (** [string_of_pattern p] return a string representation of pattern [p]. *) 53 | 54 | (* Matrix operations *) 55 | 56 | val to_columns : cmatrix -> pmatrix * action vector 57 | (** [to_columns m] returns the matrix as a pattern matrix and a column of 58 | actions. *) 59 | 60 | val of_columns : pmatrix -> action vector -> cmatrix 61 | (** [of_columns ps rs] returns a matrix computed from the transpose of the 62 | pattern matrix and the column of actions. *) 63 | 64 | val get_pmatrix : cmatrix -> pmatrix 65 | (** [get_pmatrix m] returns the pattern matrix of the given clause matrix. *) 66 | 67 | val prpatmatrix : pmatrix -> unit 68 | (** [prpatmatrix m] print the pattern matrix [m] to standard output. *) 69 | 70 | val prmatrix : cmatrix -> unit 71 | (** [prmatrix m] print the matrix m to standard output. *) 72 | 73 | (* Matrix decomposition operations. *) 74 | 75 | val specialise : MidTyping.type_sig -> cmatrix -> cmatrix 76 | (** [specialise tsg m] simplify [m] by assuming that the first value admits 77 | [tsg] as a type signature and return the resulting simplified clause 78 | matrix. *) 79 | 80 | val default : cmatrix -> cmatrix 81 | (** [default m] returns the "default" matrix computed from [m] which retains 82 | the rows of [m] whose first pattern admits as instances all type 83 | signatures that are not present in the first column of [m]. *) 84 | 85 | val compute_heads : pattern vector -> MidTyping.TypeSigSet.t 86 | (** [compute_heads ps] computes the head type signatures for the column of 87 | patterns [ps]. *) 88 | 89 | (* Matching, evaluation and compilation operations. *) 90 | 91 | val matches : value vector -> pmatrix -> int option 92 | (** [matches vs p] returns the row [Some j] of [p] which filters [vs] 93 | i.e. [vs] matches row [Some j]. [None] is returned if [vs] does not match 94 | any row in [p].*) 95 | 96 | val compile : MidTyping.env -> ParseTree.src_type vector -> cmatrix -> dtree 97 | (** [compile env ts m] returns the decision tree corresponding to the clause 98 | matrix [m] with respect to the typing environment [env] and the vector of 99 | type signatures [ts] which correspond to the types of the columns of 100 | patterns in [m]. *) 101 | -------------------------------------------------------------------------------- /mid/patternMatchingUnitTest.ml: -------------------------------------------------------------------------------- 1 | (* A small test file for the pattern matching compilation module. *) 2 | 3 | open ListUtils 4 | open MidTree 5 | open ParseTree 6 | open ParseTreeBuilder 7 | open PatternMatching 8 | open Utility 9 | 10 | (* Value pattern helper constructors *) 11 | let vpat = Pattern.vpat 12 | let any_vpat = Pattern.any_value 13 | let any_pat = vpat @ any_vpat 14 | let bool_pat = vpat @ Pattern.boolean 15 | let ctr_pat k vs = vpat (Pattern.ctr k ~pats:vs ()) 16 | let int_pat = vpat @ Pattern.integer 17 | let float_pat = vpat @ Pattern.float 18 | let str_pat = vpat @ Pattern.str 19 | let var_vpat = Pattern.var 20 | let var_pat = vpat @ var_vpat 21 | 22 | (* Value helper constructors *) 23 | let ival iv = Mcvalue_ivalue iv 24 | let bool_val b = ival (Mivalue_bool b) 25 | let ctr_val k vs = Mcvalue_ctr (k, vs) 26 | let id_val id = ival (Mivalue_var id) 27 | let int_val n = ival (Mivalue_int n) 28 | let float_val f = ival (Mivalue_float f) 29 | let str_val s = ival (Mivalue_str s) 30 | 31 | let make_iexp n = Mccomp_cvalue (Mcvalue_ivalue (Mivalue_int n)) 32 | 33 | (* Helper constructors for values. *) 34 | let make_cons x xs = ctr_val "Cons" [x; xs] 35 | let make_nil () = ctr_val "Nil" [] 36 | let make_unit () = ctr_val "Unit" [] 37 | let make_one () = make_cons (make_unit ()) (make_nil ()) 38 | 39 | let ps = 40 | [int_pat 1; 41 | bool_pat false; 42 | str_pat "Hello"; 43 | var_pat "x"; 44 | ctr_pat "Cons" [any_vpat (); var_vpat "xs"]; 45 | float_pat 1.2; 46 | any_pat ()] 47 | 48 | let vs = 49 | [int_val 1; 50 | bool_val false; 51 | str_val "Hello"; 52 | id_val "y"; 53 | ctr_val "Cons" [id_val "x"; ctr_val "Cons" [id_val "y"; id_val "ys"]]; 54 | float_val 1.2; 55 | ctr_val "Unit" []] 56 | 57 | let pa = 58 | [([ctr_pat "Nil" []; any_pat ()], make_iexp 1); 59 | ([any_pat (); ctr_pat "Nil" []], make_iexp 2); 60 | ([ctr_pat "Cons" [any_vpat (); var_vpat "xs"]; 61 | ctr_pat "Cons" [any_vpat (); var_vpat "ys"]], make_iexp 3)] 62 | 63 | let div = 64 | [([var_pat "x"; int_pat 0], make_iexp 1); 65 | ([var_pat "x"; var_pat "y"], make_iexp 2)] 66 | 67 | let run_test p v = 68 | let msg = ShowPattern.show p ^ " <= " ^ ShowMidCValue.show v in 69 | print_endline (msg ^ " = " ^ (string_of_bool (is_inst p v))) 70 | 71 | let run_match_test (km, m) (kvs, vs) = 72 | let msg = "matches " ^ kvs ^ " " ^ km ^ " = " in 73 | let res = matches vs m in 74 | print_endline (msg ^ Show.show res) 75 | 76 | let gen_tests () = 77 | let vs1 = [make_nil (); make_one ()] in 78 | let vs2 = [make_one (); make_nil ()] in 79 | let vs3 = [make_one (); make_one ()] in 80 | [("vs1", vs1); ("vs2", vs2); ("vs3", vs3)] 81 | 82 | let main = 83 | List.iter (uncurry run_test) (List.combine ps vs); 84 | print_endline "----P -> A------"; 85 | prmatrix pa; 86 | print_endline "----S((::), P->A)-----Specialising to Cons----"; 87 | prmatrix (specialise (MidTyping.TSCtr ("Cons", 2)) pa); 88 | print_endline "----S([], P->A)-----Specialising to Nil----"; 89 | prmatrix (specialise (MidTyping.TSCtr ("Nil", 0)) pa); 90 | let pm = get_pmatrix pa in 91 | print_endline "---just the patterns----"; 92 | prpatmatrix pm; 93 | List.iter (run_match_test ("P", pm)) (gen_tests ()); 94 | print_endline "---div---"; 95 | prmatrix div; 96 | print_endline "---S(0, swap div 0 1)---Specalising to error case---"; 97 | let (pm,rs) = to_columns div in 98 | let pm' = swap pm 0 1 in 99 | let div' = List.combine (transpose pm') rs in 100 | prmatrix (specialise (MidTyping.TSInt 0) div') 101 | -------------------------------------------------------------------------------- /mid/typingPatternMatching.ml: -------------------------------------------------------------------------------- 1 | (* A small test file for typing pattern matching compilation module. *) 2 | 3 | open ErrorHandling 4 | open Lexer 5 | open Lexing 6 | open ListUtils 7 | open MidEvaluator 8 | open EvalComp 9 | open MidTranslate 10 | open MidTree 11 | open MidTyping 12 | open ParseTree 13 | open ParseTreeBuilder 14 | open PatternMatching 15 | open Printf 16 | open Utility 17 | 18 | let print_position outx lexbuf = 19 | let pos = lexbuf.lex_curr_p in 20 | fprintf outx "%s:%d:%d" pos.pos_fname 21 | pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) 22 | 23 | let parse_with_error lexbuf = 24 | try Parser.program Lexer.token lexbuf with 25 | | SyntaxError msg -> 26 | fprintf stderr "%a:%s\n" print_position lexbuf msg; [] 27 | | Parser.Error -> 28 | fprintf stderr "%a: syntax error\n" print_position lexbuf; 29 | exit (-1) 30 | 31 | let translate_with_error prog = 32 | let ext = function Merr_not_comp msg 33 | | Merr_inv_clause msg 34 | | Merr_inv_ctr msg 35 | | Merr_no_main msg 36 | | Merr_duplicate_tvar msg 37 | | Merr_shadowing_builtin msg -> msg in 38 | try translate prog with 39 | | MidTranslate.Error err 40 | -> fprintf stderr "Translation error: %s\n" (ext err); 41 | exit (-1) 42 | 43 | let type_with_error prog = 44 | try type_prog prog with 45 | | TypeError s -> fprintf stderr "Type error: %s\n" s; exit (-1) 46 | 47 | let rec parse_file lexbuf = 48 | match parse_with_error lexbuf with 49 | | [] -> ([], HandlerMap.empty, CtrSet.empty, CmdSet.empty) 50 | | prog -> translate_with_error prog 51 | 52 | let preprocess_lines st = 53 | let last buf = Buffer.length buf - 1 in 54 | let nth buf n = Buffer.nth buf n in 55 | (* Make it optional to include the dot at the end of a sentence and 56 | also guard against special cases e.g. line ends in a comment or we 57 | encountered a blank line. *) 58 | let last_cond buf = 59 | nth buf (last buf) != '.' && 60 | (nth buf ((last buf) - 1) != '-' && nth buf (last buf) != '}') && 61 | nth buf (last buf) != '\n' in 62 | let rec process_char_until c buf = 63 | let c' = Stream.next st in 64 | if c' = c then c 65 | else if c' = '{' then (* Multi-line comment encountered. *) 66 | let d = Stream.next st in 67 | Buffer.add_char buf c'; Buffer.add_char buf d; 68 | (* Eat entire comment. *) 69 | (if d = '-' then Buffer.add_char buf (process_char_until '}' buf)); 70 | process_char_until c buf 71 | else if c' = '"' then (* String encountered. *) 72 | (Buffer.add_char buf c'; 73 | (* Eat entire string. *) 74 | Buffer.add_char buf (process_char_until '"' buf); 75 | process_char_until c buf) 76 | else (Buffer.add_char buf c'; process_char_until c buf) in 77 | let rec process_lines buf = 78 | let nl = process_char_until '\n' buf in 79 | let c = try Stream.next st with 80 | | Stream.Failure -> '\n' in 81 | (if c != ' ' && c != '\t' && last_cond buf then 82 | Buffer.add_char buf '.'); 83 | Buffer.add_char buf nl; Buffer.add_char buf c; 84 | process_lines buf in 85 | let buf = Buffer.create 10 in 86 | try process_lines buf with 87 | | Stream.Failure -> Buffer.contents buf 88 | 89 | (* Value pattern helper constructors *) 90 | let vpat = Pattern.vpat 91 | let any_vpat = Pattern.any_value 92 | let any_pat = vpat @ any_vpat 93 | let bool_pat = vpat @ Pattern.boolean 94 | let ctr_pat k vs = vpat (Pattern.ctr k ~pats:vs ()) 95 | let int_pat = vpat @ Pattern.integer 96 | let float_pat = vpat @ Pattern.float 97 | let str_pat = vpat @ Pattern.str 98 | let thunk_pat = Pattern.thunk 99 | let var_vpat = Pattern.var 100 | let var_pat = vpat @ var_vpat 101 | 102 | (* Command pattern helper contructors *) 103 | let cmd_pat c vs k = Pattern.cpat (Pattern.request c ~pats:vs k) 104 | 105 | (* Value helper constructors *) 106 | let ival iv = Mcvalue_ivalue iv 107 | let bool_val b = ival (Mivalue_bool b) 108 | let ctr_val k vs = Mcvalue_ctr (k, vs) 109 | let id_val id = ival (Mivalue_var id) 110 | let int_val n = ival (Mivalue_int n) 111 | let float_val f = ival (Mivalue_float f) 112 | let str_val s = ival (Mivalue_str s) 113 | 114 | let ret es v = TypExp.returner v ~effs:es () 115 | let rtvar v = TypExp.fresh_rigid_tvar v 116 | let datatype = TypExp.datatype 117 | let effin ei ps = TypExp.effin ei ~params:ps () 118 | let oes = TypExp.effect_var_set 119 | let ces = TypExp.closed_effect_set 120 | 121 | let make_iexp n = Mccomp_cvalue (Mcvalue_ivalue (Mivalue_int n)) 122 | 123 | (* Helper constructors for values. *) 124 | let make_cons x xs = ctr_val "Cons" [x; xs] 125 | let make_nil () = ctr_val "Nil" [] 126 | let make_unit () = ctr_val "Unit" [] 127 | let make_one () = make_cons (make_unit ()) (make_nil ()) 128 | 129 | let ps = 130 | [int_pat 1; 131 | bool_pat false; 132 | str_pat "Hello"; 133 | var_pat "x"; 134 | ctr_pat "Cons" [any_vpat (); var_vpat "xs"]; 135 | float_pat 1.2; 136 | any_pat ()] 137 | 138 | let vs = 139 | [int_val 1; 140 | bool_val false; 141 | str_val "Hello"; 142 | id_val "y"; 143 | ctr_val "Cons" [id_val "x"; ctr_val "Cons" [id_val "y"; id_val "ys"]]; 144 | float_val 1.2; 145 | ctr_val "Unit" []] 146 | 147 | let pa = 148 | [([ctr_pat "Nil" []; any_pat ()], make_iexp 1); 149 | ([any_pat (); ctr_pat "Nil" []], make_iexp 2); 150 | ([ctr_pat "Cons" [any_vpat (); var_vpat "xs"]; 151 | ctr_pat "Cons" [any_vpat (); var_vpat "ys"]], make_iexp 3)] 152 | 153 | let tsPA = [ret oes (datatype "List" [rtvar "x"]); 154 | ret oes (datatype "List" [rtvar "x"])] 155 | 156 | let div = 157 | [([var_pat "x"; int_pat 0], make_iexp 1); 158 | ([var_pat "x"; var_pat "y"], make_iexp 2)] 159 | 160 | let run_test p v = 161 | let msg = ShowPattern.show p ^ " <= " ^ ShowMidCValue.show v in 162 | print_endline (msg ^ " = " ^ (string_of_bool (is_inst p v))) 163 | 164 | let run_match_test (km, m) (kvs, vs) = 165 | let msg = "matches " ^ kvs ^ " " ^ km ^ " = " in 166 | let res = matches vs m in 167 | print_endline (msg ^ Show.show res) 168 | 169 | let gen_tests () = 170 | let vs1 = [make_nil (); make_one ()] in 171 | let vs2 = [make_one (); make_nil ()] in 172 | let vs3 = [make_one (); make_one ()] in 173 | [("vs1", vs1); ("vs2", vs2); ("vs3", vs3)] 174 | 175 | let get_typing_env (name, prog) = 176 | let st = Stream.of_string prog in 177 | let buf = preprocess_lines st in 178 | let lexbuf = Lexing.from_string buf in 179 | let () = lexbuf.lex_curr_p <- { 180 | lexbuf.lex_curr_p with pos_fname = name 181 | } in 182 | let (mtree, hmap, ctrs, cmds) = parse_file lexbuf in 183 | let (_, env) = type_with_error mtree in 184 | env 185 | 186 | let test_list = 187 | String.concat "" 188 | ["data List x = Nil : List x | Cons : x -> List x -> List x\n"; 189 | "main : Int\n"; 190 | "main = 0\n"] 191 | 192 | let ctr_test = 193 | String.concat "" 194 | ["data List x = Nil : List x | Cons : x -> List x -> List x\n"; 195 | "simple : List Int -> Int\n"; 196 | "simple (Cons x xs) = 1\n"; 197 | "simple Nil = 0\n"; 198 | "main : Int\n"; 199 | "main = 0\n"] 200 | 201 | let ctr_cs = map return [VCon ("Cons", [VInt 1; VCon ("Nil", [])])] 202 | 203 | let ctr_ts = 204 | let tvs = datatype "List" [TypExp.int ()] in 205 | [ret ces tvs] 206 | 207 | let ctr_matrix = 208 | [([ctr_pat "Cons" [var_vpat "x"; var_vpat "xs"]], make_iexp 1); 209 | ([ctr_pat "Nil" []], make_iexp 0)] 210 | 211 | (* This test demonstrates compilation of constructor patterns. *) 212 | 213 | let get_ctr_test () = 214 | ("ctr_test", ctr_test, ctr_cs, ctr_ts, ctr_matrix) 215 | 216 | let closed_test = 217 | String.concat "" 218 | ["data List x = Nil : List x | Cons : x -> List x -> List x\n"; 219 | "interface OneCmd = oc1 : Unit\n"; 220 | "interface TwoCmd = tc1 : Unit | tc2 : Unit\n"; 221 | "simple : [OneCmd, TwoCmd]List Int -> Int\n"; 222 | "simple [oc1 -> k] = 1\n"; 223 | "simple [tc1 -> k] = 2\n"; 224 | "simple [tc2 -> k] = 3\n"; 225 | "simple (Cons x xs) = 4\n"; 226 | "simple Nil = 0\n"; 227 | "main : Int\n"; 228 | "main = 0\n"] 229 | 230 | let closed_cs = [command "tc1" []] 231 | 232 | let closed_ts = 233 | let ocmd = effin "OneCmd" [] in 234 | let tcmd = effin "TwoCmd" [] in 235 | let tvs = datatype "List" [TypExp.int ()] in 236 | [ret (ces ++ [ocmd;tcmd]) tvs] 237 | 238 | let closed_matrix = 239 | [([cmd_pat "oc1" [] "k"], make_iexp 1); 240 | ([cmd_pat "tc1" [] "k"], make_iexp 2); 241 | ([cmd_pat "tc2" [] "k"], make_iexp 3); 242 | ([ctr_pat "Cons" [var_vpat "x"; var_vpat "xs"]], make_iexp 4); 243 | ([ctr_pat "Nil" []], make_iexp 0)] 244 | 245 | (* This test demonstrates compilation of closed effect sets. *) 246 | 247 | let get_closed_test () = 248 | ("closed_test", closed_test, closed_cs, closed_ts, closed_matrix) 249 | 250 | let simple_test = 251 | String.concat "" 252 | ["data ThreeVs = One : ThreeVs | Two : ThreeVs | Three : ThreeVs\n"; 253 | "interface OneCmd = oc1 : Unit\n"; 254 | "interface TwoCmd = tc1 : Unit | tc2 : Unit\n"; 255 | "simple : [OneCmd, TwoCmd]ThreeVs -> Int\n"; 256 | "simple [oc1 -> k] = 1\n"; 257 | "simple [tc2 -> k] = 2\n"; 258 | "simple x = 0\n"; 259 | "main : Int\n"; 260 | "main = 0\n"] 261 | 262 | let simple_ts = 263 | let ocmd = effin "OneCmd" [] in 264 | let tcmd = effin "TwoCmd" [] in 265 | let tvs = datatype "ThreeVs" [] in 266 | [ret (oes ++ [ocmd;tcmd]) tvs] 267 | 268 | let simple_matrix = 269 | [([cmd_pat "oc1" [] "k"], make_iexp 1); 270 | ([cmd_pat "tc2" [] "k"], make_iexp 2); 271 | ([var_pat "x"], make_iexp 0)] 272 | 273 | (* This test demonstrates an unhandled command tc1. *) 274 | 275 | let get_simple_test () = 276 | ("simple_test", simple_test, [], simple_ts, simple_matrix) 277 | 278 | (* This test demonstrates ignoring the entire computation. It demonstrates 279 | the requirement of a default case. *) 280 | 281 | let ignore_test = 282 | String.concat "" 283 | ["data ThreeVs = One : ThreeVs | Two : ThreeVs | Three : ThreeVs\n"; 284 | "interface OneCmd = oc1 : Unit\n"; 285 | "interface TwoCmd = tc1 : Unit | tc2 : Unit\n"; 286 | "simple : [OneCmd, TwoCmd]ThreeVs -> Int\n"; 287 | "simple x = 0\n"; 288 | "simple [t] = 1\n"; 289 | "main : Int\n"; 290 | "main = 0\n"] 291 | 292 | let ignore_ts = simple_ts 293 | 294 | let ignore_matrix = 295 | [([var_pat "x"], make_iexp 0); 296 | ([thunk_pat "t"], make_iexp 1)] 297 | 298 | let get_ignore_test () = 299 | ("ignore_test", ignore_test, [], ignore_ts, ignore_matrix) 300 | 301 | let run_test (n, test, cs, ts, matrix) = 302 | print_endline ("\n\n----\nRunning " ^ n ^ "\n----"); 303 | let env = get_typing_env (n, test) in 304 | let tree = compile env ts matrix in 305 | let c = eval_dtree ENV.empty cs tree in 306 | print_endline (Show.show tree); 307 | print_endline ("eval_dtree EMPTY cs tree = " ^ (show c)); 308 | print_endline ("----\nFinished " ^ n ^ "\n----") 309 | 310 | let main = 311 | let env = get_typing_env ("test_list", test_list) in 312 | let t1 = TypeSigSet.singleton TSAmbientCmds in 313 | let t2 = TypeSigSet.singleton (TSAllValues None) in 314 | let b = TypeSigSet.is_ambient t1 in 315 | print_endline ("Test is_ambient ... " ^ (string_of_bool b)); 316 | let b = TypeSigSet.is_ambient (TypeSigSet.union t1 t2) in 317 | print_endline ("Test is_ambient ... " ^ (string_of_bool b)); 318 | print_endline (Show.show (env_lookup "List" env)); 319 | (* let tree = compile env tsPA pa in *) 320 | (* print_endline (Show.show tree) *) 321 | (* run_test (get_ctr_test ()); *) 322 | run_test (get_closed_test ()); 323 | (* run_test (get_simple_test ()); *) 324 | (* run_test (get_ignore_test ()) *) 325 | -------------------------------------------------------------------------------- /parsing/errorHandling.ml: -------------------------------------------------------------------------------- 1 | (*********************************************************************** 2 | * Error handling for parsing of the Frank source language. 3 | * 4 | * Created by Craig McLaughlin on 20/7/2015. 5 | *********************************************************************** 6 | *) 7 | 8 | exception SyntaxError of string 9 | -------------------------------------------------------------------------------- /parsing/errorHandling.mli: -------------------------------------------------------------------------------- 1 | (*********************************************************************** 2 | * Error handling for parsing of the Frank source language. 3 | * 4 | * Created by Craig McLaughlin on 20/7/2015. 5 | *********************************************************************** 6 | *) 7 | 8 | exception SyntaxError of string 9 | -------------------------------------------------------------------------------- /parsing/lexer.mll: -------------------------------------------------------------------------------- 1 | (*********************************************************************** 2 | * Lexer for Frank source language. 3 | * 4 | * Created by Craig McLaughlin on 1/6/2015. 5 | *********************************************************************** 6 | *) 7 | 8 | { 9 | open Lexing 10 | open Parser 11 | open ErrorHandling 12 | 13 | let comment_depth = ref 0 14 | 15 | } 16 | 17 | let int = '-'? ['0'-'9']+ 18 | let float = '-'? ['0'-'9']* '.' ['0'-'9']+ 19 | let white = [' ' '\t']+ 20 | let newline = '\r' | '\n' | "\r\n" 21 | let alpha = ['a'-'z' 'A'-'Z' '_'] 22 | let uppercase = ['A'-'Z'] 23 | let alphanumeric = alpha | ['0'-'9'] 24 | let id = alpha (alphanumeric | ['\''])* 25 | 26 | rule token = parse 27 | | white { token lexbuf } 28 | | newline { new_line lexbuf; token lexbuf } 29 | | int { INTLIT (int_of_string (Lexing.lexeme lexbuf)) } 30 | | float { FLOATLIT (float_of_string (Lexing.lexeme lexbuf)) } 31 | | "!" { BANG } 32 | | "data" { DATA } 33 | | "interface" { INTERFACE } 34 | | "true" { TRUE } 35 | | "false" { FALSE } 36 | | "let" { LET } 37 | | "in" { IN } 38 | | '{' { LBRACE } 39 | | "{-" { comment_depth := !comment_depth + 1; comment lexbuf } 40 | | '[' { LBRACKET } 41 | | '(' { LPAREN } 42 | | '}' { RBRACE } 43 | | ']' { RBRACKET } 44 | | ')' { RPAREN } 45 | | ':' { COLON } 46 | | '=' { EQUAL } 47 | | '|' { BAR } 48 | | "->" { RARROW } 49 | | '.' { DOT } 50 | | ',' { COMMA } 51 | | '"' { read_string (Buffer.create 20) lexbuf } 52 | | '_' { UNDERSCORE } 53 | | uppercase alphanumeric* { UID (Lexing.lexeme lexbuf) } 54 | | id { ID (Lexing.lexeme lexbuf) } 55 | | _ { raise (SyntaxError ("Unexpected character: " ^ 56 | Lexing.lexeme lexbuf)) } 57 | | eof { EOF } 58 | 59 | and comment = parse 60 | | "{-" { comment_depth := !comment_depth + 1; comment lexbuf } 61 | | "-}" { comment_depth := !comment_depth - 1; 62 | if !comment_depth == 0 then token lexbuf else comment lexbuf } 63 | | newline { new_line lexbuf; comment lexbuf } 64 | | _ { comment lexbuf } 65 | | eof { raise (SyntaxError ("Comment not terminated.")) } 66 | 67 | and read_string buf = parse 68 | | '"' { STRLIT (Buffer.contents buf) } 69 | | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf } 70 | | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf } 71 | | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf } 72 | | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf } 73 | | [^ '"' '\\']+ { Buffer.add_string buf (Lexing.lexeme lexbuf); 74 | read_string buf lexbuf } 75 | | _ { raise (SyntaxError ("Illegal string character " ^ 76 | Lexing.lexeme lexbuf)) } 77 | | eof { raise (SyntaxError ("Non-terminating string")) } 78 | -------------------------------------------------------------------------------- /parsing/parseTree.ml: -------------------------------------------------------------------------------- 1 | open Show 2 | open ListUtils 3 | open Utility 4 | 5 | type prog = term list 6 | 7 | and term = 8 | | Sterm_datatype of datatype_declaration 9 | | Sterm_effin of effect_interface 10 | | Sterm_vdecl of value_declaration 11 | | Sterm_vdefn of value_definition 12 | 13 | and checkable_computation = 14 | | CComp_cvalue of checkable_value 15 | | CComp_hdr_clause of pattern list * checkable_computation 16 | | CComp_compose of checkable_computation list 17 | 18 | and checkable_value = 19 | | CValue_ivalue of inferable_value 20 | | CValue_ctr of string * checkable_value list 21 | | CValue_thunk of checkable_computation 22 | 23 | and inferable_value = 24 | | IValue_ident of string 25 | (** Could be a monovar, polyvar or effect signature. *) 26 | | IValue_int of int 27 | | IValue_float of float 28 | | IValue_bool of bool 29 | | IValue_str of string 30 | (** Int/Bool/String literals *) 31 | | IValue_icomp of inferable_computation 32 | 33 | and inferable_computation = 34 | | IComp_app of inferable_value * checkable_computation list 35 | | IComp_let of string * checkable_computation * checkable_computation 36 | 37 | and pattern = 38 | { 39 | spat_desc : pattern_desc; 40 | } 41 | 42 | and pattern_desc = 43 | | Spat_value of value_pattern 44 | | Spat_comp of computation_pattern 45 | | Spat_any (* [_] *) 46 | | Spat_thunk of string (* [t] for string t *) 47 | 48 | and computation_pattern = 49 | | Scpat_request of string * value_pattern list * string 50 | 51 | and value_pattern = 52 | | Svpat_any (* _ *) 53 | | Svpat_var of string 54 | | Svpat_int of int 55 | | Svpat_float of float 56 | | Svpat_bool of bool 57 | | Svpat_str of string 58 | (** Int/Bool/String literals *) 59 | | Svpat_ctr of string * value_pattern list 60 | 61 | and value_definition = 62 | { 63 | vdef_name : string; 64 | vdef_args : pattern list; 65 | vdef_comp : checkable_computation; 66 | } 67 | 68 | and datatype_declaration = 69 | { 70 | sdt_name : string; 71 | sdt_parameters : src_type list; 72 | sdt_constructors : constructor_declaration list; 73 | } 74 | 75 | and constructor_declaration = 76 | { 77 | sctr_name : string; 78 | sctr_args : src_type list; 79 | sctr_res : src_type 80 | } 81 | 82 | and effect_interface = 83 | { 84 | sei_name : string; 85 | sei_parameters: src_type list; 86 | sei_commands : command_declaration list 87 | } 88 | 89 | and command_declaration = 90 | { 91 | scmd_name : string; 92 | scmd_args : src_type list; 93 | scmd_res : src_type 94 | } 95 | 96 | and value_declaration = 97 | { 98 | svdecl_name : string; 99 | svdecl_type : src_type; 100 | } 101 | 102 | and src_type = 103 | { 104 | styp_desc : src_type_desc 105 | } 106 | 107 | and src_type_desc = 108 | (* Values *) 109 | | Styp_datatype of string * src_type list 110 | | Styp_thunk of src_type 111 | | Styp_tvar of string (* user generated type variable *) 112 | | Styp_rtvar of src_tvar (* rigid (i.e. desugared user generated) type 113 | variable *) 114 | | Styp_ftvar of src_tvar (* flexible (i.e. unification generated) type 115 | variable *) 116 | | Styp_eff_set of src_type list (* set of effects: used for unifying 117 | flexible effect sets *) 118 | | Styp_ref of (src_type Unionfind.point) 119 | (** Unification variable *) 120 | (* Computations *) 121 | | Styp_comp of src_type list * src_type 122 | (* Returners *) 123 | | Styp_ret of src_type list * src_type 124 | (* Effect interfaces *) 125 | | Styp_effin of string * src_type list 126 | (* Builtin types *) 127 | | Styp_bool 128 | | Styp_int 129 | | Styp_float 130 | | Styp_str 131 | 132 | and src_tvar = string * int 133 | deriving (Show) 134 | 135 | let string_of_args sep ?(bbegin = true) ?(endd = false) f xs = match xs with 136 | | [] -> "" 137 | | xs -> (if bbegin then sep else "") 138 | ^ (String.concat sep (List.map f xs)) ^ 139 | (if endd then sep else "") 140 | 141 | let unbox t = 142 | match t.styp_desc with 143 | | Styp_ref pt -> Unionfind.find pt 144 | | _ -> t 145 | 146 | let rec compare x y = 147 | let f acc x y = 148 | if acc != 0 then acc 149 | else compare x y in 150 | match (unbox x).styp_desc , (unbox y).styp_desc with 151 | | Styp_datatype (d, ps) , Styp_datatype (d', ps') 152 | -> let cmp = String.compare d d' in 153 | let cmp' = Pervasives.compare (length ps) (length ps') in 154 | if cmp != 0 then cmp 155 | else if cmp' != 0 then cmp' 156 | else foldl (uncurry @ f) 0 (zip ps ps') 157 | | Styp_datatype _ , _ -> 1 158 | | _ , Styp_datatype _ -> -1 159 | 160 | | Styp_thunk c, Styp_thunk c' -> compare c c' 161 | | Styp_thunk _, _ -> 1 162 | | _ , Styp_thunk _ -> -1 163 | 164 | | Styp_tvar v, Styp_tvar v' -> String.compare v v' 165 | | Styp_tvar _, _ -> 1 166 | | _ , Styp_tvar _ -> -1 167 | 168 | | Styp_rtvar (_, n), Styp_rtvar (_, n') -> Pervasives.compare n n' 169 | | Styp_rtvar _, _ -> 1 170 | | _ , Styp_rtvar _ -> -1 171 | 172 | | Styp_ftvar (_, n), Styp_ftvar (_, n') -> Pervasives.compare n n' 173 | | Styp_ftvar _, _ -> 1 174 | | _ , Styp_ftvar _ -> -1 175 | 176 | | Styp_eff_set es, Styp_eff_set es' 177 | -> let cmp = Pervasives.compare (length es) (length es') in 178 | if cmp != 0 then cmp 179 | else foldl (uncurry @ f) 0 (zip es es') 180 | | Styp_eff_set _, _ -> 1 181 | | _ , Styp_eff_set _ -> -1 182 | 183 | | Styp_ref pt , Styp_ref pt' 184 | -> compare (Unionfind.find pt) (Unionfind.find pt) 185 | | Styp_ref pt , _ -> compare (Unionfind.find pt) y 186 | | _ , Styp_ref pt -> compare x (Unionfind.find pt) 187 | 188 | | Styp_comp (ts, t), Styp_comp (ts', t') 189 | -> let cmp = compare t t' in 190 | let cmp' = Pervasives.compare (length ts) (length ts') in 191 | if cmp != 0 then cmp 192 | else if cmp' != 0 then cmp' 193 | else foldl (uncurry @ f) 0 (zip ts ts') 194 | | Styp_comp _ , _ -> 1 195 | | _ , Styp_comp _ -> -1 196 | 197 | | Styp_ret (ts, t) , Styp_ret (ts', t') 198 | -> let cmp = compare t t' in 199 | let cmp' = Pervasives.compare (length ts) (length ts') in 200 | if cmp != 0 then cmp 201 | else if cmp' != 0 then cmp' 202 | else foldl (uncurry @ f) 0 (zip ts ts') 203 | | Styp_ret _ , _ -> 1 204 | | _ , Styp_ret _ -> -1 205 | 206 | | Styp_effin (ei, ts), Styp_effin (ei', ts') 207 | -> let cmp = String.compare ei ei' in 208 | let cmp' = Pervasives.compare (length ts) (length ts') in 209 | if cmp != 0 then cmp 210 | else if cmp' != 0 then cmp' 211 | else foldl (uncurry @ f) 0 (zip ts ts') 212 | | Styp_effin _ , _ -> 1 213 | | _ , Styp_effin _ -> -1 214 | 215 | | Styp_bool , Styp_bool -> 0 216 | | Styp_bool , _ -> 1 217 | | _ , Styp_bool -> -1 218 | 219 | | Styp_int , Styp_int -> 0 220 | | Styp_int , _ -> 1 221 | | _ , Styp_int -> -1 222 | 223 | | Styp_float , Styp_float -> 0 224 | | Styp_float , _ -> 1 225 | | _ , Styp_float -> -1 226 | 227 | | Styp_str , Styp_str -> 0 228 | 229 | 230 | (** Show functions *) 231 | module ShowPattern : SHOW with type t = pattern = struct 232 | type t = pattern 233 | let rec show p = match p.spat_desc with 234 | | Spat_comp cp -> cshow cp 235 | | Spat_value vp -> vshow vp 236 | | Spat_any -> "[_]" 237 | | Spat_thunk thk -> "[" ^ thk ^ "]" 238 | 239 | and cshow cp = 240 | match cp with 241 | | Scpat_request (c, ps, k) 242 | -> "[" ^ c ^ (string_of_args " " vshow ps) ^ " -> " ^ k ^ "]" 243 | 244 | and vshow vp = 245 | match vp with 246 | | Svpat_any -> "_" 247 | | Svpat_var v -> v 248 | | Svpat_int n -> string_of_int n 249 | | Svpat_float f -> string_of_float f 250 | | Svpat_bool b -> string_of_bool b 251 | | Svpat_str s -> "\"" ^ (String.escaped s) ^ "\"" 252 | | Svpat_ctr (k, ps) 253 | -> "(" ^ k ^ (string_of_args " " vshow ps) ^ ")" 254 | end 255 | 256 | module rec ShowSrcType : SHOW with type t = src_type = struct 257 | type t = src_type 258 | let rec show typ = match typ.styp_desc with 259 | | Styp_tvar v -> v 260 | | Styp_rtvar (v,n) -> "r?" ^ v ^ (string_of_int n) 261 | | Styp_ftvar (v,n) -> "f?" ^ v ^ (string_of_int n) 262 | | Styp_eff_set es -> "[" ^ String.concat ", " (List.map show es) ^ "]" 263 | | Styp_bool -> "Bool" 264 | | Styp_comp (args, res) 265 | -> "#" ^ (string_of_args " -> " ~bbegin:false ~endd:true show args) ^ 266 | show res ^ "#" 267 | | Styp_datatype (k, ts) 268 | -> "(" ^ k ^ string_of_args " " show ts ^ ")" 269 | | Styp_effin (s, ts) 270 | -> s ^ " " ^ (String.concat " " (List.map show ts)) 271 | | Styp_int -> "Int" 272 | | Styp_float -> "Float" 273 | | Styp_ret (effs, res) 274 | -> "[" ^ (String.concat ", " (List.map show effs)) ^ "]" ^ (show res) 275 | | Styp_thunk c -> "{" ^ show c ^ "}" 276 | | Styp_ref t -> "|" ^ show (Unionfind.find t) ^ "|" 277 | | Styp_str -> "String" 278 | end 279 | 280 | and ShowDatatype : SHOW with type t = datatype_declaration = struct 281 | type t = datatype_declaration 282 | let show dt = 283 | "data " ^ dt.sdt_name ^ " " ^ 284 | (String.concat " " (List.map ShowSrcType.show dt.sdt_parameters)) ^ 285 | " = " ^ 286 | (String.concat "\n\t| " (List.map ShowCtr.show dt.sdt_constructors)) ^ 287 | "\n" 288 | end 289 | 290 | and ShowCtr : SHOW with type t = constructor_declaration = struct 291 | type t = constructor_declaration 292 | let show ctr = 293 | ctr.sctr_name ^ " : " ^ 294 | (match ctr.sctr_args with 295 | | [] -> "" 296 | | xs -> (String.concat " -> " (List.map ShowSrcType.show xs)) ^ " -> ") 297 | ^ (ShowSrcType.show ctr.sctr_res) 298 | end 299 | 300 | and ShowEffin : SHOW with type t = effect_interface = struct 301 | type t = effect_interface 302 | let show ei = 303 | "interface " ^ ei.sei_name ^ " " ^ 304 | (String.concat " " (List.map ShowSrcType.show ei.sei_parameters)) ^ 305 | " = " ^ 306 | (String.concat "\n\t| " (List.map ShowCmd.show ei.sei_commands)) ^ 307 | "\n" 308 | end 309 | 310 | and ShowCmd : SHOW with type t = command_declaration = struct 311 | type t = command_declaration 312 | let show cmd = 313 | cmd.scmd_name ^ " : " ^ 314 | (match cmd.scmd_args with 315 | | [] -> "" 316 | | xs -> (String.concat " -> " (List.map ShowSrcType.show xs)) ^ " -> ") 317 | ^ (ShowSrcType.show cmd.scmd_res) 318 | end 319 | -------------------------------------------------------------------------------- /parsing/parseTree.mli: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | (*********************************************************************** 3 | * Untyped Abstract Syntax Tree for the Frank source language. 4 | * 5 | * 6 | * Created by Craig McLaughlin on 30/06/2015. 7 | *********************************************************************** 8 | *) 9 | 10 | open Show 11 | 12 | type prog = term list 13 | 14 | and term = 15 | | Sterm_datatype of datatype_declaration 16 | | Sterm_effin of effect_interface 17 | | Sterm_vdecl of value_declaration 18 | | Sterm_vdefn of value_definition 19 | 20 | and checkable_computation = 21 | | CComp_cvalue of checkable_value 22 | | CComp_hdr_clause of pattern list * checkable_computation 23 | | CComp_compose of checkable_computation list 24 | 25 | and checkable_value = 26 | | CValue_ivalue of inferable_value 27 | | CValue_ctr of string * checkable_value list 28 | | CValue_thunk of checkable_computation 29 | 30 | and inferable_value = 31 | | IValue_ident of string 32 | (** Could be a monovar, polyvar or command. *) 33 | | IValue_int of int 34 | | IValue_float of float 35 | | IValue_bool of bool 36 | | IValue_str of string 37 | (** Int/Bool literals *) 38 | | IValue_icomp of inferable_computation 39 | 40 | and inferable_computation = 41 | | IComp_app of inferable_value * checkable_computation list 42 | | IComp_let of string * checkable_computation * checkable_computation 43 | 44 | and pattern = 45 | { 46 | spat_desc : pattern_desc; 47 | } 48 | 49 | and pattern_desc = 50 | | Spat_value of value_pattern 51 | | Spat_comp of computation_pattern 52 | | Spat_any (* [_] *) 53 | | Spat_thunk of string (* [t] for string t *) 54 | 55 | and computation_pattern = 56 | | Scpat_request of string * value_pattern list * string 57 | 58 | and value_pattern = 59 | | Svpat_any (* _ *) 60 | | Svpat_var of string 61 | | Svpat_int of int 62 | | Svpat_float of float 63 | | Svpat_bool of bool 64 | | Svpat_str of string 65 | (** Int/Bool/String literals *) 66 | | Svpat_ctr of string * value_pattern list 67 | 68 | and value_definition = 69 | { 70 | vdef_name : string; 71 | vdef_args : pattern list; 72 | vdef_comp : checkable_computation; 73 | } 74 | 75 | and datatype_declaration = 76 | { 77 | sdt_name : string; 78 | sdt_parameters : src_type list; 79 | sdt_constructors : constructor_declaration list; 80 | } 81 | 82 | and constructor_declaration = 83 | { 84 | sctr_name : string; 85 | sctr_args : src_type list; 86 | sctr_res : src_type 87 | } 88 | 89 | and effect_interface = 90 | { 91 | sei_name : string; 92 | sei_parameters: src_type list; 93 | sei_commands : command_declaration list 94 | } 95 | 96 | and command_declaration = 97 | { 98 | scmd_name : string; 99 | scmd_args : src_type list; 100 | scmd_res : src_type 101 | } 102 | 103 | and value_declaration = 104 | { 105 | svdecl_name : string; 106 | svdecl_type : src_type; 107 | } 108 | 109 | and src_type = 110 | { 111 | styp_desc : src_type_desc 112 | } 113 | 114 | and src_type_desc = 115 | (* Values *) 116 | | Styp_datatype of string * src_type list 117 | | Styp_thunk of src_type 118 | | Styp_tvar of string (* user generated type variable *) 119 | | Styp_rtvar of src_tvar (* rigid (i.e. desugared user generated) type 120 | variable *) 121 | | Styp_ftvar of src_tvar (* flexible (i.e. unification generated) type 122 | variable *) 123 | | Styp_eff_set of src_type list (* set of effects: used for unifying 124 | flexible effect sets *) 125 | | Styp_ref of (src_type Unionfind.point) 126 | (** Unification variable *) 127 | (* Computations *) 128 | | Styp_comp of src_type list * src_type 129 | (* Returners *) 130 | | Styp_ret of src_type list * src_type 131 | (* Effect interfaces *) 132 | | Styp_effin of string * src_type list 133 | (* Builtin types *) 134 | | Styp_bool 135 | | Styp_int 136 | | Styp_float 137 | | Styp_str 138 | 139 | and src_tvar = string * int 140 | deriving (Show) 141 | 142 | (** Show functions *) 143 | val string_of_args : string -> ?bbegin:bool -> ?endd:bool -> 144 | ('a -> string) -> 'a list -> string 145 | 146 | (* Extract underlying type from reference. *) 147 | val unbox : src_type -> src_type 148 | 149 | val compare : src_type -> src_type -> int 150 | (** Comparison function for types conforming to the return semantics of 151 | [Pervasives.compare]. *) 152 | 153 | module ShowPattern : SHOW with type t = pattern 154 | 155 | module ShowSrcType : SHOW with type t = src_type 156 | 157 | module ShowDatatype : SHOW with type t = datatype_declaration 158 | 159 | module ShowEffin : SHOW with type t = effect_interface 160 | -------------------------------------------------------------------------------- /parsing/parseTreeBuilder.ml: -------------------------------------------------------------------------------- 1 | (*********************************************************************** 2 | * Collection of helper functions to construct components of the 3 | * parse tree (untyped AST). Inspired by the frontend design of the 4 | * OCaml compiler. 5 | * 6 | * 7 | * Created by Craig McLaughlin on 03/07/2015. 8 | *********************************************************************** 9 | *) 10 | 11 | open ParseTree 12 | 13 | module Term = struct 14 | let datatype dtd = Sterm_datatype dtd 15 | let value_decl vdecl = Sterm_vdecl vdecl 16 | let value_defn vdefn = Sterm_vdefn vdefn 17 | let effect_in effin = Sterm_effin effin 18 | end 19 | 20 | module Datatype = struct 21 | let mk name ?(params = []) ?(ctrs = []) () = 22 | { 23 | sdt_name = name; 24 | sdt_parameters = params; 25 | sdt_constructors = ctrs 26 | } 27 | 28 | let constr_decl name ?(args = []) res = 29 | { 30 | sctr_name = name; 31 | sctr_args = args; 32 | sctr_res = res 33 | } 34 | end 35 | 36 | module CComputation = struct 37 | let cvalue cval = CComp_cvalue cval 38 | 39 | let clause pats comp = CComp_hdr_clause (pats, comp) 40 | 41 | let compose clauses = CComp_compose (clauses) 42 | end 43 | 44 | module CValue = struct 45 | let ivalue ival = CValue_ivalue ival 46 | 47 | let sus_comp scomp = CValue_thunk scomp 48 | 49 | let ctr name args = CValue_ctr (name, args) 50 | end 51 | 52 | module IValue = struct 53 | let ident name = IValue_ident name 54 | 55 | let integer n = IValue_int n 56 | 57 | let float f = IValue_float f 58 | 59 | let boolean b = IValue_bool b 60 | 61 | let str s = IValue_str s 62 | 63 | let icomp ic = IValue_icomp ic 64 | end 65 | 66 | module IComp = struct 67 | let app func ?(args = []) () = IComp_app (func, args) 68 | let let_binding x cv ic = IComp_let (x, cv, ic) 69 | end 70 | 71 | module EffInterface = struct 72 | let mk name ?(params = []) ?(cmds = []) () = 73 | { 74 | sei_name = name; 75 | sei_parameters = params; 76 | sei_commands = cmds 77 | } 78 | 79 | let cmd_decl name ?(args = []) res = 80 | { 81 | scmd_name = name; 82 | scmd_args = args; 83 | scmd_res = res 84 | } 85 | end 86 | 87 | module ValueDecl = struct 88 | let mk name stype = { svdecl_name = name; svdecl_type = stype } 89 | end 90 | 91 | module TypExp = struct 92 | let mk d = { styp_desc = d } 93 | 94 | let type_variable_counter = ref 0 95 | let fresh_tvar () = incr type_variable_counter; !type_variable_counter 96 | 97 | let tvar name = mk (Styp_tvar name) 98 | let fresh_rigid_tvar name = 99 | let n = fresh_tvar () in mk (Styp_rtvar (name, n)) 100 | let fresh_flexi_tvar name = 101 | let n = fresh_tvar () in mk (Styp_ftvar (name, n)) 102 | 103 | let datatype name ts = mk (Styp_datatype (name, ts)) 104 | let sus_comp typ_exp = mk (Styp_thunk typ_exp) 105 | 106 | let comp ?(args = []) res = mk (Styp_comp (args,res)) 107 | 108 | let returner v ?(effs = []) () = mk (Styp_ret (effs,v)) 109 | 110 | let effin name ?(params = []) () = mk (Styp_effin (name, params)) 111 | 112 | let bool () = mk (Styp_bool) 113 | let int () = mk (Styp_int) 114 | let float () = mk (Styp_float) 115 | let str () = mk (Styp_str) 116 | 117 | (* The one and only effect variable with a special non-parsable name to 118 | avoid conflicts. *) 119 | let effect_var_set = [fresh_rigid_tvar "£"] 120 | let closed_effect_set = [fresh_rigid_tvar "@"] 121 | let eff_set xs = mk (Styp_eff_set xs) 122 | end 123 | 124 | module ValueDefn = struct 125 | let mk name ?(pats = []) ccomp = 126 | { 127 | vdef_name = name; 128 | vdef_args = pats; 129 | vdef_comp = ccomp 130 | } 131 | end 132 | 133 | module Pattern = struct 134 | let mk d = { spat_desc = d } 135 | 136 | let vpat vp = mk (Spat_value vp) 137 | let cpat cp = mk (Spat_comp cp) 138 | let any () = mk Spat_any 139 | let thunk thk = mk (Spat_thunk thk) 140 | 141 | let any_value () = Svpat_any 142 | let var name = Svpat_var name 143 | let integer n = Svpat_int n 144 | let float f = Svpat_float f 145 | let boolean b = Svpat_bool b 146 | let str s = Svpat_str s 147 | let ctr name ?(pats = []) () = Svpat_ctr (name, pats) 148 | 149 | let request name ?(pats = []) cont = Scpat_request (name, pats, cont) 150 | 151 | end 152 | -------------------------------------------------------------------------------- /parsing/parseTreeBuilder.mli: -------------------------------------------------------------------------------- 1 | (*********************************************************************** 2 | * Collection of helper functions to construct components of the 3 | * parse tree (untyped AST). Inspired by the frontend design of the 4 | * OCaml compiler. 5 | * 6 | * 7 | * Created by Craig McLaughlin on 30/06/2015. 8 | *********************************************************************** 9 | *) 10 | 11 | open ParseTree 12 | 13 | (** Terms *) 14 | module Term : 15 | sig 16 | val datatype : datatype_declaration -> term 17 | val effect_in : effect_interface -> term 18 | val value_decl : value_declaration -> term 19 | val value_defn : value_definition -> term 20 | end 21 | 22 | (** Checkable computations *) 23 | module CComputation : 24 | sig 25 | val cvalue : checkable_value -> checkable_computation 26 | val clause : pattern list -> checkable_computation -> 27 | checkable_computation 28 | val compose : checkable_computation list -> checkable_computation 29 | (** Compose a (possible empty) list of clauses. *) 30 | end 31 | 32 | (** Checkable values *) 33 | module CValue : 34 | sig 35 | val ivalue : inferable_value -> checkable_value 36 | val sus_comp : checkable_computation -> checkable_value 37 | val ctr : string -> checkable_value list -> checkable_value 38 | end 39 | 40 | (** Inferable values *) 41 | module IValue : 42 | sig 43 | val ident : string -> inferable_value 44 | val integer : int -> inferable_value 45 | val float : float -> inferable_value 46 | val boolean : bool -> inferable_value 47 | val str : string -> inferable_value 48 | val icomp : inferable_computation -> inferable_value 49 | end 50 | 51 | (** Inferable computation *) 52 | module IComp : 53 | sig 54 | val app : inferable_value -> ?args:checkable_computation list -> unit -> 55 | inferable_computation 56 | val let_binding : string -> checkable_computation -> 57 | checkable_computation -> inferable_computation 58 | end 59 | 60 | (** Datatype declarations *) 61 | module Datatype : 62 | sig 63 | val mk : string -> ?params:src_type list -> 64 | ?ctrs:constructor_declaration list -> unit -> datatype_declaration 65 | 66 | val constr_decl : string -> ?args:src_type list -> src_type -> 67 | constructor_declaration 68 | end 69 | 70 | (** Effect interface *) 71 | module EffInterface : 72 | sig 73 | val mk : string -> ?params:src_type list -> 74 | ?cmds:command_declaration list -> unit -> effect_interface 75 | 76 | val cmd_decl : string -> ?args:src_type list -> src_type -> 77 | command_declaration 78 | end 79 | 80 | (** Value declarations *) 81 | module ValueDecl : 82 | sig 83 | val mk : string -> src_type -> value_declaration 84 | end 85 | 86 | (** Type expressions *) 87 | module TypExp : 88 | sig 89 | val mk : src_type_desc -> src_type 90 | 91 | (* Value type constructors *) 92 | val tvar : string -> src_type 93 | val fresh_rigid_tvar : string -> src_type 94 | val fresh_flexi_tvar : string -> src_type 95 | val datatype : string -> src_type list -> src_type 96 | val sus_comp : src_type -> src_type 97 | 98 | val comp : ?args:src_type list -> src_type -> src_type 99 | (** Construct a computation type. *) 100 | 101 | val returner : src_type -> ?effs:src_type list -> unit -> src_type 102 | (** Construct a returner type *) 103 | 104 | val effin : string -> ?params:src_type list -> unit -> src_type 105 | (** Construct an effect interface. *) 106 | 107 | val bool : unit -> src_type 108 | val int : unit -> src_type 109 | val float : unit -> src_type 110 | val str : unit -> src_type 111 | 112 | (* Effect sets *) 113 | val effect_var_set : src_type list 114 | val closed_effect_set : src_type list 115 | (* Wrapper over effect sets for unifying with flexible tvars. *) 116 | val eff_set : src_type list -> src_type 117 | end 118 | 119 | (** Value definitions *) 120 | module ValueDefn : 121 | sig 122 | val mk : string -> ?pats:pattern list -> checkable_computation -> 123 | value_definition 124 | end 125 | 126 | (** Patterns *) 127 | module Pattern : 128 | sig 129 | val mk : pattern_desc -> pattern 130 | 131 | val vpat : value_pattern -> pattern 132 | val cpat : computation_pattern -> pattern 133 | val any : unit -> pattern 134 | (** Unnamed thunk *) 135 | val thunk : string -> pattern 136 | (** Named thunk *) 137 | 138 | val any_value : unit -> value_pattern 139 | val var : string -> value_pattern 140 | val integer : int -> value_pattern 141 | val float : float -> value_pattern 142 | val boolean : bool -> value_pattern 143 | val str : string -> value_pattern 144 | val ctr : string -> ?pats:value_pattern list -> unit -> 145 | value_pattern 146 | 147 | val request : string -> ?pats:value_pattern list -> string -> 148 | computation_pattern 149 | end 150 | -------------------------------------------------------------------------------- /parsing/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | 3 | open ParseTree 4 | open ParseTreeBuilder 5 | open ErrorHandling 6 | 7 | %} 8 | 9 | %token BANG 10 | %token BAR 11 | %token COLON 12 | %token COMMA 13 | %token DATA 14 | %token DOT 15 | %token EOF 16 | %token EQUAL 17 | %token FALSE 18 | %token LET 19 | %token IN 20 | %token ID 21 | %token STRLIT 22 | %token INTERFACE 23 | %token INTLIT 24 | %token FLOATLIT 25 | %token RARROW 26 | %token LBRACE LBRACKET LPAREN 27 | %token RBRACE RBRACKET RPAREN 28 | %token TRUE 29 | %token UID 30 | %token UNDERSCORE 31 | 32 | %start program 33 | 34 | %% 35 | 36 | program: 37 | | list(term) EOF { $1 } 38 | ; 39 | 40 | term: 41 | | DATA UID opt_type_parameters EQUAL opt_constructor_decls DOT 42 | { Datatype.mk $2 ~params:$3 ~ctrs:$5 () |> Term.datatype } 43 | | ID COLON top_level_value_type DOT 44 | { ValueDecl.mk $1 $3 |> Term.value_decl } 45 | | INTERFACE ident opt_type_parameters EQUAL effect_commands DOT 46 | { EffInterface.mk $2 ~params:$3 ~cmds:$5 () |> Term.effect_in } 47 | | ID pattern* EQUAL pat_checkable_computation DOT 48 | { ValueDefn.mk $1 ~pats:$2 $4 |> Term.value_defn } 49 | ; 50 | 51 | ident: 52 | | ID { $1 } 53 | | UID { $1 } 54 | ; 55 | 56 | checkable_computation: 57 | | checkable_value { CComputation.cvalue $1 } 58 | | clauses = separated_list(BAR, pat_match_computation) 59 | { CComputation.compose clauses } 60 | ; 61 | 62 | pat_checkable_computation: 63 | | checkable_value { CComputation.cvalue $1 } 64 | (* | LPAREN *) 65 | (* clauses = separated_list(BAR, pat_match_computation) *) 66 | (* RPAREN *) 67 | (* { CComputation.compose clauses } *) 68 | ; 69 | 70 | pat_match_computation: 71 | | separated_nonempty_list(COMMA, pattern) RARROW 72 | pat_checkable_computation { CComputation.clause $1 $3 } 73 | ; 74 | 75 | (* We'd like like to do this if we could get rid of the reduce/reduce 76 | conflicts. *) 77 | (* pat_match_computation: *) 78 | (* | nonempty_list(pattern) RARROW *) 79 | (* pat_checkable_computation { CComputation.clause $1 $3 } *) 80 | (* ; *) 81 | 82 | paren_checkable_computation: 83 | | paren_checkable_value { CComputation.cvalue $1 } 84 | (* | LPAREN *) 85 | (* clauses = separated_list(BAR, pat_match_computation) *) 86 | (* RPAREN *) 87 | (* { CComputation.compose clauses } *) 88 | ; 89 | 90 | checkable_value: 91 | | inferable_value { CValue.ivalue $1 } 92 | | value_constructor { $1 } 93 | | suspended_computation { CValue.sus_comp $1 } 94 | ; 95 | 96 | paren_checkable_value: 97 | | paren_inferable_value { CValue.ivalue $1 } 98 | | paren_value_constructor { $1 } 99 | | suspended_computation { CValue.sus_comp $1 } 100 | ; 101 | 102 | inferable_value: 103 | | ID { IValue.ident $1 } 104 | | INTLIT { IValue.integer $1 } 105 | | FLOATLIT { IValue.float $1 } 106 | | STRLIT { IValue.str $1 } 107 | | TRUE { IValue.boolean true } 108 | | FALSE { IValue.boolean false } 109 | | inferable_computation { IValue.icomp $1 } 110 | ; 111 | 112 | paren_inferable_value: 113 | | ID { IValue.ident $1 } 114 | | INTLIT { IValue.integer $1 } 115 | | FLOATLIT { IValue.float $1 } 116 | | STRLIT { IValue.str $1 } 117 | | TRUE { IValue.boolean true } 118 | | FALSE { IValue.boolean false } 119 | | LPAREN inferable_computation RPAREN { IValue.icomp $2 } 120 | ; 121 | 122 | inferable_computation: 123 | | application { $1 } 124 | | let_binding { $1 } 125 | ; 126 | 127 | application: 128 | | paren_inferable_value BANG list(paren_checkable_computation) 129 | { IComp.app $1 ~args:$3 () } 130 | | paren_inferable_value nonempty_list(paren_checkable_computation) 131 | { IComp.app $1 ~args:$2 () } 132 | ; 133 | 134 | let_binding: 135 | | LET ID EQUAL pat_checkable_computation IN pat_checkable_computation 136 | { IComp.let_binding $2 $4 $6 } 137 | ; 138 | 139 | value_constructor: 140 | | UID paren_checkable_value* { CValue.ctr $1 $2 } 141 | ; 142 | 143 | paren_value_constructor: 144 | | UID { CValue.ctr $1 [] } 145 | | LPAREN value_constructor RPAREN { $2 } 146 | 147 | suspended_computation: 148 | | LBRACE checkable_computation RBRACE { $2 } 149 | ; 150 | 151 | pattern: 152 | | LPAREN pattern RPAREN { $2 } 153 | | value_pattern { Pattern.vpat $1 } 154 | | LBRACKET comp_pattern RBRACKET { Pattern.cpat $2 } 155 | | LBRACKET UNDERSCORE RBRACKET { Pattern.any () } 156 | | LBRACKET ID RBRACKET { Pattern.thunk $2 } 157 | ; 158 | 159 | value_pattern: 160 | | ID { Pattern.var $1 } 161 | | UID { Pattern.ctr $1 () } 162 | | INTLIT { Pattern.integer $1 } 163 | | FLOATLIT { Pattern.float $1 } 164 | | STRLIT { Pattern.str $1 } 165 | | TRUE { Pattern.boolean true } 166 | | FALSE { Pattern.boolean false } 167 | | LPAREN UID value_pattern+ RPAREN { Pattern.ctr $2 ~pats:$3 () } 168 | | UNDERSCORE { Pattern.any_value () } 169 | ; 170 | 171 | comp_pattern: 172 | | ID value_pattern* RARROW ID { Pattern.request $1 ~pats:$2 $4 } 173 | ; 174 | 175 | opt_type_parameters: 176 | | ps = value_types { ps } 177 | ; 178 | 179 | type_variable: 180 | | ID { TypExp.tvar $1 } 181 | ; 182 | 183 | effect_commands: 184 | | effect_command { [$1] } 185 | | bar_effect_command { [$1] } 186 | | effect_commands bar_effect_command { $2 :: $1 } 187 | ; 188 | 189 | effect_command: 190 | | ID COLON rargs = cmd_args 191 | { match rargs with 192 | | [] 193 | -> raise (SyntaxError ("Expecting command type")) 194 | (* Will never happen! *) 195 | | res :: sgra -> EffInterface.cmd_decl $1 ~args:(List.rev sgra) res } 196 | 197 | ; 198 | 199 | cmd_args: 200 | | cmd_arg { [$1] } 201 | | cmd_args RARROW cmd_arg { $3 :: $1 } 202 | ; 203 | 204 | cmd_arg: 205 | | value_type { $1 } 206 | ; 207 | 208 | bar_effect_command: 209 | | BAR effect_command { $2 } 210 | ; 211 | 212 | opt_constructor_decls: 213 | | (* empty *) { [] } 214 | | constructor_decls { $1 } 215 | 216 | constructor_decls: 217 | | constructor_decl { [$1] } 218 | | bar_constructor_decl { [$1] } 219 | | constructor_decls bar_constructor_decl { $2 :: $1 } 220 | ; 221 | 222 | constructor_decl: 223 | | UID COLON rargs = constructor_args 224 | { match rargs with 225 | | [] 226 | -> raise (SyntaxError ("Expecting constructor type")) 227 | (* Will never happen! *) 228 | | res :: sgra -> Datatype.constr_decl $1 ~args:(List.rev sgra) res } 229 | ; 230 | 231 | constructor_args: 232 | | constructor_arg { [$1] } 233 | | constructor_args RARROW constructor_arg { $3 :: $1 } 234 | 235 | constructor_arg: 236 | | LPAREN constructor_arg RPAREN { $2 } 237 | | type_variable { $1 } 238 | | datatype { $1 } 239 | ; 240 | 241 | bar_constructor_decl: 242 | | BAR constructor_decl { $2 } 243 | ; 244 | 245 | top_level_value_type: 246 | | computation_type { TypExp.sus_comp $1 } 247 | ; 248 | 249 | value_type: 250 | | LPAREN value_type RPAREN { $2 } 251 | | type_variable { $1 } 252 | | datatype { $1 } 253 | | LBRACE computation_type RBRACE { TypExp.sus_comp $2 } 254 | ; 255 | 256 | datatype: 257 | | UID value_types { TypExp.datatype $1 $2 } 258 | ; 259 | 260 | paren_value_type: 261 | | LPAREN paren_value_type RPAREN { $2 } 262 | | type_variable { $1 } 263 | | paren_datatype { $1 } 264 | | LBRACE computation_type RBRACE { TypExp.sus_comp $2 } 265 | ; 266 | 267 | paren_datatype: 268 | | UID { TypExp.datatype $1 [] } 269 | | LPAREN UID non_empty_value_types RPAREN { TypExp.datatype $2 $3 } 270 | ; 271 | 272 | non_empty_value_types: 273 | | paren_value_type+ { $1 } 274 | 275 | value_types: 276 | | list(paren_value_type) { $1 } 277 | ; 278 | 279 | computation_type: 280 | | arg { TypExp.comp $1 } 281 | | rargs = arrow_type 282 | { match rargs with 283 | | [] -> raise (SyntaxError ("Expecting function type")) 284 | (* Impossible *) 285 | | res :: sgra -> TypExp.comp ~args:(List.rev sgra) res 286 | } 287 | ; 288 | 289 | arrow_type: 290 | | arg RARROW arg { [$3 ; $1] } 291 | | arrow_type RARROW arg { $3 :: $1 } 292 | ; 293 | 294 | arg: 295 | | value_type { TypExp.returner $1 () } 296 | | returner { $1 } 297 | ; 298 | 299 | returner: 300 | | LBRACKET effects RBRACKET value_type { TypExp.returner $4 ~effs:$2 () } 301 | ; 302 | 303 | effects: 304 | | es = separated_list(COMMA, effect_interface) { es } 305 | ; 306 | 307 | effect_interface: 308 | | ident opt_type_parameters { TypExp.effin $1 ~params:$2 () } 309 | ; 310 | -------------------------------------------------------------------------------- /parsing/parser.mly.diff: -------------------------------------------------------------------------------- 1 | diff --git a/parsing/parser.mly b/parsing/parser.mly 2 | index 97b0571..f7bd00c 100644 3 | --- a/parsing/parser.mly 4 | +++ b/parsing/parser.mly 5 | @@ -18,10 +18,9 @@ 6 | %token ID 7 | %token INTERFACE 8 | %token INTLIT 9 | -%token LARROW 10 | +%token RARROW 11 | %token LBRACE LBRACKET LPAREN 12 | %token RBRACE RBRACKET RPAREN 13 | -%token SEMI 14 | %token TRUE 15 | %token UID 16 | %token UNDERSCORE 17 | @@ -37,10 +36,10 @@ program: 18 | term: 19 | | DATA UID opt_type_parameters EQUAL opt_constructor_decls DOT 20 | { Datatype.mk $2 ~params:$3 ~ctrs:$5 () |> Term.datatype } 21 | - | ID COLON top_level_value_type { ValueDecl.mk $1 $3 |> Term.value_decl } 22 | + | ID COLON top_level_value_type DOT { ValueDecl.mk $1 $3 |> Term.value_decl } 23 | | INTERFACE ident opt_type_parameters EQUAL effect_signatures DOT 24 | { EffInterface.mk $2 ~params:$3 ~sigs:$5 () |> Term.effect_in } 25 | - | ID pattern* EQUAL checkable_computation SEMI 26 | + | ID pattern* EQUAL checkable_computation DOT 27 | { ValueDefn.mk $1 ~pats:$2 $4 |> Term.value_defn } 28 | ; 29 | 30 | @@ -64,7 +63,7 @@ pat_checkable_computation: 31 | ; 32 | 33 | pat_match_computation: 34 | - | separated_nonempty_list(COMMA, pattern) LARROW 35 | + | separated_nonempty_list(COMMA, pattern) RARROW 36 | pat_checkable_computation { CComputation.clause $1 $3 } 37 | ; 38 | 39 | @@ -85,7 +84,7 @@ checkable_value: 40 | paren_checkable_value: 41 | | paren_inferable_value { CValue.ivalue $1 } 42 | | paren_value_constructor { $1 } 43 | - | LPAREN suspended_computation RPAREN { CValue.sus_comp $2 } 44 | + | suspended_computation { CValue.sus_comp $1 } 45 | ; 46 | 47 | inferable_value: 48 | @@ -105,7 +104,7 @@ paren_inferable_value: 49 | ; 50 | 51 | inferable_computation: 52 | - | inferable_value BANG { IComp.app $1 () } 53 | + | inferable_value BANG list(paren_checkable_computation) { IComp.app $1 ~args:$3 () } 54 | | paren_inferable_value nonempty_list(paren_checkable_computation) 55 | { IComp.app $1 ~args:$2 () } 56 | ; 57 | @@ -130,20 +129,20 @@ pattern: 58 | ; 59 | 60 | value_pattern: 61 | - | ID { Pattern.var $1 } 62 | - | UID { Pattern.ctr $1 () } 63 | - | INTLIT { Pattern.integer $1 } 64 | - | TRUE { Pattern.boolean true } 65 | - | FALSE { Pattern.boolean false} 66 | + | ID { Pattern.var $1 } 67 | + | UID { Pattern.ctr $1 () } 68 | + | INTLIT { Pattern.integer $1 } 69 | + | TRUE { Pattern.boolean true } 70 | + | FALSE { Pattern.boolean false} 71 | | LPAREN UID value_pattern+ RPAREN { Pattern.ctr $2 ~pats:$3 () } 72 | ; 73 | 74 | comp_pattern: 75 | - | ID value_pattern* LARROW ID { Pattern.request $1 ~pats:$2 $4 } 76 | - | ID BANG { Pattern.thunk $1 } 77 | + | ID value_pattern* RARROW ID { Pattern.request $1 ~pats:$2 $4 } 78 | + | ID BANG { Pattern.thunk $1 } 79 | 80 | opt_type_parameters: 81 | - | ps = list(value_type) { ps } 82 | + | ps = value_types { ps } 83 | ; 84 | 85 | type_variable: 86 | @@ -168,7 +167,7 @@ effect_signature: 87 | 88 | sig_args: 89 | | sig_arg { [$1] } 90 | - | sig_args LARROW sig_arg { $3 :: $1 } 91 | + | sig_args RARROW sig_arg { $3 :: $1 } 92 | ; 93 | 94 | sig_arg: 95 | @@ -201,46 +200,65 @@ constructor_decl: 96 | 97 | constructor_args: 98 | | constructor_arg { [$1] } 99 | - | constructor_args LARROW constructor_arg { $3 :: $1 } 100 | + | constructor_args RARROW constructor_arg { $3 :: $1 } 101 | 102 | constructor_arg: 103 | - | type_variable { $1 } 104 | - | datatype { $1 } 105 | + | type_variable { $1 } 106 | + | datatype { $1 } 107 | ; 108 | 109 | bar_constructor_decl: 110 | - | BAR constructor_decl { $2 } 111 | + | BAR constructor_decl { $2 } 112 | ; 113 | 114 | top_level_value_type: 115 | - | value_type { $1 } 116 | - | computation_types { TypExp.sus_comp $1 } 117 | + | computation_type { TypExp.sus_comp $1 } 118 | ; 119 | 120 | value_type: 121 | - | type_variable { $1 } 122 | - | datatype { $1 } 123 | - | LBRACE computation_types RBRACE { TypExp.sus_comp $2 } 124 | + | LPAREN value_type RPAREN { $2 } 125 | + | type_variable { $1 } 126 | + | datatype { $1 } 127 | + | LBRACE computation_type RBRACE { TypExp.sus_comp $2 } 128 | ; 129 | 130 | datatype: 131 | - | UID { TypExp.ctr $1 [] } 132 | - | LPAREN UID value_type+ RPAREN { TypExp.ctr $2 $3 } 133 | + | UID value_types { TypExp.ctr $1 $2 } 134 | ; 135 | 136 | -computation_types: 137 | - | returner { $1 } 138 | +paren_value_type: 139 | + | LPAREN paren_value_type RPAREN { $2 } 140 | + | type_variable { $1 } 141 | + | paren_datatype { $1 } 142 | + | LBRACE computation_type RBRACE { TypExp.sus_comp $2 } 143 | + ; 144 | + 145 | +paren_datatype: 146 | + | UID { TypExp.ctr $1 [] } 147 | + | LPAREN UID non_empty_value_types RPAREN { TypExp.ctr $2 $3 } 148 | + ; 149 | + 150 | +non_empty_value_types: 151 | + | paren_value_type+ { $1 } 152 | + ; 153 | + 154 | +value_types: 155 | + | list(paren_value_type) { $1 } 156 | + ; 157 | + 158 | +computation_type: 159 | + | arg { $1 } 160 | | rargs = arrow_type 161 | { match rargs with 162 | - | [] -> raise (SyntaxError ("Expecting function type")) 163 | + | [] -> raise (SyntaxError ("Expecting function type")) 164 | (* Impossible *) 165 | - | res :: sgra -> TypExp.comp (List.rev sgra) res 166 | - } 167 | + | res :: sgra -> TypExp.comp (List.rev sgra) res 168 | + } 169 | ; 170 | 171 | arrow_type: 172 | - | arg LARROW arg { [$1 ; $3] } 173 | - | arrow_type LARROW arg { $3 :: $1 } 174 | + | arg RARROW arg { [$1 ; $3] } 175 | + | arrow_type RARROW arg { $3 :: $1 } 176 | ; 177 | 178 | arg: 179 | -------------------------------------------------------------------------------- /parsing/parser.mly.orig: -------------------------------------------------------------------------------- 1 | %{ 2 | 3 | open ParseTree 4 | open ParseTreeBuilder 5 | open ErrorHandling 6 | 7 | %} 8 | 9 | %token BANG 10 | %token BAR 11 | %token COLON 12 | %token COMMA 13 | %token DATA 14 | %token DOT 15 | %token EOF 16 | %token EQUAL 17 | %token FALSE 18 | %token ID 19 | %token INTERFACE 20 | %token INTLIT 21 | %token LARROW 22 | %token LBRACE LBRACKET LPAREN 23 | %token RBRACE RBRACKET RPAREN 24 | %token SEMI 25 | %token TRUE 26 | %token UID 27 | %token UNDERSCORE 28 | 29 | %start program 30 | 31 | %% 32 | 33 | program: 34 | | list(term) EOF { $1 } 35 | ; 36 | 37 | term: 38 | | DATA UID opt_type_parameters EQUAL opt_constructor_decls DOT 39 | { Datatype.mk $2 ~params:$3 ~ctrs:$5 () |> Term.datatype } 40 | | ID COLON top_level_value_type { ValueDecl.mk $1 $3 |> Term.value_decl } 41 | | INTERFACE ident opt_type_parameters EQUAL effect_commands DOT 42 | { EffInterface.mk $2 ~params:$3 ~cmds:$5 () |> Term.effect_in } 43 | | ID pattern* EQUAL checkable_computation SEMI 44 | { ValueDefn.mk $1 ~pats:$2 $4 |> Term.value_defn } 45 | ; 46 | 47 | ident: 48 | | ID { $1 } 49 | | UID { $1 } 50 | ; 51 | 52 | checkable_computation: 53 | | checkable_value { CComputation.cvalue $1 } 54 | | clauses = separated_list(BAR, pat_match_computation) 55 | { CComputation.compose clauses } 56 | ; 57 | 58 | pat_checkable_computation: 59 | | checkable_value { CComputation.cvalue $1 } 60 | | LPAREN 61 | clauses = separated_list(BAR, pat_match_computation) 62 | RPAREN 63 | { CComputation.compose clauses } 64 | ; 65 | 66 | pat_match_computation: 67 | | separated_nonempty_list(COMMA, pattern) LARROW 68 | pat_checkable_computation { CComputation.clause $1 $3 } 69 | ; 70 | 71 | paren_checkable_computation: 72 | | paren_checkable_value { CComputation.cvalue $1 } 73 | | LPAREN 74 | clauses = separated_list(BAR, pat_match_computation) 75 | RPAREN 76 | { CComputation.compose clauses } 77 | ; 78 | 79 | checkable_value: 80 | | inferable_value { CValue.ivalue $1 } 81 | | value_constructor { $1 } 82 | | suspended_computation { CValue.sus_comp $1 } 83 | ; 84 | 85 | paren_checkable_value: 86 | | paren_inferable_value { CValue.ivalue $1 } 87 | | paren_value_constructor { $1 } 88 | | LPAREN suspended_computation RPAREN { CValue.sus_comp $2 } 89 | ; 90 | 91 | inferable_value: 92 | | ID { IValue.ident $1 } 93 | | INTLIT { IValue.integer $1 } 94 | | TRUE { IValue.boolean true } 95 | | FALSE { IValue.boolean false } 96 | | inferable_computation { IValue.icomp $1 } 97 | ; 98 | 99 | paren_inferable_value: 100 | | ID { IValue.ident $1 } 101 | | INTLIT { IValue.integer $1 } 102 | | TRUE { IValue.boolean true } 103 | | FALSE { IValue.boolean false } 104 | | LPAREN inferable_computation RPAREN { IValue.icomp $2 } 105 | ; 106 | 107 | inferable_computation: 108 | | inferable_value BANG { IComp.app $1 () } 109 | | paren_inferable_value nonempty_list(paren_checkable_computation) 110 | { IComp.app $1 ~args:$2 () } 111 | ; 112 | 113 | value_constructor: 114 | | UID paren_checkable_value* { CValue.ctr $1 $2 } 115 | ; 116 | 117 | paren_value_constructor: 118 | | UID { CValue.ctr $1 [] } 119 | | LPAREN value_constructor RPAREN { $2 } 120 | 121 | suspended_computation: 122 | | LBRACE checkable_computation RBRACE { $2 } 123 | ; 124 | 125 | pattern: 126 | | LPAREN pattern RPAREN { $2 } 127 | | value_pattern { Pattern.vpat $1 } 128 | | LBRACKET comp_pattern RBRACKET { Pattern.cpat $2 } 129 | | LBRACKET UNDERSCORE RBRACKET { Pattern.any () } 130 | | LBRACKET ID RBRACKET { Pattern.thunk $2 } 131 | ; 132 | 133 | value_pattern: 134 | | ID { Pattern.var $1 } 135 | | UID { Pattern.ctr $1 () } 136 | | INTLIT { Pattern.integer $1 } 137 | | TRUE { Pattern.boolean true } 138 | | FALSE { Pattern.boolean false } 139 | | LPAREN UID value_pattern+ RPAREN { Pattern.ctr $2 ~pats:$3 () } 140 | | UNDERSCORE { Pattern.any_value () } 141 | ; 142 | 143 | comp_pattern: 144 | | ID value_pattern* LARROW ID { Pattern.request $1 ~pats:$2 $4 } 145 | ; 146 | 147 | opt_type_parameters: 148 | | ps = list(value_type) { ps } 149 | ; 150 | 151 | type_variable: 152 | | ID { TypExp.rigid_tvar $1 } 153 | ; 154 | 155 | effect_commands: 156 | | effect_command { [$1] } 157 | | bar_effect_command { [$1] } 158 | | effect_commands bar_effect_command { $2 :: $1 } 159 | ; 160 | 161 | effect_command: 162 | | ID COLON rargs = cmd_args 163 | { match rargs with 164 | | [] 165 | -> raise (SyntaxError ("Expecting command type")) 166 | (* Will never happen! *) 167 | | res :: sgra -> EffInterface.cmd_decl $1 ~args:(List.rev sgra) res } 168 | 169 | ; 170 | 171 | cmd_args: 172 | | cmd_arg { [$1] } 173 | | cmd_args LARROW cmd_arg { $3 :: $1 } 174 | ; 175 | 176 | cmd_arg: 177 | | type_variable { $1 } 178 | | datatype { $1 } 179 | ; 180 | 181 | bar_effect_command: 182 | | BAR effect_command { $2 } 183 | ; 184 | 185 | opt_constructor_decls: 186 | | (* empty *) { [] } 187 | | constructor_decls { $1 } 188 | 189 | constructor_decls: 190 | | constructor_decl { [$1] } 191 | | bar_constructor_decl { [$1] } 192 | | constructor_decls bar_constructor_decl { $2 :: $1 } 193 | ; 194 | 195 | constructor_decl: 196 | | UID COLON rargs = constructor_args 197 | { match rargs with 198 | | [] 199 | -> raise (SyntaxError ("Expecting constructor type")) 200 | (* Will never happen! *) 201 | | res :: sgra -> Datatype.constr_decl $1 ~args:(List.rev sgra) res } 202 | ; 203 | 204 | constructor_args: 205 | | constructor_arg { [$1] } 206 | | constructor_args LARROW constructor_arg { $3 :: $1 } 207 | 208 | constructor_arg: 209 | | type_variable { $1 } 210 | | datatype { $1 } 211 | ; 212 | 213 | bar_constructor_decl: 214 | | BAR constructor_decl { $2 } 215 | ; 216 | 217 | top_level_value_type: 218 | | value_type { $1 } 219 | | computation_types { TypExp.sus_comp $1 } 220 | ; 221 | 222 | value_type: 223 | | type_variable { $1 } 224 | | datatype { $1 } 225 | | LBRACE computation_types RBRACE { TypExp.sus_comp $2 } 226 | ; 227 | 228 | datatype: 229 | | UID { TypExp.datatype $1 [] } 230 | | LPAREN UID value_type+ RPAREN { TypExp.datatype $2 $3 } 231 | ; 232 | 233 | computation_types: 234 | | returner { TypExp.comp $1 } 235 | | rargs = arrow_type 236 | { match rargs with 237 | | [] -> raise (SyntaxError ("Expecting function type")) 238 | (* Impossible *) 239 | | res :: sgra -> TypExp.comp ~args:(List.rev sgra) res 240 | } 241 | ; 242 | 243 | arrow_type: 244 | | arg LARROW arg { [$1 ; $3] } 245 | | arrow_type LARROW arg { $3 :: $1 } 246 | ; 247 | 248 | arg: 249 | | value_type { TypExp.returner $1 () } 250 | | returner { $1 } 251 | ; 252 | 253 | returner: 254 | | LBRACKET effects RBRACKET value_type { TypExp.returner $4 ~effs:$2 () } 255 | ; 256 | 257 | effects: 258 | | es = separated_list(COMMA, effect_interface) { es } 259 | ; 260 | 261 | effect_interface: 262 | | ident opt_type_parameters { TypExp.effin $1 ~params:$2 () } 263 | ; 264 | -------------------------------------------------------------------------------- /parsing/parser.mly.rej: -------------------------------------------------------------------------------- 1 | --- parser.mly 2 | +++ parser.mly 3 | @@ -36,10 +35,10 @@ 4 | term: 5 | | DATA UID opt_type_parameters EQUAL opt_constructor_decls DOT 6 | { Datatype.mk $2 ~params:$3 ~ctrs:$5 () |> Term.datatype } 7 | - | ID COLON top_level_value_type { ValueDecl.mk $1 $3 |> Term.value_decl } 8 | + | ID COLON top_level_value_type DOT { ValueDecl.mk $1 $3 |> Term.value_decl } 9 | | INTERFACE ident opt_type_parameters EQUAL effect_signatures DOT 10 | { EffInterface.mk $2 ~params:$3 ~sigs:$5 () |> Term.effect_in } 11 | - | ID pattern* EQUAL checkable_computation SEMI 12 | + | ID pattern* EQUAL checkable_computation DOT 13 | { ValueDefn.mk $1 ~pats:$2 $4 |> Term.value_defn } 14 | ; 15 | 16 | @@ -129,20 +128,20 @@ 17 | ; 18 | 19 | value_pattern: 20 | - | ID { Pattern.var $1 } 21 | - | UID { Pattern.ctr $1 () } 22 | - | INTLIT { Pattern.integer $1 } 23 | - | TRUE { Pattern.boolean true } 24 | - | FALSE { Pattern.boolean false} 25 | + | ID { Pattern.var $1 } 26 | + | UID { Pattern.ctr $1 () } 27 | + | INTLIT { Pattern.integer $1 } 28 | + | TRUE { Pattern.boolean true } 29 | + | FALSE { Pattern.boolean false} 30 | | LPAREN UID value_pattern+ RPAREN { Pattern.ctr $2 ~pats:$3 () } 31 | ; 32 | 33 | comp_pattern: 34 | - | ID value_pattern* LARROW ID { Pattern.request $1 ~pats:$2 $4 } 35 | - | ID BANG { Pattern.thunk $1 } 36 | + | ID value_pattern* RARROW ID { Pattern.request $1 ~pats:$2 $4 } 37 | + | ID BANG { Pattern.thunk $1 } 38 | 39 | opt_type_parameters: 40 | - | ps = list(value_type) { ps } 41 | + | ps = value_types { ps } 42 | ; 43 | 44 | type_variable: 45 | @@ -167,7 +166,7 @@ 46 | 47 | sig_args: 48 | | sig_arg { [$1] } 49 | - | sig_args LARROW sig_arg { $3 :: $1 } 50 | + | sig_args RARROW sig_arg { $3 :: $1 } 51 | ; 52 | 53 | sig_arg: 54 | @@ -200,46 +199,65 @@ 55 | 56 | constructor_args: 57 | | constructor_arg { [$1] } 58 | - | constructor_args LARROW constructor_arg { $3 :: $1 } 59 | + | constructor_args RARROW constructor_arg { $3 :: $1 } 60 | 61 | constructor_arg: 62 | - | type_variable { $1 } 63 | - | datatype { $1 } 64 | + | type_variable { $1 } 65 | + | datatype { $1 } 66 | ; 67 | 68 | bar_constructor_decl: 69 | - | BAR constructor_decl { $2 } 70 | + | BAR constructor_decl { $2 } 71 | ; 72 | 73 | top_level_value_type: 74 | - | value_type { $1 } 75 | - | computation_types { TypExp.sus_comp $1 } 76 | + | computation_type { TypExp.sus_comp $1 } 77 | ; 78 | 79 | value_type: 80 | - | type_variable { $1 } 81 | - | datatype { $1 } 82 | - | LBRACE computation_types RBRACE { TypExp.sus_comp $2 } 83 | + | LPAREN value_type RPAREN { $2 } 84 | + | type_variable { $1 } 85 | + | datatype { $1 } 86 | + | LBRACE computation_type RBRACE { TypExp.sus_comp $2 } 87 | ; 88 | 89 | datatype: 90 | - | UID { TypExp.ctr $1 [] } 91 | - | LPAREN UID value_type+ RPAREN { TypExp.ctr $2 $3 } 92 | + | UID value_types { TypExp.ctr $1 $2 } 93 | ; 94 | 95 | -computation_types: 96 | - | returner { $1 } 97 | +paren_value_type: 98 | + | LPAREN paren_value_type RPAREN { $2 } 99 | + | type_variable { $1 } 100 | + | paren_datatype { $1 } 101 | + | LBRACE computation_type RBRACE { TypExp.sus_comp $2 } 102 | + ; 103 | + 104 | +paren_datatype: 105 | + | UID { TypExp.ctr $1 [] } 106 | + | LPAREN UID non_empty_value_types RPAREN { TypExp.ctr $2 $3 } 107 | + ; 108 | + 109 | +non_empty_value_types: 110 | + | paren_value_type+ { $1 } 111 | + ; 112 | + 113 | +value_types: 114 | + | list(paren_value_type) { $1 } 115 | + ; 116 | + 117 | +computation_type: 118 | + | arg { $1 } 119 | | rargs = arrow_type 120 | { match rargs with 121 | - | [] -> raise (SyntaxError ("Expecting function type")) 122 | + | [] -> raise (SyntaxError ("Expecting function type")) 123 | (* Impossible *) 124 | - | res :: sgra -> TypExp.comp (List.rev sgra) res 125 | - } 126 | + | res :: sgra -> TypExp.comp (List.rev sgra) res 127 | + } 128 | ; 129 | 130 | arrow_type: 131 | - | arg LARROW arg { [$1 ; $3] } 132 | - | arrow_type LARROW arg { $3 :: $1 } 133 | + | arg RARROW arg { [$1 ; $3] } 134 | + | arrow_type RARROW arg { $3 :: $1 } 135 | ; 136 | 137 | arg: 138 | -------------------------------------------------------------------------------- /parsing/test.ml: -------------------------------------------------------------------------------- 1 | open Lexer 2 | open Lexing 3 | open Printf 4 | open ParseTree 5 | open ErrorHandling 6 | 7 | let print_position outx lexbuf = 8 | let pos = lexbuf.lex_curr_p in 9 | fprintf outx "%s:%d:%d" pos.pos_fname 10 | pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) 11 | 12 | let parse_with_error lexbuf = 13 | try Parser.program Lexer.token lexbuf with 14 | | SyntaxError msg -> 15 | fprintf stderr "%a:%s\n" print_position lexbuf msg; [] 16 | | Parser.Error -> 17 | fprintf stderr "%a: syntax error\n" print_position lexbuf; 18 | exit (-1) 19 | 20 | let compose f g = fun x -> f (g x) 21 | 22 | let rec pats_of_string ?(sep = "") ps = 23 | match ps with 24 | | [] -> "" 25 | | p :: _ 26 | -> if List.length ps > 1 then List.fold_right (pat_of_string sep) ps "" 27 | else pat_of_string sep p "" 28 | 29 | and vpat_of_string p = 30 | let 31 | to_pat = fun x -> {spat_desc = Spat_value x} 32 | in 33 | match p with 34 | | Svpat_var v -> v 35 | | Svpat_ctr (c,ps) 36 | -> "(" ^ c ^ " " ^ pats_of_string (List.map to_pat ps) ^ ")" 37 | 38 | and cpat_of_string p = " " (* TODO: Add support *) 39 | 40 | and pat_of_string sep p acc = (* Implementation assumes used for fold_right *) 41 | let pstr = 42 | match p.spat_desc with 43 | | Spat_value vp -> vpat_of_string vp 44 | | Spat_comp cp -> cpat_of_string cp 45 | in if acc = "" (* end of a sequence of patterns *) then pstr 46 | else pstr ^ sep ^ " " ^ acc 47 | 48 | let rec cval_of_string cur cv = 49 | let cvstr = match cv with 50 | | CValue_ivalue iv -> ival_of_string iv 51 | | CValue_ctr (c,vs) 52 | -> "(" ^ c ^ (List.fold_left cval_of_string "" vs) ^ ")" 53 | | CValue_thunk c -> "{" ^ ccomp_of_string c ^ "}" 54 | in 55 | cur ^ " " ^ cvstr 56 | 57 | and icomp_of_string ic = 58 | match ic with 59 | | IComp_force iv -> ival_of_string iv ^ "!" 60 | | IComp_app (iv, cs) 61 | -> "(" ^ ival_of_string iv ^ " " ^ 62 | (String.concat " " (List.map ccomp_of_string cs)) ^ 63 | ")" 64 | 65 | and ival_of_string iv = 66 | match iv with 67 | | IValue_ident id -> id 68 | | IValue_int n -> string_of_int n 69 | | IValue_bool b -> string_of_bool b 70 | | IValue_icomp ic -> icomp_of_string ic 71 | 72 | and ccomp_of_string cc = 73 | match cc with 74 | | CComp_cvalue cv -> cval_of_string "" cv 75 | | CComp_hdr_clause (ps, cc) 76 | -> pats_of_string ~sep:"," ps ^ " -> " ^ ccomp_of_string cc 77 | | CComp_emp_clause -> "()" 78 | | CComp_compose cs -> String.concat " | " (List.map ccomp_of_string cs) 79 | 80 | let print_def vd = 81 | printf "\t%s %s = %s\n" vd.vdef_name 82 | (pats_of_string vd.vdef_args) 83 | (ccomp_of_string vd.vdef_comp) 84 | 85 | let print_term trm = 86 | match trm with 87 | | Sterm_datatype dt -> printf "Datatype\t%s\n" dt.sdt_name 88 | | Sterm_effin ei -> printf "Effect Interface\t%s\n" ei.sei_name 89 | | Sterm_vdecl vd -> printf "Value Declaration\t%s\n" vd.svdecl_name 90 | | Sterm_vdefn vdef 91 | -> printf "Value Definition\t%s:\n" vdef.vdef_name; print_def vdef 92 | 93 | let rec parse_and_print lexbuf = 94 | match parse_with_error lexbuf with 95 | | [] -> () 96 | | ts -> let _ = List.map print_term ts in parse_and_print lexbuf 97 | 98 | let loop filename = 99 | let inx = open_in filename in 100 | let lexbuf = Lexing.from_channel inx in 101 | lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = filename }; 102 | parse_and_print lexbuf; 103 | close_in inx 104 | 105 | let () = Arg.parse [] loop "Frank Parser:" 106 | 107 | -------------------------------------------------------------------------------- /pattern-matching-compilation: -------------------------------------------------------------------------------- 1 | suppose we have some type [E]V and we are compiling this column. 2 | 3 | first we compute the signature of the column. which will contain a unique set 4 | of values drawn from the type signature data type. then we will have to decide 5 | if we need a default case or not. there are two cases to consider. 6 | 7 | 1) the column of patterns is not exhaustive i.e. there exists some S vs in 8 | E or some k vs in V s.t. either S vs Int 46 | simple [oc1 -> k] = 1 47 | simple [tc2 -> k] = 2 48 | simple x = 0 49 | 50 | In the above example we have a type error since 'tc1' is not handled. This 51 | example also shows the partial ordering of value signatures; the final pattern 52 | yields {AllValues} with {Ctr tv1, Ctr tv2, Ctr tv3}/{AllValues} = /o (the 53 | empty set). 54 | 55 | Note, however, in the following example: 56 | 57 | simple : [OneCmd, TwoCmd]ThreeVs -> Int 58 | simple [oc1 -> k] = 1 59 | simple [tc2 -> k] = 2 60 | simple [tc1 -> k] = 3 61 | simple x = 0 62 | 63 | we *still* have T/P non-empty because the effect set is implicitly open! But 64 | considering the set difference operation in first example we have: 65 | 66 | T {Cmd oc1, Cmd tc1, Cmd tc2, AmbientCmds, Ctr tv1, Ctr tv2, Ctr tv3} 67 | / = / 68 | P {Cmd oc1, Cmd tc2, AllValues} 69 | 70 | = {Cmd tc1, AmbientCmds} 71 | 72 | and in the second example: 73 | 74 | T {Cmd oc1, Cmd tc1, Cmd tc2, AmbientCmds, Ctr tv1, Ctr tv2, Ctr tv3} 75 | / = / 76 | P {Cmd oc1, Cmd tc1, Cmd tc2, AllValues} 77 | 78 | = {AmbientCmds} 79 | 80 | the condition we require for this set to be 'okay' is that there be no 81 | unhandled commands. if we were to instead do: 82 | 83 | simple : [OneCmd, TwoCmd]ThreeVs -> Int 84 | simple x = 0 85 | simple [t] = 1 86 | 87 | Then 88 | 89 | T {Cmd oc1, Cmd tc1, Cmd tc2, AmbientCmds, Ctr tv1, Ctr tv2, Ctr tv3} 90 | / = / 91 | P {AllValues} 92 | 93 | = {Cmd oc1, Cmd tc1, Cmd tc2, AmbientCmds} 94 | 95 | thus we need a default case. we compute the default matrix which will 96 | correspond to the matrix: 97 | 98 | simple [t] = 1 99 | 100 | as required. 101 | 102 | but how did we know the difference between the last example and our initial 103 | example where we missed out the case for tc2? The answer is that the default 104 | matrix in the first example had no rows! Suggesting that if T/P is non-empty 105 | then either: 106 | 107 | 1) It is the singleton {AmbientCmds}, or 108 | 109 | 2) It contains a subset {Cmd c1, Cmd c2, ..., Cmd cN} 110 | 111 | For 1), construct new rows for forwarding commands. 112 | 113 | For 2), compute the default matrix. If it has no rows, report a type error 114 | indicating the unhandled commands. 115 | 116 | What can be said about the following example? 117 | 118 | simple : [OneCmd, TwoCmd]ThreeVs -> Int 119 | simple x = 0 120 | simple [_] = 1 121 | 122 | the above desugars to: 123 | 124 | simple : [OneCmd, TwoCmd]ThreeVs -> Int 125 | simple x = 0 126 | simple [oc1 -> k] = 1 127 | simple [tc1 -> k] = 1 128 | simple [tc2 -> k] = 1 129 | 130 | We also need to consider forwarding of unhandled (ambient) commands. 131 | 132 | A more complex example involving desugaring of thunk patterns: 133 | 134 | pipe : [Send X]Unit -> [Recv X]Y -> [Abort]Y 135 | pipe [ __ ] y = y 136 | pipe () [recv -> k] = abort! 137 | pipe [send x -> s] [recv -> r] = pipe (s ()) (r x) 138 | 139 | ----- 140 | 141 | I now have a better understanding of how to structure pattern matching 142 | compilation. it follows a three stage process. first we take the source level 143 | patterns and desugar them to mid-level patterns. second we compile the 144 | mid-level patterns and compile them to a decision tree using an algorithm 145 | inspired by standard approaches (principally maranget and petterrson). third 146 | we evaluate the decision tree against untyped computations. 147 | 148 | decomposition of the first stage 149 | -------------------------------- 150 | 151 | desugaring is composed of two stages. first we desugar thunk patterns into 152 | simple type signatures consisting of variables, constructors, or 153 | commands. second we add forwarding clauses to the matrix for each column with 154 | an open effect set, including providing RHSes for recursively calling the 155 | handler. 156 | 157 | decomposition of the second stage 158 | --------------------------------- 159 | 160 | the compilation scheme will need to be adapted to handle the new pattern 161 | constructs, namely inspecting of an unhandled command ([?c -> k]) and thunking 162 | of an unhandled computation ([?t]). i can envisage this requiring two new 163 | "type signatures", TSFwdCmd (c, vs, k) and TSThunk t. the remaining question 164 | to resolve is how to specialise on these new patterns and what their children 165 | and their children's types should be. the main issue is, in the case of [?c -> 166 | k], we do not know a priori the number of arguments the command expects (or 167 | indeed the actual name of the command we are executing). 168 | 169 | decomposition of the third stage 170 | -------------------------------- 171 | 172 | evaluation needs to handle the new pattern constructs. binding the actual 173 | command and its arguments to the generated names of the type signature. 174 | -------------------------------------------------------------------------------- /run_tests.sh: -------------------------------------------------------------------------------- 1 | 2 | SHOULD_PASS_TESTS="tests/should-pass" 3 | SHOULD_FAIL_TESTS="tests/should-fail" 4 | 5 | for dir in $(ls -1 $SHOULD_PASS_TESTS) 6 | do 7 | for file in $(ls -1 $SHOULD_PASS_TESTS/$dir/*.fk) 8 | do 9 | if [ "$1" = "v" ]; then 10 | echo "Testing ${file}..." 11 | fi 12 | ./frankInterpreter.byte ${file} > /dev/null 2>&1 13 | if [ "$?" -ne 0 ]; then 14 | echo "${file} FAILED" 15 | fi 16 | done 17 | done 18 | 19 | for dir in $(ls -1 $SHOULD_FAIL_TESTS) 20 | do 21 | for file in $(ls -1 $SHOULD_FAIL_TESTS/$dir/*.fk) 22 | do 23 | if [ "$1" = "v" ]; then 24 | echo "Testing ${file}..." 25 | fi 26 | ./frankInterpreter.byte ${file} > /dev/null 2>&1 27 | if [ "$?" -eq 0 ]; then 28 | echo "${file} FAILED" 29 | fi 30 | done 31 | done 32 | -------------------------------------------------------------------------------- /tests/should-fail/typing/inst_match.fk: -------------------------------------------------------------------------------- 1 | data List x = Nil : x 2 | | Cons : x -> (List x) -> (List x). 3 | 4 | hd : List x -> x -> x. 5 | hd Nil d = d. 6 | hd (Cons x xs) d = x. 7 | 8 | map : {a -> b} -> (List a) -> (List b). 9 | map f Nil = Nil. 10 | map f (Cons x xs) = f true. 11 | 12 | main : List Int. 13 | main = Nil. 14 | -------------------------------------------------------------------------------- /tests/should-fail/typing/no_such_interface.fk: -------------------------------------------------------------------------------- 1 | semi : x -> y -> y. 2 | semi x y = y. 3 | 4 | main : [Console,Abort]Bool. 5 | {- Fails because Abort interface is not defined. -} 6 | main = semi (putStrLn "Hello") false. 7 | -------------------------------------------------------------------------------- /tests/should-fail/typing/no_such_interface_arg.fk: -------------------------------------------------------------------------------- 1 | semi : x -> y -> y. 2 | semi x y = y. 3 | 4 | blah : [Abort]String -> [Console]Bool. 5 | {- this should fail because Abort isn't defined. -} 6 | blah x = semi (putStrLn "Hello") false. 7 | blah [some -> k] = semi (putStrLn "Hello") false. 8 | 9 | main : [Console]Bool. 10 | main = blah "Hello". 11 | -------------------------------------------------------------------------------- /tests/should-fail/typing/pat_match_dup.fk: -------------------------------------------------------------------------------- 1 | foo : Int -> Int -> Int. 2 | foo n n = n. 3 | 4 | main : Int. 5 | main = foo 0 1. 6 | -------------------------------------------------------------------------------- /tests/should-pass/eval/blame.fk: -------------------------------------------------------------------------------- 1 | {- Jack Williams-inspired example. -} 2 | data Dyn = DInt : Int -> Dyn 3 | | DBool : Bool -> Dyn. 4 | 5 | data Zero =. 6 | 7 | interface Fail = fail : String -> Zero. 8 | 9 | bind : x -> {x -> y} -> y. 10 | bind x f = f x. 11 | 12 | failure : String -> [Fail]a. 13 | failure msg = bind (fail msg) {}. 14 | 15 | toInt : Dyn -> [Fail]Int. 16 | toInt (DInt i) = i. 17 | toInt (DBool b) = failure "BOOL". 18 | 19 | run : [Fail]Int -> [Console]Int. 20 | run n = n. 21 | run [fail msg -> k] = bind (putStrLn msg) {x -> 0}. 22 | 23 | main : [Console]Int. 24 | main = run (toInt (DBool true)). 25 | 26 | -------------------------------------------------------------------------------- /tests/should-pass/eval/coins.fk: -------------------------------------------------------------------------------- 1 | data Maybe a = Nothing : Maybe a 2 | | Just : a -> Maybe a. 3 | 4 | data List a = Nil : List a 5 | | Cons : a -> List a -> List a. 6 | 7 | data Zero =. 8 | 9 | append : List a -> List a -> List a. 10 | append Nil ys = ys. 11 | append (Cons x xs) ys = Cons x (append xs ys). 12 | 13 | interface Choice = choice : Bool. 14 | interface Fail = fail : Zero. 15 | 16 | cond : Bool -> {a} -> {a} -> a. 17 | cond true t e = t!. 18 | cond false t e = e!. 19 | 20 | choose : a -> a -> [Choice]a. 21 | choose x y = cond (choice!) {x} {y}. 22 | 23 | {- Define a failure handler which can be instantiated to any type. -} 24 | {- Is there an alternative definition which doesn't use bind? -} 25 | bind : x -> {x -> y} -> y. 26 | bind x f = f x. 27 | 28 | failure : [Fail]a. 29 | failure = bind (fail!) {}. 30 | 31 | allResults : [Choice, Fail]a -> List a. 32 | allResults x = Cons x Nil. 33 | allResults [choice -> k] = 34 | append (allResults (k true)) (allResults (k false)). 35 | allResults [fail -> k] = Nil. 36 | 37 | data Toss = Heads : Toss 38 | | Tails : Toss. 39 | 40 | toss : [Choice]Toss. 41 | toss = choose Heads Tails. 42 | 43 | {- Use the failure handler instead of the fail command here. -} 44 | drunkToss : [Choice, Fail]Toss. 45 | drunkToss = cond (choice!) toss failure. 46 | 47 | drunkTosses : Int -> [Choice, Fail]List Toss. 48 | drunkTosses 0 = Nil. 49 | drunkTosses n = Cons (drunkToss!) (drunkTosses (minus n 1)). 50 | 51 | maybeResult : [Fail]a -> Maybe a. 52 | maybeResult x = Just x. 53 | maybeResult [fail -> k] = Nothing. 54 | 55 | persevere' : {[Fail]a} -> [Fail]a -> a. 56 | persevere' m x = x. 57 | persevere' m [fail -> k] = persevere' m (m!). 58 | 59 | persevere : [Fail]a -> a. 60 | persevere [m] = persevere' m (m!). 61 | 62 | {- The above should be equivalent to the following -} 63 | {- 64 | persevere : [Fail]a -> a. 65 | persevere x = persevere' {x} x. 66 | persevere [fail -> k] = persevere' {k (fail!)} (k (fail!)). 67 | -} 68 | {- The following clause fails to type check, but should succeed and be 69 | equivalent to the fail clause above -} 70 | {- persevere [fail -> k] = bind {k (fail!)} {m -> persevere' m (m!)}. -} 71 | 72 | {- This is probably what we should have written instead of persevere -} 73 | persevere'' : {[Fail]a} -> a. 74 | persevere'' m = persevere' m (m!). 75 | 76 | interface Rand = rand : Float. 77 | 78 | randomResult : [Choice]a -> [Rand]a. 79 | randomResult x = x. 80 | randomResult [choice -> k] = randomResult (k (gtf (rand!) 0.5)). 81 | 82 | handleRandom : [Rand]a -> [Random]a. 83 | handleRandom x = x. 84 | handleRandom [rand -> k] = handleRandom (k (random!)). 85 | 86 | sampleMaybe : {[Choice, Fail]a} -> [Random]Maybe a. 87 | sampleMaybe m = handleRandom (maybeResult (randomResult (m!))). 88 | 89 | sample : {[Choice, Fail]a} -> [Random]a. 90 | sample m = handleRandom (persevere (randomResult (m!))). 91 | 92 | 93 | {- This handler should fail to type-check because it doesn't cover all 94 | of the commands in the input -} 95 | sample' : [Choice, Fail]a -> [Random]a. 96 | sample' m = handleRandom (persevere (randomResult m)). 97 | 98 | {- 99 | main : List (List Toss). 100 | main = allResults (drunkTosses 3). 101 | -} 102 | 103 | {- 104 | main : [Random]List (Maybe (List Toss)). 105 | main = Cons (sampleMaybe {drunkTosses 2}) (Cons (sampleMaybe {drunkTosses 2}) Nil). 106 | -} 107 | 108 | main : [Random]List Toss. 109 | main = sample {drunkTosses 3}. 110 | -------------------------------------------------------------------------------- /tests/should-pass/eval/console.fk: -------------------------------------------------------------------------------- 1 | main : [Console]Unit. 2 | main = putStrLn "Hello, World!". 3 | -------------------------------------------------------------------------------- /tests/should-pass/eval/delimited-continuations.fk: -------------------------------------------------------------------------------- 1 | {- delimited continuations in Frank -} 2 | interface Shift0 a r = shift0 : {{a -> r} -> r} -> a. 3 | 4 | bind : x -> {x -> y} -> y. 5 | bind x f = f x. 6 | 7 | reset0 : [Shift0 a r]r -> r. 8 | reset0 x = x. 9 | reset0 [shift0 p -> k] = p {x -> reset0 (k x)}. 10 | 11 | foo : [Shift0 Int Int]Int. 12 | foo = 13 | bind (shift0 {k -> k (k (k 7))}) 14 | {x -> plus (plus x x) 1}. 15 | 16 | main : Int. 17 | main = reset0 (foo!). 18 | -------------------------------------------------------------------------------- /tests/should-pass/eval/gt.fk: -------------------------------------------------------------------------------- 1 | interface State x = get : x 2 | | put : x -> Unit 3 | 4 | interface Receive x = receive : x 5 | 6 | runState : x -> [State x]y -> y 7 | runState x [put x' -> k] = runState x' (k Unit) 8 | runState x [get -> k] = runState x (k x) 9 | runState x y = y 10 | 11 | main : Bool 12 | main = runState 3 (gt (get!) 2) 13 | -------------------------------------------------------------------------------- /tests/should-pass/eval/let.fk: -------------------------------------------------------------------------------- 1 | data Zero =. 2 | 3 | interface Abort = aborting : Zero. 4 | 5 | simple : Int. 6 | simple = let x = {0} in x!. 7 | 8 | abort : [Abort]x. 9 | abort = let x = aborting! in {}. 10 | 11 | {- 12 | abort2 : [Abort]x. 13 | abort2 = let x = {aborting!} in x!. 14 | -} 15 | 16 | baz : [Abort]Int. 17 | baz = let x = {abort!} in x!. 18 | 19 | main : Int. 20 | main = simple!. 21 | -------------------------------------------------------------------------------- /tests/should-pass/eval/nim.fk: -------------------------------------------------------------------------------- 1 | {- standard stuff -} 2 | bind : a -> {a -> b} -> b. 3 | bind x f = f x. 4 | 5 | cond : Bool -> {a} -> {a} -> a. 6 | cond true t e = t!. 7 | cond false t e = e!. 8 | 9 | maximum : Int -> Int -> Int. 10 | maximum m n = cond (gt m n) {m} {n}. 11 | 12 | minimum : Int -> Int -> Int. 13 | minimum m n = cond (gt m n) {n} {m}. 14 | 15 | lt : Int -> Int -> Bool. 16 | lt m n = gt n m. 17 | 18 | or : Bool -> Bool -> Bool. 19 | or true _ = true. 20 | or _ true = true. 21 | or false false = false. 22 | 23 | mod : Int -> Int -> Int. 24 | mod 0 n = 0. 25 | mod m n = cond (gt m n) {mod (minus m n) n} {m}. 26 | 27 | data Zero =. 28 | 29 | data Maybe a = Nothing : Maybe a 30 | | Just : a -> Maybe a. 31 | 32 | data List a = Nil : List a 33 | | Cons : a -> List a -> List a. 34 | 35 | map : {a -> b} -> List a -> List b. 36 | map f Nil = Nil. 37 | map f (Cons x xs) = Cons (f x) (map f xs). 38 | 39 | filter : {a -> Bool} -> List a -> List a. 40 | filter p Nil = Nil. 41 | filter p (Cons x xs) = cond (p x) {Cons x (filter p xs)} {filter p xs}. 42 | 43 | length : List a -> Int. 44 | length Nil = 0. 45 | length (Cons x xs) = plus 1 (length xs). 46 | 47 | zip : List a -> List b -> List (Pair a b). 48 | zip Nil _ = Nil. 49 | zip _ Nil = Nil. 50 | zip (Cons x xs) (Cons y ys) = Cons (Pair x y) (zip xs ys). 51 | 52 | elemIndex' : {a -> a -> Bool} -> Int -> a -> List a -> Maybe Int. 53 | elemIndex' eq _ _ Nil = Nothing. 54 | elemIndex' eq i z (Cons x xs) = cond (eq z x) {Just i} {elemIndex' eq (plus i 1) z xs}. 55 | 56 | elemIndex : {a -> a -> Bool} -> a -> List a -> Maybe Int. 57 | elemIndex eq z xs = elemIndex' eq 0 z xs. 58 | 59 | range : Int -> Int -> List Int. 60 | range m n = cond (gt m n) {Nil} {Cons m (range (plus m 1) n)}. 61 | 62 | 63 | data Pair a b = Pair : a -> b -> Pair a b. 64 | {- end of standard stuff -} 65 | 66 | 67 | {- 68 | Nim game (https://en.wikipedia.org/wiki/Nim) 69 | This example is adapted from Kammar et al. (2013) 70 | (https://github.com/slindley/effect-handlers) 71 | 72 | A game begins with n sticks on the table. The game has two players: Alice and Bob. 73 | Alice goes first. Alice takes between one and three sticks, then it is Bob's turn 74 | and similary Bob takes between one and three sticks. They alternate turns until 75 | there are no more sticks left. The player, who takes the last stick, wins. 76 | -} 77 | 78 | {- The game -} 79 | data Player = Alice : Player 80 | | Bob : Player. 81 | 82 | eqPlayer : Player -> Player -> Bool. 83 | eqPlayer Alice Alice = true. 84 | eqPlayer Bob Bob = true. 85 | eqPlayer _ _ = false. 86 | 87 | showPlayer : Player -> String. 88 | showPlayer Alice = "Alice". 89 | showPlayer Bob = "Bob". 90 | 91 | {- 92 | The Game interface provides a single 'move' command, which 93 | represents a move by a player in the game. The 94 | two parameters are a player and the number of sticks 95 | remaining. The return value is the number of sticks the player 96 | chooses to take. 97 | -} 98 | interface Game = move : Player -> Int -> Int. 99 | 100 | {- 101 | We model the rules of the game as an abstract computation over the 102 | Game interface that returns the winner. 103 | 104 | a game is parameterised by the number of starting sticks 105 | -} 106 | game : Int -> [Game]Player. 107 | game n = aliceTurn n. 108 | 109 | aliceTurn : Int -> [Game]Player. 110 | aliceTurn 0 = Bob. 111 | aliceTurn n = bobTurn (minus n (move Alice n)). 112 | 113 | bobTurn : Int -> [Game]Player. 114 | bobTurn 0 = Alice. 115 | bobTurn n = aliceTurn (minus n (move Alice n)). 116 | 117 | {- 118 | Note that this implementation does not check that each player takes 119 | between one and three sticks on each turn. We will add such a check 120 | later. 121 | -} 122 | 123 | {- Strategies -} 124 | 125 | {- construct a handler that assigns strategy s p to player p -} 126 | strategy : {Player -> Int -> {Int -> r} -> r} -> [Game]r -> r. 127 | strategy s x = x. 128 | strategy s [move p n -> k] = 129 | s p n {x -> strategy s (k x)}. 130 | 131 | {- naive strategy: always pick one stick -} 132 | ns : Int -> {Int -> r} -> r. 133 | ns n k = k 1. 134 | 135 | {- perfect strategy -} 136 | ps : Int -> {Int -> r} -> r. 137 | ps n k = k (maximum (mod n 4) 1). 138 | 139 | {- both players adopt a naive strategy -} 140 | nn : Int -> Player. 141 | nn n = strategy {_, n, k -> ns n k} (game n). 142 | 143 | {- both players adopt a perfect strategy -} 144 | pp : Int -> Player. 145 | pp n = strategy {_, n, k -> ps n k} (game n). 146 | 147 | data MoveTree = Take : Player -> List (Pair Int MoveTree) -> MoveTree 148 | | Winner : Player -> MoveTree. 149 | 150 | {- list of valid moves given n sticks remaining -} 151 | validMoves : Int -> List Int. 152 | validMoves n = range 1 (minimum 3 n). 153 | 154 | {- brute force strategy: enumerate all possible moves -} 155 | bfs : Player -> Int -> {Int -> Player} -> Player. 156 | bfs player n k = 157 | bind (map k (validMoves n)) {winners -> 158 | bind (elemIndex eqPlayer player winners) { Nothing -> k 1 159 | | (Just i) -> k (plus i 1)}}. 160 | 161 | {- Alice perfect vs Bob brute force -} 162 | bp : Int -> Player. 163 | bp n = strategy { Alice, n, k -> ps n k 164 | | Bob, n, k -> bfs Bob n k} (game n). 165 | 166 | {- 167 | Instead of simply evaluating the winner according to some strategy, 168 | we can also compute other data. For instance, we can compute a tree 169 | representing the possible moves of each player. 170 | -} 171 | 172 | {- reify a move as part of the move tree -} 173 | reifyMove : Player -> Int -> {Int -> MoveTree} -> MoveTree. 174 | reifyMove player n k = 175 | bind (map k (validMoves n)) {moves -> 176 | bind (zip (range 1 (length moves)) moves) {subgames -> 177 | Take player subgames}}. 178 | 179 | {- complete move tree generator -} 180 | mtGen : [Game]Player -> MoveTree. 181 | mtGen x = Winner x. 182 | mtGen [move p n -> k] = reifyMove p n {x -> mtGen (k x)}. 183 | 184 | mt : Int -> MoveTree. 185 | mt n = mtGen (game n). 186 | 187 | {- Generate a move tree for Alice in anticipation of combining it with 188 | a strategy for Bob -} 189 | aliceTree : [Game]Player -> [Game]MoveTree. 190 | aliceTree x = Winner x. 191 | aliceTree [move Alice n -> k] = reifyMove Alice n {x -> aliceTree (k x)}. 192 | aliceTree [move Bob n -> k] = 193 | bind (move Bob n) {take -> Take Bob (Cons (Pair take (aliceTree (k take))) Nil)}. 194 | 195 | {- 196 | We reuse the perfect vs perfect handler; it only ever gets to 197 | handle Move(Bob, n) even though it is defined for Move(Alice, n) as 198 | well. 199 | -} 200 | mp : Int -> MoveTree. 201 | mp n = strategy {_, n, k -> ps n k} (aliceTree (game n)). 202 | 203 | 204 | {-- Cheating --} 205 | interface Cheat = cheat : Player -> Int -> Zero. 206 | 207 | {- 208 | cheating p m is invoked when player p cheats by attempting to take 209 | m sticks (for m < 1 or 3 < m) 210 | -} 211 | cheating : Player -> Int -> [Cheat]a. 212 | cheating p m = bind (cheat p m) {}. 213 | 214 | checkMove : Player -> Int -> {Int -> r} -> [Game, Cheat]r. 215 | checkMove player n k = 216 | bind (move player n) {take -> 217 | cond (or (lt take 1) (lt 3 take)) 218 | {cheating player take} {- cheater detected -} 219 | {k take}}. 220 | 221 | 222 | check : [Game]r -> [Game, Cheat]r. 223 | check x = x. 224 | check [move player n -> k] = checkMove player n {x -> check (k x)}. 225 | 226 | checkedGame : Int -> [Cheat, Game]Player. 227 | checkedGame n = check (game n). 228 | 229 | {- 230 | A cheating strategy: take all of the sticks, no matter how many 231 | remain 232 | -} 233 | cheater : Int -> {Int -> r} -> r. 234 | cheater n k = k n. 235 | 236 | {- Alice cheats against Bob's perfect strategy -} 237 | aliceCheats : {[Game]r} -> r. 238 | aliceCheats game = strategy { Bob, n, k -> ps n k 239 | | Alice, n, k -> cheater n k} (game!). 240 | 241 | {- in an unchecked game Alice always wins -} 242 | cpUnchecked : Int -> Player. 243 | cpUnchecked n = aliceCheats {game n}. 244 | 245 | interface Error = anError : String -> Zero. 246 | 247 | error : String -> [Error]a. 248 | error s = bind (anError s) {}. 249 | 250 | displayErrors : [Error]a -> [Console]Maybe a. 251 | displayErrors x = Just x. 252 | displayErrors [anError s -> k] = bind (putStrLn s) {_ -> Nothing}. 253 | 254 | {- if a player cheats then halt the game with an error -} 255 | cheatReport : [Cheat]a -> [Error]a. 256 | cheatReport x = x. 257 | cheatReport [cheat Alice n -> k] = error "Alice Cheated". 258 | cheatReport [cheat Bob n -> k] = error "Bob Cheated". 259 | 260 | {- if a player cheats then the opponent wins immediately -} 261 | cheatLose : [Cheat]Player -> Player. 262 | cheatLose x = x. 263 | cheatLose [cheat Alice n -> k] = Bob. 264 | cheatLose [cheat Bob n -> k] = Alice. 265 | 266 | {- 267 | Alice cheats against Bob's perfect strategy 268 | 269 | (If n < 4 then Alice wins, otherwise the game is abandoned because 270 | Alices cheats.) 271 | -} 272 | cpReport : Int -> [Console]Maybe Player. 273 | cpReport n = displayErrors (cheatReport (aliceCheats {checkedGame n})). 274 | 275 | {- 276 | Alice cheats against Bob's perfect strategy 277 | 278 | (If n < 4 then Alice wins, otherwise Bob wins because Alice 279 | cheats.) 280 | -} 281 | cpLose : Int -> Player. 282 | cpLose n = cheatLose (aliceCheats {checkedGame n}). 283 | 284 | main : Player. 285 | main = pp 20. 286 | 287 | {- 288 | main : Player. 289 | main = bp 20. 290 | -} 291 | 292 | {- 293 | main : MoveTree. 294 | main = mt 3. 295 | -} 296 | 297 | {- 298 | main : MoveTree. 299 | main = mp 3. 300 | -} 301 | 302 | {- 303 | main : [Console]Maybe Player. 304 | main = cpReport 5. 305 | -} 306 | 307 | {- 308 | main : Player. 309 | main = cpLose 5. 310 | -} 311 | -------------------------------------------------------------------------------- /tests/should-pass/eval/pat_match_anon.fk: -------------------------------------------------------------------------------- 1 | foo : Int -> {Int -> Int}. 2 | foo n = {n -> n}. 3 | 4 | main : Int. 5 | main = (foo 3) 4. 6 | -------------------------------------------------------------------------------- /tests/should-pass/eval/pipe.fk: -------------------------------------------------------------------------------- 1 | data List x = Nil : x 2 | | Cons : x -> (List x) -> (List x). 3 | 4 | data Zero =. 5 | 6 | append : (List x) -> (List x) -> (List x). 7 | append Nil ys = ys. 8 | append (Cons ax xs) ys = Cons ax (append xs ys). 9 | 10 | interface Send x = send : x -> Unit. 11 | 12 | interface Receive x = receive : x. 13 | 14 | interface Abort = aborting : Zero. 15 | 16 | map : {a -> b} -> (List a) -> (List b). 17 | map f Nil = Nil. 18 | map f (Cons x xs) = Cons (f x) (map f xs). 19 | 20 | bind : x -> {x -> y} -> y. 21 | bind bx f = f bx. 22 | 23 | abort : [Abort]x. 24 | abort = bind (aborting!) {}. 25 | 26 | semi : x -> y -> y. 27 | semi x y = y. 28 | 29 | sends : (List x) -> [Send x]Unit. 30 | sends xs = semi (map send xs) Unit. 31 | 32 | helpCatter : List x -> [Receive (List x)]List x. 33 | helpCatter Nil = Nil. 34 | helpCatter cxs = append cxs (catter!). 35 | 36 | catter : [Receive (List x)](List x). 37 | catter = bind (receive!) helpCatter. 38 | 39 | {- thinking -} 40 | {- 41 | catter : [Receive (List X)](List X). 42 | catter 0 = nil. 43 | catter n = bind! (receive!) { nil -> nil 44 | | cxs -> append! cxs (catter! (minus! n 1)) }. 45 | -} 46 | 47 | pipe : [Send x]Unit -> [Receive x]y -> [Abort]y. 48 | pipe [_] y = y. 49 | pipe Unit [_] = abort!. 50 | pipe [send x -> s] [receive -> r] = pipe (s Unit) (r x). 51 | 52 | {- Test the matching of any thunk "[_]" in pipe pattern 1 (topmost) -} 53 | fibSendOneMoreTime : List (List Int). 54 | fibSendOneMoreTime = Cons 55 | (Cons 1 Nil) 56 | (Cons 57 | (Cons 1 (Cons 2 Nil)) 58 | (Cons 59 | (Cons 3 (Cons 5 (Cons 8 Nil))) 60 | (Cons 61 | (Nil) 62 | (Cons 63 | (Nil) 64 | Nil)))). 65 | 66 | {- [[1],[1,2],[3,5,8],[],[]] -} 67 | 68 | {- Test the matching of any thunk "[_]" in pipe pattern 2 -} 69 | fib : (List (List Int)). 70 | fib = Nil. 71 | 72 | sender : [Send (List Int)]Unit. 73 | sender = sends (fibSendOneMoreTime!). 74 | 75 | senderOfNothin : [Send (List Int)]Unit. 76 | senderOfNothin = sends (fib!). 77 | 78 | {- 79 | length : (List x) -> Int. 80 | length Nil = 0. 81 | length (Cons x xs) = plus 1 (length xs). 82 | -} 83 | 84 | main : [Abort](List Int). 85 | main = pipe (sender!) (catter!). {- (length! (fib!))).-} 86 | -------------------------------------------------------------------------------- /tests/should-pass/eval/pipe_with_let.fk: -------------------------------------------------------------------------------- 1 | data List x = Nil : x 2 | | Cons : x -> (List x) -> (List x). 3 | 4 | data Zero =. 5 | 6 | append : (List x) -> (List x) -> (List x). 7 | append Nil ys = ys. 8 | append (Cons ax xs) ys = Cons ax (append xs ys). 9 | 10 | interface Send x = send : x -> Unit. 11 | 12 | interface Receive x = receive : x. 13 | 14 | interface Abort = aborting : Zero. 15 | 16 | map : {a -> b} -> (List a) -> (List b). 17 | map f Nil = Nil. 18 | map f (Cons x xs) = Cons (f x) (map f xs). 19 | 20 | abort : [Abort]x. 21 | abort = let x = aborting! in {}. 22 | 23 | semi : x -> y -> y. 24 | semi x y = y. 25 | 26 | sends : (List x) -> [Send x]Unit. 27 | sends xs = semi (map send xs) Unit. 28 | 29 | helpCatter : List x -> [Receive (List x)]List x. 30 | helpCatter Nil = Nil. 31 | helpCatter cxs = append cxs (catter!). 32 | 33 | catter : [Receive (List x)](List x). 34 | catter = let xs = receive! in helpCatter xs. 35 | 36 | pipe : [Send x]Unit -> [Receive x]y -> [Abort]y. 37 | pipe [_] y = y. 38 | pipe Unit [_] = abort!. 39 | pipe [send x -> s] [receive -> r] = pipe (s Unit) (r x). 40 | 41 | {- Test the matching of any thunk "[_]" in pipe pattern 1 (topmost) -} 42 | fibSendOneMoreTime : List (List Int). 43 | fibSendOneMoreTime = Cons 44 | (Cons 1 Nil) 45 | (Cons 46 | (Cons 1 (Cons 2 Nil)) 47 | (Cons 48 | (Cons 3 (Cons 5 (Cons 8 Nil))) 49 | (Cons 50 | (Nil) 51 | (Cons 52 | (Nil) 53 | Nil)))). 54 | 55 | {- [[1],[1,2],[3,5,8],[],[]] -} 56 | 57 | {- Test the matching of any thunk "[_]" in pipe pattern 2 -} 58 | fib : (List (List Int)). 59 | fib = Nil. 60 | 61 | sender : [Send (List Int)]Unit. 62 | sender = sends (fibSendOneMoreTime!). 63 | 64 | senderOfNothin : [Send (List Int)]Unit. 65 | senderOfNothin = sends (fib!). 66 | 67 | main : [Abort](List Int). 68 | main = pipe (sender!) (catter!). 69 | -------------------------------------------------------------------------------- /tests/should-pass/eval/print_map.fk: -------------------------------------------------------------------------------- 1 | data List x = Nil : x 2 | | Cons : x -> (List x) -> (List x). 3 | 4 | map : {a -> b} -> (List a) -> (List b). 5 | map f Nil = Nil. 6 | map f (Cons x xs) = Cons (f x) (map f xs). 7 | 8 | semi : x -> y -> y. 9 | semi x y = y. 10 | 11 | main : [Console]List Int. 12 | main = map (semi (putStrLn "Hello, World!") {x -> plus x 1}) 13 | (Cons 1 (Cons 2 (Cons 3 Nil))). 14 | {- 15 | Expected output: 16 | ---------------- 17 | Hello, World! 18 | [2, 3, 4] 19 | -} 20 | -------------------------------------------------------------------------------- /tests/should-pass/eval/state.fk: -------------------------------------------------------------------------------- 1 | data List a = Nil : List a 2 | | Cons : a -> List a -> List a. 3 | 4 | data Pair a b = Pair : a -> b -> Pair a b. 5 | 6 | interface State x = get : x 7 | | put : x -> Unit. 8 | 9 | 10 | bind : a -> {a -> b} -> b. 11 | bind m f = f m. 12 | 13 | semi : a -> b -> b. 14 | semi x y = y. 15 | 16 | not : Bool -> Bool. 17 | not true = false. 18 | not false = true. 19 | 20 | evalState : s -> [State s]a -> a. 21 | evalState s v = v. 22 | evalState s [put s' -> k] = evalState s' (k Unit). 23 | evalState s [get -> k] = evalState s (k s). 24 | 25 | logState : s -> [State s]a -> Pair a (List s). 26 | logState s v = Pair v (Cons s Nil). 27 | logState s [put t -> k] = 28 | bind (logState t (k Unit)) {(Pair v ss) -> Pair v (Cons s ss)}. 29 | logState s [get -> k] = logState s (k s). 30 | 31 | toggle : [State Bool]Bool. 32 | toggle = bind (get!) {x -> semi (put (not x)) x}. 33 | 34 | main : Pair Bool (List Bool). 35 | main = logState true (toggle!). 36 | {- main : Bool. -} 37 | {- main = evalState true (toggle!). -} 38 | -------------------------------------------------------------------------------- /tests/should-pass/eval/thrice_manual.fk: -------------------------------------------------------------------------------- 1 | data Zero =. 2 | 3 | interface Send x = send : x -> Unit. 4 | 5 | interface Receive x = receive : x. 6 | 7 | interface Abort = aborting : Zero. 8 | 9 | bind : x -> {x -> y} -> y. 10 | bind bx f = f bx. 11 | 12 | abort : [Abort]x. 13 | abort = bind (aborting!) {}. 14 | 15 | semi : x -> y -> y. 16 | semi x y = y. 17 | 18 | pipe : [Send x, Console]Unit -> [Receive x]y -> [Abort,Console]y. 19 | pipe [send x -> s] y = pipe (s Unit) y. 20 | pipe Unit y = y. 21 | {- Compiler generated clauses for all commands not handled by handler. -} 22 | pipe [putStrLn s -> k] y = let x = putStrLn s in pipe (k x) y. 23 | {- End of compiler generated clause list. -} 24 | pipe Unit [_] = abort!. 25 | pipe [send x -> s] [receive -> r] = pipe (s Unit) (r x). 26 | 27 | main : [Abort, Console]Bool. 28 | main = pipe (semi (putStrLn "Once") 29 | (semi (send 1) 30 | (semi (putStrLn "Twice") 31 | (semi (send 2) 32 | (semi (putStrLn "Three") 33 | (semi (send 3) 34 | (putStrLn "Four"))))))) 35 | (semi (receive!) (semi (receive!) true)). 36 | -------------------------------------------------------------------------------- /tests/should-pass/parsing/comment.fk: -------------------------------------------------------------------------------- 1 | {- Testing out comments. -} 2 | data Nat = Zero : Nat 3 | | Suc : Nat -> Nat. 4 | 5 | data List x = Nil : List x 6 | | Cons : x -> List x -> List x. 7 | 8 | append : List x -> List x -> List x. 9 | append Nil ys = ys. 10 | append (Cons x xs) ys = Cons x (append xs ys). 11 | 12 | {- 13 | plus [?c -> k] [t] = let x = c! in plus (k! x) t! 14 | plus [t] [?c -> k] = let x = c! in plus t! (k! x) 15 | 16 | # plus (h (suc zero)) zero 17 | # --> 18 | # plus comp zero 19 | 20 | 21 | -} 22 | 23 | interface State x = get : x | put : x -> Unit. 24 | 25 | interface Receive x = receive : x. 26 | 27 | fmap : {a -> b} -> List a -> List b. 28 | fmap f Nil = Nil. 29 | fmap f (Cons x xs) = Cons (f x) (fmap f xs). 30 | 31 | bind : x -> {x -> y} -> y. 32 | bind x f = f x. 33 | 34 | {- {- {- p[ef[##'####'##esaojdknsafoewowowo {{{{{a- 35 | pi : {[]Int} 36 | pi = 3.142 ##~~~ ü 37 | -} 38 | g x y = x + y 39 | 40 | f x = { y -> plus x y } 41 | -} 42 | main = {f! 42} 43 | -} 44 | 45 | main : Int. 46 | main = 0. 47 | -------------------------------------------------------------------------------- /tests/should-pass/parsing/hello.fk: -------------------------------------------------------------------------------- 1 | interface State x = get : x 2 | | put : x -> Unit. 3 | 4 | interface Receive x = receive : x. 5 | 6 | runState : x -> [State x]y -> y. 7 | runState x [put x' -> k] = runState x' (k Unit). 8 | runState x [get -> k] = runState x (k x). 9 | runState x y = y. 10 | 11 | main : Bool. 12 | main = runState 3 (gt (get!) 2). 13 | -------------------------------------------------------------------------------- /tests/should-pass/parsing/string.fk: -------------------------------------------------------------------------------- 1 | interface State x = get : x 2 | | put : x -> Unit. 3 | 4 | interface Receive x = receive : x. 5 | 6 | semi : x -> y -> y. 7 | semi x y = y. 8 | 9 | runState : x -> [State x]y -> y. 10 | runState x [put x' -> k] = runState x' (k Unit). 11 | runState x [get -> k] = runState x (k x). 12 | runState x y = y. 13 | 14 | main : String. 15 | main = runState "Hello" (semi (put (strcat (get!) " World!\n")) (get!)). 16 | -------------------------------------------------------------------------------- /tests/should-pass/typing/bind-eff.fk: -------------------------------------------------------------------------------- 1 | interface Get = get : Int. 2 | 3 | bind : x -> {x -> y} -> y. 4 | bind x f = f x. 5 | 6 | foo : [Get]Int. 7 | foo = get!. 8 | 9 | {- all of the following should type-check - none does -} 10 | main : Int. 11 | main = bind {foo} {_ -> 42}. 12 | {-main = bind {foo!} {x -> x}.-} 13 | {-main = bind {get} {_ -> 42}.-} 14 | {-main = bind {get!} {_ -> 42}.-} 15 | -------------------------------------------------------------------------------- /tests/should-pass/typing/does_sub.fk: -------------------------------------------------------------------------------- 1 | data Zero=. 2 | 3 | interface Send x = send : x -> Unit. 4 | 5 | interface Abort = aborting : Zero. 6 | 7 | bind : x -> {x -> y} -> y. 8 | bind x f = f x. 9 | 10 | abort : [Abort]x. 11 | abort = bind (aborting!) {}. 12 | 13 | pats : [Send x]a -> [Abort]a. 14 | pats [t] = pats (t!). {- NB: makes pats non-terminating -} 15 | pats [send x -> k] = pats (k Unit). 16 | pats x = x. 17 | 18 | suspat : {[Send x]a} -> [Abort]a. 19 | suspat m = pats (m!). 20 | 21 | addAbort : a -> [Abort]a. 22 | addAbort x = x. 23 | 24 | eatAbort : [Abort]a -> a. 25 | eatAbort x = x. 26 | eatAbort [t] = eatAbort (t!). 27 | 28 | foo : {a} -> [Abort]a. 29 | foo m = addAbort (m!). 30 | 31 | bar : {a} -> a. 32 | bar m = eatAbort (foo m). 33 | 34 | baz : {[Abort]Int}. 35 | baz = bind {abort!} {x -> x}. 36 | 37 | main : Int. 38 | main = 0. 39 | -------------------------------------------------------------------------------- /tests/should-pass/typing/dup_ref_ambient.fk: -------------------------------------------------------------------------------- 1 | data List x = Nil : List x 2 | | Cons : x -> (List x) -> (List x). 3 | 4 | data Cont x = Z : Cont x 5 | | S : x -> Cont x. 6 | 7 | interface Send x = send : x -> Unit. 8 | 9 | produceList : x -> [Send (List x)]Unit. 10 | produceList m = send (Cons m Nil). 11 | 12 | dup : Cont x -> [Send (List x)]Unit. 13 | dup Z = Unit. 14 | {- r?£1, Send (List |r?x7|), Send (List |r?x7|) DOES r?£1, Send (List r?x7) -} 15 | dup (S n) = produceList n. 16 | 17 | main : Int. 18 | main = 0. 19 | -------------------------------------------------------------------------------- /tests/should-pass/typing/inst_ambient.fk: -------------------------------------------------------------------------------- 1 | data List x = Nil : List x 2 | | Cons : x -> (List x) -> (List x). 3 | 4 | data Cont x = Z : Cont x 5 | | S : x -> Cont x. 6 | 7 | interface Send x = send : x -> Unit. 8 | 9 | produceList : x -> [Send (List x)]Unit. 10 | produceList m = send (Cons m Nil). 11 | 12 | bind : x -> {x -> y} -> y. 13 | bind x f = f x. 14 | 15 | p : {x} -> x. 16 | p x = x!. 17 | 18 | tvar : Cont x -> [Send (List x)]Unit. 19 | tvar Z = Unit. 20 | {- Need to instantiate x type variable in ambient: £, Send (List r?x) -} 21 | tvar (S n) = bind (p {n}) produceList. 22 | 23 | main : Int. 24 | main = 0. 25 | -------------------------------------------------------------------------------- /tests/should-pass/typing/map.fk: -------------------------------------------------------------------------------- 1 | data List x = Nil : x 2 | | Cons : x -> (List x) -> (List x). 3 | 4 | map : {a -> b} -> (List a) -> (List b). 5 | map f Nil = Nil. 6 | map f (Cons x xs) = Cons (f x) (map f xs). 7 | 8 | main : List Int. 9 | main = map {xs -> xs} (Cons 1 (Cons 2 (Cons 3 Nil))). 10 | -------------------------------------------------------------------------------- /tests/should-pass/typing/map2.fk: -------------------------------------------------------------------------------- 1 | data List x = Nil : x 2 | | Cons : x -> (List x) -> (List x). 3 | 4 | data Zero =. 5 | 6 | append : (List x) -> (List x) -> (List x). 7 | append Nil ys = ys. 8 | append (Cons ax xs) ys = Cons ax (append xs ys). 9 | 10 | interface Send x = send : x -> Unit. 11 | 12 | interface Receive z = receive : z. 13 | 14 | interface Abort = aborting : Zero. 15 | 16 | map : {a -> b} -> (List a) -> (List b). 17 | map f Nil = Nil. 18 | map f (Cons x xs) = Cons (f x) (map f xs). 19 | 20 | bind : x -> {x -> y} -> y. 21 | bind bx f = f bx. 22 | 23 | abort : [Abort]x. 24 | abort = bind (aborting!) {}. 25 | 26 | semi : x -> y -> y. 27 | semi x y = y. 28 | 29 | sends : (List x) -> [Send x]Unit. 30 | sends xs = semi (map send xs) Unit. 31 | 32 | pipe : [Send x]Unit -> [Receive x]y -> [Abort]y. 33 | pipe [_] y = y. 34 | pipe Unit [_] = abort!. 35 | pipe [send px -> s] [receive -> r] = pipe (s Unit) (r px). 36 | 37 | {- Test the matching of any thunk "[_]" in pipe pattern 1 (topmost) -} 38 | fibSendOneMoreTime : List (List Int). 39 | fibSendOneMoreTime = Cons 40 | (Cons 1 Nil) 41 | (Cons 42 | (Cons 1 (Cons 2 Nil)) 43 | (Cons 44 | (Cons 3 (Cons 5 (Cons 8 Nil))) 45 | (Cons 46 | Nil 47 | (Cons 48 | Nil 49 | Nil)))). 50 | 51 | {- Test the matching of any thunk "[_]" in pipe pattern 2 -} 52 | fib : (List (List Int)). 53 | fib = Nil. 54 | 55 | sender : [Send (List Int)]Unit. 56 | sender = sends (fibSendOneMoreTime!). 57 | 58 | senderOfNothin : [Send (List Int)]Unit. 59 | senderOfNothin = sends (fib!). 60 | 61 | length : (List x) -> Int. 62 | length Nil = 0. 63 | length (Cons x xs) = plus 1 (length xs). 64 | 65 | main : List Int. 66 | main = map {xs -> xs} (Cons 1 (Cons 2 (Cons 3 Nil))). 67 | -------------------------------------------------------------------------------- /tests/should-pass/typing/unify_matching.fk: -------------------------------------------------------------------------------- 1 | data List x = Nil : x 2 | | Cons : x -> (List x) -> (List x). 3 | 4 | interface Receive z = receive : z. 5 | 6 | append : (List x) -> (List x) -> (List x). 7 | append Nil ys = ys. 8 | append (Cons ax xs) ys = Cons ax (append xs ys). 9 | 10 | bind : x -> {x -> y} -> y. 11 | bind bx f = f bx. 12 | 13 | {- This version requires unification to be performed at pattern matching. -} 14 | inlinedCatter : [Receive (List x)](List x). 15 | inlinedCatter = bind (receive!) { Nil -> Nil 16 | | cxs -> append cxs (inlinedCatter!)}. 17 | {- -} 18 | 19 | main : Bool. 20 | main = true. 21 | -------------------------------------------------------------------------------- /typing/midTyping.mli: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | (*********************************************************************** 3 | * Definition of the typing of the mid-level tree. 4 | * 5 | * 6 | * Created by Craig McLaughlin on 7/08/2015. 7 | *********************************************************************** 8 | *) 9 | 10 | exception TypeError of string 11 | 12 | type src_type = ParseTree.src_type 13 | 14 | type env 15 | (** The typing environment constructed during typechecking. *) 16 | 17 | type type_sig = 18 | TSAmbientCmds (* Greatest lower bound for TSCmd signatures w.r.t ambient 19 | effects. *) 20 | | TSAllValues of string option 21 | (* The top element of the lattice for value type signatures. *) 22 | | TSBool of bool 23 | | TSFloat of float 24 | | TSInt of int 25 | | TSStr of string 26 | | TSCmd of string * int (* constructor name and arity. *) 27 | | TSCtr of string * int (* command name and arity *) 28 | deriving (Show) 29 | (** The signature of a type; all its possible head constructors. *) 30 | 31 | module type TSS = sig 32 | type t 33 | val empty : t 34 | (** Return an empty set. *) 35 | val mem : type_sig -> t -> bool 36 | (** Return true if the set contains the specified type signature false 37 | otherwise. *) 38 | val union : t -> t -> t 39 | (** [union s1 s2] returns the union of [s1] and [s2] with the elements in 40 | [s1] preceding the elements of [s2] in the "insertion" order. *) 41 | val add : type_sig -> t -> t 42 | (** Add an type signature to the set if it is not already present. *) 43 | val singleton : type_sig -> t 44 | (** Return a singleton set containing the specified element. *) 45 | val elements : t -> type_sig list 46 | (** Return the list of elements of the given set. The ordering of the 47 | elements in the list respects their insertion order. *) 48 | val diff : t -> t -> t 49 | (** [diff t u] returns the set difference t/u w.r.t to the partial order 50 | defined by the type_sig datatype. *) 51 | val is_ambient : t -> bool 52 | (** [is_ambient t] is [true] iff [t] is a singleton which contains the 53 | [TSAmbientCmds] type signature and [false] otherwise. *) 54 | val all_cmds : t -> bool 55 | (** [all_cmds t] is [true] iff [t] contains only signatures of the form 56 | TSCmd or TSAmbientCmds and [false] otherwise. *) 57 | val is_empty : t -> bool 58 | (** [is_empty t] is [true] iff [t] is empty and [false] otherwise. *) 59 | end 60 | 61 | module TypeSigSet : TSS 62 | (** Set containing type signatures. *) 63 | 64 | val compute_signature : env -> src_type -> TypeSigSet.t 65 | (** [compute_signature env t] compute the signature of the given type with 66 | respect to the given environment. *) 67 | 68 | val compute_arg_types : env -> src_type -> type_sig -> src_type list 69 | (** [compute_arg_types env t tsg] computes the types that are arguments of the 70 | type signature [tsg] w.r.t the type [t], the concrete type of the type 71 | signature. [t] may provide information to the procedure such as the type 72 | at which to instantiate any parameters. *) 73 | 74 | val env_lookup : string -> env -> src_type 75 | (** [env_lookup x env] lookup the string [x] in the typing environment [env] 76 | returning the corresponding type. *) 77 | 78 | val type_prog : MidTree.prog -> src_type * env 79 | (** Typecheck a mid-level tree and return the type and the constructed 80 | environment on success. On failure, a [TypeError] exception is 81 | raised. *) 82 | 83 | val type_error : string -> 'a 84 | (** [type_error s] raise a TypeError exception with the provided string. *) 85 | -------------------------------------------------------------------------------- /typing/unionfind.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cmcl/franklyfrank/6cc1c4f7377ea2a907675ec0fae9ff32829cec83/typing/unionfind.ml -------------------------------------------------------------------------------- /typing/unionfind.mli: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | 3 | type 'a point 4 | deriving (Show) 5 | 6 | val fresh : 'a -> 'a point 7 | val find : 'a point -> 'a 8 | val change : 'a point -> 'a -> unit 9 | val equivalent : 'a point -> 'a point -> bool 10 | val union : 'a point -> 'a point -> unit 11 | -------------------------------------------------------------------------------- /util/debug.ml: -------------------------------------------------------------------------------- 1 | 2 | let do_debug = ref false 3 | 4 | let debug_flag b = do_debug := b 5 | 6 | let print fmt = 7 | let f = if !do_debug then Printf.fprintf else Printf.ifprintf in 8 | f stderr fmt 9 | -------------------------------------------------------------------------------- /util/debug.mli: -------------------------------------------------------------------------------- 1 | (*********************************************************************** 2 | * Debugging facility for displaying intermediate results and internal 3 | * program state. 4 | * 5 | * 6 | * Created by Craig McLaughlin on 30/07/2015. 7 | *********************************************************************** 8 | *) 9 | 10 | val debug_flag : bool -> unit 11 | (** [debug_flag true] enables debugging. [debug_flag false] disables 12 | debugging. Initially, debugging is disabled. *) 13 | 14 | val print : ('a, out_channel, unit) format -> 'a 15 | (** Wrapper over the functionality of [Printf.printf]. *) 16 | -------------------------------------------------------------------------------- /util/listUtils.ml: -------------------------------------------------------------------------------- 1 | 2 | let (++) = List.append 3 | let hd = List.hd 4 | let tl = List.tl 5 | let find = List.find 6 | 7 | let rec repeat x n = if n <= 0 then [] else x :: (repeat x (n-1)) 8 | 9 | let filter_map f xs = 10 | let ff x xs = match f x with 11 | | None -> xs 12 | | Some x -> x :: xs in 13 | List.fold_right ff xs [] 14 | 15 | let map = List.map 16 | 17 | let zip = List.combine 18 | 19 | let foldl = List.fold_left 20 | 21 | let length = List.length 22 | 23 | (** Haskell has a better implementation: Combination of State monad 24 | and Traversable functor. TODO: Investigate such a generalisation. *) 25 | let rec map_accum f a xs = 26 | match xs with 27 | | [] -> (a, []) 28 | | x :: xs' -> let (a', x') = f a x in 29 | let (a'', xs'') = map_accum f a' xs' in 30 | (a'', x' :: xs'') 31 | 32 | let swap zs i j = 33 | let rec swap' x y zs = 34 | match zs with 35 | | [] -> [] 36 | | (n, z) :: zs -> (if i = n then y 37 | else if j = n then x 38 | else z) :: (swap' x y zs) in 39 | let (_, zs) = map_accum (fun i z -> (i+1, (i, z))) 0 zs in 40 | let (_, x) = find (fun (n, _) -> n = i) zs in 41 | let (_, y) = find (fun (n, _) -> n = j) zs in 42 | swap' x y zs 43 | 44 | let rec transpose xss = 45 | match xss with 46 | | [] -> [] 47 | | [] :: xss -> transpose xss 48 | | (x :: xs) :: xss -> (x :: (map hd xss)) :: (transpose (xs :: map tl xss)) 49 | -------------------------------------------------------------------------------- /util/listUtils.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Some list helper functions which are supplied by other libraries but for 3 | * which I'd rather not create an unnecessary dependency. 4 | * 5 | * Created by Craig McLaughlin on 29/07/2015. 6 | ***********************************************************************) 7 | 8 | val (++) : 'a list -> 'a list -> 'a list 9 | 10 | val repeat : 'a -> int -> 'a list 11 | (** [repeat x n] returns a list of length [n] all elements of which are 12 | initialised to [x]. Return the empty list for [n <= 0]. *) 13 | 14 | val filter_map : ('a -> 'b option) -> 'a list -> 'b list 15 | (** [filter_map f as]: Return the elements of [as] for which [f] returned 16 | a [Some b] for some [b]. In other words, discard the [None]s. *) 17 | 18 | val map : ('a -> 'b) -> 'a list -> 'b list 19 | 20 | val zip : 'a list -> 'b list -> ('a * 'b) list 21 | 22 | val foldl : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a 23 | 24 | val length : 'a list -> int 25 | 26 | val map_accum : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list 27 | (** Traverse the list accumulating a result as the first element of 28 | a pair and the resulting list as the second element. *) 29 | 30 | val swap : 'a list -> int -> int -> 'a list 31 | (** [swap xs i j] swap element at position [i] with the element at position 32 | [j] and return the resulting list. *) 33 | 34 | val transpose : 'a list list -> 'a list list 35 | (** Take a NxM matrix and return an MxN matrix. Raises a Failure exception 36 | if any of the inner lists are empty. *) 37 | -------------------------------------------------------------------------------- /util/monad.mli: -------------------------------------------------------------------------------- 1 | (*********************************************************************** 2 | * Monadic module types and some basic functions. 3 | * 4 | * 5 | * Created by Craig McLaughlin on 27/07/2015. 6 | *********************************************************************** 7 | *) 8 | 9 | 10 | module type MONAD = sig 11 | type 'a t 12 | val return : 'a -> 'a t 13 | val (>>=) : 'a t -> ('a -> 'b t) -> 'b t 14 | end 15 | -------------------------------------------------------------------------------- /util/show.ml: -------------------------------------------------------------------------------- 1 | module type SHOW = sig 2 | type t 3 | val show : t -> string 4 | end 5 | 6 | module ShowList (X : SHOW) : SHOW with type t = X.t list = struct 7 | type t = X.t list 8 | let show xs = String.concat "\n" (List.map X.show xs) ^ "\n" 9 | end 10 | -------------------------------------------------------------------------------- /util/show.mli: -------------------------------------------------------------------------------- 1 | (*********************************************************************** 2 | * Show Typeclass as a module. 3 | * 4 | * Created by Craig McLaughlin on 28/07/2015. 5 | *********************************************************************** 6 | *) 7 | 8 | module type SHOW = sig 9 | type t 10 | val show : t -> string 11 | end 12 | 13 | module ShowList (X : SHOW) : SHOW with type t = X.t list 14 | (** Default show operation over lists. *) 15 | -------------------------------------------------------------------------------- /util/utility.ml: -------------------------------------------------------------------------------- 1 | let (@) f g = fun x -> f (g x) 2 | 3 | let curry f x y = f (x, y) 4 | 5 | let uncurry f (x, y) = f x y 6 | -------------------------------------------------------------------------------- /util/utility.mli: -------------------------------------------------------------------------------- 1 | (*********************************************************************** 2 | * Useful utilities that I define here rather than import a library. 3 | * 4 | * 5 | * Created by Craig McLaughlin on 27/08/2015. 6 | *********************************************************************** 7 | *) 8 | 9 | val (@) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b 10 | (** Function composition *) 11 | 12 | val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c 13 | 14 | val uncurry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c 15 | --------------------------------------------------------------------------------