syntax/utils.ml

   1 (* Copyright Jeremy Yallop 2007.
   2    This file is free software, distributed under the MIT license.
   3    See the file COPYING for details.
   4 *)
   5
   6 type ('a,'b) either = Left of 'a | Right of 'b
   7
   8 let either_partition (f : 'a -> ('b, 'c) either) (l : 'a list)
   9     : 'b list * 'c list =
  10   let rec aux (lefts, rights) = function
  11     | [] -> (List.rev lefts, List.rev rights)
  12     | x::xs ->
  13         match f x with
  14           | Left l  -> aux (l :: lefts, rights) xs
  15           | Right r -> aux (lefts, r :: rights) xs
  16   in aux ([], []) l
  17
  18
  19 module List =
  20 struct
  21   include List
  22
  23   let fold_left1 : ('a -> 'a -> 'a) -> 'a list -> 'a
  24     = fun f l -> match l with
  25       | x::xs  -> List.fold_left f x xs
  26       | []     -> invalid_arg "fold_left1"
  27
  28   let rec fold_right1 : ('a -> 'a -> 'a) -> 'a list -> 'a
  29     = fun f l -> match l with
  30       | [x]   -> x
  31       | x::xs -> f x (fold_right1 f xs)
  32       | []    -> invalid_arg "fold_right1"
  33
  34   let rec range from upto =
  35     let rec aux f t result =
  36       if f = t then result
  37       else aux (f+1) t (f::result)
  38     in if upto < from then raise (Invalid_argument "range")
  39       else List.rev (aux from upto [])
  40
  41   let rec last : 'a list -> 'a = function
  42     | []    -> invalid_arg "last"
  43     | [x]   -> x
  44     | _::xs -> last xs
  45
  46   let concat_map f l =
  47     let rec aux = function
  48       | _, [] -> []
  49       | f, x :: xs -> f x @ aux (f, xs)
  50     in aux (f,l)
  51
  52   let concat_map2 (f : 'a -> 'b -> 'c list) (l1 : 'a list) (l2 : 'b list) : 'c list =
  53     let rec aux = function
  54       | [], [] -> []
  55       | x::xs, y :: ys -> f x y @ aux (xs, ys)
  56       | _ -> invalid_arg "concat_map2"
  57     in aux (l1, l2)
  58
  59   let mapn ?(init=0) f =
  60     let rec aux n = function
  61       | [] -> []
  62       | x::xs -> f x n :: aux (n+1) xs in
  63       aux init
  64 end
  65
  66 module F =
  67 struct
  68   let id x = x
  69   let curry f x y = f (x,y)
  70   let uncurry f (x,y) = f x y
  71 end
  72
  73 module Option =
  74 struct
  75   let map f = function
  76     | None -> None
  77     | Some x -> Some (f x)
  78 end
  79
  80 module DumpAst =
  81 struct
  82   open Camlp4.PreCast.Ast
  83
  84   let rec ident = function
  85     | IdAcc (_, i1, i2) -> "IdAcc ("^ident i1^","^ident i2^")"
  86     | IdApp (_, i1, i2) -> "IdApp ("^ident i1^","^ident i2^")"
  87     | IdLid (_, s) -> "IdLid("^s^")"
  88     | IdUid (_, s) -> "IdUid("^s^")"
  89     | IdAnt (_, s) -> "IdAnt("^s^")"
  90
  91   let rec ctyp = function
  92     | TyLab (_, s, c) -> "TyLab ("^s ^ "," ^ ctyp c ^")"
  93     | TyDcl (_, s, cs, c2, ccs) -> "TyDcl ("^s ^", [" ^ String.concat ";" (List.map ctyp cs) ^"], "^ctyp c2 ^ ", ["^
  94         String.concat "," (List.map (fun (c1,c2) -> "(" ^ ctyp c1 ^ ", " ^ ctyp c2 ^ ")") ccs)
  95         ^ "])"
  96     | TyObj (_, c, _) -> "TyObj ("^ ctyp c ^ ", ?)"
  97     | TyOlb (_, s, c) -> "TyOlb ("^s ^ "," ^ ctyp c ^")"
  98     | TyOf (_, c1, c2) -> "TyOf ("^ ctyp c1 ^ ", " ^ ctyp c2 ^ ")"
  99     | TyOr (_, c1, c2) -> "TyOr ("^ ctyp c1 ^ ", " ^ ctyp c2 ^ ")"
 100     | TyRec (_, c) -> "TyRec("^ctyp c^")"
 101     | TySum (_, c) -> "TySum("^ctyp c^")"
 102     | TyPrv (_, c) -> "TyPrv("^ctyp c^")"
 103     | TyMut (_, c) -> "TyMut("^ctyp c^")"
 104     | TyTup (_, c) -> "TyTup("^ctyp c^")"
 105     | TyVrnEq (_, c) -> "TyVrnEq("^ctyp c^")"
 106     | TyVrnSup (_, c) -> "TyVrnSup("^ctyp c^")"
 107     | TyVrnInf (_, c) -> "TyVrnInf("^ctyp c^")"
 108     | TyCls (_, i) -> "TyCls("^ident i^")"
 109     | TyId (_, i) -> "TyId("^ident i^")"
 110     | TyNil (_) -> "TyNil"
 111     | TyAli (_, c1, c2) -> "TyAli ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")"
 112     | TyAny (_) -> "TyAny"
 113     | TyApp (_, c1, c2) -> "TyApp ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")"
 114     | TyArr (_, c1, c2) -> "TyArr ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")"
 115     | TyMan (_, c1, c2) -> "TyMan ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")"
 116     | TyPol (_, c1, c2) -> "TyPol ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")"
 117     | TyQuo (_, s) -> "TyQuo("^s^")"
 118     | TyQuP (_, s) -> "TyQuP("^s^")"
 119     | TyQuM (_, s) -> "TyQuM("^s^")"
 120     | TyVrn (_, s) -> "TyVrn("^s^")"
 121     | TyCol (_, c1, c2) -> "TyCol ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")"
 122     | TySem (_, c1, c2) -> "TySem ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")"
 123     | TyCom (_, c1, c2) -> "TyCom ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")"
 124     | TyAnd (_, c1, c2) -> "TyAnd ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")"
 125     | TySta (_, c1, c2) -> "TySta ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")"
 126     | TyVrnInfSup (_, c1, c2) -> "TyVrnInfSup ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")"
 127     | TyAmp (_, c1, c2) -> "TyAmp ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")"
 128     | TyOfAmp (_, c1, c2) -> "TyOfAmp ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")"
 129     | TyAnt (_, s) -> "TyAnt("^s^")"
 130     | _ -> "(?)"
 131 end
 132
 133 module StringMap =
 134 struct
 135   include Map.Make(String)
 136   exception NotFound of string
 137   let find s m =
 138     try find s m
 139     with Not_found -> raise (NotFound s)
 140   let fromList : (key * 'a) list -> 'a t = fun elems ->
 141     List.fold_right (F.uncurry add) elems empty
 142   let union_disjoint2 l r =
 143     fold
 144       (fun k v r ->
 145          if mem k r then invalid_arg "union_disjoint"
 146          else add k v r) l r
 147   let union_disjoint maps = List.fold_right union_disjoint2 maps empty
 148 end
 149
 150 module Set =
 151 struct
 152   module type OrderedType = Set.OrderedType
 153   module type S = sig
 154     include Set.S
 155     val fromList : elt list -> t
 156   end
 157   module Make (Ord : OrderedType) =
 158   struct
 159     include Set.Make(Ord)
 160     let fromList elems = List.fold_right add elems empty
 161   end
 162 end
 163
 164 let random_id length =
 165   let idchars = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_'" in
 166   let nidchars = String.length idchars in
 167   let s = String.create length in
 168     for i = 0 to length - 1 do
 169       s.[i] <- idchars.[Random.int nidchars]
 170     done;
 171     s
 172
 173 (* The function used in OCaml to convert variant labels to their
 174    integer representations.  The formula is given in Jacques
 175    Garrigue's 1998 ML workshop paper.
 176 *)
 177 let tag_hash s =
 178   let wrap = 0x40000000 in
 179   let acc = ref 0 in
 180   let mul = ref 1 in
 181   let len = String.length s in
 182     for i = 0 to len - 1 do
 183       let c = String.unsafe_get s (len - i - 1) in
 184       let n = Char.code c in
 185         acc := (!acc + n * !mul) mod wrap;
 186         mul := (!mul * 223) mod wrap;
 187     done;
 188     !acc
 189
 190 let _ =
 191   (* Sanity check to make sure the function doesn't change underneath
 192      us *)
 193   assert (tag_hash "premiums" = tag_hash "squigglier");
 194   assert (tag_hash "deriving" = 398308260)
 195