(Disclaimer: I am fairly certain that this is not idiomatic in any way. If there is some alternative tree-traversal idiom in OCaml, I'm all ears :) )
I am writing a toy compiler in OCaml, and I would like to have a visitor for my large syntax tree type. I wrote one using classes, but I thought it would be fun to try and implement one using modules/functors. My type hierarchy is massive, so let me illustrate what I'm trying to do.
Consider the following type definitions (making these up on the spot):
type expr =
SNum of int
| SVarRef of string
| SAdd of expr * expr
| SDo of stmt list
and stmt =
SIf of expr * expr * expr
| SAssign of string * expr
Let me briefly illustrate usage. Say, for example, I wanted to collect all of the SVarRefs inside of the program. If I had a mapping visitor (one which visits every node of the tree and does nothing by default), I could do the following (in a perfect world):
module VarCollector : (sig
include AST_VISITOR
val var_refs : (string list) ref
end) = struct
include MapVisitor
let var_refs = ref []
let s_var_ref (s : string) =
var_refs := s::!var_refs
SVarRef(s)
end
(* Where my_prog is a stmt type *)
let refs = begin
let _ = VarCollector.visit_stmt my_prog in
VarCollector.!var_refs
end
I should note that the advantage of having functions for each specific variant is that my actual codebase has a type which both has a large amount of variants and does not make sense to fragment. Variant-specific functions allow the avoiding of repeated iteration implementations for the other variants of a type.
Seems simple enough, but here's the catch: there are different types of visitors. MapVisitor returns the original syntax tree, so it has type
sig
(** Dispatches to variant implementations *)
val visit_stmt : stmt -> stmt
val visit_expr : expr -> expr
(** Variant implementations *)
val s_num : int -> expr
val s_var_ref : string -> expr
val s_add : (expr * expr) -> expr
val s_do : stmt list -> expr
val s_if : (expr * expr * expr) -> stmt
val s_assign : (string * expr) -> stmt
end
At the same time, one might imagine a folding visitor in which the return type is some t for every function. Attempting to abstract this as much as possible, here is my attempt:
module type AST_DISPATCHER = sig
type expr_ret
type stmt_ret
val visit_expr : expr -> expr_ret
val visit_stmt : stmt -> stmt_ret
end
(** Concrete type designation goes in AST_VISITOR_IMPL *)
module type AST_VISITOR_IMPL = sig
type expr_ret
type stmt_ret
val s_num : int -> expr_ret
val s_var_ref : string -> expr_ret
val s_add : (expr * expr) -> expr_ret
val s_do : stmt list -> expr_ret
val s_if : (expr * expr * expr) -> stmt_ret
val s_assign : (string * expr) -> stmt_ret
end
module type AST_VISITOR = sig
include AST_VISITOR_IMPL
include AST_DISPATCHER with type expr_ret := expr_ret
and type stmt_ret := stmt_ret
end
(** Dispatcher Implementation *)
module AstDispatcherF(IM : AST_VISITOR_IMPL) : AST_DISPATCHER = struct
type expr_ret = IM.expr_ret
type stmt_ret = IM.stmt_ret
let visit_expr = function
| SNum(i) -> IM.s_num i
| SVarRef(s) -> IM.s_var_ref s
| SAdd(l,r) -> IM.s_add (l,r)
| SDo(sl) -> IM.s_do sl
let visit_stmt = function
| SIf(c,t,f) -> IM.s_if (c,t,f)
| SAssign(s,e) -> IM.s_assign (s,e)
end
module rec MapVisitor : AST_VISITOR = struct
type expr_ret = expr
type stmt_ret = stmt
module D : (AST_DISPATCHER with type expr_ret := expr_ret
and type stmt_ret := stmt_ret)
= AstDispatcherF(MapVisitor)
let visit_expr = D.visit_expr
let visit_stmt = D.visit_stmt
let s_num i = SNum i
let s_var_ref s = SVarRef s
let s_add (l,r) = SAdd(D.visit_expr l, D.visit_expr r)
let s_do sl = SDo(List.map D.visit_stmt sl)
let s_if (c,t,f) = SIf(D.visit_expr c, D.visit_expr t, D.visit_expr f)
let s_assign (s,e) = SAssign(s, D.visit_expr e)
end
Running this gives me the following error message, however:
Error: Signature Mismatch:
Values do not match:
val visit_expr : expr -> expr_ret
is not included in
val visit_expr : expr -> expr_ret
I know this means that I am not expressing the relationship between the types correctly, but I cannot figure out what the fix is in this case.
Disclaimer: Modules are just records of values accompanied with type definitions. Since there are no types in your modules there is no need to use them at all, just use plain old record types, and you will get one of the idiomatic AST traversal pattern. Soon, you will find out that you need an open recursion, and will switch to class-based approach. Anyway, this was the main reason, why classes were added to OCaml. You may also wrap your classes into a state monad, to fold AST with arbitrary user data.
What concerning your error message, then it is simple, you hide your types with signatures, a common mistake. The easiest solution is to omit an annotation of the return type of a functor at all, or to propagate type equality with a with type expr = expr annotations.
If you need examples of more idiomatic approaches, then for records you can go for ppx mappers, here is an example of different visitors implemented with classes, including those that are wrapped into a state monad.
Related
Please have a look at the following parser I implemented in Kotlin using the parser combinator library better-parse. It parses—should parse, rather—simple arithmetic expressions:
object CalcGrammar: Grammar<Int>() {
val num by regexToken("""\d+""")
val pls by literalToken("+")
val min by literalToken("-")
val mul by literalToken("*")
val div by literalToken("/")
val lpr by literalToken("(")
val rpr by literalToken(")")
val wsp by regexToken("\\s+", ignore = true)
// expr ::= term + expr | term - expr | term
// term ::= fact * term | fact / term | fact
// fact ::= (expr) | -fact | int
val fact: Parser<Int> by
skip(lpr) and parser(::expr) and skip(rpr) or
(skip(min) and parser(::fact) map { -it }) or
(num map { it.text.toInt() })
val term by
leftAssociative(fact, mul) { a, _, b -> a * b } or
leftAssociative(fact, div) { a, _, b -> a / b } or
fact
val expr by
leftAssociative(term, pls) { a, _, b -> a + b } or
leftAssociative(term, min) { a, _, b -> a - b } or
term
override val rootParser by expr
}
However, when I parse -2 + 4 - 5 + 6, I get this ParseException:
Could not parse input: UnparsedRemainder(startsWith=min#8 for "-" at 7 (1:8))
At first, I thought the issue was that I have not codified the self-recursion in the expr productions, i.e., the code does not accurately represent the grammar:
// Reference to `expr` is missing on the right-hand side...
val expr = ... leftAssociative(term, min) ...
// ...although the corresponding production defines it.
// expr ::= ... term - expr ...
But then I noticed that the official example for an arithmetic parser provided as part of the library's documentation—which turns out to be almost identical afaict—also omits this.
What did I do wrong if not this? And how can I make it work?
I am not entirely familiar with this library, but it seems your translation from grammar to code is too literal for the library's syntax and the library actually implicitly handles much of what you are explicitly writing, and it seems that as a part of this "ease of use" it breaks what is seemingly correct code.
For starters, you will find that your code behaves the exact same way whether or not you chain or term on to the end of expr, and or fact on to the end of term.
Based on this I was able to come to the conclusion that these ors are not working as expected when chaining together the leftAssociatives, in fact you would run in to the same problem had you attempted to parse a division. I believe it is for this reason that the example you provided a link to combines addition and subtraction (as with multiplication and division) into a single, more dynamic, leftAssociative call. And if you copy that same work to your own code, it runs flawlessly:
object CalcGrammar: Grammar<Int>() {
val num by regexToken("""\d+""")
val pls by literalToken("+")
val min by literalToken("-")
val mul by literalToken("*")
val div by literalToken("/")
val lpr by literalToken("(")
val rpr by literalToken(")")
val wsp by regexToken("\\s+", ignore = true)
// expr ::= term + expr | term - expr | term
// term ::= fact * term | fact / term | fact
// fact ::= (expr) | -fact | int
val fact: Parser<Int> by
skip(lpr) and parser(::expr) and skip(rpr) or
(skip(min) and parser(::fact) map { -it }) or
(num map { it.text.toInt() })
private val term by
leftAssociative(fact, div or mul use { type }) { a, op, b ->
if (op == div) a / b else a * b
}
private val expr by
leftAssociative(term, pls or min use { type }) { a, op, b ->
if (op == pls) a + b else a - b
}
override val rootParser by expr
}
I wonder why one example fails and not the other.
(* this fails *)
(* (l fails to type check)
This expression has type 'a but an expression was expected of type
(module M.TFixU)
The module type M.TFixU would escape its scope
*)
let foldList1 (type ar) algr l =
let module M = FixT (ListIntF) in
let (module LU : M.TFixU) = l in
assert false
(* but this works *)
let foldList2 (type ar) algr l =
let (module LU : FixT(ListIntF).TFixU) = l in
assert false
complete code
module Higher = struct
type ('a, 't) app
module type NewType1 = sig
type 'a s
type t
val inj : 'a s -> ('a, t) app
val prj : ('a, t) app -> 'a s
end
module NewType1 (X : sig
type 'a t
end) =
struct
type 'a s = 'a X.t
type t
external inj : 'a s -> ('a, t) app = "%identity"
external prj : ('a, t) app -> 'a s = "%identity"
end
end
module Fix = struct
open Higher
module FixT (T : NewType1) = struct
module type T_Alg = sig
type a
val alg : (a, T.t) app -> a
end
module type TFixU = sig
module App : functor (A : T_Alg) -> sig
val res : A.a
end
end
type tFixU = (module TFixU)
end
end
module Pb = struct
open Higher
open Fix
(* intro *)
type 'r listIntF = Empty | Succ of (int * 'r)
module ListIntF = NewType1 (struct
type 'r t = 'r listIntF
end)
(* this fails *)
let foldList1 (type ar) algr l =
let module M = FixT (ListIntF) in
let (module LU : M.TFixU) = l in
(* (l fails to type check)
This expression has type 'a but an expression was expected of type
(module M.TFixU)
The module type M.TFixU would escape its scope
*)
let module T = LU.App (struct
type a = ar
let alg = algr
end) in
T.res
(* but this doesn't *)
let foldList2 (type ar) algr l =
let (module LU : FixT(ListIntF).TFixU) = l in
let module T = LU.App (struct
type a = ar
let alg = algr
end) in
T.res
end
In the first case, the type of l is unified with the type defined in the module M, which defines the module type. Since the type is introduced after the value l, which is a parameter in an eager language so it already exists, the value l receives a type that doesn't yet exist at the time of its creation. It is the soundness requirement of the OCaml type system that the value lifetime has to be enclosed with its type lifetime, or more simply each value must have a type. The simplest example is,
let x = ref None (* here `x` doesn't have a type since it is defined later *)
type foo = Foo;; (* the `foo` scope starts here *)
x := Some Foo (* foo escapes the scope as it is assigned to `x` via `foo option` *)
Another simplified example, that involves a function parameter is the following,
let foo x =
let open struct
type foo = Foo
end in
match x with
| Some Foo -> true (* again, type foo escapes the scope as it binds to `x` *)
| None -> false
A very good article that will help you understand in-depth scopes and generalization is Oleg Kiselyov's How OCaml type checker works -- or what polymorphism and garbage collection have in common.
Concerning the second case, you clearly specified the type of l using the applicative nature of OCaml functors. And since the typechecker knows that the lifetime of FixT(ListIntF).TFixU is greater than the lifetime of l it is happy.
I'm running into problems around recursive/mutually referential module definitions trying to use Caml's Map/Set stuff. I really want ones that just work on types, not modules. I feel like it should be possible to do this with first-class modules, but I'm failing to make the syntax work.
The signature I want is:
module type NonFunctorSet = sig
type 'a t
val create : ('a -> 'a -> int) -> 'a t
val add : 'a t -> 'a -> 'a t
val remove : 'a t -> 'a -> 'a t
val elements : 'a t -> 'a list
end
Possibly with other Caml.Set functions included. My idea for how this would work is something like:
type 'a t = {
m : (module Caml.Set.S with type elt = 'a);
set : m.t
}
let create (compare : 'a -> 'a -> t) =
module m = Caml.Set.Make(struct type t = 'a let compare = compare end) in
let set = m.empty in
{m = m; set = set;}
end
But that doesn't work for a number of reasons; 'a isn't exposed in the right places, I can't reference m.t in the same record where m was defined, etc.
Is there a version of this that works?
Adding more context about my use case:
I have two modules, Region and Tribe. Tribe needs access to a lot of the interface of Region, so I am currently creating Tribe as a functor, MakeTribe(Region : RegionT). Region mostly doesn't need to know about Tribe, but it does need to be able to store a mutable collection of Tribe.t that represent the tribes living in that region.
So, somehow or other, I need a RegionT like
module type RegionT = sig
type <region>
val get_local_tribes : <region> -> <tribes>
val add_tribe : <region> -> <tribe> -> unit
...
end
I don't really care about the specific syntax of <tribe>, <tribes> and <region> in this, so long as the fully built Tribe module can know that Region.get_local_tribes, etc, will yield an actual Tribe.t
The circular dependency problem is that the type <tribe> does not exist until the module Tribe is created. My idea so far has been to have RegionT.t actually be 'a RegionT.t, and then Tribe could simply refer to Tribe.t Region.t. This is all fine if I'm satisfied with keeping a <tribe> list inside Region, but I want it to be a set.
I feel this should be possible based on the following example code :
module Example : sig
type t
val compare : t -> t -> int
end = struct
type t = int
let compare = Int.compare
end
module ExampleSet = Caml.Set.Make(struct type t = Example.t let compare = Example.compare end)
All that Example exposes in its interface is a type and a function from two instances of that type to an int; why is that more than having a 'a -> 'a -> int, which has the same things?
Using Polymoprhic Sets and Maps from the Base Library
In Base and Core libraries, from Jane Street, ordered data structures, such as maps, sets, hash tables, and hash sets, are all implemented as polymorphic data structures, instead of functorized versions as in the vanilla OCaml standard library.
You can read about them more in the Real World OCaml Maps and Hashtbales chapter. But here are quick recipes. When you see a comparator in the function interface, e.g., in Map.empty what it actually wants you is to give you a module that implements the comparator interface. The good news is that most of the modules in Base/Core are implementing it, so you don't have to worry or know anything about this to use it, e.g.,
# open Base;;
# let empty = Map.empty (module Int);;
val empty : (Base.Int.t, 'a, Base.Int.comparator_witness) Base.Map.t =
<abstr>
# Map.add empty 1 "one";;
- : (Base.Int.t, string, Base.Int.comparator_witness) Base.Map.t
Base.Map.Or_duplicate.t
= `Ok <abstr>
So the simple rule, if you want a set,map,hashtable,hashset where the key element has type foo, just pass (module Foo) as a comparator.
Now, what if you want to make a mapping from your custom type? E.g., a pair of ints that you would like to compare in lexicographical order.
First of all, we need to define sexp_of and compare functions. For our type. We will use ppx derivers for it, but it is easy to make it manually if you need.
module Pair = struct
type t = int * int [##deriving compare, sexp_of]
end
Now, to create a comparator, we just need to use the Base.Comparator.Make functor, e.g.,
module Lexicographical_order = struct
include Pair
include Base.Comparator.Make(Pair)
end
So now we can do,
# let empty = Set.empty (module Lexicographical_order);;
val empty :
(Lexicographical_order.t, Lexicographical_order.comparator_witness)
Base.Set.t = <abstr>
# Set.add empty (1,2);;
- : (Lexicographical_order.t, Lexicographical_order.comparator_witness)
Base.Set.t
= <abstr>
Despite that Base's data structures are polymorphic they strictly require that the module that provides the comparator is instantiated and known. You can just use the compare function to create a polymorphic data structure because Base will instantiate a witness type for each defined compare function and capture it in the data structure type to enable binary methods. Anyway, it is a complex issue, read on for easier (and harder) solutions.
Instantiating Sets on mutually dependent modules
In fact, OCaml supports mutually recursive funtors and although I would suggest you to break the recursion by introducing a common abstraction on which both Region and Tribe depend, you can still encode your problem in OCaml, e.g.,
module rec Tribe : sig
type t
val create : string -> t
val compare : t -> t -> int
val regions : t -> Region.t list
end = struct
type t = string * Region.t list
let create name = name,[]
let compare (x,_) (y,_) = String.compare x y
let regions (_,r) = r
end
and Region : sig
type t
val empty : t
val add_tribe : Tribe.t -> t -> t
val tribes : t -> Tribe.t list
end = struct
module Tribes = Set.Make(Tribe)
type t = Tribes.t
let empty = Tribes.empty
let add_tribe = Tribes.add
let tribes = Tribes.elements
end
Breaking the Dependency Loop
A much better solution would be to redesign your modules and break the dependency loop. The simplest approach would be just to choose some identifier that will be used to compare tribes, e.g., by their unique names,
module Region : sig
type 'a t
val empty : 'a t
val add_tribe : string -> 'a -> 'a t -> 'a t
val tribes : 'a t -> 'a list
end = struct
module Tribes = Map.Make(String)
type 'a t = 'a Tribes.t
let empty = Tribes.empty
let add_tribe = Tribes.add
let tribes r = Tribes.bindings r |> List.map snd
end
module Tribe : sig
type t
val create : string -> t
val name : t -> string
val regions : t -> t Region.t list
val conquer : t Region.t -> t -> t Region.t
end = struct
type t = Tribe of string * t Region.t list
let create name = Tribe (name,[])
let name (Tribe (name,_)) = name
let regions (Tribe (_,r)) = r
let conquer region tribe =
Region.add_tribe (name tribe) tribe region
end
There are also tons of other options and in general, when you have mutual dependencies it is actually an indicator of a problem in your design. So, I would still revisit the design stage and eschew the circular dependencies.
Creating Polymorphic Sets using the Vanilla OCaml Standard Library
It is not an easy task, especially if you need to handle operations that involve several sets, e.g., Set.union. The problem is that Set.Make is generating a new type for the set per each compare function so when we need to union two sets it is hard for us to prove to the OCaml compiler that they were created from the same type. It is possible but really painful, I am showing how to do this only to discourage you from doing this (and to showcase OCaml's dynamic typing capabilities).
First of all we need a witness type that will reify an OCaml type for the set into a concrete value.
type _ witness = ..
module type Witness = sig
type t
type _ witness += Id : t witness
end
Now we can define our polymorphic set as an existential that holds the set itself and the module with operations. It also holds the tid (for type identifier) that we will later use to recover the type 's of the set.
type 'a set = Set : {
set : 's;
ops : (module Set.S with type elt = 'a and type t = 's);
tid : (module Witness with type t = 's);
} -> 'a set
Now we can write the create function that will take the compare function and turn it into a set,
let create : type a s. (a -> a -> int) -> a set =
fun compare ->
let module S = Set.Make(struct
type t = a
let compare = compare
end) in
let module W = struct
type t = S.t
type _ witness += Id : t witness
end in
Set {
set = S.empty;
ops = (module S);
tid = (module W);
}
The caveat here is that each call to create will generate a new instance of the set type 's so we can compare/union/etc two sets that were created with the same create function. In other words, all sets in our implementation shall share the same ancestor. But before that lets take a pain and implement at least two operations, add and union,
let add : type a. a -> a set -> a set =
fun elt (Set {set; tid; ops=(module Set)}) -> Set {
set = Set.add elt set;
ops = (module Set);
tid;
}
let union : type a. a set -> a set -> a set =
fun (Set {set=s1; tid=(module W1); ops=(module Set)})
(Set {set=s2; tid=(module W2)}) ->
match W1.Id with
| W2.Id -> Set {
set = Set.union s1 s2;
tid = (module W1);
ops = (module Set);
}
| _ -> failwith "sets are potentially using different types"
Now, we can play with it a bit,
# let empty = create compare;;
val empty : '_weak1 set = Set {set = <poly>; ops = <module>; tid = <module>}
# let x1 = add 1 empty;;
val x1 : int set = Set {set = <poly>; ops = <module>; tid = <module>}
# let x2 = add 2 empty;;
val x2 : int set = Set {set = <poly>; ops = <module>; tid = <module>}
# let x3 = union x1 x2;;
val x3 : int set = Set {set = <poly>; ops = <module>; tid = <module>}
# let x4 = create compare;;
val x4 : '_weak2 set = Set {set = <poly>; ops = <module>; tid = <module>}
# union x3 x4;;
Exception: Failure "sets are potentially using different types".
#
I'm trying to create a functor that makes a polynomial ring out of a ring. My underlying type, Ring_elt, has the following signature:
module type Ring_elt = sig
type t
val add : t -> t -> t
val mul : t -> t -> t
val zer : t
val one : t
val neg : t -> t
end;;
My polynomial functor looks like:
module Make_Poly2(Underlying:Ring_elt) = struct
type t = Poly of Underlying.t list
let rec create lst =
match List.rev lst with
| Underlying.zer :: tl -> create List.rev tl
| _ -> Poly of lst
end;;
(so the 'create' function should take a list, remove the leading zeros, and then return the polynomial of the result). However, I get a syntax error and utop underlines the "zer" after "Underlying."
By comparison, the following code (for making integer polynomials) works:
module Make_int_poly = struct
type t = Poly of int list
let rec create lst =
match List.rev lst with
| 0 :: tl -> create (List.rev tl)
| _ -> Poly lst
end;;
Any idea what's going on?
An OCaml pattern is built from constants, data constructors, and new names bound by the pattern match. Underlying.zer isn't any of those things. But 0 is one of them.
Seems like you can just use an if to compare against Underlying.zer.
Jeffrey's answer is good but instead of correcting it with an if construction, what you should do is the following : use algebraic data types
Instead of writing
val zer : t
val one : t
You could write
module type Ring_elt = sig
type t = Zer | One | Num of t
val add : t -> t -> t
val mul : t -> t -> t
val neg : t -> t
end
module Make_int_poly = struct
type t = Poly of int list
let rec create lst =
match List.rev lst with
| Underlying.Zer :: tl -> create (List.rev tl)
| _ -> Poly lst
end
It's a much better way of doing it since you can easily pattern match on it and even add some constants to your type t without problems.
I currently have two "layers" of modules that represent identifier-data relationships in a database.
The first layer defines identifier types, such as IdUser.t or IdPost.t while the second layer defines data types such as User.t or Post.t. I need all the modules of the first layer to be compiled before the modules of the second layer, because a Post.t must hold the IdUser.t of its author and the User.t holds the IdPost.t of the last five posts he visited.
Right now, IdUser.t provides functionality that should only ever be used by User.t, such as the ability to transform an IdUser.t into an IdUser.current: for security reasons, this transform must only ever be performed by the function User.check_password. Since IdUser and User are independent modules, I need to define those features as public functions and rely on conventions to avoid calling them anywhere outside of User, which is rather dirty. A symmetrical situation happens in IdPost.mine:
module IdUser : sig
type t
type current
val current_of_t : t -> current (* <--- Should not be public! *)
end = struct
type t = string
type current = string
let current_of_t x = x
end
module IdPost : sig
type t
type mine
val mine_of_t : t -> mine (* <--- Should not be public! *)
end = struct
type t = string
type mine = string
let mine_of_t x = x
end
module Post : sig
(* Should not "see" IdUser.current_of_t but needs IdPost.mine_of_t *)
val is_mine : IdUser.current -> IdPost.t -> IdPost.mine
end
module User : sig
(* Should not "see" IdPost.mine_of_t but needs IdUser.current_of_t *)
val check_password : IdUser.t -> password:string -> IdUser.current
end
Is there a way of defining an current_of_t : t -> current function in IdUser that can only be called from within module User ?
EDIT: this was a simplified example of one pair of modules, but there's an obvious solution for a single pair that cannot be generalized to multiple pairs and I need to solve this for multiple pairs — about 18 pairs, actually... So, I've extended it to be an example of two pairs.
So IdUser is in reality an existential type: For User there exists a type
IdUser.current such that the public IdUser.t can be lifted to it. There are a couple of ways to encode this: either functorize User as Gasche shows if statically managing the dependence is sufficient, or use first-class modules or objects if you need more dynamism.
I'll work out Gasche's example a bit more, using private type abbreviations for convenience and to show how to leverage translucency to avoid privatizing implementation types too much. First, and this might be a limitation, I want to declare an ADT of persistent IDs:
(* File id.ml *)
module type ID = sig
type t
type current = private t
end
module type PERSISTENT_ID = sig
include ID
val persist : t -> current
end
With this I can define the type of Posts using concrete types for the IDs but with ADTs to enforce the business rules relating to persistence:
(* File post.ml *)
module Post
(UID : ID with type t = string)
(PID : PERSISTENT_ID with type t = int)
: sig
val is_mine : UID.current -> PID.t -> PID.current
end = struct
let is_mine uid pid =
if (uid : UID.current :> UID.t) = "me" && pid = 0
then PID.persist pid
else failwith "is_mine"
end
The same thing with Users:
(* File user.ml *)
module User
(UID : PERSISTENT_ID with type t = string)
: sig
val check_password : UID.t -> password:string -> UID.current
end = struct
let check_password uid ~password =
if uid = "scott" && password = "tiger"
then UID.persist uid
else failwith "check_password"
end
Note that in both cases I make use of the concrete but private ID types. Tying all together is a simple matter of actually defining the ID ADTs with their persistence rules:
module IdUser = struct
type t = string
type current = string
let persist x = x
end
module IdPost = struct
type t = int
type current = int
let persist x = x
end
module MyUser = User (IdUser)
module MyPost = Post (IdUser) (IdPost)
At this point and to fully decouple the dependencies you will probably need signatures for USER and POST that can be exported from this module, but it's a simple matter of adding them in.
One way that seems to work at least on your simplified example is to group IdUser and User inside a same module:
module UserAndFriends : sig ... end = struct
module IdUser : sig
...
end = struct
...
end
module User = struct
...
end
end
module Post : sig
val create : (* <--- Should not "see" IdUser.current_of_t *)
author:IdUser.current -> title:string -> body:string -> IdPost.t
end
Hiding the dangerous function(s) in the signature of UserAndFriends gives the result you desire. If you do not want to make a big file containing both IdUser and User, you can use option -pack of ocamlc to create UserAndFriends. Note that in this case, you must craft your Makefile carefully so that the .cmi files of IdUser and User are not visible when compiling Post. I am not the Makefile specialist for Frama-C, but I think we use separate directories and position the compiler option -I carefully.
I suggest you parametrize Post (and possibly User for consistency) by a signature for the IdUser module : you would use a signature with current_of_t for User, and one without for Post.
This guarantee that Post doesn't use IdUser private features, but the public interface of IdUser is still too permissive. But with this setup, you have reversed the dependencies, and IdUser (the sensitive part) can control its use directly, give itself (with the private part) to IdUser and restrict the public signature to the public parts.
module type PrivateIdUser = sig
val secret : unit
end
module type PublicIdUser = sig
end
module type UserSig = sig
(* ... *)
end
module MakeUser (IdUser : PrivateIdUser) : UserSig = struct
(* ... *)
end
module IdUser : sig
include PublicIdUser
module User : UserSig
end
= struct
module IdUser = struct
let secret = ()
end
module User = MakeUser(IdUser)
include IdUser
end
module Post = struct
(* ... *)
end
Edit : Pascal Cuoq's concurrent -- in the temporal sense -- solution is alos very nice. Actually it's simpler and has less boilerplate. My solution adds an abstraction that allows for slightly more modularity, as you can define User independently of IdUser.
I think which solution is best probably depends on the specific application. If you have a lot of different modules that use PrivateIdUser private information, then using functors to write them separately instead of bundling everyone in the same module can be a good idea. If only User needs to be in the "private zone" and it's not very big, then Pascal's solution is a better choice.
Finally, while being forced to explicit Private and Public interfaces can be seen as an additional burden, it is also a way to make the access properties of different modules more explicit that using the position inside the module hierarchy.
It's possible to achieve fine-grained control over signatures with a combination of recursive modules, first-class modules and GADTs, but the limitation would be that all modules should then be inside the same top-level module and unpackings of first-class modules inside the recursive modules should be done in each function separately (not on the module-level as it would cause runtime exception Undefined_recursive_module):
module rec M1 : sig
module type M2's_sig = sig
val a : int
val c : float
end
module type M3's_sig = sig
val b : string
val c : float
end
type _ accessor =
| I'm_M2 : M2.wit -> (module M2's_sig) accessor
| I'm_M3 : M3.wit -> (module M3's_sig) accessor
val access : 'a accessor -> 'a
type wit
val do_it : unit -> unit
end = struct
module type M2's_sig = sig
val a : int
val c : float
end
module type M3's_sig = sig
val b : string
val c : float
end
type _ accessor =
| I'm_M2 : M2.wit -> (module M2's_sig) accessor
| I'm_M3 : M3.wit -> (module M3's_sig) accessor
module M1 = struct
let a = 1
let b = "1"
let c = 1.
end
let access : type a. a accessor -> a =
function
| I'm_M2 _ -> (module M1)
| I'm_M3 _ -> (module M1)
type wit = W
let do_it () =
let (module M2) = M2.(access ## I'm_M1 W) in
let (module M3) = M3.(access ## I'm_M1 W) in
Printf.printf "M1: M2: %d %s M3: %d %s\n" M2.a M2.b M3.a M3.b
end
and M2 : sig
module type M1's_sig = sig
val a : int
val b : string
end
module type M3's_sig = sig
val b : string
val c : float
end
type _ accessor =
| I'm_M1 : M1.wit -> (module M1's_sig) accessor
| I'm_M3 : M3.wit -> (module M3's_sig) accessor
val access : 'a accessor -> 'a
type wit
val do_it : unit -> unit
end = struct
module type M1's_sig = sig
val a : int
val b : string
end
module type M3's_sig = sig
val b : string
val c : float
end
type _ accessor =
| I'm_M1 : M1.wit -> (module M1's_sig) accessor
| I'm_M3 : M3.wit -> (module M3's_sig) accessor
module M2 = struct
let a = 2
let b = "2"
let c = 2.
end
let access : type a. a accessor -> a =
function
| I'm_M1 _ -> (module M2)
| I'm_M3 _ -> (module M2)
type wit = W
let do_it () =
let (module M1) = M1.(access ## I'm_M2 W) in
let (module M3) = M3.(access ## I'm_M2 W) in
Printf.printf "M2: M1: %d %f M3: %d %f\n" M1.a M1.c M3.a M3.c
end
and M3 : sig
module type M1's_sig = sig
val a : int
val b : string
end
module type M2's_sig = sig
val a : int
val c : float
end
type _ accessor =
| I'm_M1 : M1.wit -> (module M1's_sig) accessor
| I'm_M2 : M2.wit -> (module M2's_sig) accessor
val access : 'a accessor -> 'a
type wit
val do_it : unit -> unit
end = struct
module type M1's_sig = sig
val a : int
val b : string
end
module type M2's_sig = sig
val a : int
val c : float
end
type _ accessor =
| I'm_M1 : M1.wit -> (module M1's_sig) accessor
| I'm_M2 : M2.wit -> (module M2's_sig) accessor
module M3 = struct
let a = 3
let b = "3"
let c = 3.
end
let access : type a. a accessor -> a =
function
| I'm_M1 _ -> (module M3)
| I'm_M2 _ -> (module M3)
type wit = W
let do_it () =
let (module M1) = M1.(access ## I'm_M3 W) in
let (module M2) = M2.(access ## I'm_M3 W) in
Printf.printf "M3: M1: %s %f M2: %s %f\n" M1.b M1.c M2.b M2.c
end
let () =
M1.do_it ();
M2.do_it ();
M3.do_it ()