Skip to content
This repository
tree: cd0c3f8c85
Fetching contributors…

Cannot retrieve contributors at this time

file 382 lines (321 sloc) 14.168 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
(*
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/>.
*)
(* cf mli *)

(* libbase *)
module List = Base.List

(* Refactoring WIP *)
(* opa compiler *)
module Schema = QmlDbGen.Schema
(* TODO: is there not a default DbGen in the framework ? *)
module DbGen = QmlDbGen.DbGen(QmlDbGen.DbGenByPass.BSLDbGenAlpha)

(* shorthand *)
module Q = QmlAst

(* Error managment *)
let fail fmt = OManager.error ("@[<2>@{<bright>RuntimeError@}:@\n"^^fmt^^"@]@\n")

(* type alias *)
type pos = FilePos.pos
type 't pprinter = 't Base.Format.pprinter

(* Runtime Value Algebra *)
(*
Although QmlAst fun are Nary, the interpreter can not do a generic apply

We could also do something like :

let apply1 =
let apply2 =
let apply3 = ...

and decrete that there is a hard encoded limit...
This code could be generated, but anyway performance are not the target of qmltop.

To deal with function of arity 0, the first argument is an option.
If the type is None, in the implementation the function expects unit
*)
(*
TODO: in V_closure change the type so that
by construction, it must be a lambda node
(todo that in Nary version, even in master
*)


type t =
  | V_const of pos * QmlAst.const_expr
  | V_record of pos * (t Lazy.t) StringMap.t * t option ref
  | V_closure of pos * (t IdentMap.t) ref * QmlAst.expr
  | V_extern of pos * string * BslTypes.t list * Obj.t
  | V_bypass of pos * BslTypes.t list * BslTypes.t * Obj.t

let pos = LangAst.pos
let reset_pos = LangAst.reset_pos
let merge_pos = LangAst.merge_pos

(* Printing *)

let pp_value ?ty ?(force=false) fmt value =
  match ty with
  | Some (Q.TypeVar _) -> Format.pp_print_string fmt "<poly>"
  | _ ->
      (* Pretty printing of list *)
      (* Return also Some _ for non-homogene list *)
      let rec to_list value =
        match value with
        | V_record(_, fds, _) ->
            let s = StringMap.size fds in
            if s = 2 then
              Option.bind (fun tl -> Option.map (fun hd -> hd::tl) (StringMap.find_opt "hd" fds))
                (Option.bind
                   (fun x -> if force || Lazy.lazy_is_val x then to_list (Lazy.force x) else None)
                   (StringMap.find_opt "tl" fds))
            else if s = 1 then
              if StringMap.mem "nil" fds then Some [] else None
            else None
        | _ -> None
      in
      let rec aux fmt value =
        let lazy_aux fmt value =
          if force || Lazy.lazy_is_val value
          then aux fmt (Lazy.force value)
          else Format.pp_print_string fmt "<lazy>" in
        match value with
        | V_const (_, c) -> QmlAst.Const.pp_expr fmt c
        | V_record (_, fields, _) ->
            let size = StringMap.size fields in
            if size = 0 then
              Format.pp_print_string fmt "void"
            else (
              (* this may be a list *)
              match to_list value with
              | Some values ->
                  Format.fprintf fmt "[@ %a@ ]" (Base.Format.pp_list " ;@ " lazy_aux) values
              | None ->
                  (* TODO: use LangPrint.pp_fields *)
                  if size > 3
                  then
                    Format.fprintf fmt "{@\n%a@\n}"
                      (StringMap.pp " ;@\n" (LangPrint.pp_field " =@ " lazy_aux)) fields
                  else
                    Format.fprintf fmt "{ %a }"
                      (StringMap.pp " ; " (LangPrint.pp_field " = " lazy_aux)) fields
            )
        | V_closure (_, _, Q.Lambda _) -> Format.pp_print_string fmt "<fun>"
        | V_closure _ ->
            Format.pp_print_string fmt "<clos>"
        | V_extern (_, n, p, _) ->
            Format.fprintf fmt "<extern[%a]>" (LangPrint.pp_parameters BslTypes.pp n) p

        | V_bypass (pos, a, b, _) ->
            Format.fprintf fmt "<bypass[%a]>" BslTypes.pp (BslTypes.Fun (pos, a, b))

      in aux fmt value

let pp fmt x = pp_value fmt x

let pp_type fmt v =
  match v with
  | V_const (_, c) -> QmlAst.Const.pp_ty fmt (QmlAst.Const.type_of c)
  | V_record (_, fields, _) ->
      let pp_field fmt field _ = Format.pp_print_string fmt field in
      Format.fprintf fmt "{ %a }" (StringMap.pp " ; " pp_field) fields
  | V_closure _ -> Format.pp_print_string fmt "<fun>"
  | V_extern _
  | V_bypass _ -> pp fmt v

(* comparaison *)

let compare ?(strong=false) a b =
  let rec compare a b =
    match a, b with
    | V_const (_, a), V_const (_, b) ->
        let c = Pervasives.compare (QmlAst.Const.type_of a) (QmlAst.Const.type_of b) in
        if c = 0 && strong then Pervasives.compare a b else c
    | V_const _, _ -> -1
    | _, V_const _ -> 1
    | V_record (_, fields, _), V_record (_, fields', _) ->
        StringMap.compare (fun x y -> compare (Lazy.force x) (Lazy.force y)) fields fields'
    | V_record _, _ -> -1
    | _, V_record _ -> 1
    | V_closure _, V_closure _ -> -1 (* YAGNI *)
    | V_closure _, _ -> -1
    | _, V_closure _ -> 1
    | V_extern (_, a, tl, _), V_extern (_, b, ttl, _) ->
        let r = String.compare a b in
        if r <> 0 then r
        else
          let rec aux = function
            | [], [] -> 0
            | [], _::_ -> -1
            | _::_, [] -> 1
            | t::q, t2::q2 ->
                let r = BslTypes.compare ~normalize:(not strong) t t2 in
                if r <> 0 then r else aux (q, q2)
          in aux (tl, ttl)
    | V_extern _, _ -> -1
    | _, V_extern _ -> 1
    | V_bypass (_, a, b, _), V_bypass (_, c, d, _) ->
        if strong then
          let r = List.make_compare (BslTypes.compare ~normalize:(not strong)) a c in
          if r <> 0 then r
          else BslTypes.compare ~normalize:(not strong) b d
        else 1

  in compare a b

let nopos = FilePos.nopos "opatop:value"
let t_null ?(pos=nopos) () = V_extern (pos, "null", [], Obj.repr 0)

(* value env *)

type env = t IdentMap.t

(*
Note for hackers :

This part of the code provides transcription functions between ocaml and qmltop for bsl types
!!!!! CRITICAL SECTION !!!!!
be carrefully by hacking this code, there could be seg-faulting consequences

If you are wondering why [ocaml_of_t] and [t_of_ocaml] are not mutually recursive,
like in the compiled back-end's, you're a specialist :), congratulations.

It is because we project function in a currified way, and dynamically. The rest of the projection
is done argument by argument.
*)
module Proj =
struct
  module B = BslTypes

  let t_int ?(pos=nopos) i = V_const (pos, Q.Int i)
  let t_float ?(pos=nopos) f = V_const (pos, Q.Float f)
  let t_string ?(pos=nopos) s = V_const (pos, Q.String s)
  let t_void ?(pos=nopos) () = V_record (pos, StringMap.empty, ref None)
  let t_int64 ?(pos=nopos) i = V_const (pos, Q.Int (Int64.to_int i))

  let shared_void = t_void ()
  let shared_lazy_void = Lazy.lazy_from_val shared_void
  let shared_simple field = StringMap.add field shared_lazy_void StringMap.empty
  let shared_true = shared_simple "true"
  let shared_false = shared_simple "false"
  let shared_none = shared_simple "none"

  let t_true ?(pos=nopos) () = V_record (pos, shared_true, ref None)
  let t_false ?(pos=nopos) () = V_record (pos, shared_false, ref None)

  let t_bool ?(pos=nopos) b = if b then t_true ~pos () else t_false ~pos ()

  let t_none ?(pos=nopos) () = V_record (pos, shared_none, ref None)
  let t_some ?(pos=nopos) t =
    V_record (pos, StringMap.add "some" (Lazy.lazy_from_val t) StringMap.empty, ref None)

  let t_option ?(pos=nopos) = function
    | None -> t_none ~pos ()
    | Some v -> t_some ~pos v

  let t_extern ?(pos=nopos) name params x = V_extern (pos, name, params, Obj.repr x)

  let rec t_of_ocaml ty x =
    match ty with
    | B.OpaValue _ ->
        (* A value manipluated by the ServerLib in the external primitive library *)
        Obj.magic x

    | B.Const (pos, Q.TyInt) -> t_int ~pos (Obj.magic x)
    | B.Const (pos, Q.TyFloat) -> t_float ~pos (Obj.magic x)
    | B.Const (pos, Q.TyString) -> t_string ~pos (Obj.magic x)
    | B.Const (pos, Q.TyNull) -> t_null ~pos ()

    (* If a type is still an alpha, that means that it is a opa-value represented by itself *)
    | B.TypeVar _ -> Obj.magic x

    | B.Void pos -> t_void ~pos ()
    | B.Bool pos -> t_bool ~pos (Obj.magic x)


    | B.Option (pos, o) -> (
        match Obj.magic x with
        | None -> t_none ~pos ()
        | Some ocaml -> t_some ~pos (t_of_ocaml o ocaml)
      )

    | B.External (pos, name, params) -> t_extern ~pos name params x

    | B.Fun (pos, u, v) ->
        (* x is a ocaml function *)
        (* we generate dynamically a new ocaml function *)
        (* Note: The projections will be done currified way, application by application *)
        V_bypass (pos, u, v, Obj.repr x)


  let rec ocaml_of_t ~eval:eval ty value =
    let rec aux ty value =
      (* FIXME: see what kind of citation are given *)
      let clash ?(extra="") () =
        fail "Type Citation:%aValue Citation:%aContext requires a value of type %a@\nbut got a value of type %a@\nThe value is %a%s"
          FilePos.pp_citation (BslTypes.pos ty)
          FilePos.pp_citation (pos value)
          BslTypes.pp ty
          pp_type value
          pp value
          extra
      in
      match ty, value with
      | B.TypeVar _, _ ->
          (* Note that in this case, we give direct the opa-value 'as is' *)
          (* there is no probleme, because the ocaml-function which will take it is polymorphic *)
          Obj.magic value

      | B.OpaValue _, _ ->
          (* Value manipulated through the ServerLib API *)
          Obj.magic value

      (* Consts *)
      | B.Const (_, Q.TyInt) , V_const (_, Q.Int i) -> Obj.magic i
      | B.Const (_, Q.TyFloat) , V_const (_, Q.Float f) -> Obj.magic f
      | B.Const (_, Q.TyString) , V_const (_, Q.String s) -> Obj.magic s
      | B.Const (_, Q.TyNull) , _ -> Obj.magic 0

      | B.Void _, V_record (_, m, r) when StringMap.is_empty m && !r = None -> Obj.magic ()

      (* bool *)
      | B.Bool _, V_record (_, fields, _) ->
          let semantic_bool = (StringMap.mem "true" fields) && not (StringMap.mem "false" fields) in
          Obj.magic semantic_bool

      (* option *)
      | B.Option (_, o), V_record (_, fds, _) ->
          let semantic_option =
            match StringMap.find_opt "some" fds with
            | None -> if not (StringMap.mem "none" fds) then clash () else None
            | Some v -> Some (aux o (Lazy.force v))
          in
          Obj.magic semantic_option

      | B.External (_, name_exp, param_exp), V_extern (_, name, params, obj) ->
          (*
The typer should have done his work, we could actually just give
the value as it is : Obj.obj obj, but we add some runtime checks
because opatop can work in #typer off mode.
TODO: maybe add an option for desactivating checks, and let
opatop just segfauls.
*)
          let _ = (* check *)
            if name_exp <> name
            then clash ()
            else
              (* verification of parametres - specialisation of parametric types in externs types *)
              let rec fold subst = function
                | [], [] -> subst
                | a::u, b::v ->
                    let expected = a in
                    let found = b in
                    let subst = BslTypes.check_inclusion ~static_strict_check:false subst ~expected ~found in
                    fold subst (u, v)
                | _ -> clash ()
              in
              let subst = BslTypes.empty_substitution in
              let _ = fold subst (param_exp, params) in
              ()
          in
          (* the extern must not be projected *)
          Obj.obj obj

      | B.External _, _ ->
          let extra = "@\nHowever, if this opa value is really@ the extern type the bypass is waiting for,@ consider that this bypass is doing @{<bright>illicit things@}...@ The implementation of this bypass should be@ patched to use the type constructor opa[]@\n"
          in
          clash ~extra ()

      (* Here, if the arg-sig or ret_sig are more general that the typ in the real function
We must add some qml-conversion *)
      | B.Fun _, V_bypass (pos, args, ret, obj) -> (
          (* A value in a V_bypass is an ocaml function. It can be passed 'as is' *)
          (* We perform some checks (cf documentation [Runtime type checking) of this module) *)
          let _ =
            BslTypes.check ~static_strict_check:false ~expected:ty ~found:(B.Fun (pos, args, ret))
          in
          Obj.obj obj
        )

      (* Here is the mixte-functionnal conversion qml --> ocaml : Good Luck to have something like it in C ;) *)
      | B.Fun (_, tys, tyres), V_closure (_, env, Q.Lambda (_, ids, body)) ->
          let rec caml_lambda rtys rids env = match rtys, rids with
            | [], [] ->
                Obj.magic (fun () -> aux tyres (eval env body) )
            | [ty], [id] ->
                Obj.magic (fun v ->
                  let qml = t_of_ocaml ty v in
                  let env = IdentMap.add id qml env in
                  aux tyres (eval env body)
                )
            | ty::rtys, id::rids ->
                Obj.magic (fun v ->
                  let qml = t_of_ocaml ty v in
                  let env = IdentMap.add id qml env in
                  caml_lambda rtys rids env
                )
            | _ -> assert false
          in caml_lambda tys ids (!env)

      | _, _ -> clash ()
    in
    aux ty value

end
Something went wrong with that request. Please try again.