Source file exparser.ml

(* camlp5r *)
(* exparser.ml,v *)
(* Copyright (c) INRIA 2007-2017 *)

(* #load "q_MLast.cmo" *)

type spat_comp =
    SpTrm of MLast.loc * MLast.patt * MLast.expr option MLast.v
  | SpNtr of MLast.loc * MLast.patt * MLast.expr
  | SpLet of MLast.loc * MLast.patt * MLast.expr
  | SpLhd of MLast.loc * MLast.patt list list
  | SpStr of MLast.loc * MLast.patt
type sexp_comp =
    SeTrm of MLast.loc * MLast.expr
  | SeNtr of MLast.loc * MLast.expr

type spat_comp_opt =
    SpoNoth
  | SpoBang
  | SpoQues of MLast.expr

type spat_parser_ast =
  MLast.patt option *
    ((spat_comp * spat_comp_opt) list * MLast.patt option * MLast.expr) list

let strm_n = "strm__"
let peek_fun loc =
  MLast.ExFle
    (loc, MLast.ExLong (loc, MLast.LiUid (loc, Ploc.VaVal "Stream")),
     Ploc.VaVal (None, Ploc.VaVal "peek"))
let junk_fun loc =
  MLast.ExFle
    (loc, MLast.ExLong (loc, MLast.LiUid (loc, Ploc.VaVal "Stream")),
     Ploc.VaVal (None, Ploc.VaVal "junk"))

(* Parsers *)

let rec pattern_eq_expression p e =
  match p, e with
    MLast.PaLid (_, Ploc.VaVal a), MLast.ExLid (_, Ploc.VaVal b) -> a = b
  | MLast.PaLong (_, MLast.LiUid (_, Ploc.VaVal a), Ploc.VaVal []),
    MLast.ExLong (_, MLast.LiUid (_, Ploc.VaVal b)) ->
      a = b
  | MLast.PaApp (_, p1, p2), MLast.ExApp (_, e1, e2) ->
      pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2
  | _ -> false

let is_raise e =
  match e with
    MLast.ExApp (_, MLast.ExLid (_, Ploc.VaVal "raise"), _) -> true
  | _ -> false

let is_raise_failure e =
  match e with
    MLast.ExApp
      (_, MLast.ExLid (_, Ploc.VaVal "raise"),
       MLast.ExLong
         (_,
          MLast.LiAcc
            (_, MLast.LiUid (_, Ploc.VaVal "Stream"),
             Ploc.VaVal "Failure"))) ->
      true
  | _ -> false

let rec handle_failure e =
  match e with
    MLast.ExTry
      (_, te,
       Ploc.VaVal
         [MLast.PaLong
            (_,
             MLast.LiAcc
               (_, MLast.LiUid (_, Ploc.VaVal "Stream"),
                Ploc.VaVal "Failure"),
             Ploc.VaVal []),
          Ploc.VaVal None, e]) ->
      handle_failure e
  | MLast.ExMat (_, me, Ploc.VaVal pel) ->
      handle_failure me &&
      List.for_all
        (function
           _, Ploc.VaVal None, e -> handle_failure e
         | _ -> false)
        pel
  | MLast.ExLet (_, Ploc.VaVal false, Ploc.VaVal pel, e) ->
      List.for_all (fun (p, e, _) -> handle_failure e) pel && handle_failure e
  | MLast.ExSeq (_, Ploc.VaVal el) -> List.for_all handle_failure el
  | MLast.ExFle
      (_, MLast.ExLong (_, MLast.LiUid (_, Ploc.VaVal _)),
       Ploc.VaVal (None, Ploc.VaVal _)) |
    MLast.ExLid (_, Ploc.VaVal _) | MLast.ExInt (_, Ploc.VaVal _, "") |
    MLast.ExStr (_, Ploc.VaVal (_, Ploc.VaVal _)) |
    MLast.ExChr (_, Ploc.VaVal _) | MLast.ExFun (_, Ploc.VaVal _) |
    MLast.ExLong (_, MLast.LiUid (_, Ploc.VaVal _)) ->
      true
  | MLast.ExApp (_, MLast.ExLid (_, Ploc.VaVal "raise"), e) ->
      begin match e with
        MLast.ExLong
          (_,
           MLast.LiAcc
             (_, MLast.LiUid (_, Ploc.VaVal "Stream"),
              Ploc.VaVal "Failure")) ->
          false
      | _ -> true
      end
  | MLast.ExApp (_, f, x) ->
      no_raising_failure_fun f && handle_failure f && handle_failure x
  | _ -> false
and no_raising_failure_fun =
  function
    MLast.ExLong (_, MLast.LiUid (_, Ploc.VaVal _)) -> true
  | MLast.ExLid (_, Ploc.VaVal _) -> false
  | MLast.ExFle
      (_, MLast.ExLong (_, MLast.LiUid (_, Ploc.VaVal "Stream")),
       Ploc.VaVal (None, Ploc.VaVal "peek")) |
    MLast.ExFle
      (_, MLast.ExLong (_, MLast.LiUid (_, Ploc.VaVal "Stream")),
       Ploc.VaVal (None, Ploc.VaVal "junk")) ->
      true
  | MLast.ExApp (_, x, y) -> no_raising_failure_fun x && handle_failure y
  | _ -> false

let rec subst v e =
  match e with
    MLast.ExLid (loc, Ploc.VaVal x) ->
      let x = if x = v then strm_n else x in MLast.ExLid (loc, Ploc.VaVal x)
  | MLast.ExLong (_, MLast.LiUid (_, Ploc.VaVal _)) -> e
  | MLast.ExInt (_, Ploc.VaVal _, "") -> e
  | MLast.ExChr (_, Ploc.VaVal _) -> e
  | MLast.ExStr (_, Ploc.VaVal (_, Ploc.VaVal _)) -> e
  | MLast.ExFle (_, _, Ploc.VaVal (None, Ploc.VaVal _)) -> e
  | MLast.ExLet (loc, Ploc.VaVal rf, Ploc.VaVal pel, e) ->
      MLast.ExLet
        (loc, Ploc.VaVal rf, Ploc.VaVal (List.map (subst_pe v) pel),
         subst v e)
  | MLast.ExApp (loc, e1, e2) -> MLast.ExApp (loc, subst v e1, subst v e2)
  | MLast.ExTup (loc, Ploc.VaVal el) ->
      MLast.ExTup (loc, Ploc.VaVal (List.map (subst v) el))
  | _ -> raise Not_found
and subst_pe v (p, e, attrs) =
  match p with
    MLast.PaLid (_, Ploc.VaVal v') when v <> v' -> p, subst v e, attrs
  | _ -> raise Not_found

let optim = ref true
let _ =
  Pcaml.add_option "-no-pa-opt" (Arg.Clear optim) "No parsers optimization."

let rec perhaps_bound s =
  function
    MLast.ExTup (_, Ploc.VaVal el) -> List.exists (perhaps_bound s) el
  | MLast.ExLong (_, MLast.LiUid (_, Ploc.VaVal _)) |
    MLast.ExStr (_, Ploc.VaVal (_, Ploc.VaVal _)) ->
      false
  | _ -> true

let wildcard_if_not_bound p e =
  match p with
    MLast.PaLid (loc, Ploc.VaVal s) ->
      if perhaps_bound s e then p else MLast.PaAny loc
  | _ -> p

let stream_pattern_component skont ckont =
  function
    SpTrm (loc, p, wo) ->
      MLast.ExMat
        (loc,
         MLast.ExApp
           (loc, peek_fun loc, MLast.ExLid (loc, Ploc.VaVal strm_n)),
         Ploc.VaVal
           [MLast.PaApp
              (loc,
               MLast.PaLong
                 (loc, MLast.LiUid (loc, Ploc.VaVal "Some"), Ploc.VaVal []),
               p),
            wo,
            MLast.ExSeq
              (loc,
               Ploc.VaVal
                 [MLast.ExApp
                    (loc, junk_fun loc, MLast.ExLid (loc, Ploc.VaVal strm_n));
                  skont]);
            MLast.PaAny loc, Ploc.VaVal None, ckont])
  | SpNtr (loc, p, e) ->
      let e =
        match e with
          MLast.ExFun
            (_,
             Ploc.VaVal
               [MLast.PaTyc
                  (_, MLast.PaLid (_, Ploc.VaVal v),
                   MLast.TyApp
                     (_,
                      MLast.TyAcc
                        (_, MLast.LiUid (_, Ploc.VaVal "Stream"),
                         Ploc.VaVal "t"),
                      MLast.TyAny _)),
                Ploc.VaVal None, e])
          when v = strm_n ->
            e
        | _ -> MLast.ExApp (loc, e, MLast.ExLid (loc, Ploc.VaVal strm_n))
      in
      if !optim then
        if pattern_eq_expression p skont then
          if is_raise_failure ckont then e
          else if handle_failure e then e
          else
            MLast.ExTry
              (loc, e,
               Ploc.VaVal
                 [MLast.PaLong
                    (loc,
                     MLast.LiAcc
                       (loc, MLast.LiUid (loc, Ploc.VaVal "Stream"),
                        Ploc.VaVal "Failure"),
                     Ploc.VaVal []),
                  Ploc.VaVal None, ckont])
        else if is_raise_failure ckont then
          let p = wildcard_if_not_bound p skont in
          MLast.ExLet
            (loc, Ploc.VaVal false, Ploc.VaVal [p, e, Ploc.VaVal []], skont)
        else if is_raise ckont then
          let tst =
            if handle_failure e then e
            else
              MLast.ExTry
                (loc, e,
                 Ploc.VaVal
                   [MLast.PaLong
                      (loc,
                       MLast.LiAcc
                         (loc, MLast.LiUid (loc, Ploc.VaVal "Stream"),
                          Ploc.VaVal "Failure"),
                       Ploc.VaVal []),
                    Ploc.VaVal None, ckont])
          in
          let p = wildcard_if_not_bound p skont in
          MLast.ExLet
            (loc, Ploc.VaVal false, Ploc.VaVal [p, tst, Ploc.VaVal []], skont)
        else if
          pattern_eq_expression
            (MLast.PaApp
               (loc,
                MLast.PaLong
                  (loc, MLast.LiUid (loc, Ploc.VaVal "Some"), Ploc.VaVal []),
                p))
            skont
        then
          MLast.ExTry
            (loc,
             MLast.ExApp
               (loc, MLast.ExLong (loc, MLast.LiUid (loc, Ploc.VaVal "Some")),
                e),
             Ploc.VaVal
               [MLast.PaLong
                  (loc,
                   MLast.LiAcc
                     (loc, MLast.LiUid (loc, Ploc.VaVal "Stream"),
                      Ploc.VaVal "Failure"),
                   Ploc.VaVal []),
                Ploc.VaVal None, ckont])
        else
          MLast.ExMat
            (loc,
             MLast.ExTry
               (loc,
                MLast.ExApp
                  (loc,
                   MLast.ExLong (loc, MLast.LiUid (loc, Ploc.VaVal "Some")),
                   e),
                Ploc.VaVal
                  [MLast.PaLong
                     (loc,
                      MLast.LiAcc
                        (loc, MLast.LiUid (loc, Ploc.VaVal "Stream"),
                         Ploc.VaVal "Failure"),
                      Ploc.VaVal []),
                   Ploc.VaVal None,
                   MLast.ExLong (loc, MLast.LiUid (loc, Ploc.VaVal "None"))]),
             Ploc.VaVal
               [MLast.PaApp
                  (loc,
                   MLast.PaLong
                     (loc, MLast.LiUid (loc, Ploc.VaVal "Some"),
                      Ploc.VaVal []),
                   p),
                Ploc.VaVal None, skont;
                MLast.PaAny loc, Ploc.VaVal None, ckont])
      else
        MLast.ExMat
          (loc,
           MLast.ExTry
             (loc,
              MLast.ExApp
                (loc,
                 MLast.ExLong (loc, MLast.LiUid (loc, Ploc.VaVal "Some")), e),
              Ploc.VaVal
                [MLast.PaLong
                   (loc,
                    MLast.LiAcc
                      (loc, MLast.LiUid (loc, Ploc.VaVal "Stream"),
                       Ploc.VaVal "Failure"),
                    Ploc.VaVal []),
                 Ploc.VaVal None,
                 MLast.ExLong (loc, MLast.LiUid (loc, Ploc.VaVal "None"))]),
           Ploc.VaVal
             [MLast.PaApp
                (loc,
                 MLast.PaLong
                   (loc, MLast.LiUid (loc, Ploc.VaVal "Some"), Ploc.VaVal []),
                 p),
              Ploc.VaVal None, skont;
              MLast.PaAny loc, Ploc.VaVal None, ckont])
  | SpLet (_, _, _) -> assert false
  | SpLhd (loc, pl :: pll) ->
      let mklistpat loc pl =
        List.fold_right
          (fun p1 p2 ->
             MLast.PaApp
               (loc,
                MLast.PaApp
                  (loc,
                   MLast.PaLong
                     (loc, MLast.LiUid (loc, Ploc.VaVal "::"), Ploc.VaVal []),
                   p1),
                p2))
          pl
          (MLast.PaLong
             (loc, MLast.LiUid (loc, Ploc.VaVal "[]"), Ploc.VaVal []))
      in
      let len = List.length pl in
      if List.exists (fun pl -> List.length pl <> len) pll then
        Ploc.raise loc
          (Stream.Error "lookahead patterns must be of the same lengths")
      else
        let p =
          let p = mklistpat loc pl in
          let pl = List.map (mklistpat loc) pll in
          List.fold_left (fun p1 p2 -> MLast.PaOrp (loc, p1, p2)) p pl
        in
        MLast.ExMat
          (loc,
           MLast.ExApp
             (loc,
              MLast.ExApp
                (loc,
                 MLast.ExFle
                   (loc,
                    MLast.ExLong
                      (loc, MLast.LiUid (loc, Ploc.VaVal "Stream")),
                    Ploc.VaVal (None, Ploc.VaVal "npeek")),
                 MLast.ExInt (loc, Ploc.VaVal (string_of_int len), "")),
              MLast.ExLid (loc, Ploc.VaVal "strm__")),
           Ploc.VaVal
             [p, Ploc.VaVal None, skont;
              MLast.PaAny loc, Ploc.VaVal None, ckont])
  | SpLhd (loc, []) -> ckont
  | SpStr (loc, p) ->
      try
        match p with
          MLast.PaLid (_, Ploc.VaVal v) ->
            MLast.ExLet
              (loc, Ploc.VaVal false,
               Ploc.VaVal
                 [MLast.PaLid (loc, Ploc.VaVal v),
                  MLast.ExLid (loc, Ploc.VaVal "strm__"), Ploc.VaVal []],
               skont)
        | _ -> raise Not_found
      with Not_found ->
        MLast.ExLet
          (loc, Ploc.VaVal false,
           Ploc.VaVal
             [p, MLast.ExLid (loc, Ploc.VaVal strm_n), Ploc.VaVal []],
           skont)

let rec stream_pattern loc epo e ekont =
  function
    [] ->
      begin match epo with
        Some ep ->
          MLast.ExLet
            (loc, Ploc.VaVal false,
             Ploc.VaVal
               [ep,
                MLast.ExApp
                  (loc,
                   MLast.ExFle
                     (loc,
                      MLast.ExLong
                        (loc, MLast.LiUid (loc, Ploc.VaVal "Stream")),
                      Ploc.VaVal (None, Ploc.VaVal "count")),
                   MLast.ExLid (loc, Ploc.VaVal strm_n)),
                Ploc.VaVal []],
             e)
      | _ -> e
      end
  | (SpLet (loc, p1, e1), _) :: spcl ->
      let skont = stream_pattern loc epo e ekont spcl in
      MLast.ExLet
        (loc, Ploc.VaVal false, Ploc.VaVal [p1, e1, Ploc.VaVal []], skont)
  | (spc, err) :: spcl ->
      let skont =
        let ekont =
          function
            SpoQues estr ->
              MLast.ExApp
                (loc, MLast.ExLid (loc, Ploc.VaVal "raise"),
                 MLast.ExApp
                   (loc,
                    MLast.ExLong
                      (loc,
                       MLast.LiAcc
                         (loc, MLast.LiUid (loc, Ploc.VaVal "Stream"),
                          Ploc.VaVal "Error")),
                    estr))
          | SpoBang ->
              MLast.ExApp
                (loc, MLast.ExLid (loc, Ploc.VaVal "raise"),
                 MLast.ExLong
                   (loc,
                    MLast.LiAcc
                      (loc, MLast.LiUid (loc, Ploc.VaVal "Stream"),
                       Ploc.VaVal "Failure")))
          | SpoNoth ->
              MLast.ExApp
                (loc, MLast.ExLid (loc, Ploc.VaVal "raise"),
                 MLast.ExApp
                   (loc,
                    MLast.ExLong
                      (loc,
                       MLast.LiAcc
                         (loc, MLast.LiUid (loc, Ploc.VaVal "Stream"),
                          Ploc.VaVal "Error")),
                    MLast.ExStr (loc, Ploc.VaVal (loc, Ploc.VaVal ""))))
        in
        stream_pattern loc epo e ekont spcl
      in
      let ckont = ekont err in stream_pattern_component skont ckont spc

let stream_patterns_term loc ekont tspel =
  let pel =
    List.map
      (fun (p, w, loc, spcl, epo, e) ->
         let p =
           MLast.PaApp
             (loc,
              MLast.PaLong
                (loc, MLast.LiUid (loc, Ploc.VaVal "Some"), Ploc.VaVal []),
              p)
         in
         let e =
           let ekont =
             function
               SpoQues estr ->
                 MLast.ExApp
                   (loc, MLast.ExLid (loc, Ploc.VaVal "raise"),
                    MLast.ExApp
                      (loc,
                       MLast.ExLong
                         (loc,
                          MLast.LiAcc
                            (loc, MLast.LiUid (loc, Ploc.VaVal "Stream"),
                             Ploc.VaVal "Error")),
                       estr))
             | SpoBang ->
                 MLast.ExApp
                   (loc, MLast.ExLid (loc, Ploc.VaVal "raise"),
                    MLast.ExLong
                      (loc,
                       MLast.LiAcc
                         (loc, MLast.LiUid (loc, Ploc.VaVal "Stream"),
                          Ploc.VaVal "Failure")))
             | SpoNoth ->
                 MLast.ExApp
                   (loc, MLast.ExLid (loc, Ploc.VaVal "raise"),
                    MLast.ExApp
                      (loc,
                       MLast.ExLong
                         (loc,
                          MLast.LiAcc
                            (loc, MLast.LiUid (loc, Ploc.VaVal "Stream"),
                             Ploc.VaVal "Error")),
                       MLast.ExStr (loc, Ploc.VaVal (loc, Ploc.VaVal ""))))
           in
           let skont = stream_pattern loc epo e ekont spcl in
           MLast.ExSeq
             (loc,
              Ploc.VaVal
                [MLast.ExApp
                   (loc, junk_fun loc, MLast.ExLid (loc, Ploc.VaVal strm_n));
                 skont])
         in
         p, w, e)
      tspel
  in
  let pel = pel @ [MLast.PaAny loc, Ploc.VaVal None, ekont ()] in
  MLast.ExMat
    (loc,
     MLast.ExApp (loc, peek_fun loc, MLast.ExLid (loc, Ploc.VaVal strm_n)),
     Ploc.VaVal pel)

let rec group_terms =
  function
    ((SpTrm (loc, p, w), SpoNoth) :: spcl, epo, e) :: spel ->
      let (tspel, spel) = group_terms spel in
      (p, w, loc, spcl, epo, e) :: tspel, spel
  | spel -> [], spel

let rec parser_cases loc =
  function
    [] ->
      MLast.ExApp
        (loc, MLast.ExLid (loc, Ploc.VaVal "raise"),
         MLast.ExLong
           (loc,
            MLast.LiAcc
              (loc, MLast.LiUid (loc, Ploc.VaVal "Stream"),
               Ploc.VaVal "Failure")))
  | spel ->
      if !optim then
        match group_terms spel with
          [], (spcl, epo, e) :: spel ->
            stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl
        | tspel, spel ->
            stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel
      else
        match spel with
          (spcl, epo, e) :: spel ->
            stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl
        | [] ->
            MLast.ExApp
              (loc, MLast.ExLid (loc, Ploc.VaVal "raise"),
               MLast.ExLong
                 (loc,
                  MLast.LiAcc
                    (loc, MLast.LiUid (loc, Ploc.VaVal "Stream"),
                     Ploc.VaVal "Failure")))

(* optim: left factorization of consecutive rules *)

type ('a, 'b) tree_node =
    Node of 'a * ('a, 'b) tree_node list
  | Leaf of 'b

let rec map_tree_node f_node f_leaf =
  function
    Node (x, tl) -> f_node x (List.map (map_tree_node f_node f_leaf) tl)
  | Leaf b -> f_leaf b

let rec insert_in_tree eq (l, a) tl =
  match tl with
    Node (n, tl1) :: tl2 ->
      begin match l with
        x :: l ->
          if eq x n then Node (n, insert_in_tree eq (l, a) tl1) :: tl2
          else
            List.fold_right (fun x n -> Node (x, [n])) (x :: l) (Leaf a) :: tl
      | [] ->
          let rec loop =
            function
              Node (n, tl1) :: tl -> Node (n, tl1) :: loop tl
            | tl -> Leaf a :: tl
          in
          loop tl
      end
  | _ -> List.fold_right (fun x n -> Node (x, [n])) l (Leaf a) :: tl

let tree_of_list eq ll = List.fold_right (insert_in_tree eq) ll []

let rec list_of_tree mk_node mk_leaf tl =
  List.map (map_tree_node mk_node mk_leaf) tl

let eq_spat_comp spc1 spc2 =
  match spc1, spc2 with
    SpTrm (_, p1, Ploc.VaVal None), SpTrm (_, p2, Ploc.VaVal None) ->
      Reloc.eq_patt p1 p2
  | SpNtr (_, p1, e1), SpNtr (_, p2, e2) ->
      Reloc.eq_patt p1 p2 && Reloc.eq_expr e1 e2
  | _ -> false

let eq_spo spco1 spco2 =
  match spco1, spco2 with
    SpoQues e1, SpoQues e2 -> Reloc.eq_expr e1 e2
  | _ -> spco1 = spco2

let eq_spat_comp_opt (spc1, spco1) (spc2, spco2) =
  eq_spat_comp spc1 spc2 && eq_spo spco1 spco2

let mk_empty b = [], b

let mk_rule x =
  function
    [] -> failwith "mk_rule"
  | [rl, a] -> x :: rl, a
  | ll ->
      let loc = Ploc.dummy in
      let e =
        let rl = List.map (fun (rl, (eo, a)) -> rl, eo, a) ll in
        let e = parser_cases loc rl in
        let p =
          MLast.PaTyc
            (loc, MLast.PaLid (loc, Ploc.VaVal strm_n),
             MLast.TyApp
               (loc,
                MLast.TyAcc
                  (loc, MLast.LiUid (loc, Ploc.VaVal "Stream"),
                   Ploc.VaVal "t"),
                MLast.TyAny loc))
        in
        MLast.ExFun (loc, Ploc.VaVal [p, Ploc.VaVal None, e])
      in
      let spo =
        if List.exists
             (fun (rl, _) ->
                match rl with
                  [] -> true
                | (_, SpoBang) :: _ -> true
                | _ -> false)
             ll
        then
          SpoBang
        else SpoNoth
      in
      [x; SpNtr (loc, MLast.PaLid (loc, Ploc.VaVal "a"), e), spo],
      (None, MLast.ExLid (loc, Ploc.VaVal "a"))

let left_factorize rl =
  let rl = List.map (fun (rl, eo, a) -> rl, (eo, a)) rl in
  let t = tree_of_list eq_spat_comp_opt rl in
  let rl = list_of_tree mk_rule mk_empty t in
  List.map (fun (rl, (eo, a)) -> rl, eo, a) rl

(* Converting into AST *)

let cparser loc (bpo, pc) =
  let pc = left_factorize pc in
  let e = parser_cases loc pc in
  let e =
    let loc = Ploc.with_comment loc "" in
    match bpo with
      Some bp ->
        MLast.ExLet
          (loc, Ploc.VaVal false,
           Ploc.VaVal
             [bp,
              MLast.ExApp
                (loc,
                 MLast.ExFle
                   (loc,
                    MLast.ExLong
                      (loc, MLast.LiUid (loc, Ploc.VaVal "Stream")),
                    Ploc.VaVal (None, Ploc.VaVal "count")),
                 MLast.ExLid (loc, Ploc.VaVal strm_n)),
              Ploc.VaVal []],
           e)
    | None -> e
  in
  let p =
    let loc = Ploc.with_comment loc "" in
    MLast.PaTyc
      (loc, MLast.PaLid (loc, Ploc.VaVal strm_n),
       MLast.TyApp
         (loc,
          MLast.TyAcc
            (loc, MLast.LiUid (loc, Ploc.VaVal "Stream"), Ploc.VaVal "t"),
          MLast.TyAny loc))
  in
  MLast.ExFun (loc, Ploc.VaVal [p, Ploc.VaVal None, e])

let rec is_not_bound s =
  function
    MLast.ExLong (_, MLast.LiUid (_, Ploc.VaVal _)) -> true
  | MLast.ExApp
      (_, MLast.ExLid (_, Ploc.VaVal "raise"),
       MLast.ExLong
         (_,
          MLast.LiAcc
            (_, MLast.LiUid (_, Ploc.VaVal "Stream"),
             Ploc.VaVal "Failure"))) ->
      true
  | _ -> false

let cparser_match loc me (bpo, pc) =
  let pc = left_factorize pc in
  let iloc = Ploc.with_comment loc "" in
  let pc = parser_cases iloc pc in
  let e =
    let loc = iloc in
    match bpo with
      Some bp ->
        MLast.ExLet
          (loc, Ploc.VaVal false,
           Ploc.VaVal
             [bp,
              MLast.ExApp
                (loc,
                 MLast.ExFle
                   (loc,
                    MLast.ExLong
                      (loc, MLast.LiUid (loc, Ploc.VaVal "Stream")),
                    Ploc.VaVal (None, Ploc.VaVal "count")),
                 MLast.ExLid (loc, Ploc.VaVal strm_n)),
              Ploc.VaVal []],
           pc)
    | None -> pc
  in
  match me with
    MLast.ExLid (_, Ploc.VaVal x) when x = strm_n -> e
  | _ ->
      let p =
        let loc = iloc in
        if is_not_bound strm_n e then MLast.PaAny loc
        else MLast.PaLid (loc, Ploc.VaVal strm_n)
      in
      MLast.ExLet
        (loc, Ploc.VaVal false,
         Ploc.VaVal
           [MLast.PaTyc
              (loc, p,
               MLast.TyApp
                 (loc,
                  MLast.TyAcc
                    (loc, MLast.LiUid (loc, Ploc.VaVal "Stream"),
                     Ploc.VaVal "t"),
                  MLast.TyAny loc)),
            me, Ploc.VaVal []],
         e)

(* Streams *)

let rec not_computing =
  function
    MLast.ExLid (_, Ploc.VaVal _) |
    MLast.ExLong (_, MLast.LiUid (_, Ploc.VaVal _)) |
    MLast.ExInt (_, Ploc.VaVal _, "") | MLast.ExFlo (_, Ploc.VaVal _) |
    MLast.ExChr (_, Ploc.VaVal _) |
    MLast.ExStr (_, Ploc.VaVal (_, Ploc.VaVal _)) ->
      true
  | MLast.ExApp (_, x, y) -> is_cons_apply_not_computing x && not_computing y
  | _ -> false
and is_cons_apply_not_computing =
  function
    MLast.ExLong (_, MLast.LiUid (_, Ploc.VaVal _)) -> true
  | MLast.ExLid (_, Ploc.VaVal _) -> false
  | MLast.ExApp (_, x, y) -> is_cons_apply_not_computing x && not_computing y
  | _ -> false

let slazy loc e =
  match e with
    MLast.ExApp (_, f, MLast.ExLong (_, MLast.LiUid (_, Ploc.VaVal "()"))) ->
      begin match f with
        MLast.ExLid (_, Ploc.VaVal _) -> f
      | _ ->
          MLast.ExFun (loc, Ploc.VaVal [MLast.PaAny loc, Ploc.VaVal None, e])
      end
  | _ -> MLast.ExFun (loc, Ploc.VaVal [MLast.PaAny loc, Ploc.VaVal None, e])

let rec cstream gloc =
  function
    [] ->
      let loc = gloc in
      MLast.ExFle
        (loc, MLast.ExLong (loc, MLast.LiUid (loc, Ploc.VaVal "Stream")),
         Ploc.VaVal (None, Ploc.VaVal "sempty"))
  | [SeTrm (loc, e)] ->
      if not_computing e then
        MLast.ExApp
          (loc,
           MLast.ExFle
             (loc, MLast.ExLong (loc, MLast.LiUid (loc, Ploc.VaVal "Stream")),
              Ploc.VaVal (None, Ploc.VaVal "ising")),
           e)
      else
        MLast.ExApp
          (loc,
           MLast.ExFle
             (loc, MLast.ExLong (loc, MLast.LiUid (loc, Ploc.VaVal "Stream")),
              Ploc.VaVal (None, Ploc.VaVal "lsing")),
           slazy loc e)
  | SeTrm (loc, e) :: secl ->
      if not_computing e then
        MLast.ExApp
          (loc,
           MLast.ExApp
             (loc,
              MLast.ExFle
                (loc,
                 MLast.ExLong (loc, MLast.LiUid (loc, Ploc.VaVal "Stream")),
                 Ploc.VaVal (None, Ploc.VaVal "icons")),
              e),
           cstream gloc secl)
      else
        MLast.ExApp
          (loc,
           MLast.ExApp
             (loc,
              MLast.ExFle
                (loc,
                 MLast.ExLong (loc, MLast.LiUid (loc, Ploc.VaVal "Stream")),
                 Ploc.VaVal (None, Ploc.VaVal "lcons")),
              slazy loc e),
           cstream gloc secl)
  | [SeNtr (loc, e)] ->
      if not_computing e then e
      else
        MLast.ExApp
          (loc,
           MLast.ExFle
             (loc, MLast.ExLong (loc, MLast.LiUid (loc, Ploc.VaVal "Stream")),
              Ploc.VaVal (None, Ploc.VaVal "slazy")),
           slazy loc e)
  | SeNtr (loc, e) :: secl ->
      if not_computing e then
        MLast.ExApp
          (loc,
           MLast.ExApp
             (loc,
              MLast.ExFle
                (loc,
                 MLast.ExLong (loc, MLast.LiUid (loc, Ploc.VaVal "Stream")),
                 Ploc.VaVal (None, Ploc.VaVal "iapp")),
              e),
           cstream gloc secl)
      else
        MLast.ExApp
          (loc,
           MLast.ExApp
             (loc,
              MLast.ExFle
                (loc,
                 MLast.ExLong (loc, MLast.LiUid (loc, Ploc.VaVal "Stream")),
                 Ploc.VaVal (None, Ploc.VaVal "lapp")),
              slazy loc e),
           cstream gloc secl)