Skip to content
This repository
tag: v1466
Fetching contributors…

Cannot retrieve contributors at this time

file 88 lines (70 sloc) 2.414 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
module Q = QmlAst

exception Bad_structure


(* assert false are forbidden !!! *)

let of_coerce = function
  | Q.Coerce (_, e, t) -> e, t
  | _ -> raise Bad_structure

let rec of_couple e = match e with
  | Q.Record (_, [("f1", e1); ("f2", e2) ]) -> (e1, e2)
  | _ -> of_couple (fst (of_coerce e) )

let is f e =
  try let _ = f e in true
  with Bad_structure -> false

let is_couple e = is of_couple e


module Pat =
struct
  type 'a util = Q.pat -> 'a

  let void_coerce ty =
    match ty with
    | Q.TypeName ([], ty) when let id = Q.TypeIdent.to_string ty in id = "void" || id = "unit" -> true
    | Q.TypeRecord (Q.TyRow ([], None)) -> true
    | _ -> false

  let bool_coerce ty =
    match ty with
    | Q.TypeName ([], ty) when Q.TypeIdent.to_string ty = "bool" -> true
    | _ -> false

  let is_void = function
    | Q.PatRecord (_, [], `closed) -> true
    | Q.PatCoerce (_, Q.PatRecord (_, [], _), ty) -> void_coerce ty
    | _ -> false

  let rec is_bool = function
    | Q.PatCoerce (_, pat, ty) -> if bool_coerce ty then is_bool pat else None
    | Q.PatRecord (_, [bool, void], `closed) ->
        if is_void void
        then (
          match bool with
          | "true" -> Some true
          | "false" -> Some false
          | _ -> None
        )
        else None
    | _ -> None
end

let uncons_ifthenelse if_ pats =
    match pats with
    | [ true_, then_ ; false_, else_ ] -> (
        if (Pat.is_bool true_) = (Some true) && (Pat.is_bool false_) = (Some false)
        then (
          match if_ with
          | Q.Coerce (_, if_, ty) ->
              if Pat.bool_coerce ty
              then Some (if_, then_, else_)
              else None
          | _ -> Some (if_, then_, else_)
        )
        else None
      )
    | _ -> None
Something went wrong with that request. Please try again.