diff --git a/flap/src/hopix/hopixTypechecker.ml b/flap/src/hopix/hopixTypechecker.ml index 1d4bd98..0976d74 100644 --- a/flap/src/hopix/hopixTypechecker.ml +++ b/flap/src/hopix/hopixTypechecker.ml @@ -146,52 +146,67 @@ and pattern_tannot : HopixTypes.typing_environment -> HopixAST.pattern Position.located -> HopixAST.ty Position.located -> HopixTypes.aty * HopixTypes.typing_environment = - fun tenv p ty -> - let aty_of_ty = HopixTypes.internalize_ty tenv ty in - match p.value with + fun tenv p ty -> + let aty_of_ty = HopixTypes.internalize_ty tenv ty in + match p.value with | PWildcard -> aty_of_ty, tenv - | PVariable i -> aty_of_ty,HopixTypes.bind_value i.value (HopixTypes.monomorphic_type_scheme aty_of_ty) tenv - | _ -> let pattern_type, tenv = synth_pattern tenv p in - check_equal_types p.position ~expected:aty_of_ty ~given:pattern_type; pattern_type, tenv + | PVariable i -> + ( aty_of_ty + , HopixTypes.bind_value i.value (HopixTypes.monomorphic_type_scheme aty_of_ty) tenv ) + | _ -> + let pattern_type, tenv = synth_pattern tenv p in + check_equal_types p.position ~expected:aty_of_ty ~given:pattern_type; + pattern_type, tenv and pattern_tuple : HopixTypes.typing_environment -> HopixAST.pattern Position.located list -> HopixTypes.aty * HopixTypes.typing_environment = - fun tenv plist -> let tys, tenv = - List.fold_left( - fun(tys,tenv) pat -> - let (ty,tenv) = synth_pattern tenv pat in - (ty::tys,tenv) - ) ([],tenv) plist in - HopixTypes.ATyTuple(List.rev tys), tenv + fun tenv plist -> + let tys, tenv = + List.fold_left + (fun (tys, tenv) pat -> + let ty, tenv = synth_pattern tenv pat in + ty :: tys, tenv) + ([], tenv) + plist + in + HopixTypes.ATyTuple (List.rev tys), tenv and pattern_or : HopixTypes.typing_environment -> HopixAST.pattern Position.located list -> HopixTypes.aty * HopixTypes.typing_environment = - fun tenv plist -> - let ty', tenv' = synth_pattern tenv (List.hd (plist)) in - let tenv = List.fold_left ( - fun tenv pat -> + fun tenv plist -> + let ty', tenv' = synth_pattern tenv (List.hd plist) in + let tenv = + List.fold_left + (fun tenv pat -> let pattern_type, tenv = synth_pattern tenv pat in - check_equal_types pat.position ~expected:pattern_type ~given:ty';tenv - ) tenv' plist - in ty', tenv + check_equal_types pat.position ~expected:pattern_type ~given:ty'; + tenv) + tenv' + plist + in + ty', tenv - (* TODO : Même code que pattern_or, à revoir ?*) +(* TODO : Même code que pattern_or, à revoir ? *) and pattern_and : HopixTypes.typing_environment -> HopixAST.pattern Position.located list -> HopixTypes.aty * HopixTypes.typing_environment = - fun tenv plist -> - let ty', tenv' = synth_pattern tenv (List.hd (plist)) in - let tenv = List.fold_left ( - fun tenv pat -> + fun tenv plist -> + let ty', tenv' = synth_pattern tenv (List.hd plist) in + let tenv = + List.fold_left + (fun tenv pat -> let pattern_type, tenv = synth_pattern tenv pat in - check_equal_types pat.position ~expected:pattern_type ~given:ty';tenv - ) tenv' plist - in ty', tenv + check_equal_types pat.position ~expected:pattern_type ~given:ty'; + tenv) + tenv' + plist + in + ty', tenv and pattern_tagval : HopixTypes.typing_environment -> HopixAST.constructor Position.located @@ -199,8 +214,9 @@ and pattern_tagval -> HopixTypes.aty * HopixTypes.typing_environment = fun tenv cons tlist plist -> failwith "synth_pattern | PTagged" - (* TODO : à finir (trop fatigué sah): s'inspirer de ce qui a déjà été fait pour lex expressions. - let cons_scheme = +(* (* TODO : à finir (trop fatigué sah): + s'inspirer de ce qui a déjà été fait pour lex expressions. *) + let cons_scheme = try HopixTypes.lookup_type_scheme_of_constructor cons.position cons.value tenv with | HopixTypes.Unbound (pos, Constructor (KId c)) -> HopixTypes.type_error pos (Printf.sprintf "Unbound constructor `%s'." c) @@ -216,8 +232,7 @@ and pattern_tagval try HopixTypes.instantiate_type_scheme cons_scheme tys with | HopixTypes.InvalidInstantiation { expected; given } -> invalid_instantiation cons.position expected given - in - *) + in *) and pattern_record : HopixTypes.typing_environment @@ -227,7 +242,6 @@ and pattern_record = fun tenv plist tlist -> failwith "synth_pattern | PRecord" - and synth_variable : HopixTypes.typing_environment -> identifier Position.located -> ty Position.located list option -> HopixTypes.aty