syntax.ml

   1: (** Abstract syntax *)
   2: 
   3: (** The type of variable names. *)
   4: type name = string
   5: 
   6: (** MiniHaskell types. *)
   7: type htype =
   8:     TInt (** integer [int] *)
   9:   | TBool (** booleans [bool] *)
  10:   | TTimes of htype * htype  (** Product [s * t] *)
  11:   | TArrow of htype * htype  (** Function type *)
  12:   | TList of htype (** Lists [t list] *)
  13: 
  14: (** MiniHaskell expressions *)
  15: type expr =
  16:     Var of name          (** variable *)
  17:   | Int of int           (** integer constant *)
  18:   | Bool of bool         (** boolean constant *)
  19:   | Times of expr * expr (** product [e1 * e2] *)
  20:   | Divide of expr * expr(** quotient [e1 / e2] *)
  21:   | Mod of expr * expr   (** remainder [e1 % e2] *)
  22:   | Plus of expr * expr  (** sum [e1 + e2] *)
  23:   | Minus of expr * expr (** difference [e1 - e2] *)
  24:   | Equal of expr * expr (** integer equality [e1 = e2] *)
  25:   | Less of expr * expr  (** integer comparison [e1 < e2] *)
  26:   | If of expr * expr * expr (** conditional [if e1 then e2 else e3] *)
  27:   | Fun of name * htype * expr (** function [fun x:t -> e] *)
  28:   | Apply of expr * expr (** application [e1 e2] *)
  29:   | Pair of expr * expr  (** pair [(e1, e2)] *)
  30:   | Fst of expr          (** first projection [fst e] *)
  31:   | Snd of expr          (** second projection [snd e] *)
  32:   | Rec of name * htype * expr (** recursion [rec x:t is e] *)
  33:   | Nil of htype         (** empty list *)
  34:   | Cons of expr * expr  (** cons list [e1 :: e2] *)
  35:   | Match of expr * htype * expr * name * name * expr (** list decomposition [match e with [t] -> e1 | x::y -> e2] *)
  36: 
  37: (** Toplevel commands *)
  38: type toplevel_cmd =
  39:     Expr of expr       (** an expression to be evaluated *)
  40:   | Def of name * expr (** toplevel definition [let x = e] *)
  41:   | Use of string      (** load a file [$use "<filename>"] *)
  42:   | Quit               (** exit toplevel [$quit] *)
  43: 
  44: (** Conversion from a type to a string *)
  45: let string_of_type ty =
  46:   let rec to_str n ty =
  47:     let (m, str) =
  48:       match ty with
  49:           TInt -> (4, "int")
  50:         | TBool -> (4, "bool")
  51:         | TList ty -> (3, to_str 3 ty ^ " list")
  52:         | TTimes (ty1, ty2) -> (2, (to_str 2 ty1) ^ " * " ^ (to_str 2 ty2))
  53:         | TArrow (ty1, ty2) -> (1, (to_str 1 ty1) ^ " -> " ^ (to_str 0 ty2))
  54:     in
  55:       if m > n then str else "(" ^ str ^ ")"
  56:   in
  57:     to_str (-1) ty
  58: 
  59: (** Conversion from an expression to a string *)
  60: let string_of_expr e =
  61:   let rec to_str n e =
  62:     let (m, str) =
  63:       match e with
  64:           Int n ->          (10, string_of_int n)
  65:         | Bool b ->         (10, string_of_bool b)
  66:         | Var x ->          (10, x)
  67:         | Pair (e1, e2) ->  (10, "(" ^ (to_str 0 e1) ^ ", " ^ (to_str 0 e2) ^ ")")
  68:         | Nil ty ->         (10, "[" ^ (string_of_type ty) ^ "]")
  69:         | Fst e ->           (9, "fst " ^ (to_str 9 e))
  70:         | Snd e ->           (9, "snd " ^ (to_str 9 e))
  71:         | Apply (e1, e2) ->  (10, "<app>")
  72:             (* (9, (to_str 8 e1) ^ " " ^ (to_str 9 e2)) *)
  73:         | Times (e1, e2) ->  (8, (to_str 7 e1) ^ " * " ^ (to_str 8 e2))
  74:         | Divide (e1, e2) -> (8, (to_str 7 e1) ^ " / " ^ (to_str 8 e2))
  75:         | Mod (e1, e2) ->    (8, (to_str 7 e1) ^ " % " ^ (to_str 8 e2))
  76:         | Plus (e1, e2) ->   (7, (to_str 6 e1) ^ " + " ^ (to_str 7 e2))
  77:         | Minus (e1, e2) ->  (7, (to_str 6 e1) ^ " - " ^ (to_str 7 e2))
  78:         | Cons (e1, e2) ->   (6, (to_str 6 e1) ^ " :: " ^ (to_str 5 e2))
  79:         | Equal (e1, e2) ->  (5, (to_str 5 e1) ^ " = " ^ (to_str 5 e2))
  80:         | Less (e1, e2) ->   (5, (to_str 5 e1) ^ " < " ^ (to_str 5 e2))
  81:         | If (e1, e2, e3) -> (4, "if " ^ (to_str 4 e1) ^ " then " ^
  82:                                 (to_str 4 e2) ^ " else " ^ (to_str 4 e3))
  83:         | Match (e1, ty, e2, x, y, e3) ->
  84:             (3, "match " ^ (to_str 3 e1) ^ " with " ^
  85:                "[" ^ (string_of_type ty) ^ "] -> " ^ (to_str 3 e2) ^ " | " ^
  86:                x ^ "::" ^ y ^ " -> " ^ (to_str 3 e3))
  87:         | Fun (x, ty, e) -> (10, "<fun>")
  88:             (* (2, "fun " ^ x ^ " : " ^ (string_of_type ty) ^ " -> " ^ (to_str 0 e)) *)
  89:         | Rec (x, ty, e) -> (10, "<rec>")
  90:             (* (1, "rec " ^ x ^ " : " ^ (string_of_type ty) ^ " is " ^ (to_str 0 e)) *)
  91:                
  92:     in
  93:       if m > n then str else "(" ^ str ^ ")"
  94:   in
  95:     to_str (-1) e
  96: 
  97: (** [subst [(x1,e1);...;(xn;en)] e] replaces in [e] free occurrences
  98:     of variables [x1], ..., [xn] with expressions [e1], ..., [en]. *)
  99: let rec subst s = function
 100:   |  (Var x) as e -> (try List.assoc x s with Not_found -> e)
 101:   | (Int _ | Bool _ | Nil _) as e -> e
 102:   | Times (e1, e2) -> Times (subst s e1, subst s e2)
 103:   | Divide (e1, e2) -> Divide (subst s e1, subst s e2)
 104:   | Mod (e1, e2) -> Mod (subst s e1, subst s e2)
 105:   | Plus (e1, e2) -> Plus (subst s e1, subst s e2)
 106:   | Minus (e1, e2) -> Minus (subst s e1, subst s e2)
 107:   | Equal (e1, e2) -> Equal (subst s e1, subst s e2)
 108:   | Cons (e1, e2) -> Cons  (subst s e1, subst s e2)
 109:   | Less (e1, e2) -> Less (subst s e1, subst s e2)
 110:   | If (e1, e2, e3) -> If (subst s e1, subst s e2, subst s e3)
 111:   | Fun (x, ty, e) -> let s' = List.remove_assoc x s in Fun (x, ty, subst s' e)
 112:   | Rec (x, ty, e) -> let s' = List.remove_assoc x s in Rec (x, ty, subst s' e)
 113:   | Match (e1, ty, e2, x, y, e3) ->
 114:       let s' = List.remove_assoc y (List.remove_assoc x s) in
 115:         Match (subst s e1, ty, subst s e2, x, y, subst s' e3)
 116:   | Apply (e1, e2) -> Apply (subst s e1, subst s e2)
 117:   | Pair (e1, e2) -> Pair (subst s e1, subst s e2)
 118:   | Fst e -> Fst (subst s e)
 119:   | Snd e -> Snd (subst s e)

type_check.ml

   1: (** Type checking. *)
   2: 
   3: open Syntax
   4: 
   5: (** Exception indicating a type-checking error. *)
   6: exception Type_error of string
   7: 
   8: (** [ty_error msg] raises exception [Type_error msg]. *)
   9: let type_error msg = raise (Type_error msg)
  10: 
  11: (** [check ctx ty e] checks that expression [e] has type [ty] in context [ctx].
  12:     It raises [Type_error] if it does not. *)
  13: let rec check ctx ty e =
  14:   let ty' = type_of ctx e in
  15:     if ty' <> ty then
  16:       type_error
  17:         (string_of_expr e ^ " has type " ^ string_of_type ty' ^
  18:          " but is used as if it had type " ^ string_of_type ty)
  19: 
  20: (** [type-of ctx e] computes the type of expression [e] in context [ctx].
  21:     It raises [Type_error] if [e] does not have a type. *)
  22: and type_of ctx = function
  23:   | Var x ->
  24:       (try List.assoc x ctx with
  25:            Not_found -> type_error ("unknown identifier " ^ x))
  26:   | Int _ -> TInt
  27:   | Bool _ -> TBool
  28:   | Nil ty -> TList ty
  29:   | Times (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TInt
  30:   | Divide (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TInt
  31:   | Mod (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TInt
  32:   | Plus (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TInt
  33:   | Cons (e1, e2) -> let ty = type_of ctx e1 in check ctx (TList ty) e2; TList ty
  34:   | Minus (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TInt
  35:   | Equal (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TBool
  36:   | Less (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TBool
  37:   | If (e1, e2, e3) ->
  38:       check ctx TBool e1 ;
  39:       let ty = type_of ctx e2 in
  40:         check ctx ty e3 ; ty
  41:   | Fun (x, ty, e) -> TArrow (ty, type_of ((x,ty)::ctx) e)
  42:   | Rec (x, ty, e) -> check ((x,ty)::ctx) ty e; ty
  43:   | Match (e1, ty, e2, x, y, e3) ->
  44:       (match type_of ctx e1 with
  45:            TList ty1 ->
  46:              check ctx (TList ty) e1;
  47:              let ty2 = type_of ctx e2 in
  48:                check ((x,ty)::(y, TList ty)::ctx) ty2 e3 ; ty2
  49:          | ty -> type_error (string_of_expr e1 ^
  50:                             " is used as a list but its type is " ^
  51:                             string_of_type ty))
  52:   | Apply (e1, e2) ->
  53:       (match type_of ctx e1 with
  54:            TArrow (ty1, ty2) -> check ctx ty1 e2 ; ty2
  55:          | ty ->
  56:              type_error (string_of_expr e1 ^
  57:                          " is used as a function but its type is " ^
  58:                          string_of_type ty))
  59:         | Pair (e1, e2) -> TTimes (type_of ctx e1, type_of ctx e2)
  60:   | Fst e ->
  61:       (match type_of ctx e with
  62:            TTimes (ty1, _) -> ty1
  63:          | ty ->
  64:              type_error (string_of_expr e ^
  65:                          " is used as a pair but its type is " ^
  66:                          string_of_type ty))
  67:   | Snd e ->
  68:       (match type_of ctx e with
  69:            TTimes (_, ty2) -> ty2
  70:          | ty ->
  71:              type_error (string_of_expr e ^
  72:                          " is used as a pair but its type is " ^
  73:                          string_of_type ty))
  74: 

eval.ml

   1: (** Small step semantics, for demonstration purposes only. *)
   2: 
   3: open Syntax
   4: 
   5: (** [is_value e] returns [true], if [e] is a value. *)
   6: let rec is_value = function
   7:     Int _ | Bool _ | Fun _ | Nil _ | Cons _ | Pair _ -> true
   8:   | Var _ | Times _ | Divide _ | Mod _ | Plus _ | Minus _
   9:   | Equal _ | Less _ | If _ | Apply _
  10:   | Match _ | Rec _ | Fst _ | Snd _ -> false
  11: 
  12: (** Expression [Eval_error] indicates a runtime error. *)
  13: exception Eval_error
  14: 
  15: (** [eval1 e] performs one evaluation step of program [e]. If there is
  16:     no next step, it raises [Eval_error], which happens if [e] is a value
  17:     or if [e] gets stuck. *)
  18: let rec eval1 = function
  19:   | Var _ | Int _ | Bool _ | Fun _ | Nil _ | Pair _ | Cons _ -> raise Eval_error
  20:   | Times (Int k1, Int k2) -> Int (k1 * k2)
  21:   | Times (Int k1, e2)     -> Times (Int k1, eval1 e2)
  22:   | Times (e1, e2)         -> Times (eval1 e1, e2)
  23:   | Divide (Int k1, Int k2)-> Int (k1 / k2)
  24:   | Divide (Int k1, e2)    -> Divide (Int k1, eval1 e2)
  25:   | Divide (e1, e2)        -> Divide (eval1 e1, e2)
  26:   | Mod (Int k1, Int k2)   -> Int (k1 mod k2)
  27:   | Mod (Int k1, e2)       -> Mod (Int k1, eval1 e2)
  28:   | Mod (e1, e2)           -> Mod (eval1 e1, e2)
  29:   | Plus (Int k1, Int k2)  -> Int (k1 + k2)
  30:   | Plus (Int k1, e2)      -> Plus (Int k1, eval1 e2)
  31:   | Plus (e1, e2)          -> Plus (eval1 e1, e2)
  32:   | Minus (Int k1, Int k2) -> Int (k1 - k2)
  33:   | Minus (Int k1, e2)     -> Minus (Int k1, eval1 e2)
  34:   | Minus (e1, e2)         -> Minus (eval1 e1, e2)
  35:   | Equal (Int k1, Int k2) -> Bool (k1 = k2)
  36:   | Equal (Int k1, e2)     -> Equal (Int k1, eval1 e2)
  37:   | Equal (e1, e2)         -> Equal (eval1 e1, e2)
  38:   | Less (Int k1, Int k2)  -> Bool (k1 < k2)
  39:   | Less (Int k1, e2)      -> Less (Int k1, eval1 e2)
  40:   | Less (e1, e2)          -> Less (eval1 e1, e2)
  41:   | If (Bool true, e2, e3) -> e2
  42:   | If (Bool false, e2, e3)-> e3
  43:   | If (e1, e2, e3)        -> If (eval1 e1, e2, e3)
  44:   | Apply (Fun (x, _, e), e2) -> subst [(x, e2)] e
  45:   | Apply (e1, e2) -> Apply (eval1 e1, e2)
  46:   | Rec (x, _, e') as e -> subst [(x,e)] e'
  47:   | Match (Nil _, _, e, _, _, _) -> e
  48:   | Match (Cons (e1, e2), _, _, x, y, e) -> subst [(x,e1);(y,e2)] e
  49:   | Match (e1, ty, e2, x, y, e3) -> Match (eval1 e1, ty, e2, x, y, e3)
  50:   | Fst (Pair (e1, _)) -> e1
  51:   | Fst e -> Fst (eval1 e)
  52:   | Snd (Pair (_, e2)) -> e2
  53:   | Snd e -> Snd (eval1 e)
  54: 
  55: (** [eval n e] evaluates program [e]. It raises [Eval_error] if [e] gets stuck.
  56:     It forces up to [n] levels of evaluation in pairs and lists. This function
  57:     is inefficient and is here for demostration purposes only. See module [Interpret]
  58:     for a more efficient version.
  59: *)
  60: let rec eval n e =
  61:   let rec loop = function
  62:       Pair (e1, e2) -> Pair (eval (n-1) e1, eval (n-1) e2)
  63:     | Cons (e1, e2) -> Cons (eval n e1, if n <= 0 then e2 else eval (n-1) e2)
  64:     | e when is_value e -> e
  65:     | e -> loop (eval1 e)
  66:   in
  67:     loop e

interpret.ml

   1: (** An efficient interpreter. *)
   2: 
   3: open Syntax
   4: 
   5: type environment = (name * value ref) list
   6: 
   7: and value =
   8:   | VInt of int
   9:   | VBool of bool
  10:   | VNil of htype
  11:   | VClosure of environment * expr
  12: 
  13: exception Runtime_error of string
  14: 
  15: let runtime_error msg = raise (Runtime_error msg)
  16: 
  17: let rec interp env = function
  18:   | Var x ->
  19:       (try
  20:          let r = List.assoc x env in
  21:            match !r with
  22:                VClosure (env', e) -> let v = interp env' e in r := v ; v
  23:              | v -> v
  24:        with
  25:            Not_found -> runtime_error ("Unknown variable " ^ x))
  26:   | Int k -> VInt k
  27:   | Bool b -> VBool b
  28:   | Times (e1, e2) ->
  29:       (match (interp env e1), (interp env e2) with
  30:            VInt k1, VInt k2 -> VInt (k1 * k2)
  31:          | _ -> runtime_error "Integers expected in multiplication")
  32:   | Divide (e1, e2) ->
  33:       (match (interp env e1), (interp env e2) with
  34:            VInt k1, VInt 0  -> runtime_error ("Division by 0")
  35:          | VInt k1, VInt k2 -> VInt (k1 / k2)
  36:          | _ -> runtime_error "Integers expected in division")
  37:   | Mod (e1, e2) ->
  38:       (match (interp env e1), (interp env e2) with
  39:            VInt k1, VInt 0  -> runtime_error ("Division by 0")
  40:          | VInt k1, VInt k2 -> VInt (k1 mod k2)
  41:          | _ -> runtime_error "Integers expected in remainder")
  42:   | Plus (e1, e2) ->
  43:       (match (interp env e1), (interp env e2) with
  44:            VInt k1, VInt k2 -> VInt (k1 + k2)
  45:          | _ -> runtime_error "Integers expected in addition")
  46:   | Minus (e1, e2) ->
  47:       (match (interp env e1), (interp env e2) with
  48:            VInt k1, VInt k2 -> VInt (k1 - k2)
  49:          | _ -> runtime_error "Integers expected in subtraction")
  50:   | Equal (e1, e2) ->
  51:       (match (interp env e1), (interp env e2) with
  52:            VInt k1, VInt k2 -> VBool (k1 = k2)
  53:          | _ -> runtime_error "Integers expected in =")
  54:   | Less (e1, e2) ->
  55:       (match (interp env e1), (interp env e2) with
  56:            VInt k1, VInt k2 -> VBool (k1 < k2)
  57:          | _ -> runtime_error "Integers expected in <")
  58:   | If (e1, e2, e3) ->
  59:       (match interp env e1 with
  60:            VBool true -> interp env e2
  61:          | VBool false -> interp env e3
  62:          | _ -> runtime_error "Boolean expected in if")
  63:   | Fun _ as e -> VClosure (env, e)
  64:   | Apply (e1, e2) ->
  65:       (match interp env e1 with
  66:            VClosure (env', Fun (x, _, e)) ->
  67:              interp ((x, ref (VClosure (env, e2)))::env') e
  68:          | _ -> runtime_error "Function expected in application")
  69:   | Pair _ as e ->  VClosure (env, e)
  70:   | Fst e ->
  71:       (match interp env e with
  72:            VClosure (env', Pair (e1, e2)) -> interp env' e1
  73:          | _ -> runtime_error "Pair expected in fst")
  74:   | Snd e ->
  75:       (match interp env e with
  76:            VClosure (env', Pair (e1, e2)) -> interp env' e2
  77:          | _ -> runtime_error "Pair expected in snd")
  78:   | Rec (x, _, e) -> 
  79:       let rec env' = (x,ref (VClosure (env',e))) :: env in
  80:         interp env' e
  81:   | Nil ty -> VNil ty
  82:   | Cons _ as e -> VClosure (env, e)
  83:   | Match (e1, _, e2, x, y, e3) ->
  84:       (match interp env e1 with
  85:            VNil _ -> interp env e2
  86:          | VClosure (env', Cons (d1, d2)) ->
  87:              interp ((x,ref (VClosure(env',d1)))::(y,ref (VClosure(env',d2)))::env) e3
  88:          | _ -> runtime_error "List expected in match")
  89: 
  90: 
  91: (** [print_result n v] prints at most [n] nodes of the value [v]. *)
  92: let rec print_result n v =
  93:   (if n = 0 then
  94:      print_string "..."
  95:    else
  96:      match v with
  97:          VInt k -> print_int k
  98:        | VBool b -> print_string (string_of_bool b)
  99:        | VNil ty -> print_string ("[" ^ string_of_type ty ^ "]")
 100:        | VClosure (env, Pair (e1, e2)) ->
 101:           print_char '(' ;
 102:           print_result (n/2) (interp env e1) ;
 103:           print_string ", " ;
 104:           print_result (n/2) (interp env e2) ;
 105:           print_char ')'
 106:       | VClosure (env, Cons (e1, e2)) ->
 107:           let v1 = interp env e1 in
 108:             (match v1 with
 109:                  VClosure (_, Cons _) ->
 110:                    print_char '(' ; print_result (n/2) v1 ; print_char ')'
 111:                | _ -> print_result (n/2) v1) ;
 112:           print_string " :: " ;
 113:           print_result (n-1) (interp env e2)
 114:       | VClosure (_, Fun _) -> print_string "<fun>"
 115:       | _ -> print_string "?"
 116:   ) ;
 117:   flush stdout

lexer.mll

   1: {
   2:   open Parser
   3:   open Lexing
   4: 
   5:   let incr_linenum lexbuf =
   6:     let pos = lexbuf.lex_curr_p in
   7:     lexbuf.lex_curr_p <- { pos with
   8:       pos_lnum = pos.pos_lnum + 1;
   9:       pos_bol = pos.pos_cnum;
  10:     }
  11: }
  12: 
  13: let var = ['_' 'a'-'z' 'A'-'Z'] ['_' 'a'-'z' 'A'-'Z' '0'-'9']*
  14: 
  15: rule token = parse
  16:     '#' [^'\n']* '\n' { incr_linenum lexbuf; token lexbuf }
  17:   | '\n'            { incr_linenum lexbuf; token lexbuf }
  18:   | [' ' '\t']      { token lexbuf }
  19:   | ['0'-'9']+      { INT (int_of_string(lexeme lexbuf)) }
  20:   | "bool"          { TBOOL }
  21:   | "else"          { ELSE }
  22:   | "false"         { FALSE }
  23:   | "fst"           { FST }
  24:   | "fun"           { FUN }
  25:   | "if"            { IF }
  26:   | "int"           { TINT }
  27:   | "is"            { IS }
  28:   | "let"           { LET }  
  29:   | "list"          { TLIST }
  30:   | "match"         { MATCH }
  31:   | "rec"           { REC }
  32:   | "snd"           { SND }
  33:   | "then"          { THEN }
  34:   | "true"          { TRUE }
  35:   | "$use"           { USE }
  36:   | "$quit"          { QUIT }
  37:   | "with"          { WITH }
  38:   | "->"            { ARROW }
  39:   | "::"            { CONS }
  40:   | ";;"            { SEMICOLON2 }
  41:   | '\"' [^'\"']* '\"' { let str = lexeme lexbuf in
  42:                         STRING (String.sub str 1 (String.length str - 2)) }
  43:   | '%'             { MOD }
  44:   | '('             { LPAREN }
  45:   | ')'             { RPAREN }
  46:   | '*'             { TIMES }
  47:   | '+'             { PLUS }
  48:   | ','             { COMMA }
  49:   | '-'             { MINUS }
  50:   | '/'             { DIVIDE }
  51:   | ':'             { COLON }
  52:   | '<'             { LESS }
  53:   | '='             { EQUAL }
  54:   | '['             { LBRACK }
  55:   | ']'             { RBRACK }
  56:   | '|'             { ALTERNATIVE }
  57:   | var             { VAR (lexeme lexbuf) }
  58:   | eof             { EOF }
  59: 
  60: {
  61: }

parser.mly

   1: %{
   2:   open Syntax
   3: %}
   4: 
   5: %token TINT
   6: %token TBOOL
   7: %token TTIMES
   8: %token TARROW
   9: %token TLIST
  10: %token <Syntax.name> VAR
  11: %token <int> INT
  12: %token TRUE FALSE
  13: %token PLUS
  14: %token MINUS
  15: %token TIMES
  16: %token DIVIDE
  17: %token MOD
  18: %token EQUAL LESS
  19: %token IF THEN ELSE
  20: %token FUN ARROW
  21: %token COLON
  22: %token LPAREN RPAREN
  23: %token LET
  24: %token SEMICOLON2
  25: %token COMMA
  26: %token FST
  27: %token SND
  28: %token LBRACK RBRACK
  29: %token CONS
  30: %token MATCH WITH ALTERNATIVE
  31: %token REC IS
  32: %token QUIT
  33: %token USE
  34: %token <string>STRING
  35: %token EOF
  36: 
  37: %start toplevel
  38: %type <Syntax.toplevel_cmd list> toplevel
  39: 
  40: %nonassoc REC IS
  41: %right FUN ARROW
  42: %nonassoc MATCH WITH
  43: %nonassoc IF THEN ELSE
  44: %nonassoc EQUAL LESS
  45: %left PLUS MINUS
  46: %left TIMES DIVIDE MOD
  47: %right CONS
  48: %right TARROW
  49: %left TTIMES
  50: %nonassoc TLIST
  51: 
  52: %%
  53: 
  54: toplevel:
  55:   | EOF                      { [] }
  56:   | lettop                   { $1 }
  57:   | exprtop                  { $1 }
  58:   | cmdtop                   { $1 }
  59: 
  60: lettop:
  61:   | def EOF                  { [$1] }
  62:   | def lettop               { $1 :: $2 }
  63:   | def SEMICOLON2 toplevel  { $1 :: $3 }
  64: 
  65: exprtop:
  66:   | expr EOF                 { [Expr $1] }
  67:   | expr SEMICOLON2 toplevel { Expr $1 :: $3 }
  68: 
  69: cmdtop:
  70:   | cmd EOF                  { [$1] }
  71:   | cmd SEMICOLON2 toplevel  { $1 :: $3 }
  72: 
  73: cmd:
  74:   | USE STRING { Use $2 }
  75:   | QUIT       { Quit }
  76: 
  77: def: LET VAR EQUAL expr { Def ($2, $4) }
  78: 
  79: expr:
  80:   | non_app             { $1 }
  81:   | app                 { $1 }
  82:   | arith               { $1 }
  83:   | boolean             { $1 }
  84:   | expr CONS expr      { Cons ($1, $3) }
  85:   | IF expr THEN expr ELSE expr        { If ($2, $4, $6) }
  86:   | FUN VAR COLON ty ARROW expr { Fun ($2, $4, $6) }
  87:   | REC VAR COLON ty IS expr { Rec ($2, $4, $6) }
  88:   | MATCH expr WITH nil ARROW expr ALTERNATIVE VAR CONS VAR ARROW expr
  89:       { Match ($2, $4, $6, $8, $10, $12) }
  90: 
  91: app:
  92:     app non_app         { Apply ($1, $2) }
  93:   | FST non_app         { Fst $2 }
  94:   | SND non_app         { Snd $2 }
  95:   | non_app non_app     { Apply ($1, $2) }
  96: 
  97: non_app:
  98:     VAR                                  { Var $1 }
  99:   | TRUE                          { Bool true }
 100:   | FALSE                         { Bool false }
 101:   | INT                                  { Int $1 }
 102:   | nil                           { Nil $1 }
 103:   | LPAREN expr RPAREN                  { $2 }    
 104:   | LPAREN expr COMMA expr RPAREN { Pair ($2, $4) }
 105: 
 106: arith:
 107:   | MINUS INT           { Int (-$2) }
 108:   | expr PLUS expr        { Plus ($1, $3) }
 109:   | expr MINUS expr        { Minus ($1, $3) }
 110:   | expr TIMES expr        { Times ($1, $3) }
 111:   | expr DIVIDE expr        { Divide ($1, $3) }
 112:   | expr MOD expr        { Mod ($1, $3) }
 113: 
 114: nil: LBRACK ty RBRACK   { $2 }
 115: 
 116: boolean:
 117:   | expr EQUAL expr { Equal ($1, $3) }
 118:   | expr LESS expr  { Less ($1, $3) }
 119: 
 120: ty:
 121:     TBOOL                      { TBool }
 122:   | TINT                      { TInt }
 123:   | ty TIMES ty { TTimes ($1, $3) }
 124:   | ty ARROW ty { TArrow ($1, $3) }
 125:   | ty TLIST                 { TList $1 }
 126:   | LPAREN ty RPAREN         { $2 }
 127: 
 128: %%

minihaskell.ml

   1: (** MiniHaskell toplevel. *)
   2: 
   3: open Message
   4: open Syntax
   5: 
   6: (**
   7:   The toplevel accepts global value definitions [let x = e] and expressions,
   8:   separated by double semicolons [;;] when contained in a file.
   9: 
  10:   Usage:
  11: 
  12:     [minihaskell] runs the interactive loop
  13: 
  14:     [minihaskell dat1 ... datN] evaluates the contents of files
  15:     [dat1], ..., [datN] then runs the interactive loop.
  16: 
  17:     [minihaskell -n dat1 ..., datN] evaluates the contents of files
  18:     [dat1],...,[datN] and exits.
  19: *)
  20: 
  21: exception Fatal_error of string
  22: 
  23: let fatal_error msg = raise (Fatal_error msg)
  24: 
  25: (** [exec_cmd (ctx, env) n cmd] executes the toplevel command [cmd] in
  26:     the given context [ctx] and environment [env]. It forces
  27:     evaluation of up to [n] levels of nesting of pairs and lists. It
  28:     returns the new context and environment. *)
  29: let rec exec_cmd n (ctx, env) = function
  30:     Expr e ->
  31:       (* type check [e], evaluate, and print result *)
  32:       let ty = Type_check.type_of ctx e in
  33:       let v = Interpret.interp env e in
  34:         print_string ("- : " ^ string_of_type ty ^ " = ") ;
  35:         Interpret.print_result n v ;
  36:         print_newline () ;
  37:         (ctx, env)
  38:   | Def (x, e) ->
  39:       (* type check [e], and store it unevaluated! *)
  40:       let ty = Type_check.type_of ctx e in
  41:         print_endline ("val " ^ x ^ " : " ^ string_of_type ty) ;
  42:         ((x,ty)::ctx, (x, ref (Interpret.VClosure (env,e)))::env)
  43:   | Quit -> raise End_of_file
  44:   | Use fn -> exec_file n (ctx, env) fn
  45: 
  46: 
  47: (** [exec_file (ctx, env) n fn] executes the contents of file [fn] in
  48:     the given context [ctx] and environment [env]. It forces
  49:     evaluation of up to [n] levels of nesting of pairs and lists. It
  50:     returns the new context and environment. *)
  51: and exec_file n ce fn =
  52:   let fh = open_in fn in
  53:   let lex = Message.lexer_from_channel fn fh in
  54:     try
  55:       let cmds = Parser.toplevel Lexer.token lex in
  56:         close_in fh ;
  57:         exec_cmds n ce cmds
  58:     with
  59:         Type_check.Type_error msg -> fatal_error (fn ^ ":\n" ^ msg)
  60:       | Interpret.Runtime_error msg -> fatal_error msg
  61:       | Sys.Break -> fatal_error "Interrupted."
  62:       | Parsing.Parse_error | Failure("lexing: empty token") ->
  63:           fatal_error (Message.syntax_error lex)
  64: 
  65: (** [exec_cmds (ctx, env) n cmds] executes the list of toplevel
  66:     commands [cmd] in the given context [ctx] and environment
  67:     [env]. It forces evaluation of up to [n] levels of nesting of
  68:     pairs and lists. It returns the new context and environment. *)
  69: and exec_cmds n ce cmds =
  70:   List.fold_left (exec_cmd n) ce cmds
  71: ;;
  72: 
  73: (** [shell ctx env] is the interactive shell. Here [ctx] and [env] are
  74:     the context and environment of global definitions. *)
  75: let shell n ctx env =
  76:   print_string ("MiniHaskell. Press ") ;
  77:   print_string (match Sys.os_type with
  78:                     "Unix" | "Cygwin" -> "Ctrl-D"
  79:                   | "Win32" -> "Ctrl-Z"
  80:                   | _ -> "EOF") ;
  81:   print_endline " to exit." ;
  82:   let global_ctx = ref ctx in
  83:   let global_env = ref env in
  84:     try
  85:       while true do
  86:         try
  87:           (* read a line, parse it and exectute it *)
  88:           print_string "MiniHaskell> ";
  89:           let str = read_line () in
  90:           let lex = Message.lexer_from_string str in
  91:           let cmds =
  92:             try
  93:               Parser.toplevel Lexer.token lex
  94:             with
  95:               | Failure("lexing: empty token")
  96:               | Parsing.Parse_error -> fatal_error (Message.syntax_error lex)
  97:           in
  98:           let (ctx, env) = exec_cmds n (!global_ctx, !global_env) cmds in
  99:             (* set the new values of the global context and environment *)
 100:             global_ctx := ctx ;
 101:             global_env := env
 102:         with
 103:             Fatal_error msg -> Message.report msg
 104:           | Interpret.Runtime_error msg -> Message.report msg
 105:           | Type_check.Type_error msg -> Message.report msg
 106:           | Sys.Break -> Message.report ("Interrupted.")
 107:       done 
 108:     with
 109:         End_of_file -> print_endline "\nGood bye."
 110: 
 111: (** The main program. *)
 112: let main =
 113:   Sys.catch_break true ;
 114:   let print_depth = ref 100 in
 115:   let noninteractive = ref false in
 116:   let files = ref [] in
 117:     Arg.parse
 118:       [("-n", Arg.Set noninteractive, "do not run the interactive shell");
 119:        ("-p", Arg.Int (fun n -> print_depth := n), "set print depth")]
 120:       (fun f -> files := f :: !files)
 121:       "Usage: minihaskell [-p <int>] [-n] [file] ..." ;
 122:     files := List.rev !files ;
 123:     let ctx, env =
 124:       try
 125:         List.fold_left (exec_file !print_depth) ([],[]) !files
 126:       with
 127:           Fatal_error msg -> Message.report msg ; exit 1
 128:     in    
 129:       if not !noninteractive then shell !print_depth ctx env