diff --git a/main.ml b/main.ml index 4240964..e62d227 100644 --- a/main.ml +++ b/main.ml @@ -9,12 +9,12 @@ let filename = ref "" in let reduce = ref false in let alpha = ref false in -let typecheck = ref false in +let typecheck_option = ref false in Arg.parse [("-reduce", Arg.Set reduce, "Show the step-by-step reduction of a lambda-term"); ("-alpha", Arg.Set alpha, "Check is two lambda-terms separated by '&' are alpha-convertible"); - ("-typecheck", Arg.Set typecheck, "Check if a lambda term has a given type")] + ("-typecheck", Arg.Set typecheck_option, "Check if a lambda term has a given type")] (fun s -> filename := s) "The available options are:"; @@ -121,4 +121,17 @@ while !subgoals <> [] do ) done; -Printf.printf "Final proof :\n%s\n" (string_of_lam (!fill_holes []));; +let finalLam = !fill_holes [] in + if (typecheck [] finalLam ty) + then + Printf.printf "Final proof :\n%s\n" (string_of_lam finalLam) + else + ( + Printf.printf "Invalid proof constructed !\n"; + Printf.printf "%s can't be typed with %s.\n" (string_of_lam finalLam) (string_of_ty ty); + Printf.printf "The whole development team of pieuvre is sorry for the damage eventually done by this error.\n" + ) +;; + + + diff --git a/pieuvre.ml b/pieuvre.ml index 78d0e47..08fe688 100644 --- a/pieuvre.ml +++ b/pieuvre.ml @@ -1,6 +1,7 @@ open Structs open Str + exception TODOException;; exception IllegalVarNameException of var @@ -115,23 +116,31 @@ let rec reduce (l:lam) : unit = | None -> () ;; -(* Vérifie que le λ-terme l sous l'environnement env a bien le type t *) -let rec typecheck (env: gam) (l: lam) (t: ty) : bool = - match (l,t) with - | (LFun(x,t,l'),TImpl(tx,ty)) -> typecheck ((x,tx)::env) l' ty - | (LFun(_,_,_),_) -> false (* Une fonction est forcément une ... fonction *) - | (LApp(lf,lx),t) -> - let t' = raise TODOException in - (typecheck env lf (TImpl(t',t))) && (typecheck env lx t') - | (LVar(x),t) -> +(* Calcule le type du λ-terme l sous l'environnement env. 7 +Renvoie None si la formule n'est pas typable ou si la formule n'est pas close (sous d'environnement)*) +let rec computeType (env: gam) (l: lam) : ty option = + match l with + | LFun(x,tx,l') -> Option.bind (computeType ((x,tx)::env) l') (fun ty -> Some (TImpl(tx,ty))) + | LApp(lf,lx) -> + let tx = computeType env lx in + let tf = computeType env lf in + begin + match tf with + | Some TImpl(tx',ty') -> if Some tx'=tx then Some ty' else None + | _ -> None (* Si none, l'argument n'est pas typable, si Some _, on ne peut typer l'application *) + end + | LVar(x) -> begin match env with - | (y,t')::env' -> if x=y then t=t' - else typecheck env' l t - | [] -> raise TODOException + | (y,ty)::env' -> if x=y then Some ty + else computeType env' l + | [] -> None end - | (LExf(l',t'),t) -> - if t=t' - then typecheck env l' t - else false (* Le ex falso a le mauvais type *) + | LExf(l',t) -> + if (computeType env l')=Some t + then Some t + else None (* Le ex falso a le mauvais type *) ;; + +(* Vérifie que le λ-terme l sous l'environnement env a bien le type t *) +let typecheck (env: gam) (l: lam) (t: ty) : bool = (computeType env l = Some t);