Re: [Caml-list] How to Create Sensible Debugging Information when Dynamically Typechecking Code Generated with camlp5 Quotations

["Nicolas Pouillard" <nicolas.pouillard@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 6678 bytes --]

Excerpts from echinuz echinuz's message of Sat Dec 15 20:32:55 +0100 2007:
> Allow me to clarify what I meant by type errors and antiquotations.  Here is a
> very simple program that contains the parser, type checker, and quotation
> generator:

Ok,  I  understand your problem and will try to help you using Camlp4 examples
based on your original code.

In  first  I  attach  alg1.ml that is some minimum translation of your code in
order to use Camlp4 and to have locations.

I also attach a _tags file that helps ocamlbuild to build them.

Let's try this first example using alg1_test.ml.

$ mkdir algtest
$ cd algtest
$ cp <attachments> .
$ ocamlbuild alg1.cmo
$ cat alg1_test.ml
open Alg1;;
let x = <:exp< add(21, 21) >>;;
let y = <:exp< add(31, 11.0) >>;;
$ camlp4of ./_build/alg1.cmo alg1_test.ml
open Alg1
let x = App ("add", [ Int 21; Int 21 ])
let y = App ("add", [ Int 31; Flo 11.0 ])

Then  let's add antiquotations (alg1_ant.ml), basically one adds a Ant case to
the  alg type that will hold the antiquoted expression/pattern plus it's type.
We  embed  the  type  to  simplify the dynamic typing and don't involving some
type  inference.  One also embed the type of an expression at runtime in order
to check it against the type of the hole.

In  order to show some useful examples of typing errors one add strings values
to the language (alg1_ant_str.ml).

Here is the kind of program that we want accept:

$ cat alg1_ant_test.ml
open Alg1_ant;;
let x = <:exp< add(21, 21) >> in
let y = <:exp< add(31, 11.0) >> in
<:exp< add(add($Int: x$, $Real: y$), 42) >>

And the kind of programs that we want to dynamically reject:

$ cat alg1_ant_test_bad.ml
open Alg1_ant_str;;
let x = <:exp< "FOO" >> in
<:exp< add(42, $Int:x$) >>

Let's try the two new extensions:

# Compilation
$ ocamlbuild alg1_ant.cmo alg1_ant_str.cmo

# Let's look at the result
$ camlp4of ./_build/alg1_ant.cmo alg1_ant_test.ml
open Alg1_ant
let x = ((App ("add", [ Int 21; Int 21 ])), `Int) in
let y = ((App ("add", [ Int 31; Flo 11.0 ])), `Real)
in
  ((App ("add",
      [ App ("add",
          [ type_check
              (Loc.of_tuple
                 ("alg1_ant_test.ml", 4, 84, 100, 4, 84, 107, false))
              x `Int;
            type_check
              (Loc.of_tuple
                 ("alg1_ant_test.ml", 4, 84, 110, 4, 84, 118, false))
              y `Real ]);
        Int 42 ])),
   `Real)

# Let's compile and run the example
$ ocamlbuild alg1_ant_test.byte --

# Let's try the bad example to see that there is no static error.
$ camlp4of ./_build/alg1_ant_str.cmo alg1_ant_test_bad.ml
open Alg1_ant_str
let x = ((Str "FOO"), `Str)
in
  ((App ("add",
      [ Int 42;
        type_check
          (Loc.of_tuple
             ("alg1_ant_test_bad.ml", 3, 47, 63, 3, 47, 69, false))
          x `Int ])),
   `Int)

# Finally let's run it to show the runtime check failure.
$ ocamlbuild alg1_ant_test_bad.byte --
Dynamic Typing Error at File "alg1_ant_test_bad.ml", line 3, characters 16-22
Fatal error: exception Alg1_ant_str.TypeError

Hope that helps

Best regards,

> ---------------------------------------
> #load "pa_extend.cmo";;
> #load "q_MLast.cmo";;
> 
> (* Parser *)
> type palg=
> | PApp of string*palg list
> | PInt of string
> | PFlo of string;;
> 
> 
> let g=Grammar.gcreate (Plexer.gmake ());;
> let exp_eoi = Grammar.Entry.create g "exp_eoi";;
> 
> EXTEND
>     GLOBAL: exp_eoi;
>     exp_eoi:
>         [[ x = exp; EOI -> x ]] ;
>     exp:
>         [[x=INT -> PInt x
>         | x=FLOAT -> PFlo x
>         | f = LIDENT; "("; xs=LIST1 SELF SEP ","; ")"-> PApp (f,xs)]];
> END;;
> 
> let parse s = Grammar.Entry.parse exp_eoi (Stream.of_string s);;
> 
> (* Type Checker *)
> exception TypeError;;
> type integer=[`Int];;
> type real=[integer | `Real];;
> let rec type_expr=function
>     | PApp (f,args) ->
>         (match f with
>         | "add" ->
>             if List.length args != 2 then
>                 raise TypeError
>             else
>                 let args=List.map type_expr args in
>                 (match (List.nth args 0,List.nth args 1) with
>                 | #integer,#integer -> `Int
>                 | #real,#real -> `Real)
>         | _ -> raise TypeError)
>     | PInt _ -> `Int
>     | PFlo _ -> `Real
> ;;
> 
> 
> (* Quotations *)
> type alg=
> | App of string*alg list
> | Int of int
> | Flo of float;;
> 
> let loc=Ploc.dummy;;
> let rec to_expr=function
>     | PInt x-> <:expr< Int $int:x$ >>
>     | PFlo x-> <:expr< Flo $flo:x$ >>
>     | PApp (f,el)->
>         let rec make_el=function
>             | x::xs -> <:expr< [$x$::$make_el xs$] >>
>             | [] -> <:expr< [] >>
>         in
>         let el=List.map to_expr el in
>         let el=make_el el in
>         <:expr< App ($str:f$,$el$) >>
> ;;
> let rec to_patt=function
>     | PInt x-> <:patt< Int $int:x$ >>
>     | PFlo x-> <:patt< Flo $flo:x$ >>
>     | PApp (f,el)->
>         let rec make_el=function
>             | x::xs -> <:patt< [$x$::$make_el xs$] >>
>             | [] -> <:patt< [] >>
>         in
>         let el=List.map to_patt el in
>         let el=make_el el in
>         <:patt< App ($str:f$,$el$) >>
> ;;
> 
> let expand_expr s=
>     let p=parse s in
>     let t=type_expr p in
>     to_expr p
> ;;
> let expand_patt s=
>     let p=parse s in
>     let t=type_expr p in
>     to_patt p
> ;;
> Quotation.add "exp" (Quotation.ExAst (expand_expr,expand_patt));;
>  ---------------------------------------
> 
> Thus, by type check, I mean actually verifying the typing rules of the DSL.  In
> this case, it means that the only function allowed is "add" and that this
> function requires two arguments.  Now, imagine the above language where
> antiquotations are allowed.  The parsed AST would have datatype
> 
> type palg=
> | PApp of string*palg list
> | PInt of string
> | PFlo of string
> | PQuote of Ploc.t*string
> 
> and it becomes impossible to type check in the above sense since we can not
> ascertain the type of PQuote.  Now, we can still type check the resulting AST
> of type alg (not palg).  But, this must occur at runtime rather than during the
> preprocessing step at compile time.  Therein lies the problem.
> 
> If we discover a type error during runtime, it would be nice to give the user
> some indication of where the error occurs short of saying, "Add expects two
> arguments."  Since the location information provided is relative to the quote,
> it can still be challenging to determine exactly where the type error occurs. 
> Thus, I'm either trying to obtain better location information or perhaps learn
> that there's a better place or method to type check than what I'm using.
> 

-- 
Nicolas Pouillard aka Ertai

[-- Attachment #2: alg1.ml --]
[-- Type: application/octet-stream, Size: 2795 bytes --]

(* Parser *)
open Camlp4.PreCast;;

type palg=
| PApp of Loc.t * string * palg list (* if you want locations, you have to keep them *)
| PInt of Loc.t * string
| PFlo of Loc.t * string;;

module G = MakeGram(Lexer);; (* instead of let g=Grammar.gcreate (Plexer.gmake ());; *)
let exp_eoi = G.Entry.mk "exp_eoi";; (* instead of Grammar.Entry.create g "exp_eoi";; *)

EXTEND G (* specify which grammar you extend *)
  GLOBAL: exp_eoi;
  exp_eoi:
    [[ x = exp; `EOI (* `EOI instead of EOI *) -> x ]];
  exp:
    [[ x = INT -> PInt(_loc, x)
     | x = FLOAT -> PFlo(_loc, x)
     | f = LIDENT; "("; xs = LIST1 SELF SEP ","; ")" -> PApp(_loc, f, xs) ]];
END;;

let parse = G.parse_string exp_eoi;; (* instead of let parse s = Grammar.Entry.parse exp_eoi (Stream.of_string s);; *)

(* Type Checker *)
exception TypeError;;
type integer=[`Int];;
type real=[integer | `Real];;
let rec type_expr=function
  | PApp(_loc, f,args) ->
      begin match f, args with (* pattern matching is your friend *)
      | "add", [arg1; arg2] ->
          (match type_expr arg1, type_expr arg2 with
           | #integer,#integer -> `Int
           | #real,#real -> `Real)
      | _ -> Loc.raise _loc TypeError (* note the location wrapping to have a correct location *)
      end
  | PInt _ -> `Int
  | PFlo _ -> `Real
;;


(* Quotations *)
type alg=
| App of string*alg list
| Int of int
| Flo of float;;

(* One cannot expect good locations with this declaration: let loc=Ploc.dummy;; *)
let rec to_expr=function
    | PInt(_loc, x) -> <:expr< Int $int:x$ >>
    | PFlo(_loc, x) -> <:expr< Flo $flo:x$ >>
    | PApp(_loc, f, el)->
        let rec make_el=function
            | x::xs -> <:expr< $x$::$make_el xs$ >>
              (* instead of <:expr< [$x$::$make_el xs$] >> since I've used camlp4of *)
            | [] -> <:expr< [] >>
        in
        let el=List.map to_expr el in
        let el=make_el el in
        <:expr< App ($str:f$,$el$) >>
;;
let rec to_patt=function
    | PInt(_loc, x) -> <:patt< Int $int:x$ >>
    | PFlo(_loc, x) -> <:patt< Flo $flo:x$ >>
    | PApp(_loc, f, el) ->
        let rec make_el=function
            | x::xs -> <:patt< $x$::$make_el xs$ >>
            | [] -> <:patt< [] >>
        in
        let el=List.map to_patt el in
        let el=make_el el in
        <:patt< App ($str:f$,$el$) >>
;;

let expand_expr loc _loc_name s =
    let p = parse loc s in
    let _t = type_expr p in
    to_expr p
;;
let expand_patt loc _loc_name s =
    let p = parse loc s in
    let _t = type_expr p in
    to_patt p
;;

let expand_str_item loc loc_name s =
  <:str_item@loc< $exp:expand_expr loc loc_name s$ >>

module Q = Syntax.Quotation;;
Q.add "exp" Q.DynAst.expr_tag expand_expr;;
Q.add "exp" Q.DynAst.patt_tag expand_patt;;
Q.add "exp" Q.DynAst.str_item_tag expand_str_item;;

[-- Attachment #3: _tags --]
[-- Type: application/octet-stream, Size: 198 bytes --]

true: use_camlp4_full, camlp4of
<alg1_test.ml>: pp(camlp4of ./alg1.cmo)
<alg1_ant_test.ml>: pp(camlp4of ./alg1_ant.cmo)
<alg1_ant_test_bad.ml>: pp(camlp4of ./alg1_ant_str.cmo)
<*.byte>: use_dynlink

[-- Attachment #4: alg1_test.ml --]
[-- Type: application/octet-stream, Size: 78 bytes --]

open Alg1;;
let x = <:exp< add(21, 21) >>;;
let y = <:exp< add(31, 11.0) >>;;

[-- Attachment #5: alg1_ant.ml --]
[-- Type: application/octet-stream, Size: 4159 bytes --]

(* Parser *)
open Camlp4.PreCast;;
module Loc = Camlp4.PreCast.Loc;;

type palg=
| PApp of Loc.t * string * palg list (* if you want locations, you have to keep them *)
| PInt of Loc.t * string
| PFlo of Loc.t * string
| PAnt of Loc.t * string (* the type *) * string (* the expr/patt *)
;;

module G = MakeGram(Lexer);; (* instead of let g=Grammar.gcreate (Plexer.gmake ());; *)
let exp_eoi = G.Entry.mk "exp_eoi";; (* instead of Grammar.Entry.create g "exp_eoi";; *)

EXTEND G (* specify which grammar you extend *)
  GLOBAL: exp_eoi;
  exp_eoi:
    [[ x = exp; `EOI (* `EOI instead of EOI *) -> x ]];
  exp:
    [[ x = INT -> PInt(_loc, x)
     | x = FLOAT -> PFlo(_loc, x)
     | f = LIDENT; "("; xs = LIST1 SELF SEP ","; ")" -> PApp(_loc, f, xs)
     | `ANTIQUOT(ty, str) -> PAnt(_loc, ty, str) ]];
END;;

let parse = G.parse_string exp_eoi;; (* instead of let parse s = Grammar.Entry.parse exp_eoi (Stream.of_string s);; *)

exception NoSuchType of string;;
let ty_of_string _loc = function
  | "Int"  -> `Int
  | "Real" -> `Real
  | ty     -> Loc.raise _loc (NoSuchType ty)
;;
let string_of_ty = function
  | `Int -> "Int"
  | `Real -> "Real"
;;

(* Type Checker *)
exception TypeError;;
type integer=[`Int];;
type real=[integer | `Real];;
let rec type_expr=function
  | PApp(_loc, f,args) ->
      begin match f, args with (* pattern matching is your friend *)
      | "add", [arg1; arg2] ->
          (match type_expr arg1, type_expr arg2 with
           | #integer,#integer -> `Int
           | #real,#real -> `Real)
      | _ -> Loc.raise _loc TypeError (* note the location wrapping to have a correct location *)
      end
  | PInt _ -> `Int
  | PFlo _ -> `Real
  | PAnt(_loc, ty, _) -> ty_of_string _loc ty
;;

(* Quotations *)
(* note that this type definition will be useful only in programs that will use
 * <:exp< ... >> but not here. *)
type alg =
| App of string*alg list
| Int of int
| Flo of float
and typed_alg = (alg * real)
;;

let type_check _loc (expr, ty_expr) ty =
  if ty_expr = ty then expr
  else begin
    Format.eprintf "@[<2>Dynamic Typing Error at@ %a@]@." Loc.print _loc;
    raise TypeError
  end

let expr_of_loc loc = Camlp4.PreCast.Ast.Meta.MetaLoc.meta_loc_expr loc loc;;

module CamlSyntax =
  Camlp4OCamlParser.Make(
    Camlp4OCamlRevisedParser.Make(
      Camlp4.PreCast.Syntax
    )
  );;
let expr_of_string = CamlSyntax.Gram.parse_string CamlSyntax.expr_eoi;;

Camlp4_config.antiquotations := true;; (* Tell camlp4 that you want use antiquotations *)

(* One cannot expect good locations with this declaration: let loc=Ploc.dummy;; *)
let rec to_expr=function
    | PInt(_loc, x) -> <:expr< Int $int:x$ >>
    | PFlo(_loc, x) -> <:expr< Flo $flo:x$ >>
    | PApp(_loc, f, el)->
        let rec make_el=function
            | x::xs -> <:expr< $x$::$make_el xs$ >>
              (* instead of <:expr< [$x$::$make_el xs$] >> since I've used camlp4of *)
            | [] -> <:expr< [] >>
        in
        let el=List.map to_expr el in
        let el=make_el el in
        <:expr< App ($str:f$,$el$) >>
    | PAnt(_loc, ty, str) ->
        <:expr< type_check $expr_of_loc _loc$ $expr_of_string _loc str$ `$ty$ >>
;;
let rec to_patt=function
    | PInt(_loc, x) -> <:patt< Int $int:x$ >>
    | PFlo(_loc, x) -> <:patt< Flo $flo:x$ >>
    | PApp(_loc, f, el) ->
        let rec make_el=function
            | x::xs -> <:patt< $x$::$make_el xs$ >>
            | [] -> <:patt< [] >>
        in
        let el=List.map to_patt el in
        let el=make_el el in
        <:patt< App ($str:f$,$el$) >>
    | PAnt _ -> invalid_arg "antiquotations not supported in patterns"
;;

let expand_expr _loc _loc_name s =
    let p = parse _loc s in
    let t = type_expr p in
    <:expr< ($to_expr p$, `$string_of_ty t$) >>
;;
let expand_patt _loc _loc_name s =
    let p = parse _loc s in
    let t = type_expr p in
    <:patt< ($to_patt p$, `$string_of_ty t$) >>
;;

let expand_str_item loc loc_name s =
  <:str_item@loc< $exp:expand_expr loc loc_name s$ >>

module Q = Syntax.Quotation;;
Q.add "exp" Q.DynAst.expr_tag expand_expr;;
Q.add "exp" Q.DynAst.patt_tag expand_patt;;
Q.add "exp" Q.DynAst.str_item_tag expand_str_item;;

[-- Attachment #6: alg1_ant_test.ml --]
[-- Type: application/octet-stream, Size: 128 bytes --]

open Alg1_ant;;
let x = <:exp< add(21, 21) >> in
let y = <:exp< add(31, 11.0) >> in
<:exp< add(add($Int: x$, $Real: y$), 42) >>

[-- Attachment #7: alg1_ant_str.ml --]
[-- Type: application/octet-stream, Size: 4485 bytes --]

open Camlp4.PreCast;;
module Loc = Camlp4.PreCast.Loc;;

type palg=
| PApp of Loc.t * string * palg list (* if you want locations, you have to keep them *)
| PInt of Loc.t * string
| PFlo of Loc.t * string
| PStr of Loc.t * string
| PAnt of Loc.t * string (* the type *) * string (* the expr/patt *)
;;

(* Parser *)
module G = MakeGram(Lexer);; (* instead of let g=Grammar.gcreate (Plexer.gmake ());; *)
let exp_eoi = G.Entry.mk "exp_eoi";; (* instead of Grammar.Entry.create g "exp_eoi";; *)

EXTEND G (* specify which grammar you extend *)
  GLOBAL: exp_eoi;
  exp_eoi:
    [[ x = exp; `EOI (* `EOI instead of EOI *) -> x ]];
  exp:
    [[ x = INT -> PInt(_loc, x)
     | x = FLOAT -> PFlo(_loc, x)
     | x = STRING -> PStr(_loc, x)
     | f = LIDENT; "("; xs = LIST1 SELF SEP ","; ")" -> PApp(_loc, f, xs)
     | `ANTIQUOT(ty, str) -> PAnt(_loc, ty, str) ]];
END;;

let parse = G.parse_string exp_eoi;; (* instead of let parse s = Grammar.Entry.parse exp_eoi (Stream.of_string s);; *)

exception NoSuchType of string;;
let ty_of_string _loc = function
  | "Int"  -> `Int
  | "Real" -> `Real
  | "Str"  -> `Str
  | ty     -> Loc.raise _loc (NoSuchType ty)
;;
let string_of_ty = function
  | `Int -> "Int"
  | `Real -> "Real"
  | `Str -> "Str"
;;

(* Type Checker *)
exception TypeError;;
type integer=[`Int];;
type real=[integer | `Real];;
type any=[real | `Str];;
let rec type_expr=function
  | PApp(_loc, f,args) ->
      begin match f, args with (* pattern matching is your friend *)
      | "add", [arg1; arg2] ->
          (match type_expr arg1, type_expr arg2 with
           | #integer,#integer -> `Int
           | #real,#real -> `Real
           | #any,#any -> Loc.raise _loc TypeError)
      | _ -> Loc.raise _loc TypeError (* note the location wrapping to have a correct location *)
      end
  | PInt _ -> `Int
  | PFlo _ -> `Real
  | PStr _ -> `Str
  | PAnt(_loc, ty, _) -> ty_of_string _loc ty
;;

(* Quotations *)
(* note that this type definition will be useful only in programs that will use
 * <:exp< ... >> but not here. *)
type alg =
| App of string*alg list
| Int of int
| Flo of float
| Str of string
and typed_alg = (alg * any)
;;

(* Dynamic Type Checker *)
let type_check _loc (expr, ty_expr) ty =
  if ty_expr = ty then expr
  else begin
    Format.eprintf "@[<2>Dynamic Typing Error at@ %a@]@." Loc.print _loc;
    raise TypeError
  end

let expr_of_loc loc = Camlp4.PreCast.Ast.Meta.MetaLoc.meta_loc_expr loc loc;;

module CamlSyntax =
  Camlp4OCamlParser.Make(
    Camlp4OCamlRevisedParser.Make(
      Camlp4.PreCast.Syntax
    )
  );;
let expr_of_string = CamlSyntax.Gram.parse_string CamlSyntax.expr_eoi;;

Camlp4_config.antiquotations := true;; (* Tell camlp4 that you want use antiquotations *)

(* One cannot expect good locations with this declaration: let loc=Ploc.dummy;; *)
let rec to_expr=function
    | PInt(_loc, x) -> <:expr< Int $int:x$ >>
    | PFlo(_loc, x) -> <:expr< Flo $flo:x$ >>
    | PStr(_loc, x) -> <:expr< Str $str:x$ >>
    | PApp(_loc, f, el)->
        let rec make_el=function
            | x::xs -> <:expr< $x$::$make_el xs$ >>
              (* instead of <:expr< [$x$::$make_el xs$] >> since I've used camlp4of *)
            | [] -> <:expr< [] >>
        in
        let el=List.map to_expr el in
        let el=make_el el in
        <:expr< App ($str:f$,$el$) >>
    | PAnt(_loc, ty, str) ->
        <:expr< type_check $expr_of_loc _loc$ $expr_of_string _loc str$ `$ty$ >>
;;
let rec to_patt=function
    | PInt(_loc, x) -> <:patt< Int $int:x$ >>
    | PFlo(_loc, x) -> <:patt< Flo $flo:x$ >>
    | PStr(_loc, x) -> <:patt< Str $str:x$ >>
    | PApp(_loc, f, el) ->
        let rec make_el=function
            | x::xs -> <:patt< $x$::$make_el xs$ >>
            | [] -> <:patt< [] >>
        in
        let el=List.map to_patt el in
        let el=make_el el in
        <:patt< App ($str:f$,$el$) >>
    | PAnt _ -> invalid_arg "antiquotations not supported in patterns"
;;

let expand_expr _loc _loc_name s =
    let p = parse _loc s in
    let t = type_expr p in
    <:expr< ($to_expr p$, `$string_of_ty t$) >>
;;
let expand_patt _loc _loc_name s =
    let p = parse _loc s in
    let t = type_expr p in
    <:patt< ($to_patt p$, `$string_of_ty t$) >>
;;

let expand_str_item loc loc_name s =
  <:str_item@loc< $exp:expand_expr loc loc_name s$ >>

module Q = Syntax.Quotation;;
Q.add "exp" Q.DynAst.expr_tag expand_expr;;
Q.add "exp" Q.DynAst.patt_tag expand_patt;;
Q.add "exp" Q.DynAst.str_item_tag expand_str_item;;

[-- Attachment #8: alg1_ant_test_bad.ml --]
[-- Type: application/octet-stream, Size: 74 bytes --]

open Alg1_ant_str;;
let x = <:exp< "FOO" >> in
<:exp< add(42, $Int:x$) >>