elvis/lci
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Removed multiple input functions, added tuples, fixed parser

Browse Source
This commit is contained in:
elvis
2024-11-15 17:23:04 +01:00
parent 0ff17560ee
commit 7ad217dfb0
15 changed files with 808 additions and 307 deletions
Download Patch File Download Diff File Expand all files Collapse all files

95
lib/miniFun/Lexer.mll Normal file
View File

@ -0,0 +1,95 @@
{
open Parser
exception LexingError of string
let create_hashtable size init =
let tbl = Hashtbl.create size in
List.iter (fun (key, data) -> Hashtbl.add tbl key data) init;
tbl
let keyword_table =
let mapping = [
("bool", TYPEBOOL);
("else", ELSE);
("false", BOOL(false));
("fst", FIRST);
("snd", SECOND);
("fun", LAMBDA);
("if", IF);
("in", IN);
("int", TYPEINT);
("lambda", LAMBDA);
("let", LET);
("not", BNOT);
("powmod", POWERMOD);
("rand", RAND);
("rec", REC);
("then", THEN);
("true", BOOL(true));
]
in create_hashtable (List.length mapping) mapping
}
let digit = ['0'-'9']
let alpha = ['a'-'z' 'A'-'Z']
let white = [' ' '\t']+ | '\r' | '\n' | "\r\n"
let integer = ('-')?(digit)(digit*)
let var = (alpha|'_') (alpha|digit|'_')*
let symbols = ['!'-'/' ':'-'?' '[' ']' '^' '{'-'}' '~']
(* lexing rules *)
rule read = parse
| white {read lexbuf}
| var as v {
match Hashtbl.find_opt keyword_table v with
| Some keyword -> keyword
| None -> VARIABLE(v)
}
| "%" {MODULO}
| "&&" {BAND}
| "(" {LEFTPAR}
| ")" {RIGHTPAR}
| "*" {TIMES}
| "+" {PLUS}
| "," {COMMA}
| "-" {MINUS}
| "->" {TYPEFUNCTION}
| "/" {DIVISION}
| ":" {COLUMN}
| "<" {CMPLESS}
| "<=" {CMPLESSEQ}
| "=" {ASSIGNMENT}
| "==" {CMP}
| "=>" {RESULTS}
| ">" {CMPGREATER}
| ">=" {CMPGREATEREQ}
| "\\" {LAMBDA}
| "^" {POWER}
| "||" {BOR}
| integer as i {INT(int_of_string i)}
| "(*" {comments 0 lexbuf}
| eof {EOF}
| _ {
raise
(LexingError
(Printf.sprintf
"Error scanning %s on line %d at char %d"
(Lexing.lexeme lexbuf)
(lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum)
(lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum)
))}
and comments level = parse
| "*)" {if level = 0
then read lexbuf
else comments (level-1) lexbuf}
| "(*" {comments (level+1) lexbuf}
| _ {comments level lexbuf}
| eof {raise (LexingError ("Comment is not closed"))}
{
let lex = read
}

98
lib/miniFun/Parser.mly Normal file
View File

@ -0,0 +1,98 @@
(* code to be copied in the scanner module *)
(*
*)
%{
open Types
%}
(* tokens *)
%token TYPEBOOL TYPEINT TYPEFUNCTION
%token LAMBDA RAND IF IN THEN ELSE LET REC BNOT POWERMOD RESULTS
%token <bool> BOOL
%token <string> VARIABLE
%token <int> INT
%token COMMA COLUMN LEFTPAR RIGHTPAR CMPLESS CMPGREATER PLUS MINUS TIMES
%token DIVISION MODULO POWER ASSIGNMENT BAND BOR CMP CMPLESSEQ CMPGREATEREQ
%token FIRST SECOND
%token EOF
%type <t_exp> prg
%type <t_exp> texp
%type <ftype> typeexp
(* start nonterminal *)
%start prg
(* associativity in order of precedence *)
/*%right rightlowest */
%left lowest
%right TYPEFUNCTION
%left COMMA
%nonassoc INT BOOL VARIABLE
%left POWERMOD
%left IF
%left BOR BAND
%left CMP CMPLESS CMPLESSEQ CMPGREATER CMPGREATEREQ
%left PLUS MINUS
%left TIMES DIVISION MODULO
%left POWER
%right BNOT RAND
%left FIRST SECOND
%left LAMBDA
%left LET
%left LEFTPAR
%right righthighest
%%
(* grammar *)
prg:
| e = texp; EOF {e}
texp:
| i = INT {Integer (i)}
| b = BOOL {Boolean (b)}
| a = VARIABLE {Variable (a)}
| LEFTPAR; a = texp; COMMA; b = texp; RIGHTPAR
{Tuple (a, b)}
| LAMBDA; v = VARIABLE; COLUMN; t = typeexp; RESULTS; body = texp
%prec lowest {Function (v, t, body)}
| a = texp; b = texp {Application (a, b)} %prec righthighest
| a = texp; PLUS; b = texp {Plus (a, b)}
| a = texp; MINUS; b = texp {Minus (a, b)}
| a = texp; TIMES; b = texp {Times (a, b)}
| a = texp; DIVISION; b = texp {Division (a, b)}
| a = texp; MODULO; b = texp {Modulo (a, b)}
| a = texp; POWER; b = texp {Power (a, b)}
| a = texp; BAND; b = texp {BAnd (a, b)}
| a = texp; BOR; b = texp {BOr (a, b)}
| FIRST; a = texp {First (a)}
| SECOND; a = texp {Second (a)}
| a = texp; CMP; b = texp {Cmp (a, b)}
| a = texp; CMPLESS; b = texp {CmpLess (a, b)}
| a = texp; CMPLESSEQ; b = texp {CmpLessEq (a, b)}
| a = texp; CMPGREATER; b = texp {CmpGreater (a, b)}
| a = texp; CMPGREATEREQ; b = texp {CmpGreaterEq (a, b)}
| POWERMOD; LEFTPAR; t1 = texp; COMMA;
t2 = texp; COMMA;
t3 = texp; RIGHTPAR
{PowerMod (t1, t2, t3)}
| RAND; t = texp; {Rand (t)}
| BNOT; b = texp {BNot (b)}
| IF; b = texp; THEN; c1 = texp; ELSE; c2 = texp;
%prec lowest {IfThenElse (b, c1, c2)}
| LET; v = VARIABLE; ASSIGNMENT; c = texp; IN; rest = texp
%prec lowest {LetIn (v, c, rest)}
| LET; REC; f = VARIABLE; x = VARIABLE; COLUMN; t = typeexp; ASSIGNMENT; body = texp; IN; rest = texp
%prec lowest {LetFun (f, x, t, body, rest)}
| LEFTPAR; a = texp; RIGHTPAR {a}
typeexp:
| TYPEINT {IntegerType}
| TYPEBOOL {BooleanType}
| v = delimited(LEFTPAR, typeexp, RIGHTPAR)
{v}
| a = typeexp; COMMA; b = typeexp {TupleType (a, b)}
| vin = typeexp; TYPEFUNCTION; vout = typeexp
{FunctionType (vin, vout)}

85
lib/miniFun/Semantics.ml
View File

@ -14,14 +14,19 @@ let rec evaluate (mem: memory) (command: t_exp) : (permittedValues, error) resul
None -> Error (`AbsentAssignment ("The variable " ^ v ^ " is not defined."))
| Some a -> Ok a
)
| Function (xs, _, f) ->
| Tuple (x, y) -> (
let* xval = evaluate mem x in
let* yval = evaluate mem y in
Ok (TuplePermitted (xval, yval))
)
| Function (x, _, f) ->
Ok (FunctionPermitted
{inputList = xs;
{input = x;
body = f;
assignments = mem.assignments;
recursiveness = None}
)
| Application (f, xs) -> (
| Application (f, x) -> (
let* evalf = evaluate mem f in
let* funcClosure = (
match evalf with
@ -30,45 +35,20 @@ let rec evaluate (mem: memory) (command: t_exp) : (permittedValues, error) resul
^ " it's an integer"))
| BooleanPermitted _ -> Error (`WrongType ("Function is not a function,"
^ " it's a boolean"))
| TuplePermitted _ -> Error (`WrongType ("Function is not a function,"
^ " it's a tuple"))
) in
let parmList = List.map (fun k -> evaluate mem k) xs in
let rec helper m params values =
match (params, values) with
(_, []) -> Ok (m, params)
| ([], _) ->
Error (`WrongArity ("Function application has arity " ^
(List.length funcClosure.inputList
|> string_of_int) ^
", but was applied to " ^
(List.length xs |> string_of_int) ^
" parameters"))
| (p::tlparams, (Ok v)::tlvalues) -> helper
(VariableMap.add p v m)
tlparams
tlvalues
| (_, (Error e)::_) -> Error e
in
let* (mem2assignments, params) = helper
funcClosure.assignments
funcClosure.inputList
parmList
in
let mem2 = (
let* param = evaluate mem x in
let mem2 =
match funcClosure.recursiveness with
None -> {assignments = mem2assignments}
| Some nameF -> {
assignments =
VariableMap.add
nameF
(FunctionPermitted funcClosure)
mem2assignments
}
) in
match params with
[] -> evaluate mem2 funcClosure.body
| _ -> (
Ok (FunctionPermitted {funcClosure with inputList = params;
assignments = mem2assignments}))
None -> {assignments = (
VariableMap.add funcClosure.input param funcClosure.assignments)}
| Some nameF -> {assignments = (
VariableMap.add funcClosure.input param funcClosure.assignments |>
VariableMap.add nameF (FunctionPermitted funcClosure)
)}
in
evaluate mem2 funcClosure.body
)
| Plus (a, b) ->
let* aval = (
@ -248,7 +228,24 @@ let rec evaluate (mem: memory) (command: t_exp) : (permittedValues, error) resul
)
in
Ok (BooleanPermitted (not aval))
| First a ->
let* aval = (
match evaluate mem a with
Ok TuplePermitted (x, _) -> Ok x
| Error e -> Error e
| _ -> Error (`WrongType ("Value is not a tuple"))
)
in
Ok (aval)
| Second a ->
let* aval = (
match evaluate mem a with
Ok TuplePermitted (_, x) -> Ok x
| Error e -> Error e
| _ -> Error (`WrongType ("Value is not a tuple"))
)
in
Ok (aval)
| Cmp (exp_1, exp_2) ->
let* exp_1val = match evaluate mem exp_1 with
Ok IntegerPermitted x -> Ok x
@ -329,13 +326,13 @@ let rec evaluate (mem: memory) (command: t_exp) : (permittedValues, error) resul
let* evalxval = evaluate mem xval in
let mem2 = {assignments = VariableMap.add x evalxval mem.assignments} in
evaluate mem2 rest
| LetFun (f, xs, _, fbody, rest) ->
| LetFun (f, x, _, fbody, rest) ->
let mem2 = {
assignments =
VariableMap.add
f
(FunctionPermitted
{ inputList = xs;
{ input = x;
body = fbody;
assignments = mem.assignments;
recursiveness = Some f})
@ -345,7 +342,7 @@ let rec evaluate (mem: memory) (command: t_exp) : (permittedValues, error) resul
let reduce (program: t_exp) (iin : int) : (int, error) result =
let program' = (Application (program, [(Integer iin)])) in
let program' = (Application (program, (Integer iin))) in
let mem : memory = {assignments = VariableMap.empty} in
match (evaluate mem program') with
Ok IntegerPermitted a -> Ok a

2
lib/miniFun/Semantics.mli
View File

@ -1 +1,3 @@
val reduce : Types.t_exp -> int -> (int, Types.error) result
val evaluate : Types.memory -> Types.t_exp -> (Types.permittedValues, Types.error) result

104
lib/miniFun/TypeChecker.ml
View File

@ -15,59 +15,35 @@ let rec evaluate_type (program: t_exp) (context: ftype VariableMap.t) : (ftype,
("The variable " ^ x ^ " is not defined."))
| Some t -> Ok t
)
| Function (xs, typef, fbody) -> (
| Tuple (x, y) -> (
let* xtype = evaluate_type x context in
let* ytype = evaluate_type y context in
Ok (TupleType (xtype, ytype))
)
| Function (x, typef, fbody) -> (
(* first check that the function has the right specified type then check
that the number of inputs are the right number, finally eval the type
of the body using the bindings for the inputs *)
the type of the body using the bindings for the input *)
match typef with
FunctionType (tin, tout) -> (
if List.length xs <> List.length tin then
Error (`WrongTypeSpecification
("Type specification for function has wrong arity."))
let* typefbody = evaluate_type fbody (VariableMap.add x tin context) in
if (typefbody = tout) then
Ok typef
else
let context1 = List.fold_left2
(fun acc x t -> VariableMap.add x t acc)
context
xs
tin
in
let* typefbody = evaluate_type fbody context1 in
if (typefbody = tout) then
Ok typef
else
Error (`WrongTypeSpecification
("Function does not return specified type."))
Error (`WrongTypeSpecification
("Function does not return specified type."))
)
| _ -> Error (`WrongTypeSpecification
("Specification of function is not a function type."))
)
| Application (f, xs) -> (
(* check that the type is actually a function, then checks that the
supplied inputs are of the right type, returns the return type if all
inputs are supplied, otherwise a function from the remaining inputs to
the output types *)
| Application (f, x) -> (
let* evalf = evaluate_type f context in
let* evalx = evaluate_type x context in
match evalf with
FunctionType (tin, tout) -> (
let rec helper (params: t_exp list) (typeparams: ftype list) =
(* consumes until params are exausted *)
match (params, typeparams) with
([], _) -> Ok typeparams
| (_, []) -> Error (`WrongArity ("Function application has arity " ^
(List.length tin |> string_of_int) ^
", but was applied to " ^
(List.length xs |> string_of_int) ^
" parameters"))
| (p::tlparams, v::tltypeparams) ->
if evaluate_type p context = Ok v then
helper tlparams tltypeparams
else
Error (`WrongType "Argument with wrong type.")
in
let* typesremaining = helper xs tin in
match typesremaining with
[] -> Ok tout
| t -> Ok (FunctionType (t, tout))
if tin = evalx then
Ok tout
else
Error (`WrongType "Appling function with wrong input type to value")
)
| _ -> Error (`WrongType "Applying to a non function type")
)
@ -117,6 +93,18 @@ let rec evaluate_type (program: t_exp) (context: ftype VariableMap.t) : (ftype,
| (BooleanType) -> Ok BooleanType
| (_) -> Error (`WrongType "Term is not a boolean.")
)
| First (x) -> (
let* typex = evaluate_type x context in
match typex with
| (TupleType (x, _)) -> Ok x
| (_) -> Error (`WrongType "Term is not a tuple.")
)
| Second (x) -> (
let* typex = evaluate_type x context in
match typex with
| (TupleType (_, x)) -> Ok x
| (_) -> Error (`WrongType "Term is not a tuple.")
)
| Cmp (x, y)
| CmpLess (x, y)
| CmpLessEq (x, y)
@ -146,26 +134,18 @@ let rec evaluate_type (program: t_exp) (context: ftype VariableMap.t) : (ftype,
(* bind the type to the variable name in the context *)
let* typex = evaluate_type xval context in
evaluate_type rest (VariableMap.add x typex context)
| LetFun (f, xs, typef, fbody, rest) ->
(* like with the function type, but also add f itself to the bindings *)
| LetFun (f, x, typef, fbody, rest) ->
(* like with the function case, but also add f itself to the bindings *)
match typef with
FunctionType (tin, tout) -> (
if List.length xs <> List.length tin then
Error (`WrongArity "Type specification for function has wrong arity.")
else
let context1 = VariableMap.add f typef context in
let context2 = List.fold_left2
(fun acc x t -> VariableMap.add x t acc)
context1
xs
tin
in
let* typefbody = evaluate_type fbody context2 in
let* typerest = evaluate_type rest context1 in
match (typefbody = tout, typerest) with
(false, _) -> Error (`WrongTypeSpecification
"Function does not return specified type.")
| (true, t) -> Ok t
let newcontext = VariableMap.add f typef context in
let newcontextwithx = VariableMap.add x tin newcontext in
let* typefbody = evaluate_type fbody newcontextwithx in
let* typerest = evaluate_type rest newcontext in
match (typefbody = tout, typerest) with
(false, _) -> Error (`WrongTypeSpecification
"Function does not return specified type.")
| (true, t) -> Ok t
)
| _ -> Error (`WrongTypeSpecification
"Specification of function is not a function type.")
@ -173,7 +153,7 @@ let rec evaluate_type (program: t_exp) (context: ftype VariableMap.t) : (ftype,
let typecheck (program: t_exp) : (ftype, error) result =
let* typeprogram = evaluate_type program VariableMap.empty in
match typeprogram with
FunctionType ([IntegerType], IntegerType) -> (
Ok (FunctionType ([IntegerType], IntegerType))
FunctionType (IntegerType, IntegerType) -> (
Ok (typeprogram)
)
| _ -> Error (`WrongType "Program is not a function from int to int.")

24
lib/miniFun/Types.ml
View File

@ -5,14 +5,16 @@ module VariableMap = Map.Make(String)
type ftype =
IntegerType
| BooleanType
| FunctionType of ftype list * ftype
| TupleType of ftype * ftype
| FunctionType of ftype * ftype
type t_exp =
Integer of int (* x := a *)
| Boolean of bool (* v *)
| Variable of variable (* x *)
| Function of variable list * ftype * t_exp (* lambda x: t. x *)
| Application of t_exp * t_exp list (* x x *)
| Tuple of t_exp * t_exp (* (a, b) *)
| Function of variable * ftype * t_exp (* lambda x: t. x *)
| Application of t_exp * t_exp (* x x *)
| Plus of t_exp * t_exp (* x + x *)
| Minus of t_exp * t_exp (* x - x *)
| Times of t_exp * t_exp (* x * x *)
@ -21,9 +23,11 @@ type t_exp =
| Power of t_exp * t_exp (* x ^ x *)
| PowerMod of t_exp * t_exp * t_exp (* (x ^ x) % x *)
| Rand of t_exp (* rand(0, x) *)
| BAnd of t_exp * t_exp (* x and x *)
| BOr of t_exp * t_exp (* x or x *)
| BAnd of t_exp * t_exp (* x && x *)
| BOr of t_exp * t_exp (* x || x *)
| BNot of t_exp (* not x *)
| First of t_exp (* fst x *)
| Second of t_exp (* scn x *)
| Cmp of t_exp * t_exp (* x == x *)
| CmpLess of t_exp * t_exp (* x < x *)
| CmpLessEq of t_exp * t_exp (* x <= x *)
@ -31,14 +35,15 @@ type t_exp =
| CmpGreaterEq of t_exp * t_exp (* x >= x *)
| IfThenElse of t_exp * t_exp * t_exp (* if b then c else c *)
| LetIn of variable * t_exp * t_exp (* let x = x in x *)
| LetFun of variable * variable list * ftype * t_exp * t_exp (* let rec x: t. x in x*)
| LetFun of variable * variable * ftype * t_exp * t_exp (* let rec x. y: t. x in x*)
type permittedValues =
IntegerPermitted of int
| BooleanPermitted of bool
IntegerPermitted of int
| BooleanPermitted of bool
| TuplePermitted of permittedValues * permittedValues
| FunctionPermitted of closure
and closure = {
inputList: variable list;
input: variable;
body: t_exp;
assignments: permittedValues VariableMap.t;
recursiveness: variable option
@ -52,6 +57,5 @@ type error = [
`AbsentAssignment of string
| `WrongType of string
| `DivisionByZero of string
| `WrongArity of string
| `WrongTypeSpecification of string
]

24
lib/miniFun/Types.mli
View File

@ -5,14 +5,16 @@ module VariableMap : Map.S with type key = variable
type ftype =
IntegerType
| BooleanType
| FunctionType of ftype list * ftype
| TupleType of ftype * ftype
| FunctionType of ftype * ftype
type t_exp =
Integer of int (* x := a *)
| Boolean of bool (* v *)
| Variable of variable (* x *)
| Function of variable list * ftype * t_exp (* lambda x: t. x *)
| Application of t_exp * t_exp list (* x x *)
| Tuple of t_exp * t_exp (* (a, b) *)
| Function of variable * ftype * t_exp (* lambda x: t. x *)
| Application of t_exp * t_exp (* x x *)
| Plus of t_exp * t_exp (* x + x *)
| Minus of t_exp * t_exp (* x - x *)
| Times of t_exp * t_exp (* x * x *)
@ -21,9 +23,11 @@ type t_exp =
| Power of t_exp * t_exp (* x ^ x *)
| PowerMod of t_exp * t_exp * t_exp (* (x ^ x) % x *)
| Rand of t_exp (* rand(0, x) *)
| BAnd of t_exp * t_exp (* x and x *)
| BOr of t_exp * t_exp (* x or x *)
| BAnd of t_exp * t_exp (* x && x *)
| BOr of t_exp * t_exp (* x || x *)
| BNot of t_exp (* not x *)
| First of t_exp (* fst x *)
| Second of t_exp (* scn x *)
| Cmp of t_exp * t_exp (* x == x *)
| CmpLess of t_exp * t_exp (* x < x *)
| CmpLessEq of t_exp * t_exp (* x <= x *)
@ -31,14 +35,15 @@ type t_exp =
| CmpGreaterEq of t_exp * t_exp (* x >= x *)
| IfThenElse of t_exp * t_exp * t_exp (* if b then c else c *)
| LetIn of variable * t_exp * t_exp (* let x = x in x *)
| LetFun of variable * variable list * ftype * t_exp * t_exp (* let rec x: t. x in x*)
| LetFun of variable * variable * ftype * t_exp * t_exp (* let rec x. y: t. x in x*)
type permittedValues =
IntegerPermitted of int
| BooleanPermitted of bool
IntegerPermitted of int
| BooleanPermitted of bool
| TuplePermitted of permittedValues * permittedValues
| FunctionPermitted of closure
and closure = {
inputList: variable list;
input: variable;
body: t_exp;
assignments: permittedValues VariableMap.t;
recursiveness: variable option
@ -52,6 +57,5 @@ type error = [
`AbsentAssignment of string
| `WrongType of string
| `DivisionByZero of string
| `WrongArity of string
| `WrongTypeSpecification of string
]

12
lib/miniFun/dune
View File

@ -1,6 +1,16 @@
(ocamllex Lexer)
(menhir
(modules Parser)
(explain true)
(infer true)
(flags --dump --table)
)
(library
(name miniFun)
(public_name miniFun)
(libraries utility))
(modules Lexer Parser Types Semantics TypeChecker)
(libraries utility menhirLib))
(include_subdirs qualified)