Introduce and use the auxiliary function [CodeBits.annotate].

src/codeBackend.ml

@@ -1239,7 +1239,7 @@ let reducebody prod =
       Production.action prod
     in
     let act =
-      EAnnot (Action.to_il_expr action, type2scheme (semvtypent nt))
+      annotate (Action.to_il_expr action) (semvtypent nt)
     in
 
     tracecomment
@@ -1586,10 +1586,9 @@ let discarddef = {
   valpublic = false;
   valpat = PVar discard;
   valval =
-    EAnnot (
-      discardbody,
-      type2scheme (arrow tenv tenv)
-    )
+    annotate
+      discardbody
+      (arrow tenv tenv)
 }
 
 (* This is [initenv], used to allocate a fresh parser environment.
@@ -1605,7 +1604,7 @@ let initenvdef =
     valpublic = false;
     valpat = PVar initenv;
     valval =
-      EAnnot (
+      annotate (
         EFun ( [ PVar lexer; PVar lexbuf ],
           blet (
             (* We do not have a dummy token at hand, so we forge one. *)
@@ -1619,9 +1618,9 @@ let initenvdef =
             ]
             )
           )
-        ),
-        type2scheme (marrow [ tlexer; tlexbuf ] tenv)
-      )
+        )
+       )
+       (marrow [ tlexer; tlexbuf ] tenv)
   }
 
 (* ------------------------------------------------------------------------ *)

src/codeBits.ml

@@ -124,6 +124,11 @@ let scheme qs t =
 let type2scheme t =
   scheme [] t
 
+(* Constraining an expression to have a (monomorphic) type. *)
+
+let annotate e t =
+  EAnnot (e, type2scheme t)
+
 let pat2var = function
   | PVar x ->
       x

src/codeBits.mli

@@ -53,6 +53,10 @@ val tvar: string -> typ
 val scheme: string list -> typ -> typescheme
 val type2scheme: typ -> typescheme
 
+(* Constraining an expression to have a (monomorphic) type. *)
+
+val annotate: expr -> typ -> expr
+
 (* Projecting out of a [PVar] pattern. *)
 
 val pat2var: pattern -> string

src/codeInliner.ml

@@ -174,7 +174,7 @@ let inline_valdefs (defs : valdef list) : valdef list =
   let rec annotate formals body typ =
     match formals, typ with
     | [], _ ->
-        [], EAnnot (body, type2scheme typ)
+        [], CodeBits.annotate body typ
     | formal :: formals, TypArrow (targ, tres) ->
         let formals, body = annotate formals body tres in
         PAnnot (formal, targ) :: formals, body

src/codePieces.ml

@@ -190,7 +190,7 @@ let destructuretokendef name codomain bindsemv branch = {
   valpublic = false;
   valpat = PVar name;
   valval =
-    EAnnot (
+    annotate (
       EFun ([ PVar token ],
         EMatch (EVar token,
           Terminal.fold (fun tok branches ->
@@ -201,9 +201,9 @@ let destructuretokendef name codomain bindsemv branch = {
                 branchbody = branch tok } :: branches
           ) []
         )
-      ),
-      type2scheme (arrow TokenType.ttoken codomain)
+      )
     )
+    (arrow TokenType.ttoken codomain)
 }
 
 (* ------------------------------------------------------------------------ *)

src/infer.ml

@@ -144,10 +144,9 @@ let actiondef grammar symbol branch =
      semantic action. *)
 
   let body =
-    EAnnot (
-      Action.to_il_expr branch.action,
-      type2scheme (nttype grammar symbol)
-    )
+    annotate
+      (Action.to_il_expr branch.action)
+      (nttype grammar symbol)
   in
 
   match formals with
@@ -188,7 +187,7 @@ let program grammar =
   let def = {
     valpublic = true;
     valpat = PTuple ps;
-    valval = ELet (bindings1 @ bindings2, EAnnot (bottom, type2scheme (TypTuple ts)))
+    valval = ELet (bindings1 @ bindings2, annotate bottom (TypTuple ts))
   }
   in
 

src/tableBackend.ml

@@ -191,7 +191,7 @@ let reducecellcasts prod i symbol casts =
   (* Cast: [let id = ((Obj.magic id) : t) in ...]. *)
   (
     PVar id,
-    EAnnot (EMagic (EVar id), type2scheme t)
+    annotate (EMagic (EVar id)) t
   ) :: casts
 
 (* 2015/11/04. The start and end positions of an epsilon production are obtained
@@ -260,7 +260,7 @@ let reducebody prod =
     Production.action prod
   in
   let act =
-    EAnnot (Action.to_il_expr action, type2scheme (semvtypent nt))
+    annotate (Action.to_il_expr action) (semvtypent nt)
   in
 
   EComment (
@@ -697,7 +697,7 @@ let monolithic_entry_point state nt t =
     and lexbuf = "lexbuf" in
     EFun (
       [ PVar lexer; PVar lexbuf ],
-      EAnnot (
+      annotate (
         EMagic (
           EApp (
             EVar entry, [
@@ -706,9 +706,9 @@ let monolithic_entry_point state nt t =
               EVar lexbuf
             ]
           )
-        ),
-        type2scheme (TypTextual t)
+        )
       )
+      (TypTextual t)
     )
   )
 
@@ -732,7 +732,7 @@ let incremental_entry_point state nt t =
        to the standard error channel. *)
     EFun (
       [ PVar initial ],
-      EAnnot (
+      annotate (
         EMagic (
           EApp (
             EVar start, [
@@ -740,9 +740,9 @@ let incremental_entry_point state nt t =
               EVar initial;
             ]
           )
-        ),
-        type2scheme (checkpoint (TypTextual t))
+        )
       )
+      (checkpoint (TypTextual t))
     )
   )