Skip to content
This repository
tree: 0091b784cf
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 404 lines (355 sloc) 13.775 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 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403
(*
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/>.
*)
(**
@deprecated Use OpaWalk instead
*)

(* TODO remove *)
open Base
open SurfaceAst
open SurfaceAstHelper

let (|>) = InfixOperator.(|>)
let (@*) = InfixOperator.(@*)

(* FIXME: add some signatures *)

let unannot sub (v,annot) =
  let unsub, l = sub v in
    (fun l -> (unsub l, annot)), l

(**
Traversal functions on patterns
*)

module SPat = struct
  open Traverse.Utils
  type 'a t = 'b pat constraint 'a = 'b * 'c * 'd

  let sub_p = sub_current
  let sub_ident x = sub_ignore x
  let sub_pat_record_node pr = sub_list (sub_2 sub_ignore sub_p) pr
  let sub_pat_record pr = unannot sub_pat_record_node pr

  let sub_pat_node = function
    | PatRecord (pr, rowvar) -> (
        match rowvar with
        | `closed ->
            wrap patrecord (sub_pat_record_node pr)
        | `open_ ->
            wrap patextendrecord (sub_pat_record_node pr)
      )
    | (PatAny | PatConst _ | PatVar _) as v -> sub_ignore v
    | PatCoerce (p,ty) -> wrap patcoerce (sub_2 sub_p sub_ignore (p,ty))
    | PatAs (p, i) -> wrap patas (sub_2 sub_p sub_ignore (p,i))

  let sub_pat c = unannot sub_pat_node c
  let subs_cons x = sub_pat x

  (* only goes through opa top level patterns *)
  let sub_code_elt_node = function
    | NewVal (pel,b) -> wrap newval (sub_2 (sub_list (sub_2 sub_p sub_ignore)) sub_ignore (pel,b))
    | v -> sub_ignore v

  let sub_code_elt c = unannot sub_code_elt_node c
  let sub_code c = sub_list sub_code_elt c
end

module PatTraverse =
  Traverse.Make(SPat)

module Pattern =
struct
  let get_vars_gen add empty p =
    PatTraverse.fold (fun acc -> function
                        | (PatVar a, _) -> add a acc
                        | (PatAs (_,a), _) -> add a acc
                        | _ -> acc
                     ) empty p
  (* TODO: one functor applied to string and exprident? *)
  let get_vars_string p = get_vars_gen StringSet.add StringSet.empty p
  let get_vars_ident p = get_vars_gen IdentSet.add IdentSet.empty p
  let get_vars_ident' p = p |> get_vars_ident |> IdentSet.elements
  let get_vars_code l =
    PatTraverse.lift_fold SPat.sub_code
      (fun acc -> function
         | (PatVar a, _) -> IdentSet.add a acc
         | (PatAs (_,a), _) -> IdentSet.add a acc
         | _ -> acc
      ) IdentSet.empty l
  (* FIXME: we can have duplicates *)
  (* FIXME: almost the same function is defined several times already! *)
  let get_var_list sub l =
    (* using fold_right to keep the order *)
    PatTraverse.lift_fold_right_down sub
      (fun x acc ->
         match x with
           | (PatVar a, _) -> a :: acc
           | (PatAs (_,a), _) -> a :: acc
           | _ -> acc
      ) l []
  let get_var_list_pattern l = get_var_list SPat.sub_p l
  let get_var_list_code_elt_node l =
    get_var_list SPat.sub_code_elt_node l
  let get_var_list_code l =
    get_var_list SPat.sub_code l
end

(**
Traversal functions on 'expr'
*)

module SExpr =
struct
  open Traverse.Utils
  type 'a t = ('b, 'c) expr constraint 'a = 'b * 'c * _

  let sub_e e = sub_current e
  let sub_ident x = sub_ignore x
  let sub_ty x = sub_ignore x
  let sub_record_node l = sub_list (sub_2 sub_ignore sub_e) l
  let sub_record r = unannot sub_record_node r
  let sub_pattern x = sub_ignore x
  let sub_db_elt = function
    | FldKey _
    | NewKey as v -> sub_ignore v
    | ExprKey e -> wrap (fun x -> ExprKey x) (sub_e e)

  let sub_db_def x = QmlAst.Db.sub_db_def sub_e sub_ty x


  (* this part does not depend on the type of identifiers, and so can be used by renaming
* for uninteresting cases *)
  let sub_expr_no_ident = function
    | Const _ as e -> sub_ignore e
    | Apply (e, r) -> wrap apply (sub_2 sub_e sub_record (e,r))
    | Record r -> wrap record (sub_record_node r)
    | ExtendRecord (r,e) -> wrap extendrecord (sub_2 sub_record_node sub_e (r,e))
    | Dot (e,s) -> wrap dot (sub_2 sub_e sub_ignore (e,s))
    | Bypass b -> wrap bypass (sub_ignore b)
    | DBPath (a,b) -> wrap dbpath (sub_2 (unannot (sub_list (unannot sub_db_elt))) sub_ignore (a,b))
    | _ -> assert false
  let sub_expr_node' fd = function
    | Ident _ as e -> sub_ignore e
    | Lambda (p, e) -> wrap lambda (sub_2 sub_ignore sub_e (p,e))
    | LetIn (b,iel,e) -> wrap letin (sub_3 sub_ignore (sub_list (sub_2 sub_ident sub_e)) sub_e (b,iel,e))
    | Match (e, pel) -> wrap match_ (sub_2 sub_e (sub_list (sub_2 sub_pattern sub_e)) (e,pel))
    | Directive (a,el,t) -> wrap directive (sub_3 sub_ignore (sub_list sub_e) sub_ignore (fd a,el,t))
    | e -> sub_expr_no_ident e

  let sub_expr' fd x = unannot (sub_expr_node' fd) x
  let sub_expr_node e = sub_expr_node' identity e
  let sub_expr x = unannot sub_expr_node x


  let subs_cons x = sub_expr x


  (* unbuild/rebuild code into expressions *)
  let sub_code_elt_node = function
    | (Database _ | NewType _ | Package _) as e ->
        sub_ignore e
    | NewDbDef dbdef ->
        wrap newdbdef (sub_db_def dbdef)
    | NewVal (pel,b) ->
        wrap newval (sub_2 (sub_list (sub_2 sub_ignore sub_e)) sub_ignore (pel,b))

  let sub_code_elt c = unannot sub_code_elt_node c
  let sub_code c = sub_list sub_code_elt c
end

module ExprTraverse =
  struct
    include Traverse.Make(SExpr)

    (*
* Functions in this module can map on an expression
* while changing its type
* it is supposed to be used by passes that remove directives
* (so that the type is changed accordingly)
*)
    module Heterogeneous =
      struct
        let map_down fd f e =
          let rec aux e =
            let build, l = SExpr.sub_expr' fd (f e) in
            let l = List.map aux l in
            build l in
          aux e
        let lift_map_down fd f code =
          let build, l = SExpr.sub_code code in
          let l = List.map (fun e -> map_down fd f e) l in
          build l
        let map_down_to_fixpoint fd f e =
          let rec aux e =
            let e' = f e in
            if e' == e then
              let build, l = SExpr.sub_expr' fd e in
              let l = List.map aux l in
              build l
            else
              aux e' in
          aux e
        let lift_map_down_to_fixpoint fd f code =
          let build, l = SExpr.sub_code code in
          let l = List.map (fun e -> map_down_to_fixpoint fd f e) l in
          build l
        let foldmap_down fd f acc e =
          let rec aux acc e =
            let acc, e = f acc e in
            let build, l = SExpr.sub_expr' fd e in
            let acc, l = List.fold_left_map aux acc l in
            acc, build l in
          aux acc e
        let foldmap = foldmap_down

        let traverse_foldmap fd f acc e =
          let rec tra acc e =
            let build, l = SExpr.sub_expr' fd e in
            let acc, l = List.fold_left_map (f tra) acc l in
            acc, build l
          in f tra acc e

      end
    let lift_map_down = lift_map_down
  end

module Expr =
struct
  let appears equal i e =
    ExprTraverse.exists
      (function
         | (Ident i', _) when equal i i' -> true
         | _ -> false
      ) e
  let get_code_exprs e =
    snd (SExpr.sub_code e)

  (* FIXME: really dirty *)
  let fold_with_env (add_env:'b->Ident.t->'a option->'b) env f acc expr =
    let get_name_and_expr_if_local = function
      | (field, (Directive (`local name, [e], _), _label)) -> Some (field, name, e)
      | (_, (Directive (`local _, _, _), _)) -> assert false
      | _ -> None in
    let get_local_name_and_expr fe =
      Option.get (get_name_and_expr_if_local fe) in
    let add_record r env =
      match r with
        | [] -> None
        | h :: _ ->
            match get_name_and_expr_if_local h with
              | None ->
                  (* case after dependency analysis *)
                  assert (List.for_all (Option.is_none @* get_name_and_expr_if_local) r);
                  None
              | Some _ ->
                  (* before and while dependency analysis *)
                  Some (
                    List.fold_right
                      (fun fe (env,r) ->
                         let (field,name,e) = get_local_name_and_expr fe in
                           (add_env env name (Some e), (field,e) :: r))
                      r
                      (env,[])
                  ) in
    let add_bnd env (n,e) =
      add_env env n (Some e) in
    (* FIXME: use the generic function to find vars in patterns *)
    let add_lambda r env =
      PatTraverse.lift_fold SPat.sub_pat_record_node
        (fun env ->
           function
             | (PatVar a, _) -> add_env env a None
             | (PatAs (_,a), _) -> add_env env a None (* could say Some... *)
             | _ -> env) env r in
    let add_pat pat env =
      PatTraverse.fold
        (fun env ->
           function
             | (PatVar a, _) -> add_env env a None
             | (PatAs (_,a), _) -> add_env env a None (* could say Some... *)
             | _ -> env) env pat in
    let rec process_pattern_expr tra env acc (pat,expr) =
      let env_bnd = add_pat pat env in
      process_expr tra env_bnd acc expr
    and process_expr tra env acc expr =
      let env, acc = f env acc expr in
        match fst expr with
          | Lambda (r, expr) ->
              process_expr tra (add_lambda r env) acc expr
          | Record r ->
              ( match add_record r env with
                  | Some (env, r) ->
                      process_expr tra env acc (Record r, snd expr)
                  | None ->
                      tra env acc expr )
          | LetIn (rec_, bnd, expr) ->
              let full_env = List.fold_left add_bnd env bnd in
              let local_env = if rec_ then full_env else env in
              let acc =
                List.fold_left (fun acc (_,expr) -> process_expr tra local_env acc expr) acc bnd in
              process_expr tra full_env acc expr
          | Match (expr, pel) ->
              let acc = process_expr tra env acc expr in
              List.fold_left (process_pattern_expr tra env) acc pel
          | _ -> tra env acc expr in
    ExprTraverse.traverse_fold_context_down process_expr env acc expr

  let wrap f =
    (fun env acc expr -> env, f env acc expr)

  let fold_with_expr_map ?(env = IdentMap.empty) f acc expr =
    fold_with_env (fun map id optval -> IdentMap.add id optval map) env (wrap f) acc expr

  let traverse_fold_with_set ?(env = IdentSet.empty) f acc expr =
    fold_with_env (fun map id _optval -> IdentSet.add id map) env f acc expr

  let fold_with_set ?env f acc expr =
    traverse_fold_with_set ?env (wrap f) acc expr

  let get_vars_gen add empty p =
    ExprTraverse.fold (fun acc -> function
                        | (Ident a, _) -> add a acc
                        | _ -> acc
                     ) empty p
  (* TODO: one functor applied to string and exprident? *)
  let get_vars_stringset p = get_vars_gen StringSet.add StringSet.empty p
  let get_vars_identset p = get_vars_gen IdentSet.add IdentSet.empty p
  let get_vars_identlist p = p |> get_vars_identset |> IdentSet.elements
end


module Code =
struct
  let get_pattern_expr code =
    List.concat_map (function
                    | (NewVal (pel,_), _) -> pel
                    | _ -> []
                 ) code

  let map_up f code = ExprTraverse.lift_map_up SExpr.sub_code f code
end

(**
General purpose traversal functions on types
*)

module SType =
struct
  open Traverse.Utils
  type 'a t = 'b ty constraint 'a = 'b * 'c * 'd
  let sub_t = sub_current
  let sub_fields x = sub_list (sub_2 sub_ignore sub_t) x
  let sub_row_t_node (TyRow (fields,rowvar)) =
    wrap tyrow (sub_2 sub_fields sub_ignore (fields,rowvar))
  let sub_row_t v = unannot sub_row_t_node v
  let sub_arrow_t_node (row_t,ty) =
    sub_2 sub_row_t sub_t (row_t,ty)
  let sub_arrow_t v = unannot sub_arrow_t_node v
  let sub_typeinstance_node (ident,tyl) =
    sub_2 sub_ignore (sub_list sub_t) (ident,tyl)
  let sub_sum_t_node = function
    | SumName ti -> wrap sumname (sub_typeinstance_node ti)
    | SumRecord row_t -> wrap sumrecord (sub_row_t_node row_t)
    | SumVar _ as v -> sub_ignore v
  let sub_sum_t v = unannot sub_sum_t_node v
  let sub_ty_node = function
    | TypeConst _
    | TypeVar _
    | TypeExternal as v -> sub_ignore v
    | TypeArrow r -> wrap typearrow (sub_arrow_t_node r)
    | TypeRecord r -> wrap typerecord (sub_row_t_node r)
    | TypeSumSugar l -> wrap typesumsugar (sub_list sub_sum_t l)
    | TypeNamed ti -> wrap typenamed (sub_typeinstance_node ti)
    | TypeForall (vars, t) -> wrap typeforall (sub_2 sub_ignore sub_t (vars, t))
    | TypeModule fields -> wrap typemodule (sub_fields fields)
  let sub_ty ty = unannot sub_ty_node ty

  let subs_cons = sub_ty
end

module TypeTraverse =
  Traverse.Make(SType)

module Type =
struct
  (* FIXME: we can have duplicates *)
  let get_typename_list sub l =
    TypeTraverse.lift_fold_right_down sub
      (fun x acc ->
         match x with
           | (TypeNamed (Typeident ident, _tyl), _) -> ident :: acc
           | _ -> acc
      ) l []
  let get_typename_list_arrow_t l =
    get_typename_list SType.sub_arrow_t l
  let get_typename_list_type l =
    get_typename_list SType.sub_t l
end
Something went wrong with that request. Please try again.