diff --git a/INSTALL b/INSTALL index 71418ee7289db70d510bd185481af6e6ee11fe74..59573e8eb990929b3eefd57a397f05c5dfeda00a 100644 --- a/INSTALL +++ b/INSTALL @@ -24,8 +24,10 @@ In order to compile the ACG toolkit, you need: + ocaml (>=3.07) installed (http://caml.inria.fr/) + dypgen (>=20080925) installed (http://dypgen.free.fr/) + + bolt (>=1.4) installed (http://bolt.x9c.fr/downloads.html +======= IMPORTANT: A fast an easy way to install dypgen and all important ocaml libraries is @@ -36,6 +38,8 @@ The installation typically goes that way: + then install opam + then install dypgen with the command opam install dypgen + + then install bolt with the command + opam install bolt + don't forget to add the required library in your path (look at "Initializing opam" at http://opam.ocaml.org/doc/Advanced_Install.html) @@ -67,7 +71,7 @@ For instance, run: Then run: - make + make byte to get the bytecode executable, or @@ -75,7 +79,7 @@ to get the bytecode executable, or to get native code binaries -It should produce executables in the current directory: acgc (or +It should produce two executables in the current directory: acgc (or acgc.opt for the native code executable) and acg (or acg.opt for the native code executable). diff --git a/Makefile.in b/Makefile.in index 6a38cfb4d869a061283a0a5a1933111d776e6d39..4c7ae7973d44c6317fc31ea2e80214d5b6218f44 100644 --- a/Makefile.in +++ b/Makefile.in @@ -17,9 +17,9 @@ # # ########################################################################## -.PHONY: config byte opt clean superclean install tar version release +.PHONY: config byte opt clean superclean install tar version release test force -BINARIES=acgc acgc.opt acg acg.opt +BINARIES=acg acg.opt acgc acgc.opt VERSION_FILE = src/utils/version.ml VERSION = $(shell date "+%Y%m%d") @@ -27,22 +27,38 @@ RELEASE = acg-$(VERSION) TAR_RELEASE =acg-$(TAR_VERSION) - - prefix = @prefix@ exec_prefix = @exec_prefix@ -byte opt: - $(MAKE) -C src $@ && for file in $(BINARIES); do find . -name "$$file" -exec cp {} . \; ; done +ACG_DIR=src/scripting +ACGC_DIR=src/acg-data + +byte: acg acgc + +opt: acg.opt acgc.opt + +all: byte opt test + +acg acg.opt: force + $(MAKE) -C $(ACG_DIR) $@ + cp $(ACG_DIR)/$@ . + +acgc acgc.opt: force + $(MAKE) -C $(ACGC_DIR) $@ + cp $(ACGC_DIR)/$@ . + +force: + -all: byte opt +test: + $(MAKE) -C src $@ clean: -if test "$@" = clean ; then $(MAKE) -C config $@ ; fi -$(MAKE) -C src $@ - rm -rf *.log *~ autom4te.cache *.tar.gz + rm -rf *.log *~ autom4te.cache *.tar.gz *.acgo find . -name "*~" -exec rm -f {} \; - -for file in $(BINARIES); do rm $$file ; done + -for file in $(BINARIES); do rm -f $$file ; done superclean: clean -find . -path "./*/*.in" -print | sed -e 's/\(.*\)\.in/\1/' | xargs -n 1 rm @@ -58,7 +74,7 @@ uninstall: config: configure -configure: config/configure.ac +configure: config/configure.ac config/ac_lib_checking.m4 cd $(S; + +to check whether "lambda x.cst x" is a term of type "NP ->S" according +to Sig. + +You can type: + +# Lex realize lambda x.cst x: NP ->S; + +to compute the image of "lambda x.cst x" is a term of type "NP ->S" by +Lex (assuming this term and this type are correct according to the +abstract signature of Lex). + +You can type: + +# Lex parse John+loves+Mary: S; + +to check whether the term "John+loves+Mary" has an antecend of type +"S" by Lex, assuming that "John+loves+Mary" is a term of type "Lex +(S)" in the object signature of Lex. + +Type CTRL-D to exit from the program. + ******************** ** ACG emacs mode ** ******************** @@ -152,6 +198,9 @@ lexicon my_lex_name(abstract_sig_name) : object_sig_name = lex_entries end +or by lexicon composition as in: +lexicon my_new_lex = lex_2 << lex_1 + Lex_entries always ends with a ; and have the following form: abstract_atomic_type1, abstract_atomic_type2 := object_type; abstract_const1, abstract_const2 := object_term; diff --git a/TODO b/TODO new file mode 100644 index 0000000000000000000000000000000000000000..5bb0ba8c80be3267c8dd35c2e4927b43607468d4 --- /dev/null +++ b/TODO @@ -0,0 +1,94 @@ +; -*-org-*- + +* Général + +** Avant Prochaine release ++ [ ] merge avec trunk ++ [ ] remplacer tous les gforge.loria en gforge.inria ++ [ ] réfléchir si changement de construction des numéros de version ++ [ ] renommer s_datalog et datalog en datalog.prover et datalog.solver ++ [X] modifier la documentation + +** TODO Faire un Bolt package + + +** DONE Utiliser Bolt (http://bolt.x9c.fr/) ++ [X] Intégrer dans le configure.ac la dépendance à Bolt ++ [X] Laisser la possibilité que la librairie ne soit pas installée *Impossible* ++ [X] Gérer la présence d'un fichier bolt_config (bolt.config) (DONE: + bug fix in BOLT) + +** DONE Configuration ++ [X] Utiliser les outils de Paul + +** Permettre l'utilisation des PersistentArray + +** TODO Vérifier (et supprimer ou mettre en IFDEBUG) les assert + +** TODO Avant merge et prochaine release : ++ [X] mettre la commande "analyse" en deprecated ++ [X] la remplacer par + + [X] une commande "check" + + [X] une commande "realise" ++ [X] mettre une commande "idb" ++ [X] mettre une commande "query" ++ [ ] vérifier que tous les "help cmd" fonctionnent + +** lexer and parser ++ [ ] change the compilation order and the token emission + +* datalog.ml ++ [ ] Vérifier pourquoi "pred_table" est paramètre de Rule.to_abstract + et aussi de Datalog_AbstractSyntax.Rule.to_string ++ [ ] Vérifier pourquoi content est passé en paramètre dans les + to_abstract alors que c'est un champ du record rule ++ [ ] Idem pour Rule.extract_consequence ++ [ ] Réfléchir à la possibilité de faire de l'unification directement + entre contents. Ça réduirait par exemple les itérations dans + "extract_consequence" ++ [X] Autoriser l'instanciation avec des variables encore présentes ++ [X] Implanter la réponse à une requête. ++ [ ] Ajouter dans le programme l'enregistrement de toutes les + constantes et les parcourir pour ajouter aux faits ceux qui ont + encore des variables. ++ [ ] Ajouter la possibilité d'étendre un programme datalog ++ [ ] changer le champ idb de prog en Set plutôt que list ++ [ ] changer edb et idb en Set plutôt que list ++ [ ] build_forest sans query n'est pas correct (il faut faire + plusieurs forêts) + +* alterTrees.ml ++ [ ] changer la focused list des forêts en simple liste ? ++ [ ] garder trace de Link_to plutôt que de l'actual forest dans les move ++ [X] gérer les analyses infinies (ordre sur les chemins) + +* unionFind.ml ++ [ ] Changer le rank dans "union" lorsque match de Value contre + Link_to + +* lambda.ml ++ [ ] Vérifier les passages de paramètres dans les + unfold_{labs|abs|binder} pour l'affichage, et simplifier + +* typeInference.ml ++ [ ] change or add inference (possibly with a signature) to principal + typing ++ [ ] remove the level parameter (and any other useless parameter) + from the inference_aux function (when no LOG occur) + + +* acg_lexicon.ml ++ [X] rebuild the datalog program after composition ++ [ ] add the int id (as in Lambda.Const i) in the map from the + constant name for abstract constants ++ [X] Définir le parsing de la composition de lexique ++ [ ] Définir le parsing pour les types non atomiques ++ [ ] Définir le parsing pour les almost linear terms + +* Divers ++ [X] ajouter la commande compose dans les fichiers de définition de + lexiques et signature ++ [ ] ajouter un espace de nommage pour les lexiques et signatures ++ [X] faire des dumps des interfaces et des représentations binaires + pour charger plus vite ++ [ ] Ajouter un -nooout option pour acgc ? diff --git a/bolt.config b/bolt.config new file mode 100644 index 0000000000000000000000000000000000000000..c47c0e907a1c452299970bf99d3ab980e8a14f5b --- /dev/null +++ b/bolt.config @@ -0,0 +1,9 @@ +logger "" { + level = trace; + filter = all; + layout = default; + mode = direct; + output = file; + name = "acg.log"; +} + diff --git a/config/ac_lib_checking.m4 b/config/ac_lib_checking.m4 new file mode 100644 index 0000000000000000000000000000000000000000..be2b8a9ad2e625c5b187d8029de067a99726bc1a --- /dev/null +++ b/config/ac_lib_checking.m4 @@ -0,0 +1,166 @@ +################################################################################ +# AC_LIB_CHECKING +# permet le test de la présence d'une librairie Ocaml dans le repertoire +# standard d'installation des librairies (ocamlc -where), dans un repertoire +# dédié (+...), ou installée avec ocamlfind +# @param $1 : le nom a afficher de la librairie +# @param $2 : le repertoire standard de la librairie (par ex : zen pour -I +zen) +# @param $3 : le nom du fichier contenant la librairie +# @param $4 : le nom de la librairie pour ocamlfind +# @param $5 : le nom du package opam (s'il existe) +# @param $6 : le module a tester pour vérifier la présence de la librairie +# @param $7 : les options de "compilation" pour la verification de la présence de la lib +# @param $8 : true si la librairie est obligatoire, false si elle est optionnelle +# @param $9 : nom de la variable si un chemin non standard est spécifié +AC_DEFUN([AC_LIB_CHECKING], + + MACRO="A" + MACRO=$MACRO"C_LIB_CHECKING" + + + NAME=$1 + STD_FOLDER=$2 + LIB_FILE=$3 + OFIND_NAME=$4 + OPAM_PACKAGE=$5 + MOD=$6 + OPTIONS=$7 + NO_OPTIONAL=$8 + LIB_PATH=$9 + + # test au cas ou un argument obligatoire est manquant + if test "$NAME" = "" || test "$STD_FOLDER" = "" || test "$OFIND_NAME" = "" || test "$LIB_FILE" = "" || test "$MOD" = "" ; then + echo "" + echo "Can't check a library" + echo "Missing argument in $MACRO($NAME,$STD_FOLDER,$OFIND_NAME,$LIB_FILE,$MOD,$OPTIONS,$NO_OPTIONAL)" + echo "" + exit 1 + fi + + # affichage du nom de la librairie a checker (avec details sur l'optionalité) + if test "$NO_OPTIONAL" = true; then + AC_MSG_CHECKING([for requested library : $NAME]) + else + AC_MSG_CHECKING([for optional library : $NAME]) + fi + + # si le fichier ml de test existe + if test -f c_check_$STD_FOLDER.ml ; then + # si on peut le supprimer + if test -w c_check_$STD_FOLDER.ml ; then + # on le supprimer + rm c_check_$STD_FOLDER.ml >& /dev/null + # sinon on arrete et on balance un message d'erreur (ie on a pas les droits sur le fichier + else + AC_MSG_FAILURE(Cannot remove c_check_$2.ml. Please change its right with chmod 666 c_check_$2.ml) + fi + fi + + # on prepare le fichier ml de test + echo "open $MOD;;" > c_check_$STD_FOLDER.ml + + # définition de la variable disant si on a trouvé la librairie ou pas + FOUND_LIB="no" + + + if test -n "$LIB_PATH" ; then + LIB_INCLUDE="-I $LIB_PATH" + # on teste maintenant si on peut exectuer le fichier ml de test + if ($OCAMLC -c $OPTIONS $LIB_INCLUDE $LIB_FILE.cma c_check_$STD_FOLDER.ml >& /dev/null) ; then + # on y arrive, on dit qu'on a trouvé la lib avec la variable d'environnement + FOUND_LIB=yes + AC_MSG_RESULT(Found with the environment variable => $LIB_INCLUDE) + fi + fi + + if test "$FOUND_LIB" = "no" ; then + # si on arrive à l'executer avec la librairie dans le rep de lib de caml + if ($OCAMLC -c $OPTIONS c_check_$STD_FOLDER.ml >& /dev/null) ; then + # pas besoin d'include + LIB_INCLUDE="" + LIB_DIR=`$OCAMLC -where` + FOUND_LIB=yes + AC_MSG_RESULT(Found in ocaml lib directory) + fi + fi + + # sinon on essaie avec un repertoire dedié à la lib (-I +xxx yyy.cma) + if test "$FOUND_LIB" = "no" ; then + if ($OCAMLC -c $OPTIONS -I +$STD_FOLDER $LIB_FILE.cma c_check_$STD_FOLDER.ml >& /dev/null) ; then + # si ca marche, on s'arrete et on precise le include + LIB_INCLUDE="-I +$STD_FOLDER" + LIB_DIR=`$OCAMLC -where` + LIB_DIR="$LIB_DIR/$STD_FOLDER" + FOUND_LIB=yes + AC_MSG_RESULT(Found in $STD_FOLDER directory => $LIB_INCLUDE) + fi + fi + + # sinon, on essaie avec ocamlfind + if test "$FOUND_LIB" = "no" ; then + # si on n'a pas ocamlfind , on s'arrete (dans le cas d'une lib oblig.) ou + # on lance un warning (dans le cas d'une lib optionelle) + if test "$OCAMLFIND" != "no" ; then + echo testing with $OCAMLFIND + # on regarde déjà si la lib est installée avec ocamlfind + if $OCAMLFIND query $OFIND_NAME > /dev/null 2>&1 ; then + # si c'est le cas, on recupere le repertoire d'installation et le include correspondant + LIB_INCLUDE=`$OCAMLFIND query $OFIND_NAME` + LIB_INCLUDE="-I $LIB_INCLUDE" + + # on teste maintenant si on peut exectuer le fichier ml de test + if ($OCAMLC -c $OPTIONS $LIB_INCLUDE $LIB_FILE.cma c_check_$STD_FOLDER.ml >& /dev/null) ; then + # on y arrive, on dit qu'on a trouvé la lib avec ocamlfind + FOUND_LIB=yes + LIB_DIR=`$OCAMLFIND query $OFIND_NAME` + AC_MSG_RESULT(Found with $OCAMLFIND => $LIB_INCLUDE) + fi + fi + fi + fi + + if test "$FOUND_LIB" = "no" ; then + # si opam est installé, on essaye dans la lib de opam + if test "$OPAM$" != "no" ; then + if test "$OPAM config var $OPAM_PACKAGE:installed" = "true" ; then + OPAM_OCAML_VERSION=`opam config var ocaml-version` + OCAML_VERSION=`$OCAMLC -version` + if test "$OPAM_OCAML_VERSION" = "$OCAML_VERSION" ; then + LIB_INCLUDE=`$OPAM config var lib` + LIB_INCLUDE="-I $LIB_INCLUDE/$STD_FOLDER" + + # on teste maintenant si on peut exectuer le fichier ml de test + if ($OCAMLC -c $OPTIONS $LIB_INCLUDE $LIB_FILE.cma c_check_$STD_FOLDER.ml >& /dev/null) ; then + # on y arrive, on dit qu'on a trouvé la lib avec opam + FOUND_LIB=yes + LIB_DIR=`$OPAM config var lib` + LIB_DIR="$LIB_DIR/$STD_FOLDER" + AC_MSG_RESULT(Found with $OPAM => $LIB_INCLUDE) + fi + else + AC_MSG_RESULT(There is an opam installation of the library, but the current $OPAM switch does not correspond to the $OCAMLC compiler) + fi + fi + fi + fi + + + + if test "$FOUND_LIB" = "no" ; then + # suivant l'optionalité de la lib: un warning ou une erreur + if test "$NO_OPTIONAL" = "true"; then + AC_MSG_ERROR(The $NAME library is missing.) + LIB_INCLUDE="no" + else + AC_MSG_RESULT(The $NAME library is missing.) + LIB_INCLUDE="no" + fi + fi + + + # suppression du fichier ml de test + rm c_check_$STD_FOLDER.ml >& /dev/null + rm c_check_$STD_FOLDER.cmo >& /dev/null + rm c_check_$STD_FOLDER.cmi >& /dev/null +) +################################################################################ diff --git a/config/configure.ac b/config/configure.ac index fc1598fe04302e3c7aea97407951f4d6e5e6b95f..48681a51a1f34db88128c691bc009b431f5812c4 100644 --- a/config/configure.ac +++ b/config/configure.ac @@ -20,6 +20,7 @@ AC_INIT([ACG DTK],[0.1],[sylvain.pogodalla@loria.fr]) #AC_COPYRIGHT([Cecill]) +m4_include(ac_lib_checking.m4) OCAML_REQUIRED=3.07 @@ -62,23 +63,32 @@ if test "$OCAMLDEP" = no ; then AC_MSG_ERROR(Cannot find ocamldep.) fi -# Look for camllex +# Look for ocamllex AC_CHECK_PROGS(OCAMLLEX,ocamllex.opt ocamllex,no) if test "$OCAMLLEX" = no ; then AC_MSG_ERROR(Cannot find ocamllex) fi +# Look for ocamlyacc +AC_CHECK_PROGS(OCAMLYACC,ocamlyacc.opt ocamlyacc,no) +if test "$OCAMLYACC" = no ; then + AC_MSG_ERROR(Cannot find ocamlyac) +fi + # Look for ocamlfind AC_PATH_PROG(OCAMLFIND,ocamlfind,no) +# Look for opam +AC_PATH_PROG(OPAM,opam,no) + #Look for dypgen DYPGEN_NEEDED=20080925 AC_ARG_VAR(DYPGEN_PATH,[Directory where to find dypgen if not in a standard location]) if test -n "$DYPGEN_PATH" ; then AC_CHECK_PROG(DYPGEN,dypgen,$DYPGEN_PATH/dypgen,no,$DYPGEN_PATH) else - AC_CHECK_PROGS(DYPGEN,dypgen.opt dypgen,no) + AC_CHECK_PROGS(DYPGEN,dypgen.opt dypgen,no) fi if test "$DYPGEN" = no ; then AC_MSG_ERROR(Cannot find dypgen) @@ -87,85 +97,67 @@ else AC_MSG_CHECKING([for $DYPGEN version]) if test $DYPGEN_VERSION -ge $DYPGEN_NEEDED ; then AC_MSG_RESULT($DYPGEN ($DYPGEN_VERSION) is ok) + AC_SUBST(DYPGEN) else AC_MSG_ERROR($DYPGEN version $DYPGEN_VERSION found ; version $DYPGEN_NEEDED or greater is needed) fi fi # Look for DYPGEN_LIB with or without ocamlfind -AC_MSG_CHECKING([dypgen library]) -AC_ARG_VAR(DYPGENLIB_PATH,[Directory where to find dypgen library if not in a standard location]) -if test -n "$DYPGENLIB_PATH" ; then - DYPGEN_PLACE=$DYPGENLIB_PATH - DYPGEN_INCLUDE="-I $DYPGEN_PLACE" - if test -f $DYPGEN_PLACE/dyp.cma ; then - AC_MSG_RESULT(dypgen library is $DYPGEN_PLACE/dyp.cma) - else - AC_MSG_ERROR(Could not find dypgen library in $DYPGEN_PLACE) +AC_ARG_VAR(DYPGENLIB_PATH,[Directory where to find the dypgen library if not in a standard location]) +AC_LIB_CHECKING(dypgen,dyp,dyp,dyp,dypgen,Dyp,,true,$DYPGENLIB_PATH) + +if test "$FOUND_LIB" != "no" ; then + AC_SUBST(DYPGEN_INCLUDE,$LIB_INCLUDE) +fi + +AC_ARG_ENABLE( + [kaputt], + [AS_HELP_STRING([--enable-kaputt], [Compile with kaputt for unit testing])], + [with_kaputt=$enableval], + [with_kaputt=no]) +if test "$with_kaputt" != no ; then + # Look for KAPUTT_LIB + AC_LIB_CHECKING(kaputt,kaputt,kaputt,kaputt,kaputt,Kaputt,,false,,) + if test "$FOUND_LIB" != "no" ; then + if test -f $LIB_DIR/kaputt_pp.byte ; then + KAPUTT_PP="$LIB_DIR/kaputt_pp.byte" + AC_MSG_RESULT(kaputt_pp.byte preprocessor is $KAPUTT_PP) + AC_SUBST(KAPUTT_INCLUDE,$LIB_INCLUDE) + AC_SUBST(KAPUTT_LIB,$LIB_FILE.cma) + AC_SUBST(KAPUTT_PP) + else + AC_MSG_ERROR(Could not find kaputt_pp.byte preprocessor in $LIB_DIR.) + fi fi -else - if test "$OCAMLFIND" != no ; then - if $OCAMLFIND query dypgen > /dev/null 2>&1 ; then - DYPGEN_INCLUDE_DIR=`$OCAMLFIND query dypgen` - DYPGEN_PLACE=$DYPGEN_INCLUDE_DIR - DYPGEN_INCLUDE="-I $DYPGEN_INCLUDE_DIR" - else - if $OCAMLFIND query dyp > /dev/null 2>&1 ; then - DYPGEN_INCLUDE_DIR=`$OCAMLFIND query dyp` - DYPGEN_PLACE=$DYPGEN_INCLUDE_DIR - DYPGEN_INCLUDE="-I $DYPGEN_INCLUDE_DIR" - else - AC_MSG_RESULT(dypgen library was not installed by ocamlfind) - fi - fi - else - OCAML_LIB=`$OCAMLC -where` - # Old versions of dypgen where put in a dypgen directory - if test -d $OCAML_LIB/dypgen ; then - DYPGEN_PLACE=$OCAML_LIB/dypgen - DYPGEN_INCLUDE="-I +dypgen" - else - # New versions of dypgen where put in a dyp directory - if test -d $OCAML_LIB/dyp ; then - DYPGEN_PLACE=$OCAML_LIB/dyp - DYPGEN_INCLUDE="-I +dyp" - else - AC_MSG_ERROR(Could not find a suitable place for dypgen library in $OCAML_LIB) - fi - fi - fi -fi -if test -f $DYPGEN_PLACE/dyp.cma ; then - AC_MSG_RESULT(dypgen library is $DYPGEN_PLACE/dyp.cma) -else - AC_MSG_ERROR(Could not find dypgen library "dyp.cma" in $DYPGEN_PLACE) fi -# Look for KAPUTT_LIB with ocamlfind -AC_MSG_CHECKING([(optional) kaputt library]) -if test "$OCAMLFIND" != no ; then - if $OCAMLFIND query kaputt > /dev/null 2>&1 ; then - KAPUTT_INCLUDE_DIR=`$OCAMLFIND query kaputt` - KAPUTT_PLACE=$KAPUTT_INCLUDE_DIR - KAPUTT_INCLUDE="-I $KAPUTT_INCLUDE_DIR" +# Look for BOLT_LIB with ocamlfind +AC_ARG_VAR(BOLTLIB_PATH,[Directory where to find the bolt library if not in a standard location]) +AC_LIB_CHECKING(bolt,bolt,bolt,bolt,bolt,Bolt,"unix.cma dynlink.cma",true,$BOLTLIB_PATH) +if test "$FOUND_LIB" != "no" ; then + if test -f $LIB_DIR/bolt_pp.cmo ; then + BOLT_PP="$LIB_DIR/bolt_pp.cmo -level \$(BOLT_LEVEL)" + AC_MSG_RESULT(bolt_pp.byte preprocessor is $BOLT_PP) + AC_SUBST(BOLT_INCLUDE,$LIB_INCLUDE) + AC_SUBST(BOLT_LIB,$LIB_FILE.cma) + AC_SUBST(BOLT_PP) else - AC_MSG_RESULT(kaputt library was not installed by ocamlfind) + AC_MSG_ERROR(Could not find bolt_pp.byte preprocessor in $LIB_DIR.) fi -else - OCAML_LIB=`$OCAMLC -where` - if test -d $OCAML_LIB/kaputt ; then - KAPUTT_PLACE=$OCAML_LIB/kaputt - KAPUTT_INCLUDE="-I +kaputt" - else - AC_MSG_RESULT(Could not find a suitable place for kaputt library in $OCAML_LIB. No link to the kaputt library will be allowed in compilation) - fi -fi -if test -f $KAPUTT_PLACE/kaputt.cma ; then - AC_MSG_RESULT(kaputt library is $KAPUTT_PLACE/kaputt.cma) -else - AC_MSG_RESULT(Could not find kaputt library "kaputt.cma" in $KAPUTT_PLACE. No link to the kaputt library will be allowed in compilation) fi +AC_ARG_ENABLE( + [log], + [AS_HELP_STRING([--enable-log], [Enable log information to be produced by bolt])], + [with_log=$enableval], + [with_log=no]) +if test "$with_log" = "no" ; then + AC_SUBST(BOLT_LEVEL,NONE) +else + AC_SUBST(BOLT_LEVEL,TRACE) +fi +AC_MSG_RESULT(Bolt log level is $BOLT_LEVEL.) # What is the OCAML version ? @@ -226,10 +218,10 @@ AC_SUBST(OCAMLDOC) AC_SUBST(OCAMLDEP) AC_SUBST(OCAMLLEX) -#AC_SUBST(OCAMLYACC) -AC_SUBST(DYPGEN) -AC_SUBST(DYPGEN_INCLUDE) -AC_SUBST(KAPUTT_INCLUDE) +AC_SUBST(OCAMLYACC) + + + AC_SUBST(TYPES) AC_SUBST(OCAML09WARNINGS) @@ -237,7 +229,7 @@ AC_SUBST(OCAMLP4_LOC) AC_SUBST(SET_MAKE) -AC_CONFIG_FILES([./Makefile config/Makefile src/Makefile.master src/Makefile.common src/Makefile src/utils/Makefile src/logic/Makefile src/grammars/Makefile src/acg-data/Makefile src/scripting/Makefile src/datalog/Makefile src/reduction/Makefile]) +AC_CONFIG_FILES([./Makefile config/Makefile src/Makefile.master src/Makefile.common src/Makefile src/utils/Makefile src/logic/Makefile src/grammars/Makefile src/acg-data/Makefile src/scripting/Makefile src/datalog/Makefile src/reduction/Makefile src/s_datalog/Makefile]) AC_PROG_MAKE_SET diff --git a/configure b/configure index edae8c45830508927bdeab1ac997d809465e34d1..4fa1bc30686a96355a3fb5a2a8f0c033974d1e56 100755 --- a/configure +++ b/configure @@ -1,13 +1,11 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.68 for ACG DTK 0.1. +# Generated by GNU Autoconf 2.69 for ACG DTK 0.1. # # Report bugs to . # # -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, -# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software -# Foundation, Inc. +# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation @@ -136,6 +134,31 @@ export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH +# Use a proper internal environment variable to ensure we don't fall + # into an infinite loop, continuously re-executing ourselves. + if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then + _as_can_reexec=no; export _as_can_reexec; + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +as_fn_exit 255 + fi + # We don't want this to propagate to other subprocesses. + { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh @@ -169,7 +192,8 @@ if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi -test x\$exitcode = x0 || exit 1" +test x\$exitcode = x0 || exit 1 +test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && @@ -213,21 +237,25 @@ IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : - # We cannot yet assume a decent shell, so we have to provide a - # neutralization value for shells without unset; and this also - # works around shells that cannot unset nonexistent variables. - # Preserve -v and -x to the replacement shell. - BASH_ENV=/dev/null - ENV=/dev/null - (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV - export CONFIG_SHELL - case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; - esac - exec "$CONFIG_SHELL" $as_opts "$as_myself" ${1+"$@"} + export CONFIG_SHELL + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +exit 255 fi if test x$as_have_required = xno; then : @@ -330,6 +358,14 @@ $as_echo X"$as_dir" | } # as_fn_mkdir_p + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take @@ -451,6 +487,10 @@ as_cr_alnum=$as_cr_Letters$as_cr_digits chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } + # If we had to re-execute with $CONFIG_SHELL, we're ensured to have + # already done that, so ensure we don't try to do so again and fall + # in an infinite loop. This has already happened in practice. + _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). @@ -485,16 +525,16 @@ if (echo >conf$$.file) 2>/dev/null; then # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -p'. + # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -p' + as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else - as_ln_s='cp -p' + as_ln_s='cp -pR' fi else - as_ln_s='cp -p' + as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null @@ -506,28 +546,8 @@ else as_mkdir_p=false fi -if test -x / >/dev/null 2>&1; then - as_test_x='test -x' -else - if ls -dL / >/dev/null 2>&1; then - as_ls_L_option=L - else - as_ls_L_option= - fi - as_test_x=' - eval sh -c '\'' - if test -d "$1"; then - test -d "$1/."; - else - case $1 in #( - -*)set "./$1";; - esac; - case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( - ???[sx]*):;;*)false;;esac;fi - '\'' sh - ' -fi -as_executable_p=$as_test_x +as_test_x='test -x' +as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" @@ -570,13 +590,22 @@ SET_MAKE OCAMLP4_LOC OCAML09WARNINGS TYPES +CAMLP4_LIB +BOLT_LEVEL +BOLT_PP +BOLT_LIB +BOLT_INCLUDE +BOLTLIB_PATH +KAPUTT_PP +KAPUTT_LIB KAPUTT_INCLUDE DYPGEN_INCLUDE -CAMLP4_LIB DYPGENLIB_PATH DYPGEN DYPGEN_PATH +OPAM OCAMLFIND +OCAMLYACC OCAMLLEX OCAMLDEP OCAMLDOC @@ -625,12 +654,15 @@ SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking +enable_kaputt +enable_log ' ac_precious_vars='build_alias host_alias target_alias DYPGEN_PATH -DYPGENLIB_PATH' +DYPGENLIB_PATH +BOLTLIB_PATH' # Initialize some variables set by options. @@ -1086,8 +1118,6 @@ target=$target_alias if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe - $as_echo "$as_me: WARNING: if you wanted to set the --build type, don't use --host. - If a cross compiler is detected then cross compile mode will be used" >&2 elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi @@ -1238,10 +1268,20 @@ if test -n "$ac_init_help"; then esac cat <<\_ACEOF +Optional Features: + --disable-option-checking ignore unrecognized --enable/--with options + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --enable-kaputt Compile with kaputt for unit testing + --enable-log Enable log information to be produced by bolt + Some influential environment variables: DYPGEN_PATH Directory where to find dypgen if not in a standard location DYPGENLIB_PATH - Directory where to find dypgen library if not in a standard + Directory where to find the dypgen library if not in a standard + location + BOLTLIB_PATH + Directory where to find the bolt library if not in a standard location Use these variables to override the choices made by `configure' or to help @@ -1311,9 +1351,9 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF ACG DTK configure 0.1 -generated by GNU Autoconf 2.68 +generated by GNU Autoconf 2.69 -Copyright (C) 2010 Free Software Foundation, Inc. +Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF @@ -1328,7 +1368,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by ACG DTK $as_me 0.1, which was -generated by GNU Autoconf 2.68. Invocation command line was +generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ @@ -1677,6 +1717,23 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu #AC_COPYRIGHT([Cecill]) +################################################################################ +# AC_LIB_CHECKING +# permet le test de la présence d'une librairie Ocaml dans le repertoire +# standard d'installation des librairies (ocamlc -where), dans un repertoire +# dédié (+...), ou installée avec ocamlfind +# @param $1 : le nom a afficher de la librairie +# @param $2 : le repertoire standard de la librairie (par ex : zen pour -I +zen) +# @param $3 : le nom du fichier contenant la librairie +# @param $4 : le nom de la librairie pour ocamlfind +# @param $5 : le nom du package opam (s'il existe) +# @param $6 : le module a tester pour vérifier la présence de la librairie +# @param $7 : les options de "compilation" pour la verification de la présence de la lib +# @param $8 : true si la librairie est obligatoire, false si elle est optionnelle +# @param $9 : nom de la variable si un chemin non standard est spécifié + +################################################################################ + OCAML_REQUIRED=3.07 @@ -1700,7 +1757,7 @@ do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLC="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -1750,7 +1807,7 @@ do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLCOPT="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -1796,7 +1853,7 @@ do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAML="ocaml" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -1839,7 +1896,7 @@ do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLP4="camlp4o" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -1884,7 +1941,7 @@ do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLDOC="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -1932,7 +1989,7 @@ do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLDEP="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -1961,7 +2018,7 @@ if test "$OCAMLDEP" = no ; then as_fn_error $? "Cannot find ocamldep." "$LINENO" 5 fi -# Look for camllex +# Look for ocamllex for ac_prog in ocamllex.opt ocamllex do # Extract the first word of "$ac_prog", so it can be a program name with args. @@ -1980,7 +2037,7 @@ do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLLEX="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -2009,6 +2066,54 @@ if test "$OCAMLLEX" = no ; then as_fn_error $? "Cannot find ocamllex" "$LINENO" 5 fi +# Look for ocamlyacc +for ac_prog in ocamlyacc.opt ocamlyacc +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLYACC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLYACC"; then + ac_cv_prog_OCAMLYACC="$OCAMLYACC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_OCAMLYACC="$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +OCAMLYACC=$ac_cv_prog_OCAMLYACC +if test -n "$OCAMLYACC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLYACC" >&5 +$as_echo "$OCAMLYACC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$OCAMLYACC" && break +done +test -n "$OCAMLYACC" || OCAMLYACC="no" + +if test "$OCAMLYACC" = no ; then + as_fn_error $? "Cannot find ocamlyac" "$LINENO" 5 +fi + # Look for ocamlfind # Extract the first word of "ocamlfind", so it can be a program name with args. @@ -2029,7 +2134,7 @@ do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_OCAMLFIND="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -2053,6 +2158,49 @@ fi +# Look for opam +# Extract the first word of "opam", so it can be a program name with args. +set dummy opam; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_OPAM+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $OPAM in + [\\/]* | ?:[\\/]*) + ac_cv_path_OPAM="$OPAM" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_OPAM="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_path_OPAM" && ac_cv_path_OPAM="no" + ;; +esac +fi +OPAM=$ac_cv_path_OPAM +if test -n "$OPAM"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OPAM" >&5 +$as_echo "$OPAM" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + #Look for dypgen DYPGEN_NEEDED=20080925 @@ -2073,7 +2221,7 @@ do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_DYPGEN="$DYPGEN_PATH/dypgen" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -2096,7 +2244,7 @@ fi else - for ac_prog in dypgen.opt dypgen + for ac_prog in dypgen.opt dypgen do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 @@ -2114,7 +2262,7 @@ do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_DYPGEN="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -2149,94 +2297,561 @@ $as_echo_n "checking for $DYPGEN version... " >&6; } if test $DYPGEN_VERSION -ge $DYPGEN_NEEDED ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $DYPGEN ($DYPGEN_VERSION) is ok" >&5 $as_echo "$DYPGEN ($DYPGEN_VERSION) is ok" >&6; } + else as_fn_error $? "$DYPGEN version $DYPGEN_VERSION found ; version $DYPGEN_NEEDED or greater is needed" "$LINENO" 5 fi fi # Look for DYPGEN_LIB with or without ocamlfind -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking dypgen library" >&5 -$as_echo_n "checking dypgen library... " >&6; } - -if test -n "$DYPGENLIB_PATH" ; then - DYPGEN_PLACE=$DYPGENLIB_PATH - DYPGEN_INCLUDE="-I $DYPGEN_PLACE" - if test -f $DYPGEN_PLACE/dyp.cma ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: dypgen library is $DYPGEN_PLACE/dyp.cma" >&5 -$as_echo "dypgen library is $DYPGEN_PLACE/dyp.cma" >&6; } - else - as_fn_error $? "Could not find dypgen library in $DYPGEN_PLACE" "$LINENO" 5 - fi -else - if test "$OCAMLFIND" != no ; then - if $OCAMLFIND query dypgen > /dev/null 2>&1 ; then - DYPGEN_INCLUDE_DIR=`$OCAMLFIND query dypgen` - DYPGEN_PLACE=$DYPGEN_INCLUDE_DIR - DYPGEN_INCLUDE="-I $DYPGEN_INCLUDE_DIR" - else - if $OCAMLFIND query dyp > /dev/null 2>&1 ; then - DYPGEN_INCLUDE_DIR=`$OCAMLFIND query dyp` - DYPGEN_PLACE=$DYPGEN_INCLUDE_DIR - DYPGEN_INCLUDE="-I $DYPGEN_INCLUDE_DIR" - else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: dypgen library was not installed by ocamlfind" >&5 -$as_echo "dypgen library was not installed by ocamlfind" >&6; } - fi - fi + +MACRO="A" + MACRO=$MACRO"C_LIB_CHECKING" + + + NAME=dypgen + STD_FOLDER=dyp + LIB_FILE=dyp + OFIND_NAME=dyp + OPAM_PACKAGE=dypgen + MOD=Dyp + OPTIONS= + NO_OPTIONAL=true + LIB_PATH=$DYPGENLIB_PATH + + # test au cas ou un argument obligatoire est manquant + if test "$NAME" = "" || test "$STD_FOLDER" = "" || test "$OFIND_NAME" = "" || test "$LIB_FILE" = "" || test "$MOD" = "" ; then + echo "" + echo "Can't check a library" + echo "Missing argument in $MACRO($NAME,$STD_FOLDER,$OFIND_NAME,$LIB_FILE,$MOD,$OPTIONS,$NO_OPTIONAL)" + echo "" + exit 1 + fi + + # affichage du nom de la librairie a checker (avec details sur l'optionalité) + if test "$NO_OPTIONAL" = true; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for requested library : $NAME" >&5 +$as_echo_n "checking for requested library : $NAME... " >&6; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for optional library : $NAME" >&5 +$as_echo_n "checking for optional library : $NAME... " >&6; } + fi + + # si le fichier ml de test existe + if test -f c_check_$STD_FOLDER.ml ; then + # si on peut le supprimer + if test -w c_check_$STD_FOLDER.ml ; then + # on le supprimer + rm c_check_$STD_FOLDER.ml >& /dev/null + # sinon on arrete et on balance un message d'erreur (ie on a pas les droits sur le fichier else - OCAML_LIB=`$OCAMLC -where` - # Old versions of dypgen where put in a dypgen directory - if test -d $OCAML_LIB/dypgen ; then - DYPGEN_PLACE=$OCAML_LIB/dypgen - DYPGEN_INCLUDE="-I +dypgen" - else - # New versions of dypgen where put in a dyp directory - if test -d $OCAML_LIB/dyp ; then - DYPGEN_PLACE=$OCAML_LIB/dyp - DYPGEN_INCLUDE="-I +dyp" - else - as_fn_error $? "Could not find a suitable place for dypgen library in $OCAML_LIB" "$LINENO" 5 - fi + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "Cannot remove c_check_dyp.ml. Please change its right with chmod 666 c_check_dyp.ml +See \`config.log' for more details" "$LINENO" 5; } + fi + fi + + # on prepare le fichier ml de test + echo "open $MOD;;" > c_check_$STD_FOLDER.ml + + # définition de la variable disant si on a trouvé la librairie ou pas + FOUND_LIB="no" + + + if test -n "$LIB_PATH" ; then + LIB_INCLUDE="-I $LIB_PATH" + # on teste maintenant si on peut exectuer le fichier ml de test + if ($OCAMLC -c $OPTIONS $LIB_INCLUDE $LIB_FILE.cma c_check_$STD_FOLDER.ml >& /dev/null) ; then + # on y arrive, on dit qu'on a trouvé la lib avec la variable d'environnement + FOUND_LIB=yes + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found with the environment variable => $LIB_INCLUDE" >&5 +$as_echo "Found with the environment variable => $LIB_INCLUDE" >&6; } + fi + fi + + if test "$FOUND_LIB" = "no" ; then + # si on arrive à l'executer avec la librairie dans le rep de lib de caml + if ($OCAMLC -c $OPTIONS c_check_$STD_FOLDER.ml >& /dev/null) ; then + # pas besoin d'include + LIB_INCLUDE="" + LIB_DIR=`$OCAMLC -where` + FOUND_LIB=yes + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found in ocaml lib directory" >&5 +$as_echo "Found in ocaml lib directory" >&6; } + fi + fi + + # sinon on essaie avec un repertoire dedié à la lib (-I +xxx yyy.cma) + if test "$FOUND_LIB" = "no" ; then + if ($OCAMLC -c $OPTIONS -I +$STD_FOLDER $LIB_FILE.cma c_check_$STD_FOLDER.ml >& /dev/null) ; then + # si ca marche, on s'arrete et on precise le include + LIB_INCLUDE="-I +$STD_FOLDER" + LIB_DIR=`$OCAMLC -where` + LIB_DIR="$LIB_DIR/$STD_FOLDER" + FOUND_LIB=yes + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found in $STD_FOLDER directory => $LIB_INCLUDE" >&5 +$as_echo "Found in $STD_FOLDER directory => $LIB_INCLUDE" >&6; } + fi + fi + + # sinon, on essaie avec ocamlfind + if test "$FOUND_LIB" = "no" ; then + # si on n'a pas ocamlfind , on s'arrete (dans le cas d'une lib oblig.) ou + # on lance un warning (dans le cas d'une lib optionelle) + if test "$OCAMLFIND" != "no" ; then + echo testing with $OCAMLFIND + # on regarde déjà si la lib est installée avec ocamlfind + if $OCAMLFIND query $OFIND_NAME > /dev/null 2>&1 ; then + # si c'est le cas, on recupere le repertoire d'installation et le include correspondant + LIB_INCLUDE=`$OCAMLFIND query $OFIND_NAME` + LIB_INCLUDE="-I $LIB_INCLUDE" + + # on teste maintenant si on peut exectuer le fichier ml de test + if ($OCAMLC -c $OPTIONS $LIB_INCLUDE $LIB_FILE.cma c_check_$STD_FOLDER.ml >& /dev/null) ; then + # on y arrive, on dit qu'on a trouvé la lib avec ocamlfind + FOUND_LIB=yes + LIB_DIR=`$OCAMLFIND query $OFIND_NAME` + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found with $OCAMLFIND => $LIB_INCLUDE" >&5 +$as_echo "Found with $OCAMLFIND => $LIB_INCLUDE" >&6; } + fi + fi + fi + fi + + if test "$FOUND_LIB" = "no" ; then + # si opam est installé, on essaye dans la lib de opam + if test "$OPAM$" != "no" ; then + if test "$OPAM config var $OPAM_PACKAGE:installed" = "true" ; then + OPAM_OCAML_VERSION=`opam config var ocaml-version` + OCAML_VERSION=`$OCAMLC -version` + if test "$OPAM_OCAML_VERSION" = "$OCAML_VERSION" ; then + LIB_INCLUDE=`$OPAM config var lib` + LIB_INCLUDE="-I $LIB_INCLUDE/$STD_FOLDER" + + # on teste maintenant si on peut exectuer le fichier ml de test + if ($OCAMLC -c $OPTIONS $LIB_INCLUDE $LIB_FILE.cma c_check_$STD_FOLDER.ml >& /dev/null) ; then + # on y arrive, on dit qu'on a trouvé la lib avec opam + FOUND_LIB=yes + LIB_DIR=`$OPAM config var lib` + LIB_DIR="$LIB_DIR/$STD_FOLDER" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found with $OPAM => $LIB_INCLUDE" >&5 +$as_echo "Found with $OPAM => $LIB_INCLUDE" >&6; } + fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: There is an opam installation of the library" >&5 +$as_echo "There is an opam installation of the library" >&6; } + fi fi fi + fi + + + + if test "$FOUND_LIB" = "no" ; then + # suivant l'optionalité de la lib: un warning ou une erreur + if test "$NO_OPTIONAL" = "true"; then + as_fn_error $? "The $NAME library is missing." "$LINENO" 5 + LIB_INCLUDE="no" + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: The $NAME library is missing." >&5 +$as_echo "The $NAME library is missing." >&6; } + LIB_INCLUDE="no" + fi + fi + + + # suppression du fichier ml de test + rm c_check_$STD_FOLDER.ml >& /dev/null + rm c_check_$STD_FOLDER.cmo >& /dev/null + rm c_check_$STD_FOLDER.cmi >& /dev/null + + +if test "$FOUND_LIB" != "no" ; then + DYPGEN_INCLUDE=$LIB_INCLUDE + fi -if test -f $DYPGEN_PLACE/dyp.cma ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: dypgen library is $DYPGEN_PLACE/dyp.cma" >&5 -$as_echo "dypgen library is $DYPGEN_PLACE/dyp.cma" >&6; } + +# Check whether --enable-kaputt was given. +if test "${enable_kaputt+set}" = set; then : + enableval=$enable_kaputt; with_kaputt=$enableval else - as_fn_error $? "Could not find dypgen library \"dyp.cma\" in $DYPGEN_PLACE" "$LINENO" 5 + with_kaputt=no fi -# Look for KAPUTT_LIB with ocamlfind -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking (optional) kaputt library" >&5 -$as_echo_n "checking (optional) kaputt library... " >&6; } -if test "$OCAMLFIND" != no ; then - if $OCAMLFIND query kaputt > /dev/null 2>&1 ; then - KAPUTT_INCLUDE_DIR=`$OCAMLFIND query kaputt` - KAPUTT_PLACE=$KAPUTT_INCLUDE_DIR - KAPUTT_INCLUDE="-I $KAPUTT_INCLUDE_DIR" - else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: kaputt library was not installed by ocamlfind" >&5 -$as_echo "kaputt library was not installed by ocamlfind" >&6; } +if test "$with_kaputt" != no ; then + # Look for KAPUTT_LIB + MACRO="A" + MACRO=$MACRO"C_LIB_CHECKING" + + + NAME=kaputt + STD_FOLDER=kaputt + LIB_FILE=kaputt + OFIND_NAME=kaputt + OPAM_PACKAGE=kaputt + MOD=Kaputt + OPTIONS= + NO_OPTIONAL=false + LIB_PATH= + + # test au cas ou un argument obligatoire est manquant + if test "$NAME" = "" || test "$STD_FOLDER" = "" || test "$OFIND_NAME" = "" || test "$LIB_FILE" = "" || test "$MOD" = "" ; then + echo "" + echo "Can't check a library" + echo "Missing argument in $MACRO($NAME,$STD_FOLDER,$OFIND_NAME,$LIB_FILE,$MOD,$OPTIONS,$NO_OPTIONAL)" + echo "" + exit 1 + fi + + # affichage du nom de la librairie a checker (avec details sur l'optionalité) + if test "$NO_OPTIONAL" = true; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for requested library : $NAME" >&5 +$as_echo_n "checking for requested library : $NAME... " >&6; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for optional library : $NAME" >&5 +$as_echo_n "checking for optional library : $NAME... " >&6; } + fi + + # si le fichier ml de test existe + if test -f c_check_$STD_FOLDER.ml ; then + # si on peut le supprimer + if test -w c_check_$STD_FOLDER.ml ; then + # on le supprimer + rm c_check_$STD_FOLDER.ml >& /dev/null + # sinon on arrete et on balance un message d'erreur (ie on a pas les droits sur le fichier + else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "Cannot remove c_check_kaputt.ml. Please change its right with chmod 666 c_check_kaputt.ml +See \`config.log' for more details" "$LINENO" 5; } + fi + fi + + # on prepare le fichier ml de test + echo "open $MOD;;" > c_check_$STD_FOLDER.ml + + # définition de la variable disant si on a trouvé la librairie ou pas + FOUND_LIB="no" + + + if test -n "$LIB_PATH" ; then + LIB_INCLUDE="-I $LIB_PATH" + # on teste maintenant si on peut exectuer le fichier ml de test + if ($OCAMLC -c $OPTIONS $LIB_INCLUDE $LIB_FILE.cma c_check_$STD_FOLDER.ml >& /dev/null) ; then + # on y arrive, on dit qu'on a trouvé la lib avec la variable d'environnement + FOUND_LIB=yes + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found with the environment variable => $LIB_INCLUDE" >&5 +$as_echo "Found with the environment variable => $LIB_INCLUDE" >&6; } + fi + fi + + if test "$FOUND_LIB" = "no" ; then + # si on arrive à l'executer avec la librairie dans le rep de lib de caml + if ($OCAMLC -c $OPTIONS c_check_$STD_FOLDER.ml >& /dev/null) ; then + # pas besoin d'include + LIB_INCLUDE="" + LIB_DIR=`$OCAMLC -where` + FOUND_LIB=yes + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found in ocaml lib directory" >&5 +$as_echo "Found in ocaml lib directory" >&6; } + fi + fi + + # sinon on essaie avec un repertoire dedié à la lib (-I +xxx yyy.cma) + if test "$FOUND_LIB" = "no" ; then + if ($OCAMLC -c $OPTIONS -I +$STD_FOLDER $LIB_FILE.cma c_check_$STD_FOLDER.ml >& /dev/null) ; then + # si ca marche, on s'arrete et on precise le include + LIB_INCLUDE="-I +$STD_FOLDER" + LIB_DIR=`$OCAMLC -where` + LIB_DIR="$LIB_DIR/$STD_FOLDER" + FOUND_LIB=yes + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found in $STD_FOLDER directory => $LIB_INCLUDE" >&5 +$as_echo "Found in $STD_FOLDER directory => $LIB_INCLUDE" >&6; } + fi + fi + + # sinon, on essaie avec ocamlfind + if test "$FOUND_LIB" = "no" ; then + # si on n'a pas ocamlfind , on s'arrete (dans le cas d'une lib oblig.) ou + # on lance un warning (dans le cas d'une lib optionelle) + if test "$OCAMLFIND" != "no" ; then + echo testing with $OCAMLFIND + # on regarde déjà si la lib est installée avec ocamlfind + if $OCAMLFIND query $OFIND_NAME > /dev/null 2>&1 ; then + # si c'est le cas, on recupere le repertoire d'installation et le include correspondant + LIB_INCLUDE=`$OCAMLFIND query $OFIND_NAME` + LIB_INCLUDE="-I $LIB_INCLUDE" + + # on teste maintenant si on peut exectuer le fichier ml de test + if ($OCAMLC -c $OPTIONS $LIB_INCLUDE $LIB_FILE.cma c_check_$STD_FOLDER.ml >& /dev/null) ; then + # on y arrive, on dit qu'on a trouvé la lib avec ocamlfind + FOUND_LIB=yes + LIB_DIR=`$OCAMLFIND query $OFIND_NAME` + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found with $OCAMLFIND => $LIB_INCLUDE" >&5 +$as_echo "Found with $OCAMLFIND => $LIB_INCLUDE" >&6; } + fi + fi + fi + fi + + if test "$FOUND_LIB" = "no" ; then + # si opam est installé, on essaye dans la lib de opam + if test "$OPAM$" != "no" ; then + if test "$OPAM config var $OPAM_PACKAGE:installed" = "true" ; then + OPAM_OCAML_VERSION=`opam config var ocaml-version` + OCAML_VERSION=`$OCAMLC -version` + if test "$OPAM_OCAML_VERSION" = "$OCAML_VERSION" ; then + LIB_INCLUDE=`$OPAM config var lib` + LIB_INCLUDE="-I $LIB_INCLUDE/$STD_FOLDER" + + # on teste maintenant si on peut exectuer le fichier ml de test + if ($OCAMLC -c $OPTIONS $LIB_INCLUDE $LIB_FILE.cma c_check_$STD_FOLDER.ml >& /dev/null) ; then + # on y arrive, on dit qu'on a trouvé la lib avec opam + FOUND_LIB=yes + LIB_DIR=`$OPAM config var lib` + LIB_DIR="$LIB_DIR/$STD_FOLDER" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found with $OPAM => $LIB_INCLUDE" >&5 +$as_echo "Found with $OPAM => $LIB_INCLUDE" >&6; } + fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: There is an opam installation of the library" >&5 +$as_echo "There is an opam installation of the library" >&6; } + fi + fi + fi + fi + + + + if test "$FOUND_LIB" = "no" ; then + # suivant l'optionalité de la lib: un warning ou une erreur + if test "$NO_OPTIONAL" = "true"; then + as_fn_error $? "The $NAME library is missing." "$LINENO" 5 + LIB_INCLUDE="no" + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: The $NAME library is missing." >&5 +$as_echo "The $NAME library is missing." >&6; } + LIB_INCLUDE="no" + fi + fi + + + # suppression du fichier ml de test + rm c_check_$STD_FOLDER.ml >& /dev/null + rm c_check_$STD_FOLDER.cmo >& /dev/null + rm c_check_$STD_FOLDER.cmi >& /dev/null + + if test "$FOUND_LIB" != "no" ; then + if test -f $LIB_DIR/kaputt_pp.byte ; then + KAPUTT_PP="$LIB_DIR/kaputt_pp.byte" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: kaputt_pp.byte preprocessor is $KAPUTT_PP" >&5 +$as_echo "kaputt_pp.byte preprocessor is $KAPUTT_PP" >&6; } + KAPUTT_INCLUDE=$LIB_INCLUDE + + KAPUTT_LIB=$LIB_FILE.cma + + + else + as_fn_error $? "Could not find kaputt_pp.byte preprocessor in $LIB_DIR." "$LINENO" 5 + fi fi -else - OCAML_LIB=`$OCAMLC -where` - if test -d $OCAML_LIB/kaputt ; then - KAPUTT_PLACE=$OCAML_LIB/kaputt - KAPUTT_INCLUDE="-I +kaputt" +fi + +# Look for BOLT_LIB with ocamlfind + +MACRO="A" + MACRO=$MACRO"C_LIB_CHECKING" + + + NAME=bolt + STD_FOLDER=bolt + LIB_FILE=bolt + OFIND_NAME=bolt + OPAM_PACKAGE=bolt + MOD=Bolt + OPTIONS="unix.cma dynlink.cma" + NO_OPTIONAL=true + LIB_PATH=$BOLTLIB_PATH + + # test au cas ou un argument obligatoire est manquant + if test "$NAME" = "" || test "$STD_FOLDER" = "" || test "$OFIND_NAME" = "" || test "$LIB_FILE" = "" || test "$MOD" = "" ; then + echo "" + echo "Can't check a library" + echo "Missing argument in $MACRO($NAME,$STD_FOLDER,$OFIND_NAME,$LIB_FILE,$MOD,$OPTIONS,$NO_OPTIONAL)" + echo "" + exit 1 + fi + + # affichage du nom de la librairie a checker (avec details sur l'optionalité) + if test "$NO_OPTIONAL" = true; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for requested library : $NAME" >&5 +$as_echo_n "checking for requested library : $NAME... " >&6; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for optional library : $NAME" >&5 +$as_echo_n "checking for optional library : $NAME... " >&6; } + fi + + # si le fichier ml de test existe + if test -f c_check_$STD_FOLDER.ml ; then + # si on peut le supprimer + if test -w c_check_$STD_FOLDER.ml ; then + # on le supprimer + rm c_check_$STD_FOLDER.ml >& /dev/null + # sinon on arrete et on balance un message d'erreur (ie on a pas les droits sur le fichier + else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "Cannot remove c_check_bolt.ml. Please change its right with chmod 666 c_check_bolt.ml +See \`config.log' for more details" "$LINENO" 5; } + fi + fi + + # on prepare le fichier ml de test + echo "open $MOD;;" > c_check_$STD_FOLDER.ml + + # définition de la variable disant si on a trouvé la librairie ou pas + FOUND_LIB="no" + + + if test -n "$LIB_PATH" ; then + LIB_INCLUDE="-I $LIB_PATH" + # on teste maintenant si on peut exectuer le fichier ml de test + if ($OCAMLC -c $OPTIONS $LIB_INCLUDE $LIB_FILE.cma c_check_$STD_FOLDER.ml >& /dev/null) ; then + # on y arrive, on dit qu'on a trouvé la lib avec la variable d'environnement + FOUND_LIB=yes + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found with the environment variable => $LIB_INCLUDE" >&5 +$as_echo "Found with the environment variable => $LIB_INCLUDE" >&6; } + fi + fi + + if test "$FOUND_LIB" = "no" ; then + # si on arrive à l'executer avec la librairie dans le rep de lib de caml + if ($OCAMLC -c $OPTIONS c_check_$STD_FOLDER.ml >& /dev/null) ; then + # pas besoin d'include + LIB_INCLUDE="" + LIB_DIR=`$OCAMLC -where` + FOUND_LIB=yes + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found in ocaml lib directory" >&5 +$as_echo "Found in ocaml lib directory" >&6; } + fi + fi + + # sinon on essaie avec un repertoire dedié à la lib (-I +xxx yyy.cma) + if test "$FOUND_LIB" = "no" ; then + if ($OCAMLC -c $OPTIONS -I +$STD_FOLDER $LIB_FILE.cma c_check_$STD_FOLDER.ml >& /dev/null) ; then + # si ca marche, on s'arrete et on precise le include + LIB_INCLUDE="-I +$STD_FOLDER" + LIB_DIR=`$OCAMLC -where` + LIB_DIR="$LIB_DIR/$STD_FOLDER" + FOUND_LIB=yes + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found in $STD_FOLDER directory => $LIB_INCLUDE" >&5 +$as_echo "Found in $STD_FOLDER directory => $LIB_INCLUDE" >&6; } + fi + fi + + # sinon, on essaie avec ocamlfind + if test "$FOUND_LIB" = "no" ; then + # si on n'a pas ocamlfind , on s'arrete (dans le cas d'une lib oblig.) ou + # on lance un warning (dans le cas d'une lib optionelle) + if test "$OCAMLFIND" != "no" ; then + echo testing with $OCAMLFIND + # on regarde déjà si la lib est installée avec ocamlfind + if $OCAMLFIND query $OFIND_NAME > /dev/null 2>&1 ; then + # si c'est le cas, on recupere le repertoire d'installation et le include correspondant + LIB_INCLUDE=`$OCAMLFIND query $OFIND_NAME` + LIB_INCLUDE="-I $LIB_INCLUDE" + + # on teste maintenant si on peut exectuer le fichier ml de test + if ($OCAMLC -c $OPTIONS $LIB_INCLUDE $LIB_FILE.cma c_check_$STD_FOLDER.ml >& /dev/null) ; then + # on y arrive, on dit qu'on a trouvé la lib avec ocamlfind + FOUND_LIB=yes + LIB_DIR=`$OCAMLFIND query $OFIND_NAME` + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found with $OCAMLFIND => $LIB_INCLUDE" >&5 +$as_echo "Found with $OCAMLFIND => $LIB_INCLUDE" >&6; } + fi + fi + fi + fi + + if test "$FOUND_LIB" = "no" ; then + # si opam est installé, on essaye dans la lib de opam + if test "$OPAM$" != "no" ; then + if test "$OPAM config var $OPAM_PACKAGE:installed" = "true" ; then + OPAM_OCAML_VERSION=`opam config var ocaml-version` + OCAML_VERSION=`$OCAMLC -version` + if test "$OPAM_OCAML_VERSION" = "$OCAML_VERSION" ; then + LIB_INCLUDE=`$OPAM config var lib` + LIB_INCLUDE="-I $LIB_INCLUDE/$STD_FOLDER" + + # on teste maintenant si on peut exectuer le fichier ml de test + if ($OCAMLC -c $OPTIONS $LIB_INCLUDE $LIB_FILE.cma c_check_$STD_FOLDER.ml >& /dev/null) ; then + # on y arrive, on dit qu'on a trouvé la lib avec opam + FOUND_LIB=yes + LIB_DIR=`$OPAM config var lib` + LIB_DIR="$LIB_DIR/$STD_FOLDER" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found with $OPAM => $LIB_INCLUDE" >&5 +$as_echo "Found with $OPAM => $LIB_INCLUDE" >&6; } + fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: There is an opam installation of the library" >&5 +$as_echo "There is an opam installation of the library" >&6; } + fi + fi + fi + fi + + + + if test "$FOUND_LIB" = "no" ; then + # suivant l'optionalité de la lib: un warning ou une erreur + if test "$NO_OPTIONAL" = "true"; then + as_fn_error $? "The $NAME library is missing." "$LINENO" 5 + LIB_INCLUDE="no" + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: The $NAME library is missing." >&5 +$as_echo "The $NAME library is missing." >&6; } + LIB_INCLUDE="no" + fi + fi + + + # suppression du fichier ml de test + rm c_check_$STD_FOLDER.ml >& /dev/null + rm c_check_$STD_FOLDER.cmo >& /dev/null + rm c_check_$STD_FOLDER.cmi >& /dev/null + +if test "$FOUND_LIB" != "no" ; then + if test -f $LIB_DIR/bolt_pp.cmo ; then + BOLT_PP="$LIB_DIR/bolt_pp.cmo -level \$(BOLT_LEVEL)" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: bolt_pp.byte preprocessor is $BOLT_PP" >&5 +$as_echo "bolt_pp.byte preprocessor is $BOLT_PP" >&6; } + BOLT_INCLUDE=$LIB_INCLUDE + + BOLT_LIB=$LIB_FILE.cma + + else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: Could not find a suitable place for kaputt library in $OCAML_LIB. No link to the kaputt library will be allowed in compilation" >&5 -$as_echo "Could not find a suitable place for kaputt library in $OCAML_LIB. No link to the kaputt library will be allowed in compilation" >&6; } + as_fn_error $? "Could not find bolt_pp.byte preprocessor in $LIB_DIR." "$LINENO" 5 fi fi -if test -f $KAPUTT_PLACE/kaputt.cma ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: kaputt library is $KAPUTT_PLACE/kaputt.cma" >&5 -$as_echo "kaputt library is $KAPUTT_PLACE/kaputt.cma" >&6; } + +# Check whether --enable-log was given. +if test "${enable_log+set}" = set; then : + enableval=$enable_log; with_log=$enableval else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: Could not find kaputt library \"kaputt.cma\" in $KAPUTT_PLACE. No link to the kaputt library will be allowed in compilation" >&5 -$as_echo "Could not find kaputt library \"kaputt.cma\" in $KAPUTT_PLACE. No link to the kaputt library will be allowed in compilation" >&6; } + with_log=no fi +if test "$with_log" = "no" ; then + BOLT_LEVEL=NONE + +else + BOLT_LEVEL=TRACE + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: Bolt log level is $BOLT_LEVEL." >&5 +$as_echo "Bolt log level is $BOLT_LEVEL." >&6; } # What is the OCAML version ? @@ -2327,7 +2942,6 @@ $as_echo "$OCAMLP4 calls will be done with the $CAMLP4_LIB library" >&6; } -#AC_SUBST(OCAMLYACC) @@ -2338,7 +2952,8 @@ $as_echo "$OCAMLP4 calls will be done with the $CAMLP4_LIB library" >&6; } -ac_config_files="$ac_config_files ./Makefile config/Makefile src/Makefile.master src/Makefile.common src/Makefile src/utils/Makefile src/logic/Makefile src/grammars/Makefile src/acg-data/Makefile src/scripting/Makefile src/datalog/Makefile src/reduction/Makefile" + +ac_config_files="$ac_config_files ./Makefile config/Makefile src/Makefile.master src/Makefile.common src/Makefile src/utils/Makefile src/logic/Makefile src/grammars/Makefile src/acg-data/Makefile src/scripting/Makefile src/datalog/Makefile src/reduction/Makefile src/s_datalog/Makefile" { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5 @@ -2816,16 +3431,16 @@ if (echo >conf$$.file) 2>/dev/null; then # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -p'. + # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -p' + as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else - as_ln_s='cp -p' + as_ln_s='cp -pR' fi else - as_ln_s='cp -p' + as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null @@ -2885,28 +3500,16 @@ else as_mkdir_p=false fi -if test -x / >/dev/null 2>&1; then - as_test_x='test -x' -else - if ls -dL / >/dev/null 2>&1; then - as_ls_L_option=L - else - as_ls_L_option= - fi - as_test_x=' - eval sh -c '\'' - if test -d "$1"; then - test -d "$1/."; - else - case $1 in #( - -*)set "./$1";; - esac; - case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( - ???[sx]*):;;*)false;;esac;fi - '\'' sh - ' -fi -as_executable_p=$as_test_x + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +as_test_x='test -x' +as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" @@ -2928,7 +3531,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # values after options handling. ac_log=" This file was extended by ACG DTK $as_me 0.1, which was -generated by GNU Autoconf 2.68. Invocation command line was +generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS @@ -2981,10 +3584,10 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ ACG DTK config.status 0.1 -configured by $0, generated by GNU Autoconf 2.68, +configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" -Copyright (C) 2010 Free Software Foundation, Inc. +Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." @@ -3061,7 +3664,7 @@ fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then - set X '$SHELL' '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion + set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' @@ -3102,6 +3705,7 @@ do "src/scripting/Makefile") CONFIG_FILES="$CONFIG_FILES src/scripting/Makefile" ;; "src/datalog/Makefile") CONFIG_FILES="$CONFIG_FILES src/datalog/Makefile" ;; "src/reduction/Makefile") CONFIG_FILES="$CONFIG_FILES src/reduction/Makefile" ;; + "src/s_datalog/Makefile") CONFIG_FILES="$CONFIG_FILES src/s_datalog/Makefile" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac diff --git a/emacs/acg.el b/emacs/acg.el index 73f2f4c814977b73a8b438498ed2f36e2b16b635..35f6b48a5304343b2964060b1a9834ed11016f43 100644 --- a/emacs/acg.el +++ b/emacs/acg.el @@ -31,7 +31,8 @@ "end" "type" "signature" - "lexicon") + "lexicon" + "<<") '( ; FIXME while this regexp correctly capture multi-line comments, ; they they're not highlighted in the emace buffer. Only single @@ -48,6 +49,14 @@ ("\\(lexicon\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\((\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\()\\)[ \n\t]*\\(:\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\(=\\)" 6 'font-lock-keyword-face) ("\\(lexicon\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\((\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\()\\)[ \n\t]*\\(:\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\(=\\)" 7 'font-lock-constant-face) ("\\(lexicon\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\((\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\()\\)[ \n\t]*\\(:\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\(=\\)" 8 'font-lock-keyword-face) + ("\\(lexicon\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\(=\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\(<<\\)" 1 'font-lock-keyword-face) + ("\\(lexicon\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\(=\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\(<<\\)" 2 'font-lock-constant-face) + ("\\(lexicon\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\(=\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\(<<\\)" 3 'font-lock-keyword-face) + ("\\(lexicon\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\(=\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\(<<\\)" 4 'font-lock-constant-face) + ("\\(lexicon\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\(=\\)[ \n\t]*\\([a-zA-Z0-9_']*\\)[ \n\t]*\\(<<\\)" 5 'font-lock-keyword-face) + ("\\([a-zA-Z0-9_']*\\)[ \t\n]*\\(<<\\)[ \t\n]*\\([a-zA-Z0-9_']*\\)" 1 'font-lock-constant-face) + ("\\([a-zA-Z0-9_']*\\)[ \t\n]*\\(<<\\)[ \t\n]*\\([a-zA-Z0-9_']*\\)" 2 'font-lock-keyword-face) + ("\\([a-zA-Z0-9_']*\\)[ \t\n]*\\(<<\\)[ \t\n]*\\([a-zA-Z0-9_']*\\)" 3 'font-lock-constant-face) ) '(".*\\.acg") nil diff --git a/examples/tag.acg b/examples/tag.acg index 56edfc0a56ce87dfa77d1735d8f1cc1065b8b061..b0fa92e49eb489b08e7ea32bb074d2cd22833a76 100644 --- a/examples/tag.acg +++ b/examples/tag.acg @@ -84,19 +84,32 @@ signature derived_trees = end (* Then a signature for the strings *) -signature strings = - - string: type; +signature complex_strings = + o:type; + string=o->o: type; (* we can define infix and prefix symbols. Note that as for now, the length of symbols can only be 1 *) + infix +=lambda a b.lambda z.a(b z) : string -> string -> string; + + every,dog,chases,a,cat,sleeps,slowly,new,big,black,seems,john,mary,bill,paul, + claims,loves,to,love,who,said,liked,does,think:string; +end + +signature strings = + string: type; + + (* we can define infix and prefix symbols. *) + (* Note that as for now, the length of symbols can only be 1 *) + infix + : string -> string -> string; every,dog,chases,a,cat,sleeps,slowly,new,big,black,seems,john,mary,bill,paul, claims,loves,to,love,who,said,liked,does,think:string; end + (* Ok. Now is our first lexicon. It translates derived trees into strings *) lexicon tag_strings(derived_trees) : strings = @@ -236,3 +249,4 @@ lexicon tag_syntax (derivation_trees) : derived_trees = I_n,I_vp,I_s := lambda x.x; end +lexicon tag_yields = tag_strings << tag_syntax \ No newline at end of file diff --git a/src/Makefile.common.in b/src/Makefile.common.in index 474596c6cb38f15bf6e5c8c9b92ed25de7fe4c6b..88139dca857d9fb1c733bf8d406d252227bfaefb 100644 --- a/src/Makefile.common.in +++ b/src/Makefile.common.in @@ -40,7 +40,7 @@ CMX = $(ML:.ml=.cmx) .PHONY : all byte opt clean $(PRELIMINARY) superclean -.PRECIOUS : $(DYP:%.dyp=%.ml %.mli) $(CAMLLEX:%.mll=%.ml) +.PRECIOUS : $(DYP:%.dyp=%.ml %.mli) $(CAMLLEX:%.mll=%.ml) $(CAMLYACC:%.mly=%.ml) PP = $(OCAMLPP) @@ -48,6 +48,7 @@ EXE = $(EXE_SOURCES:%.ml=%) EXEOPT = $(EXE_SOURCES:%.ml=%.opt) CAMLLEX_ML=$(CAMLLEX:%.mll=%.ml) +CAMLYACC_ML=$(CAMLYACC:%.mly=%.ml) DYP_ML=$(DYP:%.dyp=%.ml) DYP_MLI=$(DYP:%.dyp=%.mli) @@ -105,6 +106,9 @@ DYPGEN_EXE = @DYPGEN@ --no-pp --no-obj-type --ocamlc "$(LIBDIR) $(I_PREVIOUS_DIR %.ml : %.mll @OCAMLLEX@ $< +%.ml : %.mly + @OCAMLYACC@ $< + # Dependancy graphs and types ################## @@ -131,7 +135,7 @@ ifdef EXE @rm -f $(EXE) $(EXEOPT) endif # echo $(CAMLLEX_ML) $(DYP_ML) $(DYP_MLI) - @rm -f *.cm[ioax]* *.o *.a *~ *.annot depend .targets $(CAMLLEX_ML) $(DYP_ML) $(DYP_MLI) $(DYP:%.dyp=%.extract_type) $(DYP:%.dyp=%.ml.temp) + @rm -f *.cm[ioax]* *.o *.a *~ *.annot depend .targets $(CAMLLEX_ML) $(CAMLYACC_ML) $(DYP_ML) $(DYP_MLI) $(DYP:%.dyp=%.extract_type) $(DYP:%.dyp=%.ml.temp) @rm -f *.dot *.ps *.log @rm -rf doc @find . -name "*#[0-9]*" -exec printf "\n\nWARNING: I did not erase the file %s. It probably is a file automatically generated by so6 because of a conflict. Please check if the conflict was resolved, and manually erase it\n\n" {} \; diff --git a/src/Makefile.in b/src/Makefile.in index ed71c973dac9bd2481191e7bd25e047a8cb90e51..52362c9a659f1475b0b66a343c19e9d71f6ccd62 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -17,15 +17,27 @@ # # ########################################################################## -.PHONY: byte opt clean superclean +.PHONY: byte opt clean superclean test #SUBDIRS= utils logic grammars acg-data scripting lambda datalog -SUBDIRS= utils logic grammars acg-data scripting datalog reduction +#SUBDIRS= utils logic grammars acg-data scripting datalog reduction s_datalog +SUBDIRS= utils logic s_datalog grammars acg-data scripting datalog -byte: - $(foreach dir,$(SUBDIRS),$(MAKE) -r -S -C $(dir) byte;) +ACG_DIR=scripting +ACGC_DIR=acg-data + +acg acg.opt: + $(MAKE) -r -S -C $(ACG_DIR) $@ + +acgc acgc.opt: + $(MAKE) -r -S -C $(ACGC_DIR) $@ -opt: +byte: acg acgc + +opt: acg.opt acgc.opt + +test: + $(foreach dir,$(SUBDIRS),$(MAKE) -r -S -C $(dir) byte;) $(foreach dir,$(SUBDIRS),$(MAKE) -r -S -C $(dir) opt;) diff --git a/src/Makefile.master.in b/src/Makefile.master.in index bf00746034ea34bea2494e7d6c84195add076403..70998009dbf0f57226c90d7b0b478c7c11958c4f 100644 --- a/src/Makefile.master.in +++ b/src/Makefile.master.in @@ -32,10 +32,21 @@ TITLE="The ACG Development Toolkit Documentation" OCAMLDOC_FLAGS = -sort -keep-code -html -t $(TITLE) #CAMLDOC_FLAGS = -html -t $(TITLE) -LIBS = @CAMLP4_LIB@ -LIBDIR = -I +camlp4 +BOLT_DEPENDENCIES=unix.cma dynlink.cma +BOLT_LEVEL=@BOLT_LEVEL@ -OCAMLPP = -pp "@OCAMLP4@ pa_extend.cmo pa_macro.cmo $(DEBUGFLAGS) @OCAMLP4_LOC@" +LIBS = @CAMLP4_LIB@ $(BOLT_DEPENDENCIES) @BOLT_LIB@ +LIBDIR = -I +camlp4 @BOLT_INCLUDE@ + +MACRO_PP_ARGS=-DDEBUG + +OCAMLPP_ARG= pa_extend.cmo pa_macro.cmo $(MACRO_PP_ARGS) @OCAMLP4_LOC@ @BOLT_PP@ +OCAMLPP = -pp "@OCAMLP4@ $(OCAMLPP_ARG)" +ifeq ($(strip @KAPUTT_PP@),) +KAPUTT_OCAMLPP = $(OCAMLPP) +else +KAPUTT_OCAMLPP = -pp "@KAPUTT_PP@ off @OCAMLP4@ $(OCAMLPP_ARG)" +endif @SET_MAKE@ diff --git a/src/acg-data/Makefile.in b/src/acg-data/Makefile.in index 4635709ffb509e9b201f31c0a4acf5e9c400a4af..a64582fbd2596dff6d3094c5af985c44dba49696 100644 --- a/src/acg-data/Makefile.in +++ b/src/acg-data/Makefile.in @@ -34,11 +34,11 @@ LIBS += dyp.cma str.cma LIBDIR += @DYPGEN_INCLUDE@ # Directories to which the current source files depend on -PREVIOUS_DIRS = ../utils ../logic ../grammars +PREVIOUS_DIRS = ../utils ../logic ../grammars ../s_datalog # Source files in the right order of dependance -ML = type_system.ml signature.ml acg_lexicon.ml +ML = type_system.ml signature.ml reduction.ml acg_lexicon.ml EXE_SOURCES = acgc.ml diff --git a/src/acg-data/acg_lexicon.ml b/src/acg-data/acg_lexicon.ml index ee10407786e5365332687447b1aea3459cd1bc0f..95a75c4445c69644cff1ff99f8f883b88072d951 100644 --- a/src/acg-data/acg_lexicon.ml +++ b/src/acg-data/acg_lexicon.ml @@ -26,7 +26,6 @@ struct exception Duplicate_type_interpretation exception Duplicate_constant_interpretation -(* exception Not_yet_interpreted_value*) exception Missing_interpretation of string module Dico = Utils.StringMap @@ -34,6 +33,9 @@ struct type signature = Sg.t + type resume = int SharedForest.SharedForest.resumption + + type interpretation = | Type of (Abstract_syntax.location * Lambda.stype ) | Constant of (Abstract_syntax.location * Lambda.term ) @@ -45,17 +47,24 @@ struct let eta_long = Sg.eta_long_form c (fun_type_from_id abstract_type_or_cst_id) sg in Printf.sprintf "\t%s [eta-long form: %s {%s}]" (Sg.term_to_string c sg) (Sg.term_to_string eta_long sg ) (Lambda.raw_to_string eta_long) + module Datalog=Datalog.Datalog + + module RuleToCstMap=Utils.IntMap + type t = {name:string*Abstract_syntax.location; dico:interpretation Dico.t; abstract_sig:Sg.t; - object_sig:Sg.t;} + object_sig:Sg.t; + datalog_prog:(Datalog.Program.program * Lambda.term RuleToCstMap.t) option} let name {name=n}=n let get_sig {abstract_sig=abs;object_sig=obj} = abs,obj - let empty name ~abs ~obj = {name=name;dico=Dico.empty;abstract_sig=abs;object_sig=obj} + let empty name ~abs ~obj = + let prog = if Sg.is_2nd_order abs then Some (Datalog.Program.empty,RuleToCstMap.empty) else None in + {name=name;dico=Dico.empty;abstract_sig=abs;object_sig=obj;datalog_prog=prog} let emit_missing_inter lex lst = let lex_name,loc = name lex in @@ -97,29 +106,169 @@ struct let interpret t ty lex = let t_interpretation = (interpret_term t lex) in -(* let () = Printf.printf "Going_to_normalize:\t%s\n%!" (Lambda.term_to_string t_interpretation (Sg.id_to_string lex.object_sig)) in*) Lambda.normalize ~id_to_term:(fun i -> Sg.unfold_term_definition i lex.object_sig) t_interpretation,interpret_type ty lex + module Reduction=Reduction.Make(Sg) + + let add_rule_for_cst_in_prog name abs_type interpreted_term lex (prog,rule_to_cst) = + let interpreted_type = (interpret_type abs_type lex) in + let eta_long_term = + Sg.eta_long_form + interpreted_term + interpreted_type + lex.object_sig in + LOG "term: %s:%s" (Sg.term_to_string interpreted_term lex.object_sig) (Sg.type_to_string interpreted_type lex.object_sig) LEVEL TRACE; + LOG "eta-long form: %s" (Sg.term_to_string eta_long_term lex.object_sig) LEVEL TRACE; + LOG "eta-long form (as caml term): %s" (Lambda.raw_to_caml eta_long_term) LEVEL TRACE; + LOG "Datalog rule addition: lexicon \"%s\", constant \"%s:%s\" mapped to \"%s:%s\"" (fst lex.name) name (Sg.type_to_string abs_type lex.abstract_sig) (Sg.term_to_string eta_long_term lex.object_sig) (Sg.type_to_string interpreted_type lex.object_sig) LEVEL TRACE; + let obj_princ_type,obj_typing_env = TypeInference.Type.inference eta_long_term in + LOG "Interpreting \"%s\" as \"%s=%s\" with principle type: \"%s\"" name (Sg.term_to_string eta_long_term lex.object_sig) (Lambda.raw_to_caml eta_long_term) (Lambda.raw_type_to_string obj_princ_type) LEVEL DEBUG; + LOG "In the context of:" LEVEL DEBUG ; + (Utils.IntMap.iter + (fun k (t,ty) -> LOG "%d --> %s : %s" k (Lambda.raw_to_string t) (Lambda.raw_type_to_string ty) LEVEL DEBUG) + obj_typing_env); + let rule,new_prog=Reduction.generate_and_add_rule + ~abs_cst:(name,abs_type) + ~obj_princ_type + ~obj_typing_env + prog + ~abs_sig:lex.abstract_sig + ~obj_sig:lex.object_sig in + let cst_id,_ = Sg.find_term name lex.abstract_sig in + new_prog,RuleToCstMap.add rule.Datalog_AbstractSyntax.AbstractSyntax.Rule.id cst_id rule_to_cst + + let insert e ({dico=d} as lex) = match e with | Abstract_syntax.Type (id,loc,ty) -> {lex with dico=Dico.add id (Type (loc,Sg.convert_type ty lex.object_sig)) d} - | Abstract_syntax.Constant (id,loc,t) -> {lex with dico=Dico.add id (Constant (loc,Sg.typecheck t (interpret_type (Sg.type_of_constant id lex.abstract_sig) lex) lex.object_sig)) d} + | Abstract_syntax.Constant (id,loc,t) -> + let abs_type=Sg.expand_type (Sg.type_of_constant id lex.abstract_sig) lex.abstract_sig in + let interpreted_type = (interpret_type abs_type lex) in + let interpreted_term = + Lambda.normalize + ~id_to_term:(fun i -> Sg.unfold_term_definition i lex.object_sig) + (Sg.typecheck t interpreted_type lex.object_sig) in + let prog = match lex.datalog_prog with + | None -> None + | Some p -> + let new_prog= add_rule_for_cst_in_prog id abs_type interpreted_term lex p in + Some new_prog in + {lex with + dico=Dico.add id (Constant (loc,interpreted_term)) d; + datalog_prog =prog} + + let rebuild_prog lex = + match lex.datalog_prog with + | None -> lex + | Some _ -> + let new_prog= + Dico.fold + (fun key inter acc -> + match inter with + | Type (l,stype) -> acc + | Constant (l,t) -> + add_rule_for_cst_in_prog + key + (Sg.expand_type (Sg.type_of_constant key lex.abstract_sig) lex.abstract_sig) + t + lex + acc) + lex.dico + (Datalog.Program.empty,RuleToCstMap.empty) in + {lex with datalog_prog=Some new_prog} + + + let parse term dist_type lex = + match lex.datalog_prog,Sg.expand_type dist_type lex.abstract_sig with + | None,_ -> + let () = Printf.printf "Parsing is not implemented for non 2nd order ACG\n!" in + SharedForest.SharedForest.empty + | Some (prog,_), (Lambda.Atom _ as dist_type) -> + let buff=Buffer.create 80 in + let () = Buffer.add_buffer buff (Datalog_AbstractSyntax.AbstractSyntax.Program.to_buffer (Datalog.Program.to_abstract prog)) in + LOG "Before parsing. Program is currently:" LEVEL DEBUG; + Utils.log_iteration + (fun s -> LOG s LEVEL DEBUG) + (Buffer.contents buff); + let dist_type_image = interpret_type dist_type lex in + let obj_term= + Sg.eta_long_form + (Lambda.normalize + ~id_to_term:(fun i -> Sg.unfold_term_definition i lex.object_sig) + term) + dist_type_image + lex.object_sig in + let obj_princ_type,obj_typing_env = TypeInference.Type.inference obj_term in + LOG "Going to set a query for the distinguised type \"%s(%s)\"" (Signature.type_to_string dist_type lex.abstract_sig) (Lambda.raw_type_to_string dist_type) LEVEL DEBUG; + LOG "whose image is \"%s(%s)\"" (Signature.type_to_string dist_type_image lex.object_sig) (Lambda.raw_type_to_string dist_type_image) LEVEL DEBUG; + LOG "resulting int the principle type \"%s\"" (Lambda.raw_type_to_string obj_princ_type) LEVEL DEBUG; + let query,temp_prog = + Reduction.edb_and_query + ~obj_term + ~obj_type:obj_princ_type + ~obj_typing_env + ~dist_type + prog + ~abs_sig:lex.abstract_sig + ~obj_sig:lex.object_sig in + let buff'=Buffer.create 80 in + let () = Buffer.add_buffer buff' (Datalog_AbstractSyntax.AbstractSyntax.Program.to_buffer (Datalog.Program.to_abstract temp_prog)) in + LOG "Going to solve the query: \"%s\" with the program" (Datalog_AbstractSyntax.AbstractSyntax.Predicate.to_string query temp_prog.Datalog.Program.pred_table temp_prog.Datalog.Program.const_table) LEVEL TRACE; + Utils.log_iteration + (fun s -> LOG s LEVEL TRACE) + (Buffer.contents buff'); + let derived_facts,derivations = Datalog.Program.seminaive temp_prog in + let parse_forest = Datalog.Program.build_forest ~query:query derivations temp_prog in + let resume = + match parse_forest with + | [] -> SharedForest.SharedForest.empty + | [f] -> SharedForest.SharedForest.init f + | _ -> failwith "Bug: not fully specified query" in + resume + | Some _ , _ -> + let () = + Printf.printf "Parsing is not yet implemented for non atomic distinguished type\n%!" in + SharedForest.SharedForest.empty + + + let get_analysis resume lex = + LOG "Trying to get some analysis" LEVEL DEBUG; + match lex.datalog_prog with + | None -> let () = Printf.printf "Parsing is not yet implemented for non atomic distinguished type\n%!" in None,resume + | Some (_,rule_id_to_cst) -> + match SharedForest.SharedForest.resumption resume with + | None,resume -> None,resume + | Some t,resume -> + LOG "Got a result. Ready to map it" LEVEL DEBUG; + Some (SharedForest.SharedForest.fold_depth_first + ((fun rule_id -> RuleToCstMap.find rule_id rule_id_to_cst), + (fun x y -> Lambda.App(x,y))) + t), + resume let to_string ({name=n,_;dico=d;abstract_sig=abs_sg;object_sig=obj_sg} as lex) = - Printf.sprintf + let buff=Buffer.create 80 in + let () = Printf.bprintf + buff "lexicon %s(%s): %s =\n%send" n (fst (Sg.name abs_sg)) (fst (Sg.name obj_sg)) (match - Dico.fold - (fun k i -> function - | None -> Some (Printf.sprintf "\t%s := %s;" k (interpretation_to_string k (fun id -> interpret_type (Sg.type_of_constant id abs_sg) lex) i obj_sg)) - | Some a -> Some (Printf.sprintf "%s\n\t%s := %s;" a k (interpretation_to_string k (fun id -> interpret_type (Sg.type_of_constant id abs_sg) lex) i obj_sg))) - d - None with - | None -> "" - | Some s -> Printf.sprintf "%s\n" s) + Dico.fold + (fun k i -> function + | None -> Some (Printf.sprintf "\t%s := %s;" k (interpretation_to_string k (fun id -> interpret_type (Sg.type_of_constant id abs_sg) lex) i obj_sg)) + | Some a -> Some (Printf.sprintf "%s\n\t%s := %s;" a k (interpretation_to_string k (fun id -> interpret_type (Sg.type_of_constant id abs_sg) lex) i obj_sg))) + d + None with + | None -> "" + | Some s -> Printf.sprintf "%s\n" s) in + let () = Printf.bprintf buff "\n************************\n" in + let () = match lex.datalog_prog with + | None -> Printf.bprintf buff "This lexicon was not recognized as having a 2nd order abstract signature\n" + | Some (p,_) -> let () = Printf.bprintf buff "This lexicon recognized as having a 2nd order abstract signature. The associated datalog program is:\n" in + Buffer.add_buffer buff (Datalog_AbstractSyntax.AbstractSyntax.Program.to_buffer (Datalog.Program.to_abstract p)) in + Buffer.contents buff let check ({dico=d;abstract_sig=abs} as lex) = let missing_interpretations = @@ -142,17 +291,67 @@ struct let compose lex1 lex2 n = - {name=n; - dico = - Dico.fold - (fun key inter acc -> - match inter with - | Type (l,stype) -> Dico.add key (Type (l,interpret_type stype lex1)) acc - | Constant (l,t) -> Dico.add key (Constant (l,Lambda.normalize ~id_to_term:(fun i -> Sg.unfold_term_definition i lex1.object_sig) (interpret_term t lex1))) acc) - lex2.dico - Dico.empty; - abstract_sig = lex2.abstract_sig; - object_sig=lex1.object_sig} + LOG "Compose %s(%s) as %s" (fst(name lex1)) (fst(name lex2)) (fst n) LEVEL TRACE; + let temp_lex= + {name=n; + dico = + Dico.fold + (fun key inter acc -> + match inter with + | Type (l,stype) -> Dico.add key (Type (l,interpret_type stype lex1)) acc + | Constant (l,t) -> Dico.add key (Constant (l,Lambda.normalize ~id_to_term:(fun i -> Sg.unfold_term_definition i lex1.object_sig) (interpret_term t lex1))) acc) + lex2.dico + Dico.empty; + abstract_sig = lex2.abstract_sig; + object_sig=lex1.object_sig; + datalog_prog=lex2.datalog_prog} in + rebuild_prog temp_lex + + let program_to_buffer lex = + let buff=Buffer.create 80 in + let () = match lex.datalog_prog with + | None -> Printf.bprintf buff "This lexicon was not recognized as having a 2nd order abstract signature\n" + | Some (p,_) -> + let () = Printf.bprintf buff "This lexicon recognized as having a 2nd order abstract signature. The associated datalog program is:\n" in + Buffer.add_buffer buff (Datalog_AbstractSyntax.AbstractSyntax.Program.to_buffer (Datalog.Program.to_abstract p)) in + buff + + + + let query_to_buffer term dist_type lex = + match lex.datalog_prog,Sg.expand_type dist_type lex.abstract_sig with + | None,_ -> + let buff=Buffer.create 80 in + let () = Printf.bprintf buff "Parsing is not implemented for non 2nd order ACG\n!" in + buff + | Some (prog,_), (Lambda.Atom _ as dist_type) -> + let dist_type_image = interpret_type dist_type lex in + let obj_term= + Sg.eta_long_form + (Lambda.normalize + ~id_to_term:(fun i -> Sg.unfold_term_definition i lex.object_sig) + term) + dist_type_image + lex.object_sig in + let obj_princ_type,obj_typing_env = TypeInference.Type.inference obj_term in + let query,temp_prog = + Reduction.edb_and_query + ~obj_term + ~obj_type:obj_princ_type + ~obj_typing_env + ~dist_type + prog + ~abs_sig:lex.abstract_sig + ~obj_sig:lex.object_sig in + let buff = Datalog.Program.edb_to_buffer temp_prog in + let () = Printf.bprintf buff "Query:\n\t%s?\n" (Datalog_AbstractSyntax.AbstractSyntax.Predicate.to_string query temp_prog.Datalog.Program.pred_table temp_prog.Datalog.Program.const_table) in + buff + | Some _ , _ -> + let buff=Buffer.create 80 in + let () = + Printf.bprintf buff "Parsing is not yet implemented for non atomic distinguished type\n%!" in + buff + end diff --git a/src/acg-data/acgc.ml b/src/acg-data/acgc.ml index 16468eb36712da3b51eda7f7846a350c07513151..dc62b930599b0d312c9657cdd32cf101c40cf5b8 100644 --- a/src/acg-data/acgc.ml +++ b/src/acg-data/acgc.ml @@ -24,4 +24,4 @@ module Lex = Acg_lexicon.Sylvain_lexicon module Test = Interactive.Make(Lex) -let () = Test.main () +Test.main () diff --git a/src/acg-data/reduction.ml b/src/acg-data/reduction.ml new file mode 100644 index 0000000000000000000000000000000000000000..f5d9bfcbd44c1cbd51df96631fa5ec5c68fcbe52 --- /dev/null +++ b/src/acg-data/reduction.ml @@ -0,0 +1,140 @@ +open Datalog_AbstractSyntax +open Lambda +open Utils +open Datalog + +module Make(Sg:Interface.Signature_sig with type term = Lambda.term and type stype = Lambda.stype) = +struct + + let rec sequentialize_rev stype sequence = + match stype with + | Lambda.Atom i -> i::sequence + | Lambda.DAtom _ -> failwith "Bug: type definition should be unfolded" + | Lambda.LFun (alpha,beta) + | Lambda.Fun (alpha,beta) -> sequentialize_rev beta (sequentialize_rev alpha sequence) + | _ -> failwith "Bug: Not a 2nd order type" + + let sequentialize stype = List.rev (sequentialize_rev stype []) + + (** [map_types abs_type obj_type sg] returns a list of triple + [(id_n,name_n,image_n);...;(id_2,name_2,image_2);(id_1,name_1,image_1)] + where [abst_type=Atom(id_1) -> Atom(id_2) -> ... Atom(id_n)] and + is defined as [name_1 -> name_2 -> ... -> name_n] and + [obj_type=image_1 -> image_2 -> ... -> image_n]. Note that the + list is in the {em reverse order} and that [abs_type] should be + 2nd order. *) + let map_types abs_type obj_type sg obj_sg= + let rec map_types_aux abs_type obj_type lst = + LOG "Mapping (aux) type:%s" (Sg.type_to_string abs_type sg) LEVEL TRACE; + LOG "On (aux): %s" (Lambda.raw_type_to_string obj_type) LEVEL TRACE; + match abs_type,obj_type with + | Lambda.Atom i,_ -> (i,Sg.type_to_string abs_type sg,obj_type)::lst + | Lambda.DAtom _,_ -> failwith (Printf.sprintf "Bug: type definition in \"%s\" as \"%s\" should be unfolded" (Sg.type_to_string abs_type sg) (Lambda.raw_type_to_string abs_type)) + | Lambda.LFun (Lambda.Atom i as alpha,beta),Lambda.Fun (alpha',beta') + | Lambda.Fun (Lambda.Atom i as alpha,beta),Lambda.Fun (alpha',beta') -> + map_types_aux beta beta' ((i,Sg.type_to_string alpha sg,alpha')::lst) + | Lambda.LFun _,Lambda.Fun _ + | Lambda.Fun _,Lambda.Fun _ -> failwith "Bug: should be 2nd order type for abstract constant" + | _,_ -> failwith "Bug: Not a 2nd order type or not corresponding abstract and object type" in + LOG "Mapping type:%s (%s)" (Sg.type_to_string abs_type sg) (Lambda.raw_type_to_string abs_type) LEVEL TRACE; + LOG "On: %s" (Lambda.raw_type_to_string obj_type) LEVEL TRACE; + map_types_aux abs_type obj_type [] + + + let build_predicate_w_var_args (name,obj_type) (prog,var_gen,type_to_var_map) = + let atom_sequence = sequentialize_rev obj_type [] in + LOG "Build predicate from %s:%s ([%s])" name (Lambda.raw_type_to_string obj_type) (Utils.string_of_list ";" string_of_int atom_sequence) LEVEL TRACE; + let var_sequence,var_gen,type_to_var_map = + List.fold_left + (fun (l_var_seq,l_var_gen,l_type_to_var_map) i -> + let var,l_var_gen,l_type_to_var_map= + try + IntMap.find i l_type_to_var_map,l_var_gen,l_type_to_var_map + with + | Not_found -> + let var,l_var_gen=VarGen.get_fresh_id l_var_gen in + var,l_var_gen,IntMap.add i var l_type_to_var_map in + (AbstractSyntax.Predicate.Var var)::l_var_seq,l_var_gen,l_type_to_var_map) + ([],var_gen,type_to_var_map) + atom_sequence in + let p_id,prog=Datalog.Program.add_pred_sym name prog in + AbstractSyntax.Predicate.({p_id=p_id;arity=List.length var_sequence;arguments=var_sequence}), + (prog,var_gen,type_to_var_map) + + + let build_predicate_w_cst_args (name,obj_type) prog = + let atom_sequence = sequentialize obj_type in + LOG "Build predicate from %s:%s ([%s])" name (Lambda.raw_type_to_string obj_type) (Utils.string_of_list ";" string_of_int atom_sequence) LEVEL TRACE; + let const_sequence,prog = + List.fold_left + (fun (l_const_seq,l_prog) i -> + let const_id,l_prog=Datalog.Program.get_fresh_cst_id (string_of_int i) l_prog in + (AbstractSyntax.Predicate.Const const_id)::l_const_seq,l_prog) + ([],prog) + atom_sequence in + let p_id,prog=Datalog.Program.add_pred_sym name prog in + AbstractSyntax.Predicate.({p_id=p_id;arity=List.length const_sequence;arguments=List.rev const_sequence}),prog + + + + let generate_and_add_rule + ~abs_cst:(name,abs_t_type) + ~obj_princ_type:principle_type + ~obj_typing_env:env + prog + ~abs_sig + ~obj_sig = + let rule_id,prog=Datalog.Program.get_fresh_rule_id prog in + let type_lst = map_types abs_t_type principle_type abs_sig obj_sig in + match type_lst with + | [] -> failwith "Bug: there should be a type correspondance" + | (_,name,image)::tl -> + let lhs,(prog,var_gen,type_to_var_map) = build_predicate_w_var_args (name,image) (prog,VarGen.init (),IntMap.empty) in + let i_rhs,length,(prog,var_gen,type_to_var_map) = + List.fold_left + (fun (rhs,l_length,l_tables) (_,l_name,l_image) -> + let new_pred,new_tables=build_predicate_w_var_args (l_name,l_image) l_tables in + let l_length=l_length+1 in + (new_pred,l_length)::rhs,l_length,new_tables) + ([],0,(prog,var_gen,type_to_var_map)) + tl + in + let e_rhs,_,(prog,_,_) = + IntMap.fold + (fun _ (cst,cst_type) (rhs,l_length,l_tables) -> + let const_name=Sg.term_to_string cst obj_sig in + let () = assert (fst (Sg.is_constant const_name obj_sig)) in + let new_pred,new_tables = build_predicate_w_var_args (const_name,cst_type) l_tables in + let l_length=l_length+1 in + (new_pred,l_length)::rhs,l_length,new_tables) + env + ([],0,(prog,var_gen,type_to_var_map) ) in + LOG "Correctly set the number of intensional predi in rhs: %d" (let () = assert (length=List.length i_rhs) in length) LEVEL DEBUG; + let new_rule = AbstractSyntax.Rule.({id=rule_id;lhs;e_rhs;i_rhs;i_rhs_num=length}) in + new_rule,Datalog.Program.add_rule ~intensional:true new_rule prog + + + (* It makes the assumption that no constant has been + previously defined or used in the program *) + let edb_and_query ~obj_term ~obj_type ~obj_typing_env ~dist_type prog ~abs_sig ~obj_sig = + let type_lst = map_types dist_type obj_type abs_sig obj_sig in + match type_lst with + | [] -> failwith "Bug: there should be a type correspondance" + | [_,name,image] -> + let e_facts,prog= + IntMap.fold + (fun _ (cst,cst_type) (l_facts,l_prog) -> + let const_name=Sg.term_to_string cst obj_sig in + let () = assert (fst (Sg.is_constant const_name obj_sig)) in + let new_pred,l_prog = build_predicate_w_cst_args (const_name,cst_type) l_prog in + let rule_id,l_prog=Datalog.Program.get_fresh_rule_id l_prog in + let new_fact = AbstractSyntax.Rule.({id=rule_id;lhs=new_pred;e_rhs=[];i_rhs=[];i_rhs_num=0}) in + (new_fact::l_facts),l_prog) + obj_typing_env + ([],prog) in + let prog=Datalog.Program.add_e_facts prog (e_facts,prog.Datalog.Program.const_table,prog.Datalog.Program.rule_id_gen) in + build_predicate_w_cst_args (name,image) prog + | (_,name,image)::tl -> failwith "Bug: querying non atomic types is not yet implemented" + + +end diff --git a/src/acg-data/reduction.mli b/src/acg-data/reduction.mli new file mode 100644 index 0000000000000000000000000000000000000000..1ce714da09f4412f334b63183c0f04d8f11fd7df --- /dev/null +++ b/src/acg-data/reduction.mli @@ -0,0 +1,26 @@ +open Datalog_AbstractSyntax + + +module Make(Sg:Interface.Signature_sig with type term = Lambda.Lambda.term and type stype = Lambda.Lambda.stype): +sig + val generate_and_add_rule : + abs_cst:(string*Lambda.Lambda.stype) -> + obj_princ_type:Lambda.Lambda.stype -> + obj_typing_env:(Lambda.Lambda.term * Lambda.Lambda.stype) Utils.IntMap.t -> + Datalog.Datalog.Program.program -> + abs_sig:Sg.t -> + obj_sig:Sg.t -> + (AbstractSyntax.Rule.rule * Datalog.Datalog.Program.program) + + + val edb_and_query : + obj_term:Lambda.Lambda.term -> + obj_type:Lambda.Lambda.stype -> + obj_typing_env:(Lambda.Lambda.term * Lambda.Lambda.stype) Utils.IntMap.t -> + dist_type:Sg.stype -> + Datalog.Datalog.Program.program -> + abs_sig:Sg.t -> + obj_sig:Sg.t -> + (AbstractSyntax.Predicate.predicate * Datalog.Datalog.Program.program) + +end diff --git a/src/acg-data/signature.ml b/src/acg-data/signature.ml index e8abcf78b3fdbfb4631e87f12c34986f0088029d..8a830fca6ca5f38327e5ec13c5f890f9eecdfcc7 100644 --- a/src/acg-data/signature.ml +++ b/src/acg-data/signature.ml @@ -48,7 +48,8 @@ struct size:int; terms:entry Symbols.t; types:entry Symbols.t; - ids:entry Id.t} + ids:entry Id.t; + is_2nd_order:bool} type term = Lambda.term @@ -82,7 +83,7 @@ struct (id_to_string sg) - let empty n = {name=n;size=0;terms=Symbols.empty;types=Symbols.empty;ids=Id.empty} + let empty n = {name=n;size=0;terms=Symbols.empty;types=Symbols.empty;ids=Id.empty;is_2nd_order=true} let name {name=n} = n @@ -225,6 +226,7 @@ struct let expand_type = expand_type let find_term = find_term let type_to_string = type_to_string + let term_to_string = term_to_string end) let typecheck=Type_System.typecheck @@ -238,7 +240,8 @@ struct add_sig_type t (Type_definition (t,s,abstract_on_dependent_types k sg,convert_type ty sg)) sg | Abstract_syntax.Term_decl (t,behavior,_,ty) -> let t_type = convert_type ty sg in - add_sig_term t (Term_declaration (t,s,behavior,convert_type ty sg)) sg + let sg_is_2nd_order = sg.is_2nd_order && (Lambda.is_2nd_order t_type (fun i -> unfold_type_definition i sg)) in + add_sig_term t (Term_declaration (t,s,behavior,convert_type ty sg)) {sg with is_2nd_order=sg_is_2nd_order} | Abstract_syntax.Term_def (t,behavior,_,term,ty) -> let t_type = convert_type ty sg in let t_term = typecheck term t_type sg in @@ -294,7 +297,8 @@ struct let convert_term t ty sg = let t_type = convert_type ty sg in - typecheck t t_type sg,t_type + let t=typecheck t t_type sg in + t,t_type let type_of_constant x ({terms=syms} as sg) = try @@ -317,6 +321,7 @@ struct | Term_declaration (s,_,_,_) -> Some s | _ -> None + let is_2nd_order {is_2nd_order} = is_2nd_order end diff --git a/src/acg-data/type_system.ml b/src/acg-data/type_system.ml index 1a6ef8a3fa22e6da6a77f0d2600206826214086f..34c85e2c254d32ffdb83926a2a76465889ebbd71 100644 --- a/src/acg-data/type_system.ml +++ b/src/acg-data/type_system.ml @@ -37,6 +37,7 @@ sig val expand_type : Lambda.stype -> t -> Lambda.stype val find_term : string -> t -> Lambda.term *Lambda.stype val type_to_string : Lambda.stype -> t -> string + val term_to_string : Lambda.term -> t -> string (* val id_to_string : t -> int -> Abstract_syntax.syntactic_behavior*string *) end @@ -293,7 +294,10 @@ struct try let t_term,t_type,(_:typing_environment) = typecheck_aux t (Some (local_expand ty)) {linear_level=0;level=0;env=Utils.StringMap.empty;wrapper=None} in - t_term + LOG "Type-checked %s : %s" (Signature.term_to_string t_term sg ) (Signature.type_to_string t_type sg ) LEVEL TRACE ; + LOG "Type-checked %s : %s" (Lambda.raw_to_string t_term ) (Lambda.raw_type_to_string t_type ) LEVEL TRACE ; + LOG "Type-checked %s : %s" (Lambda.raw_to_caml t_term ) (Lambda.raw_type_to_caml t_type ) LEVEL TRACE ; + t_term with | Type_mismatch ((p1,p2),t1,t2) -> raise (Error.Error (Error.Type_error (Error.Is_Used (Signature.type_to_string t1 sg,Printf.sprintf "\"%s\"" (Signature.type_to_string t2 sg)),(p1,p2)))) | Not_linear ((s1,e1),(s2,e2)) -> raise (Error.Error (Error.Type_error (Error.Two_occurrences_of_linear_variable (s2,e2),(s1,s1)))) diff --git a/src/acg-data/type_system.mli b/src/acg-data/type_system.mli index a1220caf46f821d2c88103fe1a6ce3724697c489..59fe1912652968d65d02e23a4eda039e4bc829a6 100644 --- a/src/acg-data/type_system.mli +++ b/src/acg-data/type_system.mli @@ -28,6 +28,7 @@ sig val expand_type : Lambda.stype -> t -> Lambda.stype val find_term : string -> t -> Lambda.term *Lambda.stype val type_to_string : Lambda.stype -> t -> string + val term_to_string : Lambda.term -> t -> string (* val id_to_string : t -> int -> Abstract_syntax.syntactic_behavior*string*) end diff --git a/src/data/Jean-regarde-telescope.acg b/src/data/Jean-regarde-telescope.acg new file mode 100644 index 0000000000000000000000000000000000000000..82426cfb55c302560e50e871785c11c87260305a --- /dev/null +++ b/src/data/Jean-regarde-telescope.acg @@ -0,0 +1,58 @@ +signature Syntax= + S,NP,V,VP,PN,Det,N,Prep,PP,T:type; + + subj:NP->VP->S; + + pn:PN->NP; + np:Det -> N -> NP; + np_pp: NP -> PP -> NP; + + obj: V -> NP -> VP; + vp_pp : VP -> PP -> VP; + + pp: Prep -> NP -> PP; + + Jean:PN; + un:Det; + regarde:V; + dort:VP; + homme:N; + telescope:N; + avec:Prep; + + loop1:T->NP; + loop2:NP->T; + + +end + +signature Strings = + o:type; + string=o->o: type; + infix +=lambda x y z.x(y z):string -> string -> string; + + Jean, regarde, dort,un ,homme, avec,telescope:string; + + +end + +lexicon CFG (Syntax):Strings = + S,NP,V,VP,PN,Det,N,Prep,PP,T:=string; + + subj,np,np_pp,obj,vp_pp,pp:=lambda x y.x+y; + + pn:=lambda x.x; + + Jean:=Jean; + un:=un; + regarde:=regarde; + dort:=dort; + homme:=homme; + telescope:=telescope; + avec:=avec; + + loop1,loop2:=lambda x.x; +end + + + \ No newline at end of file diff --git a/src/data/anbncndn.acg b/src/data/anbncndn.acg new file mode 100644 index 0000000000000000000000000000000000000000..c21ee9f0514847772d7e10ca738d9526d194ec1f --- /dev/null +++ b/src/data/anbncndn.acg @@ -0,0 +1,54 @@ +signature Derivation_trees = + S,S_A:type; + C:S_A -> S_A; + Start:S_A -> S; + I_S:S_A; +end + +signature Derived_trees = + tree:type; + S_3:tree -> tree -> tree -> tree; + S_2:tree -> tree -> tree; + Empty:tree; + a,b,c,d:tree; +end + +lexicon Abs(Derivation_trees):Derived_trees = + S:=tree; + S_A:=tree -> tree; + (* Start:=lambda aux.S_3 a (aux (S_2 b c)) d; *) + Start := lambda aux. aux Empty; + C:=lambda aux sub.S_3 a (aux (S_3 b sub c)) d; + I_S:=lambda x.x; +end + +signature Strings = + o:type; + string=o->o:type; + infix +=lambda x y z.x(y z):string -> string -> string; + a,b,c,d:string; + E=lambda x.x:string; +end + +lexicon Yield (Derived_trees):Strings= + tree:=string; + S_3:=lambda x y z.x + y + z; + S_2:=lambda x y.x + y; + a:=a; + b:=b; + c:=c; + d:=d; + Empty:=E; +end + +lexicon Full = Yield << Abs + +lexicon Direct(Derivation_trees):Strings= + S:=string; + S_A:=string->string; + + I_S:=lambda x.x; + + Start:=lambda aux z. a (aux (lambda z'. b (c z')) (d z)); + C:=lambda aux sub z. a (aux (lambda z'. b (sub (c z'))) (d z)); +end diff --git a/src/grammars/acg_token.ml b/src/grammars/acg_token.ml index 320504a63e5a4f8a27065a35ff3721a1db246160..dc14ee3f3c1a4339a06623083543ea7115ae1a24 100644 --- a/src/grammars/acg_token.ml +++ b/src/grammars/acg_token.ml @@ -43,5 +43,6 @@ struct | COLON of (Abstract_syntax.location) | SEMICOLON of (Abstract_syntax.location) | EQUAL of (Abstract_syntax.location) + | COMPOSE of (Abstract_syntax.location) | EOI end diff --git a/src/grammars/acg_token.mli b/src/grammars/acg_token.mli index b0082f62c6482ca080ff561e661bf5f9c641b29a..ef040747ff7c3f46480fefeba4ba357c7b77a9bc 100644 --- a/src/grammars/acg_token.mli +++ b/src/grammars/acg_token.mli @@ -48,6 +48,7 @@ sig | COLON of (Abstract_syntax.location) | SEMICOLON of (Abstract_syntax.location) | EQUAL of (Abstract_syntax.location) + | COMPOSE of (Abstract_syntax.location) | EOI end diff --git a/src/grammars/data_lexer.mll b/src/grammars/data_lexer.mll index e9d5c7e691361ac242716f20d7cc85e556bda1e7..56f24a08e93fe501704a76501b29c8012990f927 100644 --- a/src/grammars/data_lexer.mll +++ b/src/grammars/data_lexer.mll @@ -29,6 +29,7 @@ type lexing_of = | Data of Entry.data | Term of Entry.term + | Type of Entry.stype let pr lexbuf = Printf.printf "%s\n%!" (Lexing.lexeme lexbuf) @@ -57,6 +58,9 @@ let set_to_term () = data := Term (Entry.start_term ()) + let set_to_type () = + data := Type (Entry.start_type ()) + let set_to_sig_entry () = data := Data (Entry.start_sig_entry ()) @@ -69,6 +73,8 @@ match !data with | Data d -> data := Data (Entry.data_transition d v) | Term t -> data := Term (Entry.term_transition t v) + | Type t -> data := Type (Entry.type_transition t v) + with | Entry.Expect l -> let s = Utils.string_of_list " or " Entry.valuation_to_string l in @@ -97,6 +103,9 @@ let string = (letter|digit|'_')*'\''* | ['='] {let () = update_data Entry.Equal (loc lexbuf) in let () = check_brackets () in Token.EQUAL(loc lexbuf)} + | "<<" {let () = update_data Entry.Compose (loc lexbuf) in + let () = check_brackets () in + Token.COMPOSE(loc lexbuf)} | [';'] {let () = update_data Entry.Semi_colon (loc lexbuf) in let () = check_brackets () in Token.SEMICOLON(loc lexbuf)} diff --git a/src/grammars/data_parser.dyp b/src/grammars/data_parser.dyp index e6165bc31a1a48b82dc6838d0e9d89c840490dff..1c82953f6ea91171ea2eb19980eafe2950f4a364 100644 --- a/src/grammars/data_parser.dyp +++ b/src/grammars/data_parser.dyp @@ -156,6 +156,7 @@ %token EOI EQUAL + COMPOSE SEMICOLON COLON COMMA @@ -189,6 +190,9 @@ EOI %start sig_entry %start lex_entry %start term_alone +%start heterogenous_term_and_type +%start term +%start type_expression %relation atom EQUAL lex_entries {e l} | LEX_OPEN lex_opening EQUAL lex_entries {e l} +| LEX_OPEN IDENT EQUAL lexicon_composition {c name} + +lexicon_composition : +| IDENT COMPOSE composition_argument { + fun name -> + try + let env=get_env_value dyp.last_local_data in + let l1 = E.get_lexicon name1 env in + E.Lexicon.compose l1 (l ("__NO__NAME__",(Lexing.dummy_pos,Lexing.dummy_pos))) ( name) + with + | E.Lexicon_not_found _ -> + emit_parse_error (Error.No_such_signature name1) loc} +| LPAREN lexicon_composition RPAREN {c} + +composition_argument: +| IDENT {fun res_name-> + try + E.get_lexicon name (get_env_value dyp.last_local_data) + with + | E.Lexicon_not_found _ -> + emit_parse_error (Error.No_such_signature name) loc} +| lexicon_composition {c} lex_opening : @@ -363,6 +389,13 @@ sig_entries : | term COLON type_expression EOI {let sg = (get_sig_value dyp.last_local_data) in E.Signature1.convert_term (fst (t Env.empty [])) (fst (ty sg)) sg (*(E.Signature1.empty ("fake signature",(Lexing.dummy_pos,Lexing.dummy_pos)))*)} + + heterogenous_term_and_type : +| term ...@{t,let abs_sig,_=get_abs_and_obj_sig_value dyp.last_local_data in [Local_data (Some (Signature abs_sig))]} COLON type_expression EOI { + let abs_sig=get_sig_value dyp.last_local_data in + (fst (t Env.empty [])),(fst (ty abs_sig))} + + term : | LAMBDA0 idents DOT term { let sg = get_sig_value dyp.last_local_data in @@ -454,31 +487,28 @@ sig_entries : kind} term { try -(* let () = Printf.printf "(%s) Current id: %s\n%!" (cpt_to_string ()) (Utils.string_of_list " " (fun (x,_) -> x) ids ) in - let () = Printf.printf "(%s) Current kind: %s\n%!" (cpt_to_string()) (type_or_cst_to_string kind) in *) - fun lex -> - let term = fst (t Env.empty []) in -(* let () = Printf.printf "Ok for the term\n%!" in *) - List.fold_left - (fun acc (id,loc) -> E.Lexicon.insert (Abstract_syntax.Constant (id,loc,term)) acc) - lex - ids + fun lex -> + let term = fst (t Env.empty []) in + List.fold_left + (fun acc (id,loc) -> E.Lexicon.insert (Abstract_syntax.Constant (id,loc,term)) acc) + lex + ids with - | Error.Error (Error.Parse_error (Error.Unknown_constant _,_)) when kind = Both -> raise Dyp.Giveup - | exc -> raise exc } + | Error.Error (Error.Parse_error (Error.Unknown_constant _,_)) when kind = Both -> raise Dyp.Giveup + | exc -> raise exc } | comma_ids COLON_EQUAL ...{ - let abs,obj = get_abs_and_obj_sig_value dyp.last_local_data in - let kind = - List.fold_left - (fun k (id,loc) -> - match k,fst (E.Signature1.is_constant id abs),E.Signature1.is_type id abs with - | (Nothing|Type|Both),false,true -> Type - | (Nothing|Both),true,true -> Both - | Type,_,true -> Type - | (Nothing|Both),true,false -> raise Dyp.Giveup - | (Nothing|Both),false,false -> emit_parse_error (Error.Unknown_type id) loc - | Type,_,false -> emit_parse_error (Error.Unknown_type id) loc - | Cst,_,_ -> failwith "Bug: should not occur" + let abs,obj = get_abs_and_obj_sig_value dyp.last_local_data in + let kind = + List.fold_left + (fun k (id,loc) -> + match k,fst (E.Signature1.is_constant id abs),E.Signature1.is_type id abs with + | (Nothing|Type|Both),false,true -> Type + | (Nothing|Both),true,true -> Both + | Type,_,true -> Type + | (Nothing|Both),true,false -> raise Dyp.Giveup + | (Nothing|Both),false,false -> emit_parse_error (Error.Unknown_type id) loc + | Type,_,false -> emit_parse_error (Error.Unknown_type id) loc + | Cst,_,_ -> failwith "Bug: should not occur" (* match k,E.Signature1.is_type id abs with | (None|Some Type),true -> Some Type | None,false -> @@ -534,44 +564,81 @@ sig_entries : | E.Lexicon lex -> Printf.printf "%s\n%!" (E.Lexicon.to_string lex)) e in - e + Some e with | Utils.No_file(f,msg) -> let e = Error.System_error (Printf.sprintf "No such file \"%s\" in %s" f msg) in - let () = Printf.fprintf stderr "Error: %s\n%!" (Error.error_msg e filename) in env + let () = Printf.fprintf stderr "Error: %s\n%!" (Error.error_msg e filename) in None | Sys_error s -> let e = Error.System_error s in - let () = Printf.fprintf stderr "Error: %s\n%!" (Error.error_msg e filename) in env + let () = Printf.fprintf stderr "Error: %s\n%!" (Error.error_msg e filename) in None | Error.Error e -> let () = Printf.fprintf stderr "Error: %s\n%!" (Error.error_msg e filename) in - env + None - let parse_term ?(offset="") ?(output=false) t sg = - let lexbuf = Lexing.from_string t in - try - let () = Data_lexer.set_to_term () in - let abs_term,abs_type = - try fst (List.hd(term_alone ~global_data:false ~local_data:(Some (Signature sg)) Data_lexer.lexer lexbuf)) with - | Dyp.Syntax_error -> raise (Error.dyp_error lexbuf "stdin") in - let () = match output with - | true -> let () = Printf.printf "%s : %s\n%!" (E.Signature1.term_to_string abs_term sg) (E.Signature1.type_to_string abs_type sg) in - Printf.printf "%s : %s \n%!" (E.Signature1.term_to_string (E.Signature1.unfold abs_term sg) sg) (E.Signature1.type_to_string abs_type sg) - | false -> () in - Some (abs_term,abs_type) - with - | Error.Error er -> - let s,e = Error.get_loc_error er in - let s',e' = s.Lexing.pos_cnum - s.Lexing.pos_bol,e.Lexing.pos_cnum - e.Lexing.pos_bol in - let () = Printf.fprintf - stderr - "%s\n%s%s%s\nError: %s\n%!" - t - offset - (String.make s' ' ') - (String.make (e'-s') '^') - (Error.error_msg er "stdin") in - None - | End_of_file -> None +let parse_term ?(offset="") ?(output=false) t sg = + let lexbuf = Lexing.from_string t in + try + let () = Data_lexer.set_to_term () in + let abs_term,abs_type = + try fst (List.hd(term_alone ~global_data:false ~local_data:(Some (Signature sg)) Data_lexer.lexer lexbuf)) with + | Dyp.Syntax_error -> raise (Error.dyp_error lexbuf "stdin") in + let () = match output with + | true -> let () = Printf.printf "%s : %s\n%!" (E.Signature1.term_to_string abs_term sg) (E.Signature1.type_to_string abs_type sg) in + Printf.printf "%s : %s \n%!" (E.Signature1.term_to_string (E.Signature1.unfold abs_term sg) sg) (E.Signature1.type_to_string abs_type sg) + | false -> () in + Some (abs_term,abs_type) + with + | Error.Error er -> + let s,e = Error.get_loc_error er in + let s',e' = s.Lexing.pos_cnum - s.Lexing.pos_bol,e.Lexing.pos_cnum - e.Lexing.pos_bol in + let () = Printf.fprintf + stderr + "%s\n%s%s%s\nError: %s\n%!" + t + offset + (String.make s' ' ') + (String.make (e'-s') '^') + (Error.error_msg er "stdin") in + None + | End_of_file -> None + + + +let parse_heterogenous_term ?(offset="") ?(output=false) t lex = + let lexbuf = Lexing.from_string t in + let abs,obj=E.Lexicon.get_sig lex in + try + let () = Data_lexer.set_to_term () in + let obj_term,abs_type = + try fst (List.hd(heterogenous_term_and_type ~global_data:false ~local_data:(Some (Abs_and_obj (abs,obj))) Data_lexer.lexer lexbuf)) with + | Dyp.Syntax_error -> raise (Error.dyp_error lexbuf "stdin") in + let abs_type=E.Signature1.convert_type abs_type abs in + let obj_type=E.Lexicon.interpret_type abs_type lex in + let obj_term=E.Signature1.typecheck obj_term obj_type obj in + let () = match output with + | true -> let () = Printf.printf "%s : %s (as image of %s)\n%!" (E.Signature1.term_to_string obj_term obj) (E.Signature1.type_to_string obj_type obj) (E.Signature1.type_to_string abs_type abs) in + Printf.printf "%s : %s (as image of %s)\n%!" (E.Signature1.term_to_string (E.Signature1.unfold obj_term obj) obj) (E.Signature1.type_to_string obj_type obj) (E.Signature1.type_to_string abs_type abs) + | false -> () in + Some (obj_term,abs_type) + with + | Error.Error er -> + let s,e = Error.get_loc_error er in + let s',e' = s.Lexing.pos_cnum - s.Lexing.pos_bol,e.Lexing.pos_cnum - e.Lexing.pos_bol in + let () = Printf.fprintf + stderr + "%s\n%s%s%s\nError: %s\n%!" + t + offset + (String.make s' ' ') + (String.make (e'-s') '^') + (Error.error_msg er "stdin") in + None + | End_of_file -> None + + + + let parse_sig_entry ?(offset="") t sg = let lexbuf = Lexing.from_string t in @@ -623,7 +690,7 @@ end} %mlitop { (* type token = Token.Token.t*) -(* module Env : Set.S with type elt = String.t*) + module Env : Set.S with type elt = String.t (** This module implements the functor that provides parsing functions when provided with an implementation of an environment @@ -638,14 +705,18 @@ end} (** [parse_data filename dirs e] adds the data (signatures or lexicons) parsed from file [filename] to [e] and returns the - resulting environment. [filename] is looked for in [dirs] - directories. *) - val parse_data : ?override:bool -> ?output:bool -> string -> string list -> E.t -> E.t + [Some e'] where ]e'] is the resulting environment if the parse + is successful. It returns [None] otherwise. [filename] is + looked for in [dirs] directories. *) + val parse_data : ?override:bool -> ?output:bool -> string -> string list -> E.t -> E.t option (** [term s sg] returns [Some t] with [t] being an {!Abstract_syntax.Abstract_syntax..Abstract_syntax.Abstract_syntax.term} if [s] is parsable, and [None] otherwise *) val parse_term : ?offset:string -> ?output:bool -> string -> E.Signature1.t -> (E.Signature1.term*E.Signature1.stype) option + + val parse_heterogenous_term : ?offset:string -> ?output:bool -> string -> E.Lexicon.t -> (E.Signature1.term*E.Signature1.stype) option + val parse_sig_entry : ?offset:string -> string -> E.Signature1.t -> E.Signature1.t option diff --git a/src/grammars/entry.ml b/src/grammars/entry.ml index 0af912cc7ae6c0636b036c0a512316dd3b9a21b0..35b537e6d0fe589204ef0df1c1230a5325a826e9 100644 --- a/src/grammars/entry.ml +++ b/src/grammars/entry.ml @@ -67,6 +67,7 @@ struct | Lex_kwd | Id | Equal + | Compose | Comma | Colon | Colon_equal @@ -87,6 +88,10 @@ struct and lex_id = | No_lex_dec | Lex_id + | Lex_eq + | Lex_name + | Lex_name_2 + | Lex_composition | Abstract_sig_opening | Abstract_sig_name | Abstract_sig_closing @@ -101,6 +106,7 @@ struct | Interpretation of type_or_term_in_def type term = type_or_term_in_def + type stype = type_or_term_in_def let valuation_to_string = function @@ -109,6 +115,7 @@ struct | Lex_kwd -> "\"lexicon\" kwd" | Id -> "Identifier" | Equal -> "\"=\"" + | Compose -> "\"<<\"" | Comma -> "\",\"" | Colon -> "\":\"" | Colon_equal -> "\":=\"" @@ -129,6 +136,8 @@ struct let start_term () = No_type_or_term_in_def + let start_type () = Type_or_term_in_def (Type,Colon) + let start_sig_entry () = Sig (Sig_dec_id (Sig_dec_equal (No_entry))) let start_lex_entry () = Lex(Lex_def No_lex_entry) @@ -193,6 +202,8 @@ let build_expectation lst = | Type_or_term_in_def (Nothing,_) -> failwith "Bug: Mothing should not appear in term" let term_transition q v = q + + let type_transition q v = q (* let _,result = term_expectation q in result v *) @@ -295,78 +306,91 @@ let build_expectation lst = | (Unset|Type),_ -> raise (Expect [Id;Type_or_term ARROW]) | Nothing,_ -> raise (Expect [End_kwd;Semi_colon])) | Id as a -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Equal_def (Type_or_term_in_def (fst k_o_t,a)))))) -| Sym as a -> - (match k_o_t with - | Type,_ -> raise (Expect [Type_or_term ARROW;Semi_colon]) - | (Unset|Term),(Id|Sym|Type_or_term (LPAR|RPAR|DOT)) -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Equal_def (Type_or_term_in_def (Term,a)))))) - | (Unset|Term),_ -> raise (Expect [Id]) - | Nothing,_ -> raise (Expect [End_kwd;Semi_colon])) -| _ -> raise (Expect l)) - - | Sig (Sig_dec_id (Sig_dec_equal (Prefix_infix No_symbol))) -> - let l = [Sym] in - l,(function - | Sym -> Sig (Sig_dec_id (Sig_dec_equal (Prefix_infix Symbol))) + | Sym as a -> + (match k_o_t with + | Type,_ -> raise (Expect [Type_or_term ARROW;Semi_colon]) + | (Unset|Term),(Id|Sym|Type_or_term (LPAR|RPAR|DOT)) -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Equal_def (Type_or_term_in_def (Term,a)))))) + | (Unset|Term),_ -> raise (Expect [Id]) + | Nothing,_ -> raise (Expect [End_kwd;Semi_colon])) | _ -> raise (Expect l)) - + | Sig (Sig_dec_id (Sig_dec_equal (Prefix_infix No_symbol))) -> + let l = [Sym] in + l,(function + | Sym -> Sig (Sig_dec_id (Sig_dec_equal (Prefix_infix Symbol))) + | _ -> raise (Expect l)) + + | Sig (Sig_dec_id (Sig_dec_equal (Prefix_infix Symbol))) -> - let l =[Colon;Equal] in - l,(function - | Colon -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Colon_assignment No_type_kwd_or_type_or_term)))) - | Equal -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Equal_def No_type_or_term_in_def)))) - | _ -> raise (Expect l)) - + let l =[Colon;Equal] in + l,(function + | Colon -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Colon_assignment No_type_kwd_or_type_or_term)))) + | Equal -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Equal_def No_type_or_term_in_def)))) + | _ -> raise (Expect l)) + | Sig (Sig_dec_id (Sig_dec_equal (Binder No_binder_id))) -> - let l = [Id] in - l,(function - | Id -> Sig (Sig_dec_id (Sig_dec_equal (Binder Binder_id))) - | _ -> raise (Expect l)) - + let l = [Id] in + l,(function + | Id -> Sig (Sig_dec_id (Sig_dec_equal (Binder Binder_id))) + | _ -> raise (Expect l)) + | Sig (Sig_dec_id (Sig_dec_equal (Binder Binder_id))) -> - let l = [Colon;Equal] in - l, (function - | Equal -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Equal_def No_type_or_term_in_def)))) - | Colon -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Colon_assignment No_type_kwd_or_type_or_term)))) - | _ -> raise (Expect l)) - + let l = [Colon;Equal] in + l, (function + | Equal -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Equal_def No_type_or_term_in_def)))) + | Colon -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Colon_assignment No_type_kwd_or_type_or_term)))) + | _ -> raise (Expect l)) + | Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Colon_assignment (Type_kwd_or_type_or_term k_o_t))))) -> - let l = [End_kwd;Semi_colon] in + let l = [End_kwd;Semi_colon] in l,(function - | End_kwd -> - (match k_o_t with - | Nothing,_ -> No_dec - | (Unset|Type),(Id|Type_or_term RPAR) -> No_dec - | _ -> raise (Expect [Id;Type_or_term ARROW])) - | Semi_colon -> - (match k_o_t with - | Nothing,_ -> Sig (Sig_dec_id (Sig_dec_equal No_entry)) - | (Unset|Type),(Id|Type_or_term RPAR) -> Sig (Sig_dec_id (Sig_dec_equal No_entry)) - | _ -> raise (Expect [Id;Type_or_term ARROW])) - | Id as a -> - (match k_o_t with - | (Unset|Type),Type_or_term (LPAR|ARROW) -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Colon_assignment (Type_kwd_or_type_or_term (fst k_o_t,a)))))) - | _ -> raise (Expect [Type_or_term ARROW;Semi_colon])) - | Type_or_term LPAR as a -> - (match k_o_t with - | (Unset|Type),Type_or_term (LPAR|ARROW) -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Colon_assignment (Type_kwd_or_type_or_term (fst k_o_t,a)))))) - | _ -> raise (Expect [Type_or_term ARROW;Semi_colon])) - | Type_or_term RPAR -> - (match k_o_t with - | (Unset|Type),(Id|Type_or_term LPAR) -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Colon_assignment (Type_kwd_or_type_or_term k_o_t))))) - | _ -> raise (Expect [Type_or_term ARROW;Semi_colon])) - | Type_or_term DOT -> raise (Expect [Type_or_term ARROW;Semi_colon]) - | Type_or_term LAMBDA -> raise (Expect [Type_or_term ARROW;Semi_colon]) - | Type_or_term ARROW as a-> - (match k_o_t with - | Term,_ -> raise (Expect [Type_or_term DOT]) - | (Unset|Type),(Id|Type_or_term RPAR) -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Colon_assignment (Type_kwd_or_type_or_term (Type,a)))))) - | (Unset|Type),_ -> raise (Expect [Id;Type_or_term ARROW]) - | Nothing,_ -> raise (Expect [End_kwd;Semi_colon])) - | Sym -> raise (Expect [Type_or_term ARROW;Semi_colon]) - | _ -> raise (Expect l)) + | End_kwd -> + (match k_o_t with + | Nothing,_ -> No_dec + | (Unset|Type),(Id|Type_or_term RPAR) -> No_dec + | _ -> raise (Expect [Id;Type_or_term ARROW])) + | Semi_colon -> + (match k_o_t with + | Nothing,_ -> Sig (Sig_dec_id (Sig_dec_equal No_entry)) + | (Unset|Type),(Id|Type_or_term RPAR) -> Sig (Sig_dec_id (Sig_dec_equal No_entry)) + | _ -> raise (Expect [Id;Type_or_term ARROW])) + | Id as a -> + (match k_o_t with + | (Unset|Type),Type_or_term (LPAR|ARROW) -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Colon_assignment (Type_kwd_or_type_or_term (fst k_o_t,a)))))) + | _ -> raise (Expect [Type_or_term ARROW;Semi_colon])) + | Type_or_term LPAR as a -> + (match k_o_t with + | (Unset|Type),Type_or_term (LPAR|ARROW) -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Colon_assignment (Type_kwd_or_type_or_term (fst k_o_t,a)))))) + | _ -> raise (Expect [Type_or_term ARROW;Semi_colon])) + | Type_or_term RPAR -> + (match k_o_t with + | (Unset|Type),(Id|Type_or_term LPAR) -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Colon_assignment (Type_kwd_or_type_or_term k_o_t))))) + | _ -> raise (Expect [Type_or_term ARROW;Semi_colon])) + | Type_or_term DOT -> raise (Expect [Type_or_term ARROW;Semi_colon]) + | Type_or_term LAMBDA -> raise (Expect [Type_or_term ARROW;Semi_colon]) + | Type_or_term ARROW as a-> + (match k_o_t with + | Term,_ -> raise (Expect [Type_or_term DOT]) + | (Unset|Type),(Id|Type_or_term RPAR) -> Sig (Sig_dec_id (Sig_dec_equal (Entry_id (Colon_assignment (Type_kwd_or_type_or_term (Type,a)))))) + | (Unset|Type),_ -> raise (Expect [Id;Type_or_term ARROW]) + | Nothing,_ -> raise (Expect [End_kwd;Semi_colon])) + | Sym -> raise (Expect [Type_or_term ARROW;Semi_colon]) + | _ -> raise (Expect l)) | Lex No_lex_dec -> build_expectation [Id,Lex Lex_id] - | Lex Lex_id -> build_expectation [Type_or_term LPAR,Lex Abstract_sig_opening] + (* | Lex Lex_id -> build_expectation [Type_or_term LPAR,Lex Abstract_sig_opening] *) + | Lex Lex_id -> build_expectation + [Type_or_term LPAR,Lex Abstract_sig_opening; + Equal,Lex Lex_eq] + | Lex Lex_eq -> build_expectation [Id,Lex Lex_name] + | Lex Lex_name -> build_expectation [Compose,Lex Lex_composition] + | Lex Lex_composition -> build_expectation [Id,Lex Lex_name_2] + | Lex Lex_name_2 -> build_expectation + [Compose,Lex Lex_composition; + Sig_kwd, Sig No_sig_dec_id ; + Lex_kwd, Lex No_lex_dec ; + EOI,No_dec + ] + | Lex Abstract_sig_opening -> build_expectation [Id,Lex Abstract_sig_name] | Lex Abstract_sig_name -> build_expectation [(Type_or_term RPAR),Lex Abstract_sig_closing] | Lex Abstract_sig_closing -> build_expectation [Colon,Lex Object_sig_opening] @@ -374,107 +398,107 @@ let build_expectation lst = | Lex Object_sig_name -> build_expectation [Equal,Lex (Lex_def No_lex_entry)] | Lex (Lex_def No_lex_entry) -> build_expectation [Id,Lex (Lex_def (Lex_entry_id No_interpretation));End_kwd,No_dec;Sym,Lex (Lex_def (Lex_entry_id No_interpretation))] | Lex (Lex_def (Lex_entry_id No_interpretation)) -> - build_expectation [Comma,Lex (Lex_def No_lex_entry); - Colon_equal,Lex (Lex_def (Lex_entry_id (Interpretation No_type_or_term_in_def)))] + build_expectation [Comma,Lex (Lex_def No_lex_entry); + Colon_equal,Lex (Lex_def (Lex_entry_id (Interpretation No_type_or_term_in_def)))] | Lex (Lex_def (Lex_entry_id (Interpretation ty_o_te))) -> - match ty_o_te with - | No_type_or_term_in_def -> - let l = [Id;Sym;Type_or_term LPAR;Type_or_term LAMBDA] in - l,(function - | (Id|Type_or_term LPAR) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Unset,a))))) - | (Sym|Type_or_term LAMBDA) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) - | _ -> raise (Expect [Type_or_term LPAR])) - | Type_or_term_in_def (Unset,Id) -> - let l = [Type_or_term LPAR;Semi_colon] in - l,(function - | (Id|Sym|Type_or_term (LPAR|DOT|LAMBDA)) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) - | Type_or_term RPAR as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Unset,a))))) - | Type_or_term ARROW as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Type,a))))) - | Semi_colon -> Lex (Lex_def No_lex_entry) - | End_kwd -> No_dec - | _ -> raise (Expect l)) - | Type_or_term_in_def (Unset,Type_or_term LPAR) -> - let l = [Type_or_term LPAR] in - l,(function - | (Sym|Type_or_term LAMBDA) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) - | (Id|Type_or_term LPAR) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Unset,a))))) - | _ -> raise (Expect l)) - | Type_or_term_in_def (Unset,Type_or_term RPAR) -> - let l = [Type_or_term LPAR;Semi_colon] in - l,(function - | (Id|Sym|Type_or_term (LPAR|LAMBDA)) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) - | (Type_or_term RPAR) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Unset,a))))) - | (Type_or_term ARROW) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Type,a))))) - | Semi_colon -> Lex (Lex_def No_lex_entry) - | End_kwd -> No_dec - | _ -> raise (Expect l)) - | Type_or_term_in_def (Unset,_) -> failwith "Bug: should not occur" - | Type_or_term_in_def (Term,Id) -> - let l = [Semi_colon;Type_or_term ARROW] in - l,(function - | (Id|Sym|Type_or_term (LPAR|RPAR|DOT|LAMBDA)) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) - | Semi_colon -> Lex (Lex_def No_lex_entry) - | End_kwd -> No_dec - | _ -> raise (Expect l)) - | Type_or_term_in_def (Term,Sym) -> - let l = [Type_or_term ARROW] in - l,(function - | (Id|Sym|Type_or_term (LPAR|LAMBDA)) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) - | _ -> raise (Expect l)) - | Type_or_term_in_def (Term,Type_or_term LPAR) -> - let l = [Type_or_term ARROW] in - l,(function - | (Id|Sym|Type_or_term (LPAR|LAMBDA)) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) - | _ -> raise (Expect l)) - | Type_or_term_in_def (Term,Type_or_term RPAR) -> - let l = [Semi_colon;Type_or_term ARROW] in - l,(function - | (Id|Sym|Type_or_term (LPAR|RPAR|LAMBDA)) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) - | Semi_colon -> Lex (Lex_def No_lex_entry) - | End_kwd -> No_dec - | _ -> raise (Expect l)) - | Type_or_term_in_def (Term,Type_or_term DOT) -> - let l = [Type_or_term ARROW] in - l,(function - | (Id|Sym|Type_or_term (LPAR|LAMBDA)) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) - | _ -> raise (Expect l)) - | Type_or_term_in_def (Term,Type_or_term LAMBDA) -> - let l = [Id] in - l,(function - | Id as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) - | _ -> raise (Expect l)) - | Type_or_term_in_def (Term,_) -> failwith "Bug: Should not occur" - | Type_or_term_in_def (Type,Id) -> - let l = [Semi_colon;Type_or_term RPAR;Type_or_term ARROW] in - l,(function - | End_kwd -> No_dec - | Semi_colon -> Lex (Lex_def No_lex_entry) - | Type_or_term (RPAR|ARROW) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Type,a))))) - | _ -> raise (Expect l)) - | Type_or_term_in_def (Type,Type_or_term LPAR) -> - let l = [Id;Type_or_term LPAR] in - l,(function - | (Id|Type_or_term LPAR) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Type,a))))) - | _ -> raise (Expect l)) - | Type_or_term_in_def (Type,Type_or_term RPAR) -> - let l = [Semi_colon;Type_or_term RPAR;Type_or_term ARROW] in - l,(function - | End_kwd -> No_dec - | Semi_colon -> Lex (Lex_def No_lex_entry) - | Type_or_term (RPAR|ARROW) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Type,a))))) - | _ -> raise (Expect l)) - | Type_or_term_in_def (Type,Type_or_term ARROW) -> - let l = [Id;Type_or_term LPAR] in - l,(function - | (Id|Type_or_term LPAR) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Type,a))))) - | _ -> raise (Expect l)) - | Type_or_term_in_def (Type,_) -> failwith "Bug:should not occur" - | Type_or_term_in_def (Nothing,_) -> failwith "Bug:should not occur" - - - - - + match ty_o_te with + | No_type_or_term_in_def -> + let l = [Id;Sym;Type_or_term LPAR;Type_or_term LAMBDA] in + l,(function + | (Id|Type_or_term LPAR) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Unset,a))))) + | (Sym|Type_or_term LAMBDA) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) + | _ -> raise (Expect [Type_or_term LPAR])) + | Type_or_term_in_def (Unset,Id) -> + let l = [Type_or_term LPAR;Semi_colon] in + l,(function + | (Id|Sym|Type_or_term (LPAR|DOT|LAMBDA)) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) + | Type_or_term RPAR as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Unset,a))))) + | Type_or_term ARROW as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Type,a))))) + | Semi_colon -> Lex (Lex_def No_lex_entry) + | End_kwd -> No_dec + | _ -> raise (Expect l)) + | Type_or_term_in_def (Unset,Type_or_term LPAR) -> + let l = [Type_or_term LPAR] in + l,(function + | (Sym|Type_or_term LAMBDA) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) + | (Id|Type_or_term LPAR) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Unset,a))))) + | _ -> raise (Expect l)) + | Type_or_term_in_def (Unset,Type_or_term RPAR) -> + let l = [Type_or_term LPAR;Semi_colon] in + l,(function + | (Id|Sym|Type_or_term (LPAR|LAMBDA)) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) + | (Type_or_term RPAR) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Unset,a))))) + | (Type_or_term ARROW) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Type,a))))) + | Semi_colon -> Lex (Lex_def No_lex_entry) + | End_kwd -> No_dec + | _ -> raise (Expect l)) + | Type_or_term_in_def (Unset,_) -> failwith "Bug: should not occur" + | Type_or_term_in_def (Term,Id) -> + let l = [Semi_colon;Type_or_term ARROW] in + l,(function + | (Id|Sym|Type_or_term (LPAR|RPAR|DOT|LAMBDA)) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) + | Semi_colon -> Lex (Lex_def No_lex_entry) + | End_kwd -> No_dec + | _ -> raise (Expect l)) + | Type_or_term_in_def (Term,Sym) -> + let l = [Type_or_term ARROW] in + l,(function + | (Id|Sym|Type_or_term (LPAR|LAMBDA)) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) + | _ -> raise (Expect l)) + | Type_or_term_in_def (Term,Type_or_term LPAR) -> + let l = [Type_or_term ARROW] in + l,(function + | (Id|Sym|Type_or_term (LPAR|LAMBDA)) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) + | _ -> raise (Expect l)) + | Type_or_term_in_def (Term,Type_or_term RPAR) -> + let l = [Semi_colon;Type_or_term ARROW] in + l,(function + | (Id|Sym|Type_or_term (LPAR|RPAR|LAMBDA)) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) + | Semi_colon -> Lex (Lex_def No_lex_entry) + | End_kwd -> No_dec + | _ -> raise (Expect l)) + | Type_or_term_in_def (Term,Type_or_term DOT) -> + let l = [Type_or_term ARROW] in + l,(function + | (Id|Sym|Type_or_term (LPAR|LAMBDA)) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) + | _ -> raise (Expect l)) + | Type_or_term_in_def (Term,Type_or_term LAMBDA) -> + let l = [Id] in + l,(function + | Id as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Term,a))))) + | _ -> raise (Expect l)) + | Type_or_term_in_def (Term,_) -> failwith "Bug: Should not occur" + | Type_or_term_in_def (Type,Id) -> + let l = [Semi_colon;Type_or_term RPAR;Type_or_term ARROW] in + l,(function + | End_kwd -> No_dec + | Semi_colon -> Lex (Lex_def No_lex_entry) + | Type_or_term (RPAR|ARROW) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Type,a))))) + | _ -> raise (Expect l)) + | Type_or_term_in_def (Type,Type_or_term LPAR) -> + let l = [Id;Type_or_term LPAR] in + l,(function + | (Id|Type_or_term LPAR) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Type,a))))) + | _ -> raise (Expect l)) + | Type_or_term_in_def (Type,Type_or_term RPAR) -> + let l = [Semi_colon;Type_or_term RPAR;Type_or_term ARROW] in + l,(function + | End_kwd -> No_dec + | Semi_colon -> Lex (Lex_def No_lex_entry) + | Type_or_term (RPAR|ARROW) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Type,a))))) + | _ -> raise (Expect l)) + | Type_or_term_in_def (Type,Type_or_term ARROW) -> + let l = [Id;Type_or_term LPAR] in + l,(function + | (Id|Type_or_term LPAR) as a -> Lex (Lex_def (Lex_entry_id (Interpretation (Type_or_term_in_def (Type,a))))) + | _ -> raise (Expect l)) + | Type_or_term_in_def (Type,_) -> failwith "Bug:should not occur" + | Type_or_term_in_def (Nothing,_) -> failwith "Bug:should not occur" + + + + + let data_transition q v = let _,result = data_expectation q in result v diff --git a/src/grammars/entry.mli b/src/grammars/entry.mli index 9e504cbdf25dc296dc894c6a2dec82cc5c1a0276..a58e8fdd26258c9143108f8cdb5be9d2a6751544 100644 --- a/src/grammars/entry.mli +++ b/src/grammars/entry.mli @@ -33,6 +33,12 @@ sig *) type term + (** The type for the automaton corresponding to the type being + parsed so far (it is intented to be used in some interaction + process) *) + type stype + + (** The type of the tokens or valuation found on the edges of the automaton *) type valuation = @@ -41,6 +47,7 @@ sig | Lex_kwd | Id | Equal + | Compose | Comma | Colon | Colon_equal @@ -71,6 +78,10 @@ sig initial state of the automaton *) val start_term : unit -> term + (** [start_term ()] returns an empty type corresponding to the + initial state of the automaton *) + val start_type : unit -> stype + (** [start_sig_entry ()] returns a data corresponding to the state of the automaton for entering a sig entry *) val start_sig_entry : unit -> data @@ -86,6 +97,11 @@ sig from [d] with valuation [v] *) val term_transition : term -> valuation -> term + (** [type_transition d v] returns the state of the automaton reached + from [d] with valuation [v] *) + val type_transition : stype -> valuation -> stype + + (** [valuation_to_string v] returns a tring describing it *) val valuation_to_string : valuation -> string diff --git a/src/grammars/environment.ml b/src/grammars/environment.ml index 809cf65e0a9c6858964321996bc2a343fb77fbb0..d2879e06e3a9cfc7c76d817cb155694e79c3cf54 100644 --- a/src/grammars/environment.ml +++ b/src/grammars/environment.ml @@ -29,7 +29,9 @@ sig exception Entry_not_found of string - module Signature1:Signature_sig +(* module Signature1:Signature_sig*) + + module Signature1:Signature_sig with type term=Lambda.Lambda.term module Lexicon:Interface.Lexicon_sig with type Signature.t=Signature1.t and type Signature.term=Signature1.term and type Signature.stype=Signature1.stype @@ -41,7 +43,8 @@ sig val insert : ?override:bool -> entry -> t -> t val get_signature : string -> t -> Signature1.t val get_lexicon : string -> t -> Lexicon.t - val get : string -> t -> entry + val get : string -> t -> entry + val append : ?override:bool -> t -> t -> t val iter : (entry -> unit) -> t -> unit val fold : (entry -> 'a -> 'a) -> 'a -> t -> 'a val sig_number : t -> int @@ -76,6 +79,40 @@ struct let empty = {map=Env.empty;sig_number=0;lex_number=0;focus=None} + let append ?(override=false) e1 e2 = + let erased_sig = ref 0 in + let erased_lex = ref 0 in + let new_map = + Env.merge + (fun k v1 v2 -> + match v1,v2,override with + | None,None,_ -> None + | None,Some v,_ -> Some v + | Some v,None,_ -> Some v + | Some (Lexicon _),Some v2,true -> + let () = erased_lex:=!erased_lex+1 in + Some v2 + | Some (Signature _),Some v2,true -> + let () = erased_sig:=!erased_sig+1 in + Some v2 + | Some v1,Some v2,false -> + match v2 with + | Signature sg -> + let _,pos=Sg.name sg in + raise (Error.Error (Error.Env_error (Error.Duplicated_entry k,pos))) + | Lexicon lex -> + let _,pos=Lex.name lex in + raise (Error.Error (Error.Env_error (Error.Duplicated_entry k,pos)))) + e1.map + e2.map in + {map=new_map; + sig_number=e1.sig_number + e2.sig_number - !erased_sig; + lex_number=e1.lex_number + e2.lex_number - !erased_lex; + focus = match e2.focus with + | Some e -> Some e + | None -> e1.focus} + + let insert ?(override=false) d e = match d with | Signature s -> let name,(p1,p2) = Sg.name s in if (not (Env.mem name e.map))||override diff --git a/src/grammars/environment.mli b/src/grammars/environment.mli index 88cd585e938e990ad6700c22a2d11a4aad17178e..63bfe7a5cc76dc09336a389c32e72d46365dbe44 100644 --- a/src/grammars/environment.mli +++ b/src/grammars/environment.mli @@ -38,7 +38,7 @@ sig (** The modules implementing the signatures and the lexicons managed by the environment *) - module Signature1:Signature_sig + module Signature1:Signature_sig with type term=Lambda.Lambda.term module Lexicon:Interface.Lexicon_sig with type Signature.t=Signature1.t and type Signature.term=Signature1.term and type Signature.stype=Signature1.stype (** The type of the environment *) @@ -68,8 +68,18 @@ sig signature does not exist *) val get_lexicon : string -> t -> Lexicon.t + (** [get name e] returns the entry of name [name] in the environment + [e]. Raise {!Environment.Environment_sig.Lexicon_not_found} if + such an entry does not exist. *) val get : string -> t -> entry + (** [append e1 e2] merges the two environment [e1] and [e2]. If an + entry appears in both environment then the one of [e2] is kept + if the [override] parameter is set to [true] (default is + [false]). If set to [false], if an enrtry appears in both + environment, an error is emitted. *) + val append : ?override:bool -> t -> t -> t + (** [iter f e] applies f to every data contained in the environment *) val iter : (entry -> unit) -> t -> unit diff --git a/src/grammars/error.ml b/src/grammars/error.ml index 7feb5c04e063eca1237f8db3e5b4ecb94bc8e071..344ba8d67c9daec77da42648812c21f223a00c12 100644 --- a/src/grammars/error.ml +++ b/src/grammars/error.ml @@ -58,6 +58,7 @@ type parse_error = | Unknown_type of string | Missing_arg_of_Infix of string | No_such_signature of string + | No_such_lexicon of string | Dyp_error type type_error = @@ -80,6 +81,7 @@ type type_error = type env_error = | Duplicated_signature of string | Duplicated_lexicon of string + | Duplicated_entry of string type lexicon_error = @@ -130,6 +132,7 @@ let parse_error_to_string = function | Unknown_type id -> Printf.sprintf "Syntax error: Unknown atomic type \"%s\"" id | Missing_arg_of_Infix id -> Printf.sprintf "Syntax error: \"%s\" is defined as infix but used here with less than two arguments" id | No_such_signature s -> Printf.sprintf "Syntax error: Signature id \"%s\" not in the current environment" s + | No_such_lexicon s -> Printf.sprintf "Syntax error: Lexicon id \"%s\" not in the current environment" s | Dyp_error -> "Dyp: Syntax error" let type_error_to_string = function @@ -159,6 +162,7 @@ let type_error_to_string = function let env_error_to_string = function | Duplicated_signature s -> Printf.sprintf "Syntax error: Signature id \"%s\" is used twice in this environment" s | Duplicated_lexicon s -> Printf.sprintf "Syntax error: Lexicon id \"%s\" is used twice in this environment" s + | Duplicated_entry s -> Printf.sprintf "Syntax error: Entry id \"%s\" is used twice in this environment" s let lexicon_error_to_string = function | Missing_interpretations (lex_name,abs_name,missing_inters) -> diff --git a/src/grammars/error.mli b/src/grammars/error.mli index c2acd87335173527da5b633e5646e98262488532..889bf1fed3f04ebcd670b0c2e9e416a1b9f3d8c4 100644 --- a/src/grammars/error.mli +++ b/src/grammars/error.mli @@ -41,6 +41,7 @@ type parse_error = | Unknown_type of string | Missing_arg_of_Infix of string | No_such_signature of string + | No_such_lexicon of string | Dyp_error (** The types for errors raised by the typechecker. Names should be @@ -71,6 +72,7 @@ type lexicon_error = type env_error = | Duplicated_signature of string | Duplicated_lexicon of string + | Duplicated_entry of string (** The type for errors *) diff --git a/src/grammars/interactive.ml b/src/grammars/interactive.ml index bcf976a1da6101ab9bb4e7eee2a2c4407fa9d252..2f63cd1204f412da090445f303378b37d2e0079a 100644 --- a/src/grammars/interactive.ml +++ b/src/grammars/interactive.ml @@ -23,15 +23,22 @@ let interactive = ref false let dirs = ref [""] +type status = Failure | Success + +let status = ref Success + +let output_name = ref None + let options = [ - ("-version", Arg.Unit (fun () -> Printf.printf "%s\n" Version.version;exit 0), " Prints the version number"); + ("-version", Arg.Unit (fun () -> Printf.printf "%s\n" Version.version;exit 0), Format.sprintf "@[Prints the version number@]"); + ("-o", Arg.String (fun name -> output_name:=Some name) , Format.sprintf "@[-o @[file_name sets the name of the ouput file to \"file_name\".@ The default is to use the base name@ (with no extension)@ of the first file argument with the suffix \".acgo\"@]@]"); ("-i", Arg.Set interactive , " Enters the interaction loop to parse terms according to signatures"); ("-I", Arg.String (fun dir -> dirs := (!dirs)@[dir]) , " -I dir sets dir as a directory in which file arguments can be looked for") ] -let usg_msg = Printf.sprintf "%s [options] file1 file2 ...\n\nThis will parse the files which are supposed to be files containing acg signatures or lexicons." Sys.executable_name +let usg_msg = Format.sprintf "@[usage:\n@[\t%s [options] file1 file2 ...@]@.@[This command parse the files which are supposed to be files containing acg signatures or lexicons.@ If all the parses are successful, a binary containing all the acg signatures and lexicons is created.@ Its default name is \"file1.acgo\"@ (see option -o).@ Files should have suffix \".acg\".@]" Sys.executable_name module Make(Lex:Interface.Lexicon_sig) = struct @@ -42,83 +49,118 @@ struct module Actual_parser = Data_parser.Make(Actual_env) - let parse_term sg = let t = ref None in let rec parse_rec = function | true -> - let () = Printf.printf "Enter a term: " in - let term_string = read_line () in - (match Actual_parser.parse_term term_string sg with - | None -> parse_rec true - | Some ta -> let () = t:= (Some ta) in false ) + let () = Printf.printf "Enter a term: " in + let term_string = read_line () in + (match Actual_parser.parse_term term_string sg with + | None -> parse_rec true + | Some ta -> let () = t:= (Some ta) in false ) | false -> false in let () = while (parse_rec true) do () done in - match !t with - | Some u -> u - | _ -> failwith "Strange..." - - - let parse filename = - env := Actual_parser.parse_data filename !dirs !env + match !t with + | Some u -> u + | _ -> failwith "Strange..." + let parse filename = + if !status=Failure then + () + else + if not (Filename.check_suffix filename ".acg") then + let () = Printf.fprintf stderr "File name's suffixes should be \".acg\". The name \"%s\" has not this suffix.\n" filename in + status:=Failure + else + let () = + match !output_name with + | None -> + let basename=Filename.basename filename in + let name_wo_suffix = Filename.chop_suffix basename ".acg" in + output_name:=Some (Printf.sprintf "%s.acgo" name_wo_suffix) + | Some _ -> () in + match Actual_parser.parse_data filename !dirs !env with + | None -> status:=Failure + | Some e -> env:=e + + let term_parsing i env = - let n = Actual_env.sig_number env in - let m = Actual_env.lex_number env in - let available_data = - Utils.string_of_list - "\n" - (fun x -> x) - (Actual_env.fold - (fun d a -> - match d with - | Actual_env.Signature sg -> (Printf.sprintf "\tSignature\t%s" (fst (Actual_env.Signature1.name sg)))::a - | Actual_env.Lexicon lx -> (Printf.sprintf "\tLexicon\t\t%s" (fst (Actual_env.Lexicon.name lx)))::a) - [] - env) in - let chosen_sig=Actual_env.choose_signature env in - let chosen_sig_name_loaded = - match chosen_sig with + if not i then + () + else + let n = Actual_env.sig_number env in + let m = Actual_env.lex_number env in + let available_data = + Utils.string_of_list + "\n" + (fun x -> x) + (Actual_env.fold + (fun d a -> + match d with + | Actual_env.Signature sg -> (Printf.sprintf "\tSignature\t%s" (fst (Actual_env.Signature1.name sg)))::a + | Actual_env.Lexicon lx -> (Printf.sprintf "\tLexicon\t\t%s" (fst (Actual_env.Lexicon.name lx)))::a) + [] + env) in + let chosen_sig=Actual_env.choose_signature env in + let chosen_sig_name_loaded = + match chosen_sig with | None -> "" | Some s -> Printf.sprintf "Signature \"%s\" loaded." (fst (Sg.name s)) in - if (n+m=0) || (not !i) + if (n+m=0) || (not i) then () else try let () = if (n=1)&&(m=0) then Printf.printf "%s\n" chosen_sig_name_loaded else () in - while true do - try - let () = Printf.printf "Available data:\n%s\n" available_data in - let entry = - match n,chosen_sig with - | 1, Some s -> Actual_env.Signature s - | _,_ -> - let () = Printf.printf "Enter a name: " in - let sig_string = read_line () in - Actual_env.get sig_string env in - match entry with - | Actual_env.Signature sg -> ignore (parse_term sg) - | Actual_env.Lexicon lex -> - let abs,obj=Actual_env.Lexicon.get_sig lex in - let t,ty = parse_term abs in - let t',ty'=Actual_env.Lexicon.interpret t ty lex in - Printf.printf - "Interpreted as:\n%s : %s\n" - (Actual_env.Signature1.term_to_string t' obj) - (Actual_env.Signature1.type_to_string ty' obj) - with - | Actual_env.Signature_not_found sig_name -> Printf.printf "No such signature in %s\n" sig_name - done + while true do + try + let () = Printf.printf "Available data:\n%s\n" available_data in + let entry = + match n,chosen_sig with + | 1, Some s -> Actual_env.Signature s + | _,_ -> + let () = Printf.printf "Enter a name: " in + let sig_string = read_line () in + Actual_env.get sig_string env in + match entry with + | Actual_env.Signature sg -> ignore (parse_term sg) + | Actual_env.Lexicon lex -> + let abs,obj=Actual_env.Lexicon.get_sig lex in + let t,ty = parse_term abs in + let t',ty'=Actual_env.Lexicon.interpret t ty lex in + Printf.printf + "Interpreted as:\n%s : %s\n" + (Actual_env.Signature1.term_to_string t' obj) + (Actual_env.Signature1.type_to_string ty' obj) + with + | Actual_env.Signature_not_found sig_name -> Printf.printf "No such signature in %s\n" sig_name + done with - | End_of_file -> let () = print_newline () in () - + | End_of_file -> let () = print_newline () in () + + + let output_env name env = + let outch=open_out name in + let () = output_value outch env in + let () = close_out outch in + Printf.printf "Output written on: \"%s\"\n%!" name + let main () = let () = Arg.parse options parse usg_msg in - term_parsing interactive !env + if !status = Success then + match !output_name with + | None -> + let () = Printf.fprintf stderr "No ouput file is produced\n" + in 0 + | Some n -> + let () = output_env n !env in + let () = term_parsing !interactive !env in + 0 + else + 1 end diff --git a/src/grammars/interactive.mli b/src/grammars/interactive.mli index abb7131348b9311527cfa526f663ddc690fb3897..cd500818b51fa21fa86c7ab3ed8b6942e6432418 100644 --- a/src/grammars/interactive.mli +++ b/src/grammars/interactive.mli @@ -23,5 +23,5 @@ lexicon module *) module Make(Lex:Interface.Lexicon_sig) : sig - val main : unit -> unit + val main : unit -> int end diff --git a/src/grammars/interface.ml b/src/grammars/interface.ml index 1ab7fc817c9a1df1c782db9f556c3c2e53499760..61b70c91564b49d73247b0cb1d77f8c221867f3c 100644 --- a/src/grammars/interface.ml +++ b/src/grammars/interface.ml @@ -43,6 +43,9 @@ sig (* val type_to_string : stype -> t -> string*) val unfold_type_definition : int -> t -> Lambda.stype val unfold_term_definition : int -> t -> Lambda.term + val expand_type : Lambda.stype -> t -> Lambda.stype + val expand_term : Lambda.term -> t -> Lambda.term + val add_warnings : Error.warning list -> t -> t val get_warnings : t -> Error.warning list val to_string : t -> string @@ -57,6 +60,8 @@ sig val is_declared : entry -> t -> string option val eta_long_form : term -> stype -> t -> term val unfold : term -> t -> term + val is_2nd_order : t -> bool + end module type Lexicon_sig = @@ -65,16 +70,22 @@ sig exception Duplicate_constant_interpretation type t - module Signature:Signature_sig + module Signature:Signature_sig with type term=Lambda.term type signature = Signature.t + type resume val empty : (string*Abstract_syntax.location) -> abs:signature -> obj:signature -> t val name : t -> (string*Abstract_syntax.location) val insert : Abstract_syntax.lex_entry -> t -> t val to_string : t -> string - val interpret_type : Lambda.stype -> t -> Lambda.stype + val interpret_type : Signature.stype -> t -> Signature.stype +(* val interpret_type : Lambda.stype -> t -> Lambda.stype *) val interpret_term : Lambda.term -> t -> Lambda.term val interpret : Signature.term -> Signature.stype -> t -> (Signature.term*Signature.stype) val get_sig : t -> (signature*signature) val check : t -> unit + val parse : Signature.term -> Signature.stype -> t -> resume + val get_analysis : resume -> t -> Lambda.term option * resume val compose: t -> t -> (string*Abstract_syntax.location) -> t + val program_to_buffer : t -> Buffer.t + val query_to_buffer : Signature.term -> Signature.stype -> t -> Buffer.t end diff --git a/src/grammars/interface.mli b/src/grammars/interface.mli index 31b483b16bc89460f07dd66bfe1cbdc0ead8900a..7e4cfde7430c52201be1cc6e0ed07b5086ceb8b9 100644 --- a/src/grammars/interface.mli +++ b/src/grammars/interface.mli @@ -85,18 +85,27 @@ sig val term_to_string : term -> t -> string (** [unfold_type_definition id t] returns the actual type for the - type defined by [Lambda.DAtom id]. Fails with "Bug" if [id] does - not correspond to a type definition *) - - val unfold_type_definition : int -> t -> Lambda.stype + type defined by [id] as the identifier of a type definition in + the signature [t]. Fails with "Bug" if [id] does not correspond + to a type definition *) + val unfold_type_definition : int -> t -> Lambda.stype (** [unfold_term_definition id t] returns the actual term for the - term defined by [Lambda.DConst id]. Fails with "Bug" if [id] - does not correspond to a term definition *) - - val unfold_term_definition : int -> t -> Lambda.term - - (** [add_warnings w s ] resturns a signature where the warning [w] have been added *) + term defined by [id] as the identifier of a term definition in + the signature [t]. Fails with "Bug" if [id] does not correspond + to a term definition *) + val unfold_term_definition : int -> t -> Lambda.term + + (** [expand_type t sg] returns a type where all the type + definitions have been expanded *) + val expand_type : Lambda.stype -> t -> Lambda.stype + + (** [expand_term t sg] returns a term where all the term + definitions have been expanded *) + val expand_term : Lambda.term -> t -> Lambda.term + + (** [add_warnings w s ] resturns a signature where the warning [w] + have been added *) val add_warnings : Error.warning list -> t -> t (** [get_warnings sg] returns the warnigs emitted while parsing [sg]. *) @@ -108,22 +117,22 @@ sig (** [term_to_string t sg] returns a string describing the term [t] wrt the signature [sg]. *) -(* val term_to_string : term -> t -> string *) -(* val raw_to_string : term -> string*) - + (* val term_to_string : term -> t -> string *) + (* val raw_to_string : term -> string*) + (** [type_to_string t sg] returns a string describing the term [t] wrt the signature [sg]. *) -(* val type_to_string : stype -> t -> string *) + (* val type_to_string : stype -> t -> string *) (** [convert_term t ty sg] returns a the term corresponding to the parsed term [t] with parsed type [ty] wrt to the signature [sg] *) val convert_term : Abstract_syntax.term -> Abstract_syntax.type_def -> t -> term * stype - + (** [convert_type ty sg] returns a type to the parsed type [ty] wrt to the signature [sg] *) val convert_type : Abstract_syntax.type_def -> t -> stype - + (** [type_of_constant n sg] returns the type of the constant of name [n] as defined in the signature [sg] *) val type_of_constant : string -> t -> stype @@ -157,6 +166,10 @@ sig val unfold : term -> t -> term + (** [is_2nd_order s] returns [true] if the signature [s] is 2nd + order and [false] otherwise. *) + val is_2nd_order : t -> bool + end (** This module signature describes the interface for modules implementing lexicons *) @@ -166,17 +179,24 @@ sig exception Duplicate_constant_interpretation type t - module Signature:Signature_sig + module Signature:Signature_sig with type term=Lambda.term type signature = Signature.t + type resume val empty : (string*Abstract_syntax.location) -> abs:signature -> obj:signature -> t val name : t -> (string*Abstract_syntax.location) val insert : Abstract_syntax.lex_entry -> t -> t val to_string : t -> string - val interpret_type : Lambda.stype -> t -> Lambda.stype + val interpret_type : Signature.stype -> t -> Signature.stype val interpret_term : Lambda.term -> t -> Lambda.term val interpret : Signature.term -> Signature.stype -> t -> (Signature.term*Signature.stype) val get_sig : t -> (signature*signature) val check : t -> unit + (** [parse t stype lex] tries to parse the (object) term [t] and + find it an antecedent of type [stype] by [lex] *) + val parse : Signature.term -> Signature.stype -> t -> resume + val get_analysis : resume -> t -> Lambda.term option * resume val compose: t -> t -> (string*Abstract_syntax.location) -> t + val program_to_buffer : t -> Buffer.t + val query_to_buffer : Signature.term -> Signature.stype -> t -> Buffer.t end diff --git a/src/logic/Makefile.in b/src/logic/Makefile.in index 51938cbb6b84896ed70ae884ef51a1239cfb1765..8cf9407cbb337eaaa3bdb1468ddf349a76554d70 100644 --- a/src/logic/Makefile.in +++ b/src/logic/Makefile.in @@ -26,21 +26,22 @@ include ../Makefile.master ############################### # Used libraries -LIBS += dyp.cma str.cma +LIBS += dyp.cma str.cma @KAPUTT_LIB@ # The corresponding directories # (if not in the main ocaml lib directory, # ex. -I +campl4 -LIBDIR = @DYPGEN_INCLUDE@ -I +camlp4 +LIBDIR += @DYPGEN_INCLUDE@ @KAPUTT_INCLUDE@ # Directories to which the current source files depend on PREVIOUS_DIRS = ../utils # Source files in the right order of dependance #ML = error.ml abstract_syntax.ml interface.ml environment.ml entry.ml parser.ml lexer.ml data_parsing.ml -ML = abstract_syntax.ml lambda.ml type_inference.ml +ML = abstract_syntax.ml lambda.ml type_inference.ml varUnionFind.ml typeInference.ml -EXE_SOURCES = type_inference_test.ml +#EXE_SOURCES = type_inference_test.ml typeInference_test.ml +EXE_SOURCES = typeInference_test.ml #################################### # # diff --git a/src/logic/bolt.config b/src/logic/bolt.config new file mode 100644 index 0000000000000000000000000000000000000000..4e44886f03e272e230bfb96b1f73d23d8c40952a --- /dev/null +++ b/src/logic/bolt.config @@ -0,0 +1,9 @@ +logger "" { + level = trace; + filter = all; + layout = default; + mode = direct; + output = file; + name = "typeInference_test.log"; +} + diff --git a/src/logic/lambda.ml b/src/logic/lambda.ml index b67f76e279aa2467fd2bb0576c910761c144dd34..526f12279320a0a79d19cb9756785a1c5ea3894b 100644 --- a/src/logic/lambda.ml +++ b/src/logic/lambda.ml @@ -230,7 +230,8 @@ module Lambda = let rec raw_to_string_aux = function - | (Var i | LVar i) -> Printf.sprintf "(%d)" i,true + | Var i -> Printf.sprintf "(nl: %d)" i,true + | LVar i -> Printf.sprintf "(l:%d)" i,true | (Const i | DConst i)-> Printf.sprintf "[%d]" i,true | Abs (_,t) -> Printf.sprintf "Lambda.%s" (fst (raw_to_string_aux t)),false @@ -240,6 +241,34 @@ module Lambda = let raw_to_string t = fst (raw_to_string_aux t) + let rec raw_to_caml = function + | Var i -> Printf.sprintf "(Var %d)" i + | LVar i -> Printf.sprintf "(LVar %d)" i + | Const i -> Printf.sprintf "(Const %d)" i + | DConst i-> Printf.sprintf "(DConst %d)" i + | Abs (x,t) -> Printf.sprintf "(Abs (\"%s\",%s))" x (raw_to_caml t) + | LAbs (x,t) -> Printf.sprintf "(LAbs (\"%s\",%s))" x (raw_to_caml t) + | App (t,u) -> Printf.sprintf "(App (%s,%s))" (raw_to_caml t) (raw_to_caml u) + | _ -> raise Not_yet_implemented + + + let rec raw_type_to_string_aux = function + | Atom i -> Printf.sprintf "(%d)" i,true + | DAtom i -> Printf.sprintf "[%d]" i,true + | LFun (alpha,beta) -> Printf.sprintf "%s -> %s" (parenthesize (raw_type_to_string_aux alpha)) (parenthesize (raw_type_to_string_aux beta)),false + | Fun (alpha,beta) -> Printf.sprintf "%s => %s" (parenthesize (raw_type_to_string_aux alpha)) (fst (raw_type_to_string_aux beta)),false + | _ -> failwith "Bug: Not yet implemented" + + let raw_type_to_string t = fst (raw_type_to_string_aux t) + + let rec raw_type_to_caml = function + | Atom i -> Printf.sprintf "(Atom %d)" i + | DAtom i -> Printf.sprintf "(DAtom %d)" i + | LFun (alpha,beta) -> Printf.sprintf "(LFun (%s,%s))" (raw_type_to_caml alpha) (raw_type_to_caml beta) + | Fun (alpha,beta) -> Printf.sprintf "(Fun (%s,%s))" (raw_type_to_caml alpha) (raw_type_to_caml beta) + | _ -> failwith "Bug: Not yet implemented" + + (* [is_linear tm] true if the lambda-term [tm] is such *) (* that "x" occurs linearly in "lambda x. tm", i.e., *) @@ -569,6 +598,21 @@ module Lambda = normalize t' + (* We assume here that types in [ty] have been unfolded*) + let rec order stype f_unfold_defined_type = + match stype with + | Atom _ -> 1 + | DAtom i -> order (f_unfold_defined_type i) f_unfold_defined_type + | LFun (alpha,beta) -> max ((order alpha f_unfold_defined_type)+1) (order beta f_unfold_defined_type) + | Fun (alpha,beta) -> max ((order alpha f_unfold_defined_type)+1) (order beta f_unfold_defined_type) + | _ -> failwith "Bug: order of type not defined for this type constructor" + + + let is_2nd_order stype f_unfold_defined_type = + (order stype f_unfold_defined_type)<=2 + end + + diff --git a/src/logic/lambda.mli b/src/logic/lambda.mli index 51c6f360184679c8eb4891166352f06aeb8c87c1..2d9664866d10ebda0e731cd8a16155262454cc26 100644 --- a/src/logic/lambda.mli +++ b/src/logic/lambda.mli @@ -69,15 +69,27 @@ sig val type_to_string : stype -> (int -> Abstract_syntax.syntactic_behavior * string ) -> string val term_to_string : term -> (int -> Abstract_syntax.syntactic_behavior * string) -> string val raw_to_string : term -> string + + val raw_type_to_string : stype -> string + val raw_to_caml : term -> string + val raw_type_to_caml : stype -> string + val normalize : ?id_to_term:(int -> term) -> term -> term (** [eta_long_form t ty type_of_cst] returns the eta-long form of [t] with respect of type [ty]. [t] is supposed to be in beta-normal form and all the definitions of [t] and [ty] should - have been unfolded. [type_of_cst i] is a function that returns + have been unfolded. [type_of_cst i] returns the type (with unfolded definitions) of the constant whose id is [i]. [i] is supposed to be an actual id of a constant.*) val eta_long_form : term -> stype -> (int -> stype) -> term + (** [is_2nd_order ty type_definition] returns [true] if [ty] is 2nd + order. [ty] should have been unfolded and [type_definition i] is + returns the unfolded type of a defined type ([DAtom]) whose id + is [i]. [i] is supposed to be an actual id of such a defined type.*) + val is_2nd_order : stype -> (int -> stype) -> bool + + end diff --git a/src/logic/typeInference.ml b/src/logic/typeInference.ml new file mode 100644 index 0000000000000000000000000000000000000000..7b8b968aad8734f2367a48ef173f0034bec43942 --- /dev/null +++ b/src/logic/typeInference.ml @@ -0,0 +1,153 @@ +open Utils +open Lambda + +module Value = +struct + + type t=int + type value = Lambda.stype + let unfold stype _ = + match stype with + | Lambda.Atom _ -> None + | Lambda.LFun (a,b) -> Some (1,[a;b]) + | Lambda.Fun (a,b) -> Some (1,[a;b]) + | _ -> failwith "Bug: No type inference on these types" + + +end + + + +module UF=VarUnionFind.UF(Value) + +module Type = +struct + + exception Not_typable + + type typing_env={l_level:int; + nl_level:int; + lvar_typing:int IntMap.t; + nlvar_typing:int IntMap.t; + const_typing:(int*int) IntMap.t; + (* maps the occurrence position, which is unique, + to a pair consisting of the type variable and the + constant identifier *) + cst_nbr:int; + type_equations:UF.t;} + + let empty_env= {l_level=0; + nl_level=0; + lvar_typing=IntMap.empty; + nlvar_typing=IntMap.empty; + const_typing=IntMap.empty; + cst_nbr=0; + type_equations=UF.empty;} + + let type_equation_log prefix eq = + Utils.log_iteration + (fun s -> LOG "%s%s" prefix s LEVEL TRACE) + (UF.to_string eq) + + + let rec inference_aux level t ty_var env = + let prefix=String.make (level*3) ' ' in + LOG "%sType inference of %s (currently %d). Equations are:" prefix (Lambda.raw_to_string t) ty_var LEVEL TRACE ; + type_equation_log prefix env.type_equations; + let ty,new_env = + match t with + | Lambda.Var i -> + (try + let ty_in_env=IntMap.find (env.nl_level-i-1) env.nlvar_typing in + LOG "%sAdding an equation (variable found in the environment) %d<-->%d" prefix ty_var ty_in_env LEVEL TRACE ; + let new_eq=UF.union ty_var ty_in_env env.type_equations in + ty_var,{env with type_equations=new_eq} + with + | Not_found -> + let new_var,new_eq=UF.generate_new_var env.type_equations in + LOG "%sAdding a new variable %d and an equation" prefix new_var LEVEL TRACE ; + new_var,{env with nlvar_typing=IntMap.add i new_var env.nlvar_typing; type_equations=new_eq}) + | Lambda.LVar i -> + (try + let ty_in_env=IntMap.find (env.l_level-i-1) env.lvar_typing in + LOG "%sAdding an equation (Lvariable found in the environment) %d<-->%d" prefix ty_var ty_in_env LEVEL TRACE ; + let new_eq=UF.union ty_var (IntMap.find (env.l_level-i-1) env.lvar_typing) env.type_equations in + ty_var,{env with type_equations=new_eq} + with + | Not_found -> + let new_var,new_eq=UF.generate_new_var env.type_equations in + LOG "%sAdding a new Lvariable %d and an equation" prefix new_var LEVEL TRACE ; + new_var,{env with lvar_typing=IntMap.add i new_var env.lvar_typing; type_equations=new_eq}) + | Lambda.Const i -> + (* Each occurence of a constants is considered as a new free + variables *) + let new_var,new_eq=UF.generate_new_var env.type_equations in + let new_eq=UF.union ty_var new_var new_eq in + new_var,{env with type_equations=new_eq;const_typing=IntMap.add (env.cst_nbr+1) (new_var,i) env.const_typing;cst_nbr=env.cst_nbr+1} + | Lambda.DConst _ -> failwith "Bug: there should not remain any defined constant when computing the principal type" + | Lambda.Abs (x,t) -> + LOG "%sType inference of an abstraction:" prefix LEVEL TRACE; + let alpha,new_eq=UF.generate_new_var env.type_equations in + LOG "%sAdded a variable at %d. Equations are:" prefix alpha LEVEL TRACE ; + let () = type_equation_log prefix new_eq in + let beta,new_eq=UF.generate_new_var new_eq in + LOG "%sAdded a variable at %d. Equations are:" prefix beta LEVEL TRACE ; + let () = type_equation_log prefix new_eq in + let new_const,new_eq=UF.generate_new_constr new_eq (1,[alpha;beta]) in + LOG "%sAdded new const at %d. Equations are:" prefix new_const LEVEL TRACE ; + let () = type_equation_log prefix new_eq in + LOG "%sPreparing a Union %d %d." prefix ty_var new_const LEVEL TRACE ; + let new_eq=UF.union ty_var new_const new_eq in + LOG "%sAdded a varibale at %d. Equations are:" prefix beta LEVEL TRACE ; + type_equation_log prefix new_eq; + let _,new_env=inference_aux (level+1) t beta {env with nl_level=env.nl_level+1;nlvar_typing=IntMap.add env.nl_level alpha env.nlvar_typing;type_equations=new_eq} in + let is_cyclic,new_eq=UF.cyclic ty_var new_env.type_equations in + ty_var,{env with type_equations=new_eq;const_typing=new_env.const_typing;cst_nbr=new_env.cst_nbr} + | Lambda.LAbs (x,t) -> + LOG "%sType inference of a linear abstraction:" prefix LEVEL TRACE; + let alpha,new_eq=UF.generate_new_var env.type_equations in + let beta,new_eq=UF.generate_new_var new_eq in + let new_const,new_eq=UF.generate_new_constr new_eq (1,[alpha;beta]) in + let new_eq=UF.union ty_var new_const new_eq in + let _,new_env=inference_aux (level+1) t beta {env with l_level=env.l_level+1;lvar_typing=IntMap.add env.l_level alpha env.lvar_typing;type_equations=new_eq} in + let is_cyclic,new_eq=UF.cyclic ty_var new_env.type_equations in + ty_var,{env with type_equations=new_eq;const_typing=new_env.const_typing;cst_nbr=new_env.cst_nbr} +(* ty_var,{new_env with type_equations=new_eq;lvar_typing=env.lvar_typing} *) +(* ty_var,{new_env with type_equations=new_eq} *) + | Lambda.App (t,u) -> + let u_type,new_eq=UF.generate_new_var env.type_equations in + let t_type,new_eq=UF.generate_new_constr new_eq (1,[u_type;ty_var]) in + LOG "%sType inference of the parameter in an application:" prefix LEVEL TRACE; + let u_type,new_env=inference_aux (level+1) u u_type {env with type_equations=new_eq} in + LOG "%sType inference of the functor in an application:" prefix LEVEL TRACE; + let t_type,new_env=inference_aux (level+1) t t_type new_env in + ty_var,new_env + | _ -> failwith "Bug: No principal typing algorithm for these types" in + let is_cyclic,new_eq=UF.cyclic ty new_env.type_equations in + if is_cyclic then + raise Not_typable + else + ty,{new_env with type_equations=new_eq} + + + let rec build_type i type_eq = + let (i,v),type_eq = UF.find i type_eq in + match v with + | UF.Link_to j when j=i -> Lambda.Atom(-i) + | UF.Link_to _ -> failwith "Bug: when UF.find returns a Link_to, it should be a Link_to itself" + | UF.Value _ -> failwith "Bug: when performing type inference for principal typing, no type constant should appear" + | UF.Constr (c,[alpha;beta]) -> + let alpha'=build_type alpha type_eq in + let beta'=build_type beta type_eq in + Lambda.Fun(alpha',beta') + | UF.Constr _ -> failwith "Bug: when performing type inference for principal typing, the only allowd type construction is the arrow" + + let inference t = + try + let vars=UF.empty in + let ty,vars=UF.generate_new_var vars in + let ty,env=inference_aux 0 t ty {empty_env with type_equations=vars} in + build_type ty env.type_equations,IntMap.map (fun (ty,i) -> Lambda.Const i,build_type ty env.type_equations) env.const_typing + with + | UF.Union_Failure -> raise Not_typable +end diff --git a/src/logic/typeInference.mli b/src/logic/typeInference.mli new file mode 100644 index 0000000000000000000000000000000000000000..6f92c7da16a11c94c6f309f8b1926c734df63b6f --- /dev/null +++ b/src/logic/typeInference.mli @@ -0,0 +1,20 @@ +open Lambda + +module Type : +sig + + (** [inference t] returns [(ty,map)] where [ty] is the type of [t] + and [map] is a map from [int], denoting the index of occurrences + of constants considered as free variables (as in Kanazawa's ACG + to Datalog reduction), to the constant they replace and their + associated infered type. + + The indexes of atomic types are negative to denote type + variables. + + *) + val inference : Lambda.term -> Lambda.stype * ((Lambda.term*Lambda.stype) Utils.IntMap.t) + + + +end diff --git a/src/logic/typeInference_test.ml b/src/logic/typeInference_test.ml new file mode 100644 index 0000000000000000000000000000000000000000..d9d5a66d07c29e61ccfd1d7abe67959cac0bcf68 --- /dev/null +++ b/src/logic/typeInference_test.ml @@ -0,0 +1,51 @@ +open TypeInference +open Lambda.Lambda + + + +let test t = + let () = Printf.printf "Testing \"%s\"...\n" (raw_to_string t) in + let ty,map = Type.inference t in + let () = Printf.printf "Got \"%s\".\n" (raw_type_to_string ty) in + let () = Printf.printf "In the context of:\n" in + let () = + Utils.IntMap.iter + (fun k (t,ty) -> Printf.printf "%d --> %s : %s\n" k (raw_to_string t) (raw_type_to_string ty)) + map in + () + + +(* grep Atom acg.log | grep -o "(.*" | sed -e 's/\(.*\):.*/\1;/' > ~/tmp/terms *) + +(*let term_list=[ + (Const 3) ; +(Const 4) ; +(LAbs ("o",(LAbs ("s",(App ((App ((Const 1),(LVar 0))),(App ((App ((Const 1),(Const 5))),(LVar 1))))))))) ; +(LAbs ("n",(LAbs ("P",(App ((LVar 0),(App ((App ((Const 1),(Const 6))),(LVar 1))))))))) ; +(LAbs ("n",(LAbs ("P",(App ((LVar 0),(App ((App ((Const 1),(Const 7))),(LVar 1))))))))) ; +(Const 8) ; +(Const 9) ; +(Const 3) ; +(Const 4) ; +(Const 5) ; +(Const 6) ; +(LAbs ("x",(LAbs ("y",(App ((App ((Const 2),(LVar 0))),(LVar 1))))))) ; +(LAbs ("P",(LAbs ("Q",(App ((Const 9),(Abs ("x",(App ((App ((Const 8),(App ((LVar 1),(Var 0))))),(App ((LVar 0),(Var 0))))))))))))) ; +(LAbs ("P",(LAbs ("Q",(App ((Const 10),(Abs ("x",(App ((App ((Const 7),(App ((LVar 1),(Var 0))))),(App ((LVar 0),(Var 0))))))))))))) ; +(LAbs ("x",(LAbs ("y",(App ((LVar 0),(LVar 1))))))) ; +(LAbs ("s",(LAbs ("a",(LAbs ("S",(App ((LVar 2),(App ((LVar 0),(App ((LVar 1),(LAbs ("x",(App ((Const 4),(LVar 0))))))))))))))))); +(LAbs ("s",(LAbs ("a",(LAbs ("S",(App ((LVar 2),(App ((LVar 0),(LAbs ("x",(App ((App ((LVar 2),(LAbs ("x",(App ((Const 4),(LVar 0))))))),(LVar 0))))))))))))))); +] +*) + +let term_list = + [ + (LAbs ("s",(LAbs ("a",(App ((LVar 1),App (LVar 0,(LAbs ("x",(App ((Const 4),(LVar 0)))))))))))); + (LAbs ("a",(App ((LVar 0),(LAbs ("x",(App ((Const 4),(LVar 0)))))))));(App ((App ((Const 1),(App ((App ((Const 1),(Const 5))),(App ((App ((Const 1),(Const 9))),(App ((App ((Const 1),(Const 10))),(App ((App ((Const 1),(Const 11))),(Const 3))))))))))),(Const 7))); + App ((Const 1),(Const 11)); + + ] + +(*let () = test (LAbs ("o",(LAbs ("s",(App ((App ((Const 1),(LVar 0))),(App ((App ((Const 1),(Const 5))),(LVar 1))))))))) *) + +let () = List.iter test term_list diff --git a/src/logic/varUnionFind.ml b/src/logic/varUnionFind.ml new file mode 100644 index 0000000000000000000000000000000000000000..6cdee9d3ceb9eec1504b8ef0943a45ff9130f435 --- /dev/null +++ b/src/logic/varUnionFind.ml @@ -0,0 +1,341 @@ +open Utils + + +(** Modules with this module type should provide Union-Find algorithms + and the indexed storage data structure. Note that we take the + opportunity of implementing from scratch such algorithms to allow + the [find] function returns not only the index of the + representative and the values it indexes, but also the storage + data structure, so that the [find] algorithm can modify it, in + particular with path compression. +*) + +module UF (Value : + sig + type t + type value + val unfold : value -> t -> (int*value list) option +(* val fold : (int*value list) -> t -> value *) + end) = +struct + module Store = + struct + type 'a t = 'a IntMap.t + exception Store_Not_found + let empty _ = IntMap.empty + let get k m = + try + IntMap.find k m + with + | Not_found -> raise Store_Not_found + let set k v m = IntMap.add k v m + let copy m=m + let iter = IntMap.iter + end + + + (** The type of the values (content) that are indexed. It is either + an actual value of type ['a] or a link to another indexed + value. If a content at an index [i] points to [i], it is meant + that to be a variable.*) + type content = + | Link_to of int + | Value of Value.value + | Constr of (int*int list) + + let rec content_to_string c = + match c with + | Link_to i -> Printf.sprintf "Linked to %d" i + | Value v -> Printf.sprintf "Some Value" + | Constr (i,lst) -> Printf.sprintf "Contructeur %d(%s)" i (Utils.string_of_list "," (fun j -> content_to_string(Link_to j)) lst) + + (** The actual type of the data structure. The rank is used to + implement weighted union. See {{: + http://www.risc.jku.at/education/courses/ss2012/unification/slides/02_Syntactic_Unification_Improved_Algorithms.pdf} + Introduction to Unification Theory. Speeding Up (Temur + Kutsia)} *) + type t = {rank:int Store.t;parents:content Store.t;limit:int} + + + let empty = {rank=Store.empty () ;parents=Store.empty ();limit=0} + + exception Union_Failure + + let to_string h = + IntMap.fold + (fun i v acc -> + match v with + | Link_to next -> Printf.sprintf "%s%d\t\t--->\t%d\n" acc i next + | Value _ -> failwith "Bug: should not encounter Value" + | Constr (c,i_args) -> Printf.sprintf "%s%d\t\t--->\t(%s)\n" acc i (Utils.string_of_list " -> " string_of_int i_args)) + h.parents + "" + + let to_string {rank=r;parents=p} = + let buff=Buffer.create 2 in + let to_string_aux i = + Printf.sprintf "%d\t<--->\t%s\t\t(%d)\n" i (content_to_string (Store.get i p)) (Store.get i r) in + let i=ref 1 in + try + let () = + while true do + let () = Buffer.add_string buff (to_string_aux !i) in + i:=!i+1 + done in + "Bug!" + with + | Store.Store_Not_found -> Buffer.contents buff + + + + let generate_new_var {rank;parents;limit} = + let i=limit+1 in + i,{rank=Store.set i 0 rank;parents=Store.set i (Link_to i) parents;limit=i} + + let generate_new_constr {rank;parents;limit} c = + let i=limit+1 in + i,{rank=Store.set i 0 rank;parents=Store.set i (Constr c) parents;limit=i} + + + let rank_increment i h = + {h with rank= + Store.set i + (1+( + try + Store.get i h.rank + with + | Store.Store_Not_found -> 0)) + h.rank} + + + (** [find_and_instantiate_aux i t f] returns a new indexed storage + datastructure [f'] where the content at index [i] (and the ones + it points to) has been set to [Value t]. If [i]'s representative + indexes a variable or a value equal to [Value t] then the + instantiation suceeds, otherwise it raises Union_failure. It + also performs path compression. *) + let rec find_and_instantiate_aux i term table f = + match Store.get i f.parents with + | Value v when v=term -> f + | Value _ -> raise Union_Failure + (* An actual value was reached at index [i] and we're in the case + that it differs from [term]. So the union fails *) + | Link_to next when next=i -> + (* The content indexed by [i] points to [i]. [i] is then the + representative for the variable it denotes and can be unified + with [term]. [f] is updated. *) + (match Value.unfold term table with + | None -> {f with parents=Store.set i (Value term) f.parents} + | Some (c,args) -> + let i_args,new_content = + List.fold_left + (fun (acc,cont) arg -> + let var,new_cont=generate_new_var cont in + var::acc,find_and_instantiate_aux var arg table (rank_increment var new_cont)) + ([],f) + args in + {new_content with parents=Store.set i (Constr (c,List.rev i_args)) new_content.parents} ) + | Link_to next -> + (* In the other cases, we follow the links to reach the + representative and the content it indexes *) + let new_f = find_and_instantiate_aux next term table f in + (* Then we update the storage data structure linking the context + indexed by [i] directly to the representative index. We know + it's safe to do it now since unification succeeded. *) + let updated_parents = Store.set i (Value term) new_f.parents in + {f with parents=updated_parents} + | Constr (c,i_args) -> + (match Value.unfold term table with + | None -> raise Union_Failure + | Some (c',args) when c=c'-> + (try + List.fold_left2 + (fun cont var arg -> + find_and_instantiate_aux var arg table cont) + f + i_args + args + with + | Invalid_argument _ -> raise Union_Failure) + | Some (c',_) ->raise Union_Failure) + + (** [instantiate i t h] returns a new indexed storage data structure + where the value indexed by [i] and [t] have been unified. It + fails and raises the {! UnionFind.Union_Failure} exception if + [i]'s representative indexes an actual values [Value a] such + that [a] differs from [t]. *) + let instantiate i t table h = find_and_instantiate_aux i t table h + + + + (** [find_aux i f] returns a pair [(i',v),f'] where [i'] is the + index of the representative of the data indexed by [i]. [i=i'] + means that the [i]-th element is linked to itself: it is meant + to be a variable, not an actual value. It also performs path + compression *) + let rec find_aux i f = + match Store.get i f with + | Value _ as v -> (i,v),f + (* An actual value was reached at index [i]. So [i] is returned + together with [v] and [f] *) + | Constr _ as v -> (i,v),f + (* An almost actual value was reached at index [i]. So [i] is returned + together with [v] and [f] *) + | Link_to next as v when next=i -> (i,v),f + (* The content indexed by [i] points to [i]. [i] is then the + representative for the variable it denotes. *) + | Link_to next -> + (* In the other cases, we follow the links to reach the + representative and the content it indexes *) + let (representative_index,representative_value),new_f = find_aux next f in + (* Then we update the storage data structure linking the context + indexed by [i] directly to the representative index *) + let updated_f = Store.set i (Link_to representative_index) new_f in + LOG "the \"UnionFinf.find\" function indeed returns a Link_to itself: %b" (let ()=match representative_value with + | Link_to variable -> assert (representative_index=variable) + | _ -> () in true) LEVEL FATAL; + (representative_index,representative_value),updated_f + + (** [find i h] returns a pair [(i',v),f'] where [i'] is the index of + the representative of the data indexed by [i]. [i=i'] means that + the [i]-th element is linked to itself: it is meant to be a + variable, not an actual value. It also performs path + compression. The difference with [find_aux] is that it applyes + to the whole storage data structure (that includes data for + weighted union). *) + let find i h = + let rep_i,f = find_aux i h.parents in + rep_i,{h with parents=f} + + (** [extract ~start:s i t] returns a list of the [i] first elements + of [t] starting from position [s] (default is 1, first + position). It is ensured that the results only contain the + values of representatives (i.e it follows the [Link_to] links + until the value of the representative before returning it). *) + let extract ?(start=1) i {parents=p} = + LOG "Going to extract %d elements starting at %d..." i start LEVEL DEBUG; + let rec extract_aux k res = + match k-start with + | j when j>0 -> + let (_,c),_= find_aux (start-1+j) p in + extract_aux (start+j-1) (c :: res) + | _ -> res in + extract_aux (start+i) [] + + + + + + + (** [union i j h] returns a new storage data structure [h'] where + [h'] has an equivalent content as [h] plus the unification + between the elements indexed by [i] and [j] and plus, possibly, + some path compression. *) + let rec union i j h = + let rep_i,h' = find i h in + let rep_j,h'' = find j h' in + match rep_i,rep_j with + (* in case [rep_i] (rexp. [rep_j]) is a [(i,Link_to i')] we should + have [i=i'], else there is a bug *) + | (_,v_i),(_,v_j) when v_i=v_j -> h'' + + | (rep_i_index,(Value _ as v_i)),(rep_j_index,Link_to _) -> + {h'' with parents=Store.set rep_j_index v_i h''.parents} + + | (rep_i_index,Link_to _),(rep_j_index,(Value _ as v_j)) -> + {h'' with parents=Store.set rep_i_index v_j h''.parents} + + | (rep_i_index,(Constr _ as v_i)),(rep_j_index,Link_to _) -> + {h'' with parents=Store.set rep_j_index (Link_to rep_i_index) h''.parents} + + | (rep_i_index,Link_to _),(rep_j_index,(Constr _ as v_j)) -> + {h'' with parents=Store.set rep_i_index (Link_to rep_j_index) h''.parents} + + | (rep_i_index,Constr (c_i,args_i)),(rep_j_index,Constr (c_j,args_j)) when c_i=c_j -> + let h''' = union_list args_i args_j h'' in + let rk_i = Store.get rep_i_index h'''.rank in + let rk_j = Store.get rep_j_index h'''.rank in + if rk_i > rk_j then + {h''' with + parents=Store.set rep_i_index (Constr (c_i,List.rev args_i)) (Store.set rep_j_index (Link_to rep_i_index) h'''.parents)} + else + if rk_i < rk_j then + {h''' with + parents=Store.set rep_j_index (Constr (c_i,List.rev args_j)) (Store.set rep_i_index (Link_to rep_j_index) h'''.parents)} + else + {h''' with + parents=Store.set rep_i_index (Constr (c_i,List.rev args_i)) (Store.set rep_j_index (Link_to rep_i_index) h'''.parents); + rank=Store.set rep_i_index (rk_i+1) h'''.rank} + + | (rep_i_index,Link_to i'),(rep_j_index,Link_to j') -> + let rk_i = Store.get rep_i_index h''.rank in + let rk_j = Store.get rep_j_index h''.rank in + if rk_i > rk_j then + {h'' with + parents=Store.set rep_j_index (Link_to rep_i_index) h''.parents} + else + if rk_i < rk_j then + {h'' with + parents=Store.set rep_i_index (Link_to rep_j_index) h''.parents} + else + {h'' with + parents=Store.set rep_j_index (Link_to rep_i_index) h''.parents; + rank=Store.set rep_i_index (rk_i+1) h''.rank} + | (_,Value v_i),(_,Value v_j) -> + (* v_i=v_j is caught by the first case *) + raise Union_Failure + | (_,Value _ ),(_,Constr _) -> raise Union_Failure + | (_,Constr _ ),(_,Value _) -> raise Union_Failure + | (_,Constr _),(_,Constr _) -> + (* Constr (c,_), Constr (c,_) is caught by the 6th case *) + raise Union_Failure + and union_list args_i args_j h = + match args_i,args_j with + | [],[] -> h + | i::tl_i,j::tl_j -> union_list tl_i tl_j (union i j h) + | _,_-> raise Union_Failure + + (* cyclic_aux includes path compression *) + let rec cyclic_aux i f acc = + match Store.get i f with + | Value v -> false,i,f + | Link_to next when next=i -> false,i,f + | Link_to next -> + if IntSet.mem next acc then + true,i,f + else + let cyclic,representative_index,new_f = cyclic_aux next f (IntSet.add next (IntSet.add i acc)) in + let updated_f = Store.set i (Link_to representative_index) new_f in + cyclic,representative_index,updated_f + | Constr(c,args) -> + let new_acc=IntSet.add i acc in + List.fold_left + (fun (c,l_i,l_f) arg -> + LOG "Preparing to check cyclicity from %d" arg LEVEL TRACE; + if IntSet.mem arg new_acc then + true,l_i,l_f + else + let is_c,_,new_f= cyclic_aux arg l_f new_acc in + is_c || c,l_i,new_f) + (false,i,f) + args + + + (* the cyclic function, calling cyclic_aux, compress paths + (hence also returns the parents) *) + let cyclic i h = + LOG "Checking cyclicity from %d of:" i LEVEL TRACE ; + Utils.log_iteration + (fun s -> LOG "%s" s LEVEL TRACE) + (to_string h); + let res,_,f = cyclic_aux i h.parents (IntSet.empty) in + res,{h with parents=f} + + let copy {rank=r;parents=p;limit}={rank=Store.copy r;parents=Store.copy p;limit} + + + +end + + + diff --git a/src/logic/varUnionFind.mli b/src/logic/varUnionFind.mli new file mode 100644 index 0000000000000000000000000000000000000000..1ce368b58a0719825aac4c4cb9119ff43f7ff7ed --- /dev/null +++ b/src/logic/varUnionFind.mli @@ -0,0 +1,104 @@ +(** Modules with this module type should provide Union-Find algorithms + and the indexed storage data structure. Note that we take the + opportunity of implementing from scratch such algorithms to allow + the [find] function returns not only the index of the + representative and the values it indexes, but also the storage + data structure, so that the [find] algorithm can modify it, in + particular with path compression. +*) + + +(** Modules with this module type should provide an indexed (by [int] + indexes) storage data structure for ['a] type values and access + and update functions. +*) + + +(** This module implements a {! UnionFind} data structure. The [S] + parameter is used to try different implementations of indexed data + structure, in particular eventually persistent arrays as described + in {{: http://www.lri.fr/~filliatr/ftp/publis/puf-wml07.ps}"A + Persistent Union-Find Data Structure" (Sylvain Conchon and + Jean-Chrisophe Filliâtre} *) +module UF(Value : + sig + type t + type value + val unfold : value -> t -> (int*value list) option +(* val fold : (int*value list) -> t -> value *) + end) : +sig + (** The type of the indexed data structure *) + type t + + (** The type of the values (content) that are indexed. It is either + an actual value of type ['a] or a link to another indexed + value. If a content at an index [i] points to [i], it is meant + that to be a variable.*) + type content = Link_to of int | Value of Value.value | Constr of (int*int list) + + (** Exception raised when a the union of to indexed value can not + happen. It should be raised by the [union] function when it + amounts to make the union between to actual values [Value a] and + [Value b] and [a != b]. *) + exception Union_Failure + + (** [create l] returns the corresponding indexed storage data + structure where each value (or link) is indexed by its position in [l] + (starting at 1 *) +(* val create : content list -> Value.t -> t *) + + + val empty : t + + val generate_new_var : t -> int * t + + (** [generate_new_constr h (c,var_args)] returns a pair [(j,h')] + where [h'] is [h] updated with a new index [j] that contains a + [Constr(c,var_args)] value. [var_args] is a list of already + defined indexed of [h] (not checked here). *) + val generate_new_constr : t -> (int*int list) -> int * t + + (** [extract ~start:s i t] returns a list of the [i] first elements + of [t] starting from position [s] (default is 1, first + position). It is ensured that the results only contain the + values of representatives (i.e it follows the [Link_to] links + until the value of the representative before returning it). *) + val extract : ?start:int -> int -> t -> content list + + (** [find i h] returns not only the index of the representative and + the values it indexes, but also the storage data structure, so + that the [find] algorithm can modify it, in particular with path + compression. If the returned content is a [Link_to j] then + [j=i].*) + val find : int -> t -> ((int * content) * t) + (* the content returned by [find] should not be a link. Can we + enforce this using polymorphic variants and/or GADT? *) + + (** [union i j h] returns a new indexed storage data structure where + values indexed by [i] and [j] have been unified (ie one of the + two is now linked to the index of the representative of the + other. It fails and raises the {! Union_Failure} + exception if both [i] and [j] representatives index actual + values [Value a] and [Value b] and [a != b]. *) + val union : int -> int -> t -> t + + (** [instantiate i t h] returns a new indexed storage data structure + where the value indexed by [i] and [t] have been unified. It + fails and raises the {! Union_Failure} exception if + [i]'s representative indexes an actual values [Value a] such + that [a] differs from [t]. *) + val instantiate : int -> Value.value -> Value.t -> t -> t + + (** [cyclic i h] returns a pair [(b,h')] where [b] is [true] if [h] + has a cycle (following the [Link_to] links) containing [i] and + [false] otherwise, and where [h'] contains the same information + as [h] (possibly differently stored, for instance using path + compression while checking [h] cyclicity. *) + val cyclic : int -> t -> (bool * t) + + val copy : t -> t + + val to_string : t -> string +end + diff --git a/src/reduction/Makefile.in b/src/reduction/Makefile.in index f480acc9e86e67c01224bd0fb14046067abb6039..efc08fc3679fec271e019b9bc8742fe89e073f17 100644 --- a/src/reduction/Makefile.in +++ b/src/reduction/Makefile.in @@ -31,7 +31,7 @@ LIBS += dyp.cma str.cma # The corresponding directories # (if not in the main ocaml lib directory, # ex. +campl4 -LIBDIR = @DYPGEN_INCLUDE@ -I +camlp4 +LIBDIR += @DYPGEN_INCLUDE@ # Directories to which the current source files depend on PREVIOUS_DIRS = ../utils ../logic ../datalog ../grammars ../acg-data diff --git a/src/reduction/reduction_functor.ml b/src/reduction/reduction_functor.ml index c5272893712616b145adfe180a8ca0e449e79dd7..5d8d143d283547b564dfcbd98b649549efa14a97 100644 --- a/src/reduction/reduction_functor.ml +++ b/src/reduction/reduction_functor.ml @@ -84,7 +84,8 @@ struct exception NotImplemented exception NotSecondOrder - (* renvoie la liste des constantes d'un lambda-terme lu de gauche à droite *) + (* renvoie la liste des constantes d'un lambda-terme lu de gauche à + droite *) let rec lambda_get_constants = function | LVar _ -> [] | Const x -> [x] @@ -93,44 +94,47 @@ struct | (Var _ | Abs(_,_)) -> raise NonLinear | _ -> raise NotImplemented - (* renvoie la liste des types atomiques (et d'un identifiant) présent dans une signature *) + (* renvoie la liste des types atomiques (et d'un identifiant) + présent dans une signature *) let sg_get_atomic_types s = Signature.fold (fun e l -> match Signature.is_declared e s with - | None -> l - | Some name -> if Signature.is_type name s - then (match l with - | [] -> [(name,0)] - | (t,n)::q -> (name,n+1)::(t,n)::q) - else l) + | None -> l + | Some name -> if Signature.is_type name s + then (match l with + | [] -> [(name,0)] + | (t,n)::q -> (name,n+1)::(t,n)::q) + else l) [] s - (* renvoie la liste des constantes (et d'un dientifiant) présentes dans une signature *) + (* renvoie la liste des constantes (et d'un identifiant) présentes + dans une signature *) let sg_get_constants s = Signature.fold (fun e l -> match Signature.is_declared e s with - | None -> l - | Some name -> if fst (Signature.is_constant name s) - then (match l with - | [] -> [(name,0)] - | (t,n)::q -> (name,n+1)::(t,n)::q) - else l) + | None -> l + | Some name -> if fst (Signature.is_constant name s) + then (match l with + | [] -> [(name,0)] + | (t,n)::q -> (name,n+1)::(t,n)::q) + else l) [] s - (* renvoie la liste des constantes présentes dans [s] et leur type *) + (* renvoie la liste des constantes présentes dans [s] et leur + type *) let sg_get_constants_and_constant_types s = Signature.fold (fun e l -> match Signature.is_declared e s with - | None -> l - | Some name -> if fst (Signature.is_constant name s) - then (Signature.find_term name s)::l else l) + | None -> l + | Some name -> if fst (Signature.is_constant name s) + then (Signature.find_term name s)::l else l) [] s - (* renvoie le terme où les définitions des constantes définies ont été dépliées suivant - leur définition dans la signature *) + (* renvoie le terme où les définitions des constantes définies ont + été dépliées suivant leur définition dans la signature *) let rec sg_unfold_term s = function | LVar x -> LVar x | Const x -> Const x @@ -168,7 +172,8 @@ struct | _ -> raise NotImplemented in aux i l x - (* "casse" un type en la liste de ses [n] sous-types 'grossiers', eux-mêmes "cassés" avec + (* "casse" un type en la liste de ses [n] sous-types 'grossiers', + eux-mêmes "cassés" avec break_aux : entrée : i : identifiant 'fresh' pour représenter un type atomique diff --git a/src/s_datalog/12.4.1.p287.dl b/src/s_datalog/12.4.1.p287.dl new file mode 100644 index 0000000000000000000000000000000000000000..3d596c7de8c1156759c1547bba8ede374fa735b2 --- /dev/null +++ b/src/s_datalog/12.4.1.p287.dl @@ -0,0 +1,11 @@ +S(x1,x3):-T(x1,x2),R(x2,0,x3). +T(x1,x4):-R(x1,0,x2),R(x2,1,x3),T(x3,x4). +T(x1,x3):-R(x1,0,x2),R(x2,0,x3). + + + +R(2,0,3). +R(3,1,4). +R(4,0,5). +R(5,0,6). +R(6,0,t). \ No newline at end of file diff --git a/src/s_datalog/Jean-regarde-telescope.dl b/src/s_datalog/Jean-regarde-telescope.dl new file mode 100644 index 0000000000000000000000000000000000000000..429600bb728076abfcf11f62d141a6b56db7a79b --- /dev/null +++ b/src/s_datalog/Jean-regarde-telescope.dl @@ -0,0 +1,25 @@ +S(i,k) :- NP(i,j),VP(j,k). +NP(i,j) :- PN(i,j). +NP(i,k) :- Det(i,j),N(j,k). +NP(i,k):-NP(i,j),PP(j,k). +VP(i,k):-V(i,j),NP(j,k). +VP(i,k):-VP(i,j),PP(j,k). +PP(i,k):-Prep(i,j),NP(j,k). + +PN(i,j):-Jean(i,j). +Det(i,j):-un(i,j). +V(i,j):-regarde(i,j). +N(i,j):-homme(i,j). +N(i,j):-telescope(i,j). +Prep(i,j):-avec(i,j). + +(*S(x,y):-T(x,y). +T(x,y):-S(x,y).*) + +Jean(0,1). +regarde(1,2). +un(2,3). +homme(3,4). +avec(4,5). +un(5,6). +telescope(6,7). diff --git a/src/s_datalog/Jean_edb.dl b/src/s_datalog/Jean_edb.dl new file mode 100644 index 0000000000000000000000000000000000000000..3212614064c56ae7e3948f6e49644a34a9490669 --- /dev/null +++ b/src/s_datalog/Jean_edb.dl @@ -0,0 +1,9 @@ +Jean(0,1). +regarde(1,2). +un(2,3). +homme(3,4). +avec(4,5). +un/2(5,6). +telescope(6,7). + + diff --git a/src/s_datalog/Jean_idb.dl b/src/s_datalog/Jean_idb.dl new file mode 100644 index 0000000000000000000000000000000000000000..9be9c7947004581f44de60666fbb07e6cddd98d0 --- /dev/null +++ b/src/s_datalog/Jean_idb.dl @@ -0,0 +1,18 @@ +S(i,k) :- NP(i,j),VP(j,k). +NP(i,j) :- PN(i,j). +NP(i,k) :- Det(i,j),N(j,k). +NP(i,k):-NP(i,j),PP(j,k). +VP(i,k):-V(i,j),NP(j,k). +VP(i,k):-VP(i,j),PP(j,k). +PP/2(i,k):-Prep(i,j),NP/2(j,k). + +PN(i,j):-Jean(i,j). +Det(i,j):-un(i,j). +V(i,j):-regarde(i,j). +N(i,j):-homme(i,j). +N(i,j):-telescope(i,j). +Prep(i,j):-avec(i,j). + +S(x,y):-T(x,y). +T(x,y):-S(x,y). + diff --git a/src/s_datalog/Makefile.in b/src/s_datalog/Makefile.in new file mode 100644 index 0000000000000000000000000000000000000000..7667e2eea38b7caa1a3a9e4ded31361fd617c78b --- /dev/null +++ b/src/s_datalog/Makefile.in @@ -0,0 +1,58 @@ +########################################################################## +# # +# ACG development toolkit # +# # +# Copyright 2008 INRIA # +# # +# More information on "http://acg.gforge.loria.fr/" # +# License: CeCILL, see the LICENSE file or "http://www.cecill.info" # +# Authors: see the AUTHORS file # +# # +# # +# # +# # +# $Rev:: 380 $: Revision of last commit # +# $Author:: pogodall $: Author of last commit # +# $Date:: 2012-11-19 14:57:00 +0100 (#$: Date of last commit # +# # +########################################################################## + +include ../Makefile.master + +############################### +# # +# Set the following variables # +# # +############################### + +# Used libraries +LIBS += dyp.cma str.cma @KAPUTT_LIB@ + +# The corresponding directories +# (if not in the main ocaml lib directory, +# ex. -I +campl4 +LIBDIR += @DYPGEN_INCLUDE@ @KAPUTT_INCLUDE@ + +# Directories to which the current source files depend on +PREVIOUS_DIRS = ../utils + +# Source files in the right order of dependance + +ML = persistentArray.ml arrayTraversal.ml unionFind.ml datalog_AbstractSyntax.ml datalog.ml db_parser.ml db_lexer.ml + +EXE_SOURCES = test.ml db_test.ml + +CAMLLEX = db_lexer.mll + +#################################### +# # +# End of the configuration section # +# # +#################################### + +include ../Makefile.common + +db_lexer.ml : db_parser.mli + +db_parser.mli : db_parser.mly + @OCAMLYACC@ $< \ No newline at end of file diff --git a/src/s_datalog/RSG.dl b/src/s_datalog/RSG.dl new file mode 100644 index 0000000000000000000000000000000000000000..643bbf7f6bedc43970f74494e3361f7d5cd70d1f --- /dev/null +++ b/src/s_datalog/RSG.dl @@ -0,0 +1,28 @@ +rsg(x,y):- flat(x,y). +rsg(x,y):-up(x,x1),rsg(y1,x1),down(y1,y). +(*rsg(x,x).*) + +rsg(x,y):-flat(y,x). + +(*up(x,x). *) +up(1,5). +up(1,6). +up(6,13). +up(7,14). +up(8,14). +up(9,15). +up(10,15). + +(*flat(x,x).*) +flat/2(7,6). +flat(13,14). +flat(13,15). +flat(16,13). + +down(12,6). +down(13,6). +down(7,2). +down(8,3). +down(9,4). +down(16,11). + diff --git a/src/s_datalog/Trans-Clos.dl b/src/s_datalog/Trans-Clos.dl new file mode 100644 index 0000000000000000000000000000000000000000..f28dab5bc43f3e34b87bdc0c617a76a202d5f7b8 --- /dev/null +++ b/src/s_datalog/Trans-Clos.dl @@ -0,0 +1,10 @@ +T(x,y):-G(x,y). +T(x,y):-G(x,z),T(z,y). + + + + +G(1,2). +G(2,3). +G(3,4). +G(4,5). \ No newline at end of file diff --git a/src/s_datalog/arrayTraversal.ml b/src/s_datalog/arrayTraversal.ml new file mode 100644 index 0000000000000000000000000000000000000000..48e37defc2bca8d456d11d1590aa543bafcdb154 --- /dev/null +++ b/src/s_datalog/arrayTraversal.ml @@ -0,0 +1,77 @@ +module type Evaluator_TYPE = + sig + type state + type cell + val cell_compare : cell -> cell -> int + val update: state -> cell -> state option + end + + +module Make (E:Evaluator_TYPE)= + struct + type row = E.cell list + type array = row list + + type return = Return of (E.state*(E.state*row*array) list) | Stop + + let rec visit_row state row arr resume = + match row with + | [] -> continue resume + | elt::remaining -> + begin + match E.update state elt with + | Some new_state -> visit_array new_state arr ((state,remaining,arr)::resume) + | None -> visit_row state remaining arr resume + end + and visit_array state arr resume = + match arr with + | [] -> Return (state,resume) + | row::remaining -> visit_row state row remaining resume + and continue resumption = + match resumption with + | [] -> Stop + | (state,row,arr)::resume -> visit_row state row arr resume + + + let rec all_results_aux f acc state array resume = + match visit_array state array resume with + | Return (res,(current_state,r,arr)::resume) -> + all_results_aux f (f acc res) current_state (r::arr) resume + | Return (res,[]) -> + f acc res + | Stop -> acc + + let collect_results f acc init array = all_results_aux f acc init array [] +end + + + +module type Evaluator_TYPE2 = +sig + type state + type cell + module CellSet:Set.S with type elt= cell + val update: state -> cell -> state option +end + +module Make2 (E:Evaluator_TYPE2)= + struct + type row = E.CellSet.t + type array = row list + + let rec fold_on_array f acc state = function + | [] -> f acc state + | row::remaining -> + E.CellSet.fold + (fun elt l_acc -> + match E.update state elt with + | Some new_state -> fold_on_array f l_acc new_state remaining + | None -> l_acc) + row + acc + + let collect_results f acc init array = fold_on_array f acc init array +end + + + diff --git a/src/s_datalog/arrayTraversal.mli b/src/s_datalog/arrayTraversal.mli new file mode 100644 index 0000000000000000000000000000000000000000..76b42861c0d7128871317369860318a41ba359d1 --- /dev/null +++ b/src/s_datalog/arrayTraversal.mli @@ -0,0 +1,59 @@ +(** This module implements a depth-first array traversal. It is + depth-first in order to fit with backtracking when cells contain + persistent array. *) + + +module type Evaluator_TYPE = +sig + type state + type cell + val cell_compare : cell -> cell -> int + val update: state -> cell -> state option +end + +module Make (E:Evaluator_TYPE) : +sig + (** The type of a row *) + type row = E.cell list + + (** The type of the array *) + type array = row list + + (** [collect_results f acc init a] returns [f (... (f (f (f acc s1) + s2) s3)... ) sN] where [s1 ... aN] are the states when reaching + the end of the paths from top to bottom of [a] such that for all + [s] resulting from the path [c1 ; ... ; cK] (all paths have this + shape) [s = E.update (... E.update (E.update (E.update init c1) + c2) ...) cK] and none of this [E.update] calls returned a [None] + value (hence the notation abuse of applying [E.update] to a + [state] instead of a [state option] in this description).*) + val collect_results : ('a -> E.state -> 'a) -> 'a -> E.state -> array -> 'a +end + +module type Evaluator_TYPE2 = +sig + type state + type cell + module CellSet:Set.S with type elt= cell + val update: state -> cell -> state option +end + + +module Make2 (E:Evaluator_TYPE2) : +sig + (** The type of a row *) + type row = E.CellSet.t + + (** The type of the array *) + type array = row list + + (** [collect_results f acc init a] returns [f (... (f (f (f acc s1) + s2) s3)... ) sN] where [s1 ... aN] are the states when reaching + the end of the paths from top to bottom of [a] such that for all + [s] resulting from the path [c1 ; ... ; cK] (all paths have this + shape) [s = E.update (... E.update (E.update (E.update init c1) + c2) ...) cK] and none of this [E.update] calls returned a [None] + value (hence the notation abuse of applying [E.update] to a + [state] instead of a [state option] in this description).*) + val collect_results : ('a -> E.state -> 'a) -> 'a -> E.state -> array -> 'a +end diff --git a/src/s_datalog/bolt.config b/src/s_datalog/bolt.config new file mode 100644 index 0000000000000000000000000000000000000000..0d6a87f3166e614e1995fa74d94726d710cc31e9 --- /dev/null +++ b/src/s_datalog/bolt.config @@ -0,0 +1,17 @@ +logger "" { + level = trace; + filter = all; + layout = default; + mode = direct; + output = file; + name = "db_test.log"; +} + +logger "UnionFind" { + level = trace; + filter = all; + layout = default; + mode = direct; + output = file; + name = "db_test.unionfind.log"; +} diff --git a/src/s_datalog/datalog.ml b/src/s_datalog/datalog.ml new file mode 100644 index 0000000000000000000000000000000000000000..5b0f20ada5c99818b7b4f617fea2574542eebe79 --- /dev/null +++ b/src/s_datalog/datalog.ml @@ -0,0 +1,1296 @@ +open PersistentArray +open Focused_list +open Datalog_AbstractSyntax +open SharedForest + + +module ASPred=AbstractSyntax.Predicate +module ASRule=AbstractSyntax.Rule +module ASProg=AbstractSyntax.Program + +module type Datalog_Sig= +sig + exception Fails + module UF:UnionFind.S + + module Predicate : + sig + type predicate = { p_id : ASPred.pred_id; arity : int; } + val make_predicate : Datalog_AbstractSyntax.AbstractSyntax.Predicate.predicate -> predicate + module PredMap : Map.S with type key = ASPred.pred_id + module FactSet :Set.S with type elt = ASPred.predicate + val conditionnal_add : + FactSet.elt -> FactSet.t -> FactSet.t -> FactSet.t -> FactSet.t + val facts_to_string : FactSet.t PredMap.t -> ASPred.PredIdTable.table -> Datalog_AbstractSyntax.ConstGen.Table.table -> string + module PredicateMap : Map.S with type key = ASPred.predicate + module Premise : + sig + type t = ASPred.predicate list * int * int (* the first int parameter is meant to be the rule id and the second one to be the number of intensional predicates occurring in it*) + val to_string : t -> ASPred.PredIdTable.table -> Datalog_AbstractSyntax.ConstGen.Table.table -> string + end + module PremiseSet : Set.S with type elt = Premise.t + val add_map_to_premises_to_buffer : Buffer.t -> ASPred.PredIdTable.table -> Datalog_AbstractSyntax.ConstGen.Table.table -> PremiseSet.t PredicateMap.t -> unit + val format_derivations2 : ?query:Datalog_AbstractSyntax.AbstractSyntax.Predicate.predicate -> ASPred.PredIdTable.table -> Datalog_AbstractSyntax.ConstGen.Table.table -> PremiseSet.t PredicateMap.t -> unit + + + val add_pred_arguments_to_content : + ASPred.term list -> + Datalog_AbstractSyntax.ConstGen.id UF.content list * int * + int Datalog_AbstractSyntax.VarGen.IdMap.t -> + Datalog_AbstractSyntax.ConstGen.id UF.content list * int * + int Datalog_AbstractSyntax.VarGen.IdMap.t + + end + + module Rule : + sig + type rule = { + id : int; + lhs : Predicate.predicate; + e_rhs : (Predicate.predicate*int) list; + i_rhs : (Predicate.predicate*int) list; + i_rhs_num:int; + (* stores the number of intensional predicates occurring in the + rule *) + content : Datalog_AbstractSyntax.ConstGen.id UF.t; + } + val make_rule : ASRule.rule -> rule + val cyclic_unify : int -> int -> 'a UF.t -> 'a UF.t + val extract_consequence : + rule -> Datalog_AbstractSyntax.ConstGen.id UF.t -> ASPred.predicate + module FactArray : + sig + type row = Predicate.FactSet.t + type array = row list + val collect_results : + ('a -> (int * Datalog_AbstractSyntax.ConstGen.id UF.t) * Predicate.FactSet.elt list -> 'a) -> + 'a -> + (int * Datalog_AbstractSyntax.ConstGen.id UF.t) * Predicate.FactSet.elt list -> array -> 'a + end + val immediate_consequence_of_rule : + rule -> FactArray.row Predicate.PredMap.t -> ASPred.predicate list + + module Rules:Set.S with type elt=rule + end + + module Program : + sig + type program = { + rules : Rule.rule list Predicate.PredMap.t; + edb : ASPred.pred_id list; + edb_facts:Predicate.FactSet.t Predicate.PredMap.t; + idb : ASPred.pred_id list; + pred_table: ASPred.PredIdTable.table; + const_table: Datalog_AbstractSyntax.ConstGen.Table.table; + rule_id_gen:IdGenerator.IntIdGen.t; + } + val empty : program + val make_program : ASProg.program -> program + val temp_facts : + Rule.rule -> + Rule.FactArray.row Predicate.PredMap.t -> + Rule.FactArray.row Predicate.PredMap.t -> + Rule.FactArray.row Predicate.PredMap.t -> + Rule.FactArray.row Predicate.PredMap.t -> + (ASPred.predicate * Predicate.FactSet.elt list -> Rule.rule -> 'a -> 'a) -> 'a -> ASPred.PredIdTable.table -> Datalog_AbstractSyntax.ConstGen.Table.table -> 'a + val p_semantics_for_predicate : + Predicate.PredMap.key -> + program -> + Rule.FactArray.row Predicate.PredMap.t -> + Rule.FactArray.row Predicate.PredMap.t -> + Rule.FactArray.row Predicate.PredMap.t -> + Rule.FactArray.row Predicate.PredMap.t -> Predicate.PremiseSet.t Predicate.PredicateMap.t -> Predicate.FactSet.t * Predicate.PremiseSet.t Predicate.PredicateMap.t + val seminaive : program -> Rule.FactArray.row Predicate.PredMap.t * Predicate.PremiseSet.t Predicate.PredicateMap.t + val to_abstract : program -> ASProg.program + + val extend : program -> ASProg.modifier -> program + + val add_e_facts : program -> (ASRule.rule list*Datalog_AbstractSyntax.ConstGen.Table.table*IdGenerator.IntIdGen.t) -> program + + (** [add_rule i r p] adds a [ASRule.rule] to a [Datalog.Program] + with the assumption that it will not change the {em nature} of + any predicate (that is making it change from extensional to + intensional). If [i] is set to true, then the rule concerns an + intensional predicate. If it is set to [false] then it + concerns an extensional predicate and the rhs of the rule + should be empty.*) + + val add_rule : intensional:bool -> ASRule.rule -> program -> program + + + val get_fresh_rule_id : program -> (int * program) + val get_fresh_cst_id : string -> program -> (Datalog_AbstractSyntax.ConstGen.id * program) + val add_pred_sym : string -> program -> (ASPred.pred_id*program) + + val build_forest : ?query:Datalog_AbstractSyntax.AbstractSyntax.Predicate.predicate -> Predicate.PremiseSet.t Predicate.PredicateMap.t -> program -> int SharedForest.tree list list + + + val edb_to_buffer : program -> Buffer.t + + + end +end + + + + +module Make (S:UnionFind.Store) = +struct + exception Fails + module UF= UnionFind.Make(S) + + module Predicate = + struct + + (** For the type of the predicates, we use the same identifiers as + for the predicates of the datalog abstract syntax {! + Datalog_AbstractSyntax.AbstractSyntax.Predicate} *) + type predicate={p_id:ASPred.pred_id; + arity:int; + } + + (** [make_predicate p] returns an actual predicate from some + abstract syntax representation {! + Datalog_AbstractSyntax.AbstractSyntax.Predicate} *) + let make_predicate p = {p_id=p.ASPred.p_id;arity=p.ASPred.arity} + + (** [to_abstract p (s,content) (vars,vargen)] returns a triple + [(abs_p,vars',vargen')] where [abs_p] is the [p] predicate + translated into an equivalent predicate from the datalog + abstract syntax. In order to be able to perform this + translation, we need [s] and index and [content] a indexed + storage data structure which is meant to contain the arguments + of [p] starting at index [s]. Then, in case some variable are + still present, to be able to translate them according to the + other variables that could be in the content [content], we + need to check in [vars] if it's index already was associated + to some [VarGen.id] generated by [vargen]. In this case + [vars'=vars] and [vargen'=vargen], otherwise [vars'] is [var] + with a new variable generated by [vargen] associated to the + variable index, and [vargen'] is the result of generating this + new variable from [vargen].*) + let to_abstract {p_id=id;arity=arity} (start,content) (vars,vargen) pred_table = + LOG "Starting the extraction of predicate %s/%d" (ASPred.to_string {ASPred.p_id=id;ASPred.arity=arity;ASPred.arguments=[]} pred_table ConstGen.Table.empty) arity LEVEL TRACE; + let get_var i (vars,vargen) = + try + Utils.IntMap.find i vars,(vars,vargen) + with + | Not_found -> + let new_var,new_vargen = VarGen.get_fresh_id vargen in + new_var,(Utils.IntMap.add i new_var vars,new_vargen) in + let new_vars,new_vargen,rev_arguments= + List.fold_left + (fun (vars,vargen,acc) -> function + | UF.Value v -> vars,vargen,((ASPred.Const v)::acc) + | UF.Link_to i -> let var,(new_vars,new_vargen)=get_var i (vars,vargen) in + new_vars,new_vargen,(ASPred.Var var)::acc) + (vars,vargen,[]) + (UF.extract ~start:start arity content) in + {ASPred.p_id=id; + ASPred.arity=arity; + arguments=List.rev rev_arguments}, + new_vars, + new_vargen + + (** [lst_to_abstract lst (start,content) (vars,vargen)] returns a + 4-uple [(abs_p_lst,start',vars',vargen')] where all the + predicates of [lst] have been translated and put into + [abs_p_lst]. The predicates in [lst] are supposed to be + represented in [content] starting at index [start] in an + adjacent way. [start'] indexes the component of the next + predicate in [content], and [vars'] and [vargen'] keep track + of the variable that can have been generated. *) + let lst_to_abstract lst (start,content) (vars,vargen) pred_table = + let next_idx,vars',vargen',abs_preds = + List.fold_left + (fun (s,l_vars,l_vargen,acc) (p,pos) -> + let abs_p,new_vars,new_vargen = to_abstract p (s,content) (l_vars,l_vargen) pred_table in + s+p.arity,new_vars,new_vargen,(abs_p,pos)::acc) + (start,vars,vargen,[]) + lst in + (List.rev abs_preds),next_idx,vars',vargen' + + + (** [instantiate_with p (i,c)] instantiates the content [c] with the + fact [p] starting at [i]. It returns a pair [(i',c')] when [i] + is the index of the first component of the [p] predicate in the + content [c] {e THIS IS NOT CHECKED HERE}. [i'=i+a] where [a] is + the arity of [p] (it means [i'] should index the first component + of the next predicate in the content of the rule) and [c'] is a + new content where all the components between [i] and [i'-1] have + been instantiated with the components of [p]. When such an + instantiation fails, it raises {! UF.Union_Failure} *) + let instantiate_with + {ASPred.p_id=_;ASPred.arity=_;ASPred.arguments=args} + (idx,content) = + let last_i,(new_c,_) = + List.fold_left + (fun (i,(cont,vars)) value -> + (i+1, + match value with + | ASPred.Const v -> UF.instantiate i v cont,vars + | ASPred.Var var -> + try + UF.union i (VarGen.IdMap.find var vars) cont,vars + with + | Not_found -> cont,VarGen.IdMap.add var i vars)) + (idx,(content,VarGen.IdMap.empty)) + args in + last_i,new_c + + + type unifiable_predicate={u_p_id:ASPred.pred_id; + u_arity:int; + content:ConstGen.id UF.t; + } + + (** [add_pred_arguments_to_content arguments (content,idx,mapped_vars)] + returns a triple (content',idx',mapped_vars') where [content'] + is the list [content] to which has been added {e *in the reverse + order*} the information from [arguments]. The update is such + that if the argument of [arguments] is a [Var i] then it is + replaced by a [Link_to j] such that [j] is the index at which + the variable [Var i] was met for the first time (it is stored in + [mapped_vars]. If the argument is a [Const c], then a [Value c] + is added at the current position. [idx'] is the value of the + next position if another list of arguments has to be added. And + [mapped_vars'] is a map from variables [Var i] to positions + (i.e. [int]) in which these variables first occur in [content'] + - [arguments] is the list of the arguments of some predicate + - [content] is a list meant to become the content of a rule, + i.e. an indexed storage data structure that is meant to be + extended with [arguments]. *BE CAREFUL: IT COMES IN INVERSE + ORDER* + - [idx] is the index to be given for the next element of + [content] + - [mapped_vars] is a mapping from [P.Var i] variables to the + index at which they've been stored in [content]. When such a + variable is met for the first time, as expected in the + UnionFind data structure, the content at [idx] is [Link_to]'ed + itself. *) + let add_pred_arguments_to_content arguments (content,idx,mapped_vars) = + List.fold_left + (fun (cont,i,vars) (arg : ASPred.term) -> + match arg with + | ASPred.Var v -> + begin + try + let var_index = VarGen.IdMap.find v vars in + ((UF.Link_to var_index) :: cont,i+1,vars) with + | Not_found -> + ((UF.Link_to i) :: cont,i+1,VarGen.IdMap.add v i vars) + end + | ASPred.Const c -> ((UF.Value c) :: cont,i+1,vars)) + (content,idx,mapped_vars) + arguments + + let make_unifiable_predicate {ASPred.p_id;ASPred.arity;ASPred.arguments} = + let content_as_lst,_,_ = + add_pred_arguments_to_content arguments ([],1,VarGen.IdMap.empty) in + {u_p_id=p_id;u_arity=arity;content=UF.create (List.rev content_as_lst)} + + let unifiable p u_p = + try + if p.ASPred.p_id=u_p.u_p_id then + let _ = instantiate_with p (1,u_p.content) in + true + else + false + with + | UF.Union_Failure -> false + + + (** A map whose key is of type of the predicates identifers *) + module PredMap=ASPred.PredIdMap + + (** A map whose key is of type [predicate] *) + (* TODO: Could it be replaced by predicate id only? *) + module FactSet=Set.Make + (struct + type t=ASPred.predicate + let compare = ASPred.compare + end) + + + let add_facts_to_buffer b pred_table cst_table f = + FactSet.iter (fun elt -> Buffer.add_string b (Printf.sprintf "%s.\n" (ASPred.to_string elt pred_table cst_table))) f + + let add_map_to_facts_to_buffer b pred_table cst_table map = + PredMap.iter + (fun _ v -> add_facts_to_buffer b pred_table cst_table v) + map + + + let facts_to_string facts pred_table cst_table = + let buff=Buffer.create 100 in + let () = add_map_to_facts_to_buffer buff pred_table cst_table facts in + Buffer.contents buff + + (** [conditionnal_add e s1 s2 s3] adds [e] to the set [s1] only if + [e] doesn't belong to [s2] nor to [s3]*) + let conditionnal_add e s1 s2 s3= + if FactSet.mem e s2 then + s1 + else + if FactSet.mem e s3 then + s1 + else + FactSet.add e s1 + + (** A map indexed by integers to store facts at step (or time) [i] + in the seminaive algorithm. These facts are also indexed by + [predicate_id_type]. *) + (* module Indexed_Facts=Utils.IntMap *) + + + module Premise = + struct + type t = ASPred.predicate list * int * int + (* the first int parameter is meant to be the rule id and the + second one to be the number of intensional predicates occurring + in it*) + + let rec lst_compare pred_lst_1 pred_lst_2 = + match pred_lst_1,pred_lst_2 with + | [],[] -> 0 + | _,[] -> 1 + | [],_ -> -1 + | p1::tl1,p2::tl2 -> + let diff =ASPred.compare p1 p2 in + if diff <> 0 then + diff + else + lst_compare tl1 tl2 + + let compare (pred_lst_1,r_id_1,child_num_1) (pred_lst_2,r_id_2,child_num_2) = + let cmp=r_id_1 - r_id_2 in + if cmp<>0 then + cmp + else + let cmp = child_num_1 - child_num_2 in + if cmp<>0 then + cmp + else + lst_compare pred_lst_1 pred_lst_2 + + let to_string (premises,r_id,i_num) pred_table const_table = + Printf.sprintf "%s (rule id: %d, number of intensional predicates: %d" (Utils.string_of_list "," (fun p -> ASPred.to_string p pred_table const_table) premises) r_id i_num + + + end + + module PremiseSet=Set.Make(Premise) + + module PredicateMap=Map.Make( + struct + type t = ASPred.predicate + let compare = ASPred.compare + end) + + + + + + + let rec format_derivations2 ?query pred_table cst_table map = + let u_query = + match query with + | Some q -> Some (make_unifiable_predicate q) + | None -> None in + PredicateMap.iter + (fun k v -> + match u_query with + | Some q when not (unifiable k q) -> () + | _ -> + let () = format_derivation "" k v pred_table cst_table map FactSet.empty in + Printf.fprintf stdout "\n") + map + and format_derivation prefix k v pred_table cst_table map set= + if FactSet.mem k set then + Printf.printf "... (infinite loop on %s)" (ASPred.to_string k pred_table cst_table) + else + let new_set=FactSet.add k set in + let _ = + PremiseSet.fold + (fun (premises,rule_id,_) (first,length) -> + let new_length,new_prefix= + match first with + | true -> + let s=ASPred.to_string k pred_table cst_table in + let () = Printf.fprintf stdout "%s" s in + let n_l=String.length s in + n_l,Printf.sprintf "%s%s" prefix (String.make n_l ' ') + | false -> + let () = Printf.fprintf stdout "\n%s %s" prefix (String.make (length -2) '>') in + length,Printf.sprintf "%s %s" prefix (String.make (length-2) ' ') in + let () = format_premises2 new_prefix (List.rev premises) rule_id true pred_table cst_table map new_set in + (* let () = Printf.fprintf stdout "\n" in*) + false,new_length) + v + (true,0) in + () + and format_premises2 prefix premises rule_id first pred_table cst_table map set = + let rule_info=Printf.sprintf " (rule %d) " rule_id in + let space_holder=String.make (String.length rule_info) ' ' in + let () = match first with + | true -> Printf.fprintf stdout "%s:--" rule_info + | false -> Printf.fprintf stdout "\n%s%s|--" prefix space_holder in + match premises with + | [] -> () + | [p] -> + let () = + try + format_derivation (Printf.sprintf "%s%s " prefix space_holder) p (PredicateMap.find p map) pred_table cst_table map set + with + | Not_found -> Printf.fprintf stdout "%s (not found)" (ASPred.to_string p pred_table cst_table) in + Printf.fprintf stdout "" + | p::tl -> + let () = + try + format_derivation (Printf.sprintf "%s%s " prefix space_holder) p (PredicateMap.find p map) pred_table cst_table map set + with + | Not_found -> Printf.fprintf stdout "%s" (ASPred.to_string p pred_table cst_table) in + let () = format_premises2 prefix tl rule_id false pred_table cst_table map set in + Printf.fprintf stdout "" + + + let add_map_to_premises_to_buffer b pred_table cst_table map = + PredicateMap.iter + (fun k v -> + PremiseSet.iter + (fun premise -> + Buffer.add_string + b + (Printf.sprintf + "%s <- %s\n" + (ASPred.to_string k pred_table cst_table) + (Premise.to_string premise pred_table cst_table))) + v) + map + + + + + let facts_to_string facts pred_table cst_table = + let buff=Buffer.create 100 in + let () = add_map_to_facts_to_buffer buff pred_table cst_table facts in + Buffer.contents buff + + + let add_to_map_to_set k v m = + let current_set = + try + PredicateMap.find k m + with + | Not_found -> PremiseSet.empty in + PredicateMap.add k (PremiseSet.add v current_set) m + + end + + module Derivation = + struct + + end + + + module Rule = + struct + + (** In a [rule], all the compoments of all the predicates + are stored in a {! UnionFind} indexed data structure. We assume + here that from [1] to [lhs.arity] the components of the left + hand side predicate are stored, then from [lhs.arity+1] to + [lhs.arity+(hd rhs).arity] the components of the first predicate + on the right hand side are stored, etc. It is assumed that this + structure is correct (no cycle, links within the range, etc.) *) + type rule={id:int; + lhs:Predicate.predicate; + e_rhs:(Predicate.predicate*int) list; + i_rhs:(Predicate.predicate*int) list; + i_rhs_num:int; + (* stores the number of intensional predicates + occurring in the rule *) + content:ConstGen.id UF.t; + (* TODO: Maybe put the label of the predicate in the + content in order to enforce checking of the current + instantiation *) + (* abs_rule:ASRule.rule;*) + } + + module Rules=Set.Make(struct + type t=rule + let compare {id=i} {id=j} = i-j + end) + + + (** [make_rule r] returns an internal rule, that is one whose + content is now a {! UnionFind.UnionFind} indexed data + structure *) + + let make_rule {ASRule.id=id;ASRule.lhs=lhs;ASRule.e_rhs=e_rhs;ASRule.i_rhs=i_rhs;ASRule.i_rhs_num} = + (* Be careful, the list of the rhs is reversed *) + LOG "Preparing the lhs content..." LEVEL TRACE; + let lhs_content= + Predicate.add_pred_arguments_to_content lhs.ASPred.arguments ([],1,VarGen.IdMap.empty) in + LOG "Done." LEVEL TRACE; + LOG "Preparing the e_rhs..." LEVEL TRACE; + let e_rhs,e_rhs_content = + List.fold_left + (fun (rhs,content) ({ASPred.p_id=n;ASPred.arity=k;ASPred.arguments=pred_args},pos) -> + (({Predicate.p_id=n;Predicate.arity=k},pos) :: rhs, + Predicate.add_pred_arguments_to_content pred_args content)) + ([],lhs_content) + e_rhs in + LOG "Done." LEVEL TRACE; + LOG "Preparing the i_rhs..." LEVEL TRACE; + let i_rhs,(content,_,_) = + List.fold_left + (fun (rhs,content) ({ASPred.p_id=n;ASPred.arity=k;ASPred.arguments=pred_args},pos) -> + (({Predicate.p_id=n;Predicate.arity=k},pos) :: rhs, + Predicate.add_pred_arguments_to_content pred_args content)) + ([],e_rhs_content) + i_rhs in + LOG "Done. Content is of size %d" (List.length content) LEVEL TRACE; + let internal_content = UF.create (List.rev content) in + LOG "It is represented by:" LEVEL TRACE; + Utils.log_iteration (fun c -> LOG c LEVEL TRACE) (UF.to_string internal_content); + {id=id; + lhs=Predicate.make_predicate lhs; + e_rhs=List.rev e_rhs; + i_rhs=List.rev i_rhs; + i_rhs_num=i_rhs_num; + content=internal_content; + } + + (* the [dag] parameter [h] is meant to be the components of some + predicate or rule *) + let cyclic_unify i j h = + match UF.cyclic i h with + | true,_ -> raise Fails + | _, h' -> + (try UF.union i j h with + | UF.Union_Failure -> raise Fails) + + + (** [extract_consequence r content] returns a fact from + content. The arguments are of the form [Const c] or [Var v] + (that is something of type {! + Datalog_AbstractSyntax.AbstractSyntax.Predicate.term}). When + it is a [Var v], it means that when this variable range over + the constants of the program, it still are facts (= + provable). *) + let extract_consequence r content = + let args,_,_= + List.fold_left + (fun (args,varmap,vargen) elt -> + match elt with + | UF.Value v -> (ASPred.Const v )::args,varmap,vargen + | UF.Link_to i -> + let new_var,new_varmap,new_vargen = + try + Utils.IntMap.find i varmap,varmap,vargen + with + | Not_found -> let n_v,n_vg=VarGen.get_fresh_id vargen in + n_v,Utils.IntMap.add i n_v varmap,n_vg in + (ASPred.Var new_var)::args,new_varmap,new_vargen ) + ([],Utils.IntMap.empty,VarGen.init ()) + (UF.extract (r.lhs.Predicate.arity) content) in + {ASPred.p_id=r.lhs.Predicate.p_id; + ASPred.arity=r.lhs.Predicate.arity; + ASPred.arguments=List.rev args } + (* TODO: Directly extract from content, then the list would be + crossed only once *) + + (** [to_abstract r content] returns a datalog abstract syntax rule + where the arguments of all (datalog abstract syntax) + predicates have been computed using [content]. *) + let to_abstract {id=id;lhs=lhs;e_rhs=e_rhs;i_rhs=i_rhs;i_rhs_num} content pred_table = + LOG "Going to work with the following content:" LEVEL TRACE; + Utils.log_iteration (fun s -> LOG s LEVEL TRACE) (UF.to_string content); + let abs_lhs,vars,vargen=Predicate.to_abstract lhs (1,content) (Utils.IntMap.empty,VarGen.init ()) pred_table in + let abs_e_rhs,start',vars',vargen'=Predicate.lst_to_abstract e_rhs (1+lhs.Predicate.arity,content) (vars,vargen) pred_table in + let abs_i_rhs,_,_,_ = Predicate.lst_to_abstract i_rhs (start',content) (vars',vargen') pred_table in + {ASRule.id=id; + ASRule.lhs=abs_lhs; + ASRule.e_rhs=abs_e_rhs; + ASRule.i_rhs=abs_i_rhs; + ASRule.i_rhs_num=i_rhs_num + } + + + (** [FactArray] is a module implementing a traversal of facts using + the {! ArrayTraversal.Make} functor. The [update] function is + such that we don't consider cells (i.e. facts) that don't unify + with the rule (i.e. a {! UF.Union_Failure} exception was + raised).*) + module FactArray=ArrayTraversal.Make2( + struct + type cell = Predicate.FactSet.elt (*P.fact *) + type state = (int*(ConstGen.id UF.t))*(cell list) + (* The state [(i,c),lst] stores the next index [i] of the + content [c] where the update should start, and [lst] keep + track of the facts against which the content has been + unified. {e Be careful:} it stores them in the reverse + order.*) + + module CellSet=Predicate.FactSet + let update (s,cells) c = + try + Some (Predicate.instantiate_with c s,c::cells) + with + | UF.Union_Failure -> None + end + ) + + (** [immediate_consequence_of_rule r db] returns a list of facts + generated by the rule [r] using the facts stored in [db]. {e + *these facts are not added to [db] when collecting the new + facts*}. + + Note that it is important that resulting states need to be + processed otherwise they will be lost in backtracking when using + {! PersistentArray}.*) + let rec immediate_consequence_of_rule r db = + (* We collect all the contents compatible with the facts of the + database corresponding to intensional predicates *) + let make_search_array_i_pred = + List.map (fun (pred,_) -> Predicate.PredMap.find pred.Predicate.p_id db) r.i_rhs in + (* We define the function to be run on each reached end state of + the instantiation with the extensional predicates *) + let resume_on_i_pred acc state = + FactArray.collect_results + (fun l_acc ((_,content),_) -> (extract_consequence r content)::l_acc) + acc + state + make_search_array_i_pred in + (* We now collect all the contents compatible with the facts of + the extensional database (facts of the database corresponding + to extensional predicates). *) + let make_search_array_e_pred = + List.map (fun (pred,_) -> Predicate.PredMap.find pred.Predicate.p_id db) r.e_rhs in + FactArray.collect_results + (fun acc s -> resume_on_i_pred acc s) + [] + ((r.lhs.Predicate.arity+1,r.content),[]) + make_search_array_e_pred + + end + + module Program = + struct + type program = {rules:Rule.rule list Predicate.PredMap.t; + (* the list of the rules of the program indexed by + the id of the lhs predicate *) + edb:ASPred.pred_id list; + (* the list of the ids of the extensional + predicates *) + edb_facts:Predicate.FactSet.t Predicate.PredMap.t; + (* a map from predicate ids to facts for this + predicate*) + idb:ASPred.pred_id list; + (* the list of the ids of the intensional + predicates *) + pred_table: ASPred.PredIdTable.table; + (* the table to record the translation from ids to + sym of the predicate *) + const_table: ConstGen.Table.table; + (* the table to record the translation from ids to + sym of the constants *) + rule_id_gen:IdGenerator.IntIdGen.t; + (* the id generator for the rules in case rules + are to be added after the first built of the + program*) +(* e_pred_to_rules: Rule.Rules.t AbstractSyntax.Predicate.PredIdMap.t; *) + (* a map keeping track of the rules where + extensional predicates occur so that when a rule + is dynamically added, if it turns an extensional + predicate into an intensional one, we can modify + the rules accordingly *) + (* This feature is an overkill for the kind of + extensions we're interested in for ACG parsing, + where only facts with edb predicates are added + when extending the program. To it is suppressed + for the moment *) + } + + + let empty = { + rules=Predicate.PredMap.empty; + edb=[]; + idb=[]; + edb_facts=Predicate.PredMap.empty; + pred_table=ASPred.PredIdTable.empty; + const_table=ConstGen.Table.empty; + rule_id_gen=IdGenerator.IntIdGen.init ()} + + let extend_map_to_list k v map_list = + try + let lst=Predicate.PredMap.find k map_list in + Predicate.PredMap.add k (v::lst) map_list + with + | Not_found -> Predicate.PredMap.add k [v] map_list + + let extend_map_to_set k v map_to_set = + let current_set = + try + Predicate.PredMap.find k map_to_set + with + | Not_found -> Predicate.FactSet.empty in + Predicate.PredMap.add k (Predicate.FactSet.add v current_set) map_to_set + + + + let make_program {ASProg.rules=r;ASProg.pred_table=pred_table;ASProg.const_table=cst_table;ASProg.i_preds=i_preds;ASProg.rule_id_gen;ASProg.e_pred_to_rules} = + let rules,e_facts,rule_to_rule_map = + ASRule.Rules.fold + (fun ({ASRule.lhs=lhs} as r) (acc,e_facts,r_to_r) -> + LOG "Dealing with rule:\t%s" (ASRule.to_string r pred_table cst_table) LEVEL TRACE; + let new_rule = Rule.make_rule r in + let updated_e_facts = + if not (ASPred.PredIds.mem lhs.ASPred.p_id i_preds) then + extend_map_to_set lhs.ASPred.p_id lhs e_facts + else + e_facts in + extend_map_to_list lhs.ASPred.p_id new_rule acc,updated_e_facts,ASRule.RuleMap.add r new_rule r_to_r) + r + (Predicate.PredMap.empty,Predicate.PredMap.empty,ASRule.RuleMap.empty) in + LOG "All rules done." LEVEL TRACE; + LOG "Now separate the e and i predicates." LEVEL TRACE; + let edb,idb= + ASPred.PredIdTable.fold + (fun k _ (e,i) -> + if ASPred.PredIds.mem k i_preds then + (e,k::i) + else + (k::e,i)) + pred_table + ([],[]) in + LOG "Done." LEVEL TRACE; + {rules=rules; + edb=edb; + edb_facts=e_facts; + idb=idb; + pred_table=pred_table; + const_table=cst_table; + rule_id_gen; + (*e_pred_to_rules= + AbstractSyntax.Predicate.PredIdMap.map + (fun rules -> + AbstractSyntax.Rule.Rules.fold + (fun r acc -> Rule.Rules.add (ASRule.RuleMap.find r rule_to_rule_map) acc) + rules + Rule.Rules.empty) + e_pred_to_rules*) + } + + + + + let to_abstract {rules=r;idb=idb;pred_table=pred_table;const_table=cst_table;rule_id_gen;edb_facts(*e_pred_to_rules*)} = + LOG "Transforming internal rules into abastract ones..." LEVEL TRACE; + let rules = + Predicate.PredMap.fold + (fun _ rules acc -> + List.fold_left + (fun acc' rule -> + ASRule.Rules.add (Rule.to_abstract rule rule.Rule.content pred_table) acc') + acc + rules) + r + ASRule.Rules.empty in + LOG "Done." LEVEL TRACE; + LOG "Transforming facts into rules" LEVEL TRACE; + let rules,rule_id_gen = + Predicate.PredMap.fold + (fun pred fact_set (acc,gen) -> + Predicate.FactSet.fold + (fun fact (l_acc,id_rule_gen) -> + let id_rule,id_rule_gen=IdGenerator.IntIdGen.get_fresh_id id_rule_gen in + let r=ASRule.({id=id_rule;lhs=fact;e_rhs=[];i_rhs=[];i_rhs_num=0}) in + LOG "Adding fact: %s" (ASRule.to_string r pred_table cst_table) LEVEL DEBUG; + ASRule.Rules.add r l_acc,id_rule_gen) + fact_set + (acc,gen)) + edb_facts + (rules,rule_id_gen) in + LOG "Done." LEVEL TRACE; + let i_preds= + List.fold_left + (fun acc id -> ASPred.PredIds.add id acc) + ASPred.PredIds.empty + idb in + ASProg.({rules=rules; + pred_table=pred_table; + const_table=cst_table; + i_preds=i_preds; + rule_id_gen; + e_pred_to_rules=AbstractSyntax.Predicate.PredIdMap.empty +(* AbstractSyntax.Predicate.PredIdMap.map + (fun rules -> + Rule.Rules.fold + (fun r acc -> + AbstractSyntax.Rule.Rules.add + (Rule.to_abstract r r.Rule.content pred_table) + acc) + rules + AbstractSyntax.Rule.Rules.empty) + e_pred_to_rules*) + }) + + + + (** [temp_facts r e_facts previous_step_facts facts delta_facts + agg_f start] returns the result of applying [agg_f] to [start] + and to all the facts that are deduced from [temp]{^ [time+1]}{_ + [S]} where [S] is the head predicate of the rule [r] and [temp] + is the set of temporary rules associated with [r] as in the + algorithm described in {{: + http://webdam.inria.fr/Alice/pdfs/Chapter-13.pdf} Chap. 13 of + "Foundations of Databases", Abiteboul, Hull, and Vianu} (p.315). + + [previous_step_facts] and [facts] denote the intentional facts + at the two required successive steps and [delta_facts] denote + the new facts that are computed during this step. *) + + (* TODO: if a set of facts for a predicate of the rhs is empty, we + can stop the computation *) + let temp_facts r e_facts previous_step_facts facts delta_facts agg_function start pred_table cst_table = + LOG "Scanning the rule: %s" (ASRule.to_string (Rule.to_abstract r r.Rule.content pred_table) pred_table cst_table) LEVEL TRACE; + (* We first collect all the contents compatible with the facts of + the intensional database. They depend on the intensional + predicate [delta_position] and the ones that are before it + ([rev_pred_lst]) and the ones that are after it + ([pred_lst]). This triple correspond to a {!Focused_list.t} + type. *) + let make_search_array_i_pred (rev_pred_lst,delta_position,pred_lst) = + let facts_at_delta_position= + try + Predicate.PredMap.find delta_position.Predicate.p_id delta_facts + with + | Not_found -> Predicate.FactSet.empty in + let end_pred_facts = + List.map + (fun pred -> + try + Predicate.PredMap.find pred.Predicate.p_id previous_step_facts + with + | Not_found -> Predicate.FactSet.empty) + pred_lst in + List.fold_left + (fun acc pred -> + try + (Predicate.PredMap.find pred.Predicate.p_id facts)::acc + with + | Not_found -> acc) + (facts_at_delta_position::end_pred_facts) + rev_pred_lst in + (* We define the function to be run on each reached end state of + the instantiation with the extensional predicates. This + function will run a result collection (with + [FactArray.collect_results]) for each of the possible + [delta_facts], that is for each of the possible [Focused_list] + that can be reach from [zip] (including [zip] itself). *) + let resume_on_i_pred acc (((i,content),premises) as state) = + match r.Rule.i_rhs with + | [] -> agg_function ((Rule.extract_consequence r content),premises) r acc + | _ -> + (* We now init the focused list corresponding to the intensional + predicates of the rule [r] *) + let zip=Focused_list.init (fst (List.split r.Rule.i_rhs)) in + Focused_list.fold + (fun l_acc focus -> + (* For a given focus in the intensional list of predicates + of [r], we extract all the possible facts from the rule + [r] *) + Rule.FactArray.collect_results + (fun ll_acc ((_,content),premises) -> agg_function ((Rule.extract_consequence r content),premises) r ll_acc) + l_acc + state + (make_search_array_i_pred focus)) + acc + zip in + (* We now collect all the contents compatible with the + facts of the extensional database *) + let make_search_array_e_pred = + List.map + (fun (pred,_) -> + try + Predicate.PredMap.find pred.Predicate.p_id e_facts + with + | Not_found -> Predicate.FactSet.empty) + r.Rule.e_rhs in + Rule.FactArray.collect_results + (fun acc s -> + (* For each partial completion of the rule on the extensional + database, we need to take into account the remaining + intensional predicates. *) + resume_on_i_pred acc s) + start + ((r.Rule.lhs.Predicate.arity+1,r.Rule.content),[]) + make_search_array_e_pred + + let custom_find k map = + try + Predicate.PredMap.find k map + with + | Not_found -> Predicate.FactSet.empty + + + (** [p_semantics_for_predicate s prog e_facts previous_step_facts + facts delta_facts] returns a set of all the facts that can + deduced by all the rules in [prog] at a given step and whose lhs + predicate is [s] when the edb is [e_facts], the step has + produced [facts] and the previous step has produced + [previous_step_facts] and the variation of facts at this step + are [delta_facts]. + + It corresponds to [P]{^ [time]}{_ [S]} [(edb,T]{^ [time -1]}{_ + [1]}[,...,T]{^ [time-1]}{_ [l]}[,T]{^ [time]}{_ [1]}[,...,T]{^ + [time]}{_ [l]}[, Delta]{^ [time]}{_ [T]{_ [1]}},...,[Delta]{^ + [time]}{_ [T]{_ [l]}}) in {{: + http://webdam.inria.fr/Alice/pdfs/Chapter-13.pdf} Chap. 13 of + "Foundations of Databases", Abiteboul, Hull, and Vianu} *) + let p_semantics_for_predicate s_id prog e_facts previous_step_facts facts delta_facts derivations = + List.fold_left + (fun acc r -> + temp_facts + r + e_facts + previous_step_facts + facts + delta_facts + (fun (new_fact,from_premises) r (new_fact_set,new_fact_derivations) -> + (Predicate.conditionnal_add + new_fact + new_fact_set + (custom_find r.Rule.lhs.Predicate.p_id previous_step_facts) + (custom_find r.Rule.lhs.Predicate.p_id delta_facts), + Predicate.add_to_map_to_set new_fact (from_premises,r.Rule.id,r.Rule.i_rhs_num) new_fact_derivations)) + acc + prog.pred_table + prog.const_table) + (Predicate.FactSet.empty,derivations) + (Predicate.PredMap.find s_id prog.rules) + + let seminaive prog = + (** [seminaive_aux facts delta_facts] returns [(S]{^ + [i]}[,][Delta]{^ [i+1]}{_ [S]}[)] for all [S] when [facts] + corresponds to [S]{^ [i-1]} for all [S] and [delta_facts] to + [Delta]{^ [i]}{_ [S]} for all [S] *) + let rec seminaive_aux facts delta_facts derivations = + (* TODO: Check that PredMap has all intensional predicates of + prog *) + let new_facts = + Predicate.PredMap.merge + (fun pred_id v1 v2 -> + match v1,v2 with + | Some l1,Some l2 -> Some (Predicate.FactSet.union l1 l2) + | Some _ as v,None -> v + | None, (Some _ as v) -> v + | None,None -> None) + facts + delta_facts in + let new_delta_facts,new_derivations_for_all_i_pred = + List.fold_left + (fun (acc,derivations) pred -> + LOG "Trying to derive facts for: %s" (ASPred.to_string {ASPred.p_id=pred;ASPred.arity=0;ASPred.arguments=[]} prog.pred_table prog.const_table) LEVEL DEBUG; + let new_facts_for_pred,new_derivations= + p_semantics_for_predicate + pred + prog + prog.edb_facts + facts + new_facts + delta_facts + derivations in + if Predicate.FactSet.is_empty new_facts_for_pred then + acc,new_derivations + else + Predicate.PredMap.add + pred + new_facts_for_pred + acc,new_derivations) + (Predicate.PredMap.empty,derivations) + prog.idb in + LOG "%d new facts:" (Predicate.PredMap.fold (fun _ v acc -> acc+(Predicate.FactSet.cardinal v)) new_delta_facts 0) LEVEL DEBUG; + Utils.log_iteration + (fun s -> LOG s LEVEL DEBUG) + (Predicate.facts_to_string new_delta_facts prog.pred_table prog.const_table); + (new_facts,new_delta_facts,new_derivations_for_all_i_pred) in + (** [seminaive_rec (facts,delta_facts)] returns the result when + the fixpoint is reached, ie when [seminaive_aux facts + delta_facts] does not produce any new fact. This is the + iteration at step 5 in the seminaive algo. *) + let rec seminaive_rec (facts,delta_facts,derivations)= + if Predicate.PredMap.is_empty delta_facts then + facts,derivations + else + seminaive_rec (seminaive_aux facts delta_facts derivations) in + let first_step_results = seminaive_aux prog.edb_facts Predicate.PredMap.empty Predicate.PredicateMap.empty in + seminaive_rec first_step_results + + let extend prog {ASProg.modified_rules;ASProg.new_pred_table;ASProg.new_const_table;ASProg.new_i_preds;ASProg.new_e_preds;ASProg.new_rule_id_gen;}= + let i_preds = + ASPred.PredIds.fold + (fun e acc -> + if List.mem e prog.idb then + acc + else + e::acc) + new_i_preds + prog.idb in + let internal_modified_rules,updated_e_facts = + ASRule.Rules.fold + (fun r (acc,e_facts) -> + let new_rule = Rule.make_rule r in + let updated_e_facts = + if + not (ASPred.PredIds.mem r.ASRule.lhs.ASPred.p_id new_i_preds) + && not (List.mem r.ASRule.lhs.ASPred.p_id prog.idb) + then + extend_map_to_set r.ASRule.lhs.ASPred.p_id r.ASRule.lhs e_facts + else + e_facts in + Rule.Rules.add new_rule acc,updated_e_facts) + modified_rules + (Rule.Rules.empty,prog.edb_facts) + in + let updated_rules = + Rule.Rules.fold + (fun ({Rule.lhs=lhs} as rule) acc -> + try + Predicate.PredMap.add + lhs.Predicate.p_id + (rule::(List.filter Rule.(fun r -> r.id=rule.id) (Predicate.PredMap.find lhs.Predicate.p_id acc))) + acc + with + | Not_found -> Predicate.PredMap.add lhs.Predicate.p_id [rule] acc) + internal_modified_rules + prog.rules in + {rules=updated_rules; + edb= + ASPred.PredIds.fold + (fun e acc -> + if List.mem e prog.idb then + acc + else + e::acc) + new_e_preds + prog.edb; + edb_facts=updated_e_facts; + idb=i_preds; + pred_table=new_pred_table; + const_table=new_const_table; + rule_id_gen=new_rule_id_gen; + } + + let add_e_fact prog (r,const_table,rule_id_gen) = + if List.mem r.ASRule.lhs.ASPred.p_id prog.idb then + failwith (Printf.sprintf "BUG: You're not supposed to extend a program with an intensional predicate \"%s\"" (ASPred.to_string {ASPred.p_id=r.ASRule.lhs.ASPred.p_id;ASPred.arity=r.ASRule.lhs.ASPred.arity;ASPred.arguments=[]} prog.pred_table ConstGen.Table.empty)) + else + {prog with + edb_facts= + extend_map_to_set r.ASRule.lhs.ASPred.p_id r.ASRule.lhs prog.edb_facts; + const_table; + rule_id_gen} + + let add_e_facts prog (r_lst,const_table,rule_id_gen) = + let edb,edb_facts = + List.fold_left + (fun (edb,edb_facts) r -> + let p_id=r.ASRule.lhs.ASPred.p_id in + let edb= + if List.mem p_id edb then + edb + else + p_id::edb in + let edb_facts= + if List.mem r.ASRule.lhs.ASPred.p_id prog.idb then + failwith (Printf.sprintf "BUG: You're not supposed to extend a program with an intensional predicate \"%s\"" (ASPred.to_string {ASPred.p_id=r.ASRule.lhs.ASPred.p_id;ASPred.arity=r.ASRule.lhs.ASPred.arity;ASPred.arguments=[]} prog.pred_table ConstGen.Table.empty)) + else + extend_map_to_set r.ASRule.lhs.ASPred.p_id r.ASRule.lhs edb_facts in + edb,edb_facts) + (prog.edb,prog.edb_facts) + r_lst in + {prog with + edb; + edb_facts; + const_table; + rule_id_gen} +(* + {prog with + edb= + List.fold_left + (fun acc r -> + let p_id=r.ASRule.lhs.ASPred.p_id in + if List.mem p_id acc then + acc + else + p_id::ac) + prog.edb + + edb_facts= + List.fold_left + (fun acc r -> + if List.mem r.ASRule.lhs.ASPred.p_id prog.idb then + failwith (Printf.sprintf "BUG: You're not supposed to extend a program with an intensional predicate \"%s\"" (ASPred.to_string {ASPred.p_id=r.ASRule.lhs.ASPred.p_id;ASPred.arity=r.ASRule.lhs.ASPred.arity;ASPred.arguments=[]} prog.pred_table ConstGen.Table.empty)) + else + extend_map_to_set r.ASRule.lhs.ASPred.p_id r.ASRule.lhs acc) + prog.edb_facts + r_lst; + const_table; + rule_id_gen} +*) + + + (** TODO: only useful until we change the type of idb and idb + to sets *) + + let rec list_extension_aux a lst scanned_lst = + match lst with + | [] -> List.rev (a::scanned_lst) + | b::tl when a=b -> List.rev_append scanned_lst lst + | b::tl -> list_extension_aux a tl (b::scanned_lst) + + let list_extension a lst = list_extension_aux a lst [] + + (** [add_rule r p] adds a [ASRule.rule] to a [Datalog.Program] + with the assumption that it will not change the {em + nature} of a predicate (that is making it change from + extensional to intensional). *) + + let add_rule ~intensional r prog = + let new_rule = Rule.make_rule r in + let lhs_pred=r.ASRule.lhs.ASPred.p_id in + let new_e_facts,new_edb,new_idb = + match intensional,r.ASRule.e_rhs,r.ASRule.i_rhs with + | false,[],[] -> + extend_map_to_set lhs_pred r.ASRule.lhs prog.edb_facts, + list_extension lhs_pred prog.edb, + prog.idb + | false,_,_ -> failwith "Bug: addition of a rule for an extensional predicate with non empty rhs" + | true,_,_ -> prog.edb_facts,prog.edb,list_extension lhs_pred prog.idb in + {prog with + rules=extend_map_to_list lhs_pred new_rule prog.rules; + edb_facts=new_e_facts; + edb=new_edb; + idb=new_idb} + + + + let get_fresh_rule_id ({rule_id_gen} as prog) = + let new_id,rule_id_gen=IdGenerator.IntIdGen.get_fresh_id rule_id_gen in + new_id,{prog with rule_id_gen} + + let get_fresh_cst_id name ({const_table} as prog) = + let id,const_table=ConstGen.Table.add_sym name const_table in + id,{prog with const_table} + + let add_pred_sym name ({pred_table} as prog) = + let p_id,pred_table=ASPred.PredIdTable.add_sym name pred_table in + p_id,{prog with pred_table} + + + + let rec build_children alt_num parent_address children_num facts derivations visited_facts prog = + List.fold_left + (fun (l_acc,child_num,l_visit) fact -> + LOG "Analysing fact: %s" (ASPred.to_string fact prog.pred_table prog.const_table) LEVEL DEBUG; + if List.mem fact.ASPred.p_id prog.edb then + (LOG "Skipping it" LEVEL DEBUG; + l_acc,child_num,l_visit) + else + (LOG "Keeping it" LEVEL DEBUG; + let cur_add=(alt_num,child_num)::parent_address in + LOG "It will have address [%s]" (AlterTrees.SharedForest.address_to_string (List.rev cur_add)) LEVEL DEBUG; + try + let existing_add = Predicate.PredicateMap.find fact l_visit in + let patch=SharedForest.diff (List.rev cur_add) (List.rev existing_add) in + LOG "Will point to: %s with patch %s" (SharedForest.address_to_string (List.rev existing_add)) (SharedForest.path_to_string patch) LEVEL DEBUG; + (SharedForest.Link_to patch)::l_acc, + child_num-1, + l_visit + with + | Not_found -> + let l_visit=Predicate.PredicateMap.add fact cur_add l_visit in + let premises = + try + Predicate.PredicateMap.find fact derivations + with + | Not_found -> Predicate.PremiseSet.empty in + let l_forest,_,l_visit = build_forest_aux fact premises derivations cur_add l_visit prog in + (SharedForest.Forest ([],List.rev l_forest))::l_acc, + child_num-1, + l_visit)) + ([],children_num,visited_facts) + facts + and + build_forest_aux fact premises derivations add visited_facts_addresses prog = + Predicate.PremiseSet.fold + (fun (facts,rule_id,i_rhs_num) (acc,alt_num,l_visited_facts) -> + let children_rev,_,l_visited_facts = + build_children alt_num add i_rhs_num facts derivations l_visited_facts prog in + (SharedForest.Node + (rule_id, + children_rev))::acc, + alt_num+1, + l_visited_facts) + premises + ([],1,visited_facts_addresses) + + + let build_forest_from_root fact premises derivations prog = + Predicate.PremiseSet.fold + (fun (facts,rule_id,i_rhs_num) (acc,alt_num,visited_facts_addresses) -> + LOG "Building alt_tree for root: rule %d" rule_id LEVEL DEBUG; + let cur_address= [] in + let visited_facts_addresses = Predicate.PredicateMap.add fact cur_address visited_facts_addresses in + let children_rev,_,visited_facts_addresses = + build_children alt_num [] i_rhs_num facts derivations visited_facts_addresses prog in + (SharedForest.Node + (rule_id, + children_rev + ))::acc, + alt_num+1, + visited_facts_addresses) + premises + ([],1,Predicate.PredicateMap.empty) + + + let build_forest ?query map prog = + let u_query = + match query with + | Some q -> Some (Predicate.make_unifiable_predicate q) + | None -> None in + let list_of_forest= + Predicate.PredicateMap.fold + (fun fact premises acc -> + match u_query with + | Some q when not (Predicate.unifiable fact q) -> acc + | _ -> + let forest,_,_ = + build_forest_from_root fact premises map prog in + (List.rev forest)::acc) + map + [] in + list_of_forest + + let edb_to_buffer prog = + let buff=Buffer.create 80 in + let () = + Predicate.PredMap.iter + (fun _ facts -> + Predicate.FactSet.iter + (fun fact -> Printf.bprintf buff "%s\n" (ASPred.to_string fact prog.pred_table prog.const_table)) + facts) + prog.edb_facts in + buff + + + end + + +end + + +module Datalog=Make(UnionFind.StoreAsMap) diff --git a/src/s_datalog/datalog.mli b/src/s_datalog/datalog.mli new file mode 100644 index 0000000000000000000000000000000000000000..1f0ba2354f11a8b88a8baa582c97de2e6f6eb2b1 --- /dev/null +++ b/src/s_datalog/datalog.mli @@ -0,0 +1,138 @@ +module ASPred:module type of Datalog_AbstractSyntax.AbstractSyntax.Predicate + with type pred_id=Datalog_AbstractSyntax.AbstractSyntax.Predicate.pred_id + and type PredIdTable.table = Datalog_AbstractSyntax.AbstractSyntax.Predicate.PredIdTable.table + +module ASRule:module type of Datalog_AbstractSyntax.AbstractSyntax.Rule + with type rule=Datalog_AbstractSyntax.AbstractSyntax.Rule.rule + +module ASProg:module type of Datalog_AbstractSyntax.AbstractSyntax.Program + with type program = Datalog_AbstractSyntax.AbstractSyntax.Program.program + + +module type Datalog_Sig= +sig + exception Fails + module UF:UnionFind.S + + module Predicate : + sig + type predicate = { p_id : ASPred.pred_id; arity : int; } + val make_predicate : Datalog_AbstractSyntax.AbstractSyntax.Predicate.predicate -> predicate + module PredMap : Map.S with type key = ASPred.pred_id + module FactSet :Set.S with type elt = ASPred.predicate + val conditionnal_add : + FactSet.elt -> FactSet.t -> FactSet.t -> FactSet.t -> FactSet.t + val facts_to_string : FactSet.t PredMap.t -> ASPred.PredIdTable.table -> Datalog_AbstractSyntax.ConstGen.Table.table -> string + module PredicateMap : Map.S with type key = ASPred.predicate + module Premise : + sig + type t = ASPred.predicate list * int * int (* the first int parameter is meant to be the rule id and the second one to be the number of intensional predicates occurring in it*) + val to_string : t -> ASPred.PredIdTable.table -> Datalog_AbstractSyntax.ConstGen.Table.table -> string + end + module PremiseSet : Set.S with type elt = Premise.t + val add_map_to_premises_to_buffer : Buffer.t -> ASPred.PredIdTable.table -> Datalog_AbstractSyntax.ConstGen.Table.table -> PremiseSet.t PredicateMap.t -> unit + val format_derivations2 : ?query:Datalog_AbstractSyntax.AbstractSyntax.Predicate.predicate -> ASPred.PredIdTable.table -> Datalog_AbstractSyntax.ConstGen.Table.table -> PremiseSet.t PredicateMap.t -> unit + + + + + val add_pred_arguments_to_content : + ASPred.term list -> + Datalog_AbstractSyntax.ConstGen.id UF.content list * int * + int Datalog_AbstractSyntax.VarGen.IdMap.t -> + Datalog_AbstractSyntax.ConstGen.id UF.content list * int * + int Datalog_AbstractSyntax.VarGen.IdMap.t + + end + + module Rule : + sig + type rule = { + id : int; + lhs : Predicate.predicate; + e_rhs : (Predicate.predicate*int) list; + i_rhs : (Predicate.predicate*int) list; + i_rhs_num:int; + content : Datalog_AbstractSyntax.ConstGen.id UF.t; + } + val make_rule : ASRule.rule -> rule + val cyclic_unify : int -> int -> 'a UF.t -> 'a UF.t + val extract_consequence : + rule -> Datalog_AbstractSyntax.ConstGen.id UF.t -> ASPred.predicate + module FactArray : + sig + type row = Predicate.FactSet.t + type array = row list + val collect_results : + ('a -> (int * Datalog_AbstractSyntax.ConstGen.id UF.t) * Predicate.FactSet.elt list -> 'a) -> + 'a -> + (int * Datalog_AbstractSyntax.ConstGen.id UF.t) * Predicate.FactSet.elt list -> array -> 'a + end + val immediate_consequence_of_rule : + rule -> FactArray.row Predicate.PredMap.t -> ASPred.predicate list + + module Rules:Set.S with type elt=rule + end + + module Program : + sig + type program = { + rules : Rule.rule list Predicate.PredMap.t; + edb : ASPred.pred_id list; + edb_facts:Predicate.FactSet.t Predicate.PredMap.t; + idb : ASPred.pred_id list; + pred_table: ASPred.PredIdTable.table; + const_table: Datalog_AbstractSyntax.ConstGen.Table.table; + rule_id_gen:IdGenerator.IntIdGen.t; + } + val empty : program + val make_program : ASProg.program -> program + val temp_facts : + Rule.rule -> + Rule.FactArray.row Predicate.PredMap.t -> + Rule.FactArray.row Predicate.PredMap.t -> + Rule.FactArray.row Predicate.PredMap.t -> + Rule.FactArray.row Predicate.PredMap.t -> + (ASPred.predicate * Predicate.FactSet.elt list -> Rule.rule -> 'a -> 'a) -> 'a -> ASPred.PredIdTable.table -> Datalog_AbstractSyntax.ConstGen.Table.table -> 'a + val p_semantics_for_predicate : + Predicate.PredMap.key -> + program -> + Rule.FactArray.row Predicate.PredMap.t -> + Rule.FactArray.row Predicate.PredMap.t -> + Rule.FactArray.row Predicate.PredMap.t -> + Rule.FactArray.row Predicate.PredMap.t -> Predicate.PremiseSet.t Predicate.PredicateMap.t -> Predicate.FactSet.t * Predicate.PremiseSet.t Predicate.PredicateMap.t + val seminaive : program -> Rule.FactArray.row Predicate.PredMap.t * Predicate.PremiseSet.t Predicate.PredicateMap.t + val to_abstract : program -> ASProg.program + + val extend : program -> ASProg.modifier -> program + + val add_e_facts : program -> (ASRule.rule list*Datalog_AbstractSyntax.ConstGen.Table.table*IdGenerator.IntIdGen.t) -> program + + (** [add_rule i r p] adds a [ASRule.rule] to a [Datalog.Program] + with the assumption that it will not change the {em nature} of + any predicate (that is making it change from extensional to + intensional). If [i] is set to true, then the rule concerns an + intensional predicate. If it is set to [false] then it + concerns an extensional predicate and the rhs of the rule + should be empty.*) + + val add_rule : intensional:bool -> ASRule.rule -> program -> program + + + val get_fresh_rule_id : program -> (int * program) + val get_fresh_cst_id : string -> program -> (Datalog_AbstractSyntax.ConstGen.id * program) + val add_pred_sym : string -> program -> (ASPred.pred_id*program) + + val build_forest : ?query:Datalog_AbstractSyntax.AbstractSyntax.Predicate.predicate -> Predicate.PremiseSet.t Predicate.PredicateMap.t -> program -> int SharedForest.SharedForest.tree list list + + val edb_to_buffer : program -> Buffer.t + + end +end + + + +module Make : + functor (S : UnionFind.Store) -> Datalog_Sig + +module Datalog:Datalog_Sig diff --git a/src/s_datalog/datalog_AbstractSyntax.ml b/src/s_datalog/datalog_AbstractSyntax.ml new file mode 100644 index 0000000000000000000000000000000000000000..a5426307a2ab544b48ede9a8ee55006bc93fffd4 --- /dev/null +++ b/src/s_datalog/datalog_AbstractSyntax.ml @@ -0,0 +1,410 @@ +open IdGenerator +open Utils + +module Var= +struct + type t=Var of int + let compare (Var i) (Var j)=i-j + let succ (Var i)=Var (i+1) + let start=Var 0 + let to_string (Var i) = + let c = Printf.sprintf "%c" (char_of_int (97+i)) in + c + +end + +module VarGen = IdGen(Var) + +module Const= +struct + type t=Const of int + let compare (Const i) (Const j)=i-j + let start=Const 0 + let succ (Const i)=Const (i+1) + let to_string (Const i) = string_of_int i +end + +module ConstGen=IdGen(Const) + +module AbstractSyntax = +struct + (** These modules are the abstract syntactic representations of the + predicates, of the rules, and of the programs *) + module Predicate = + struct + type term = + | Var of VarGen.id + | Const of ConstGen.id + + module VarMap = Map.Make (Var) + + let map_content_compare (k1,map1) (k2,map2) = + try + let val1 = VarMap.find k1 map1 in + (try + val1-(VarMap.find k2 map2) + with + | Not_found -> 1) + with + | Not_found -> + (try + let _ = VarMap.find k2 map2 in + -1 + with + | Not_found -> 0) + + + + let term_compare l1 l2 = + let rec term_compare_aux l1 l2 (l1_vars,l2_vars) pos = + match l1,l2 with + | [],[] -> 0 + | [],_ -> -1 + | _,[] -> 1 + | (Const _)::_,(Var _)::_ -> 1 + | (Var _)::_,(Const _)::_ -> -1 + | (Const a1)::tl1,(Const a2)::tl2 -> + let res = ConstGen.compare a1 a2 in + if ConstGen.compare a1 a2 <> 0 then + res + else + term_compare_aux tl1 tl2 (l1_vars,l2_vars) (pos+1) + | (Var a1)::tl1,(Var a2)::tl2 -> + let res = map_content_compare (a1,l1_vars) (a2,l2_vars) in + if VarGen.compare a1 a2 <> 0 then + res + else + term_compare_aux tl1 tl2 (VarMap.add a1 pos l1_vars,VarMap.add a2 pos l2_vars) (pos+1) in + term_compare_aux l1 l2 (VarMap.empty,VarMap.empty) 0 + + + let term_to_string t cst_id_table = + match t with + | Var v -> Var.to_string v + | Const c -> (* Const.to_string c *) + ConstGen.Table.find_sym_from_id c cst_id_table + + type pred_id=int + + module PredIdMap = IntIdGen.IdMap + module PredIdTable = IntIdGen.Table + + type predicate={p_id:pred_id; + arity:int; + arguments: term list + (** It is assumed that the size of the list is the + arity *) + } + + let to_string predicate (*{p_id=p_id;arguments=parameters}*) pred_id_table cst_id_table= + Printf.sprintf "%s(%s)" + (PredIdTable.find_sym_from_id predicate.p_id pred_id_table) + (Utils.string_of_list "," (fun p -> term_to_string p cst_id_table) predicate.arguments) + + let compare ({p_id=id1;arity=a1;arguments=l1}:predicate) ({p_id=id2;arity=a2;arguments=l2}:predicate) = + let res = compare id1 id2 in + if res<>0 then + res + else + let res = a1-a2 in + if res<>0 then + res + else + term_compare l1 l2 + + module PredIds=Utils.IntSet + + end + + module Proto_Rule = + struct + type t = {proto_id:int; + proto_lhs:Predicate.predicate; + proto_rhs:Predicate.predicate list; + (** represents the predicates of the rule *) + } + + let to_string r pred_id_table cst_id_table= + let head=Predicate.to_string r.proto_lhs pred_id_table cst_id_table in + let tail= + match r.proto_rhs with + | [] -> "." + | _ -> + Printf.sprintf + ":- %s." + (Utils.string_of_list "," (fun p -> Predicate.to_string p pred_id_table cst_id_table) r.proto_rhs) in + Printf.sprintf "%s%s\n" head tail + + + let to_buffer rules pred_id_table cst_id_table = + let buff=Buffer.create 4 in + let () = + List.iter + (fun r -> Buffer.add_string + buff + (Printf.sprintf "%s\n" (to_string r pred_id_table cst_id_table))) + rules in + buff + end + + module Rule = + struct + type rule={id:int; + lhs:Predicate.predicate; + e_rhs:(Predicate.predicate*int) list; + i_rhs:(Predicate.predicate*int) list; + i_rhs_num:int; + } + + let to_string r pred_id_table cst_id_table = + let head=Predicate.to_string r.lhs pred_id_table cst_id_table in + let string_of_predicate_list lst = Utils.string_of_list "," (fun p -> Predicate.to_string p pred_id_table cst_id_table) lst in + let vdash,e_i_sep = + match r.e_rhs,r.i_rhs with + | [],[] -> "","" + | [],_ -> ":- "," " + | _,[] -> ":- "," " + | _,_ -> ":- "," , " in + Printf.sprintf "%s%s%s%s%s." head vdash ((string_of_predicate_list >> fst >> List.split) r.e_rhs) e_i_sep ((string_of_predicate_list >> fst >> List.split) r.i_rhs) + + module Rules=Set.Make(struct + type t=rule + let compare {id=i} {id=j} = i-j + end) + + module RuleMap=Map.Make(struct + type t=rule + let compare {id=i} {id=j} = i-j + end) + + + let ids_to_rules ids id_to_rule_map = + IntSet.fold + (fun e acc -> Rules.add (IntMap.find e id_to_rule_map) acc) + ids + Rules.empty + + let to_buffer rules pred_id_table cst_id_table = + let buff=Buffer.create 4 in + let () = + Rules.iter + (fun r -> + let () = + Buffer.add_string + buff + (to_string r pred_id_table cst_id_table) in + Buffer.add_string buff "\n") + rules in + buff + + let init_split_rhs proto_preds intensional_pred = + let i_num,i_p,e_p,_= + List.fold_left + (fun (i_num,i_preds,e_preds,i) ({Predicate.p_id=p_id} as pred) -> + if Predicate.PredIds.mem p_id intensional_pred + then + (i_num+1,(pred,i)::i_preds,e_preds,i+1) + else + (i_num,i_preds,(pred,i)::e_preds,i+1)) + (0,[],[],1) + proto_preds in + i_num,i_p,e_p + + let update_split_rhs init proto_preds intensional_pred = + List.fold_left + (fun (i_preds,e_preds) (({Predicate.p_id=p_id},_) as pred) -> + if Predicate.PredIds.mem p_id intensional_pred + then + (pred::i_preds,e_preds) + else + (i_preds,pred::e_preds)) + init + proto_preds + + let extend_map_to_set k v map_to_set = + let current_set = + try + Predicate.PredIdMap.find k map_to_set + with + | Not_found -> IntSet.empty in + Predicate.PredIdMap.add k (IntSet.add v current_set) map_to_set + + + + let proto_rule_to_rule proto_rule intensional_pred = + let i_num,i_preds,e_preds = + init_split_rhs proto_rule.Proto_Rule.proto_rhs intensional_pred in + {id=proto_rule.Proto_Rule.proto_id; + lhs=proto_rule.Proto_Rule.proto_lhs; + e_rhs=List.rev e_preds; + i_rhs=List.rev i_preds; + i_rhs_num=i_num} + + let update rule intensional_pred = + let i_preds,e_preds = + update_split_rhs (rule.i_rhs,[]) rule.e_rhs intensional_pred in + {rule with e_rhs=e_preds;i_rhs=i_preds} + end + + module Proto_Program = + struct + type t = {rules:Proto_Rule.t list; + pred_table: Predicate.PredIdTable.table; + const_table: ConstGen.Table.table; + i_preds:Predicate.PredIds.t; + rule_id_gen:IntIdGen.t; + pred_to_rules:IntSet.t Predicate.PredIdMap.t} + + type tables = Predicate.PredIdTable.table*(VarGen.Table.table*ConstGen.Table.table) + + let empty = {rules=[]; + pred_table=Predicate.PredIdTable.empty; + const_table=ConstGen.Table.empty; + i_preds=Predicate.PredIds.empty; + rule_id_gen=IntIdGen.init (); + pred_to_rules=Predicate.PredIdMap.empty} + + let extension pred_table const_table rule_id_gen= + {rules=[]; + pred_table; + const_table; + i_preds=Predicate.PredIds.empty; + rule_id_gen; + pred_to_rules=Predicate.PredIdMap.empty} + + let add_proto_rule (f_lhs,f_rhs) prog = + let rule_id,new_rule_id_gen=IntIdGen.get_fresh_id prog.rule_id_gen in + let lhs,(new_pred_id_table,new_tables)=f_lhs (prog.pred_table,(VarGen.Table.empty,prog.const_table)) in + let rhs,(new_pred_id_table',(_,new_const_table))=f_rhs (new_pred_id_table,new_tables) in + let new_i_preds= + match rhs with + | [] -> prog.i_preds + | _ -> Predicate.PredIds.add lhs.Predicate.p_id prog.i_preds in + let new_rule = {Proto_Rule.proto_id=rule_id; + Proto_Rule.proto_lhs=lhs; + Proto_Rule.proto_rhs=rhs} in + {rules=new_rule::prog.rules; + pred_table=new_pred_id_table'; + const_table=new_const_table; + i_preds=new_i_preds; + rule_id_gen=new_rule_id_gen; + pred_to_rules= + List.fold_left + (fun acc p -> Rule.extend_map_to_set p.Predicate.p_id rule_id acc) + prog.pred_to_rules + rhs + } + + + end + + module Program = + struct + type program = {rules:Rule.Rules.t; + pred_table: Predicate.PredIdTable.table; + const_table: ConstGen.Table.table; + i_preds:Predicate.PredIds.t; + rule_id_gen:IntIdGen.t; + e_pred_to_rules: Rule.Rules.t Predicate.PredIdMap.t} + + type modifier = {modified_rules:Rule.Rules.t; + new_pred_table: Predicate.PredIdTable.table; + new_const_table: ConstGen.Table.table; + new_i_preds:Predicate.PredIds.t; + new_e_preds:Predicate.PredIds.t; + new_rule_id_gen:IntIdGen.t;} + + + let make_program {Proto_Program.rules;Proto_Program.pred_table;Proto_Program.const_table;Proto_Program.i_preds;Proto_Program.rule_id_gen;Proto_Program.pred_to_rules}= + let actual_rules,ids_to_rule_map = + List.fold_left + (fun (acc,ids_to_rule_map) p_rule -> + let rule = Rule.proto_rule_to_rule p_rule i_preds in + Rule.Rules.add rule acc, + IntMap.add p_rule.Proto_Rule.proto_id rule ids_to_rule_map) + (Rule.Rules.empty,IntMap.empty) + rules in + {rules=actual_rules; + pred_table=pred_table; + const_table=const_table; + i_preds=i_preds; + rule_id_gen=rule_id_gen; + e_pred_to_rules= + Predicate.PredIdMap.fold + (fun p rule_ids acc -> + if Predicate.PredIds.mem p i_preds then + Predicate.PredIdMap.remove p acc + else + Predicate.PredIdMap.add p (Rule.ids_to_rules rule_ids ids_to_rule_map) acc) + pred_to_rules + Predicate.PredIdMap.empty} + + + let extend prog {Proto_Program.rules;Proto_Program.pred_table;Proto_Program.const_table;Proto_Program.i_preds;Proto_Program.rule_id_gen;Proto_Program.pred_to_rules}= + let new_i_preds = Predicate.PredIds.union prog.i_preds i_preds in + let updated_e_pred_map_to_r,updated_rules = + (* all the rules that were pointed to by an extensional + predicate that has be turned into an intensional predicate + because of the program extension have to be updated *) + (* We check if some the new intensional predicates also are + keys of the e_pred_to_rules map of the previous program *) + Predicate.PredIds.fold + (fun p_id ((e_p_to_r,rules_acc) as acc) -> + try + (* First we check wether this predicate was considered + as an extensional one *) + let to_be_modified_rules = + Predicate.PredIdMap.find p_id prog.e_pred_to_rules in + (* If yes, we nee to remove it from the map *) + Predicate.PredIdMap.remove p_id e_p_to_r, + (* And to modify the rules it pointed to *) + Rule.Rules.fold + (fun r acc -> + Rule.Rules.add (Rule.update r new_i_preds) (Rule.Rules.remove r acc)) + to_be_modified_rules + rules_acc + with + (* If no, don't do anything *) + | Not_found -> acc) + i_preds + (prog.e_pred_to_rules,prog.rules) in + let new_rules,id_to_rule_map = + List.fold_left + (fun (acc,id_to_rule_map) p_rule -> + let rule=Rule.proto_rule_to_rule p_rule new_i_preds in + Rule.Rules.add rule acc, + IntMap.add p_rule.Proto_Rule.proto_id rule id_to_rule_map) + (updated_rules,IntMap.empty) + rules in + {rules=new_rules; + pred_table=pred_table; + const_table=const_table; + i_preds=new_i_preds; + rule_id_gen=rule_id_gen; + e_pred_to_rules= + Predicate.PredIdMap.merge + (fun p opt_rule_ids opt_rules -> + match opt_rule_ids, opt_rules with + | None,None -> None + | None,_ -> opt_rules + | Some ids,None -> Some (Rule.ids_to_rules ids id_to_rule_map) + | Some ids,Some rules -> + Some (Rule.Rules.union rules (Rule.ids_to_rules ids id_to_rule_map))) + pred_to_rules + updated_e_pred_map_to_r + } + + + + let to_buffer prog = + let buff = Rule.to_buffer prog.rules prog.pred_table prog.const_table in + let () = Buffer.add_string buff "Intensional predicates are:\n" in + let () = + Predicate.PredIds.iter + (fun elt -> Buffer.add_string buff (Printf.sprintf "\t%s\n%!" (Predicate.PredIdTable.find_sym_from_id elt prog.pred_table))) + prog.i_preds in + buff + end + +end + diff --git a/src/s_datalog/datalog_AbstractSyntax.mli b/src/s_datalog/datalog_AbstractSyntax.mli new file mode 100644 index 0000000000000000000000000000000000000000..b9ad6a2c296b9a4e036c11c7f105a9c708c2df0f --- /dev/null +++ b/src/s_datalog/datalog_AbstractSyntax.mli @@ -0,0 +1,119 @@ +open IdGenerator + +module VarGen:IdGen_TYPE +module ConstGen:IdGen_TYPE + +(** These modules are the abstract syntactic representations of + predicates and rules *) + + +module AbstractSyntax : +sig + module Predicate : + sig + type term = + | Var of VarGen.id + | Const of ConstGen.id + + type pred_id + + module PredIdMap:Map.S with type key=pred_id + module PredIdTable:CorrespondanceTableTYPE with type identifier=pred_id + module PredIds : Set.S with type elt=pred_id + + type predicate={p_id:pred_id; + arity:int; + arguments:term list + (** It is assumed that the size of the list is the + arity *) + } + + val to_string : predicate -> PredIdTable.table -> ConstGen.Table.table -> string + val compare : predicate -> predicate -> int + + + end + + + + module Proto_Rule: + sig + type t={proto_id:int; + proto_lhs:Predicate.predicate; + proto_rhs:Predicate.predicate list; + (** represents the predicates of the rule.*) + } + val to_string : t -> Predicate.PredIdTable.table -> ConstGen.Table.table -> string + + end + + + module Rule: + sig + + type rule={id:int; + lhs:Predicate.predicate; + e_rhs:(Predicate.predicate*int) list; + (** represents the extensionnal predicates of the + rule. The [int] represents the position in the rule *) + i_rhs:(Predicate.predicate*int) list; + (** represents the intensionnal predicates of the rule. + The [int] represents the position in the rule *) + i_rhs_num:int; + (* stores the number of intensional predicates occurring in the + rule *) + } + val to_string : rule -> Predicate.PredIdTable.table -> ConstGen.Table.table -> string + val proto_rule_to_rule : Proto_Rule.t -> Predicate.PredIds.t -> rule + + module Rules : Set.S with type elt=rule + module RuleMap : Map.S with type key=rule + end + + module Proto_Program : + sig + type t= {rules:Proto_Rule.t list; + pred_table: Predicate.PredIdTable.table; + const_table: ConstGen.Table.table; + i_preds:Predicate.PredIds.t; + rule_id_gen:IntIdGen.t; + pred_to_rules:Utils.IntSet.t Predicate.PredIdMap.t} + + type tables = Predicate.PredIdTable.table*(VarGen.Table.table*ConstGen.Table.table) + + val empty : t + + (** [extension pred_table const_table id_gen] returns an almost + empty proto program. This almost empty proto program is mean to + serve as extension of an actual program *) + val extension : Predicate.PredIdTable.table -> ConstGen.Table.table -> IntIdGen.t -> t + + val add_proto_rule : ((tables -> (Predicate.predicate*tables))*(tables -> ((Predicate.predicate list)*tables))) -> t -> t + + end + + module Program : + sig + + type program = {rules:Rule.Rules.t; + pred_table: Predicate.PredIdTable.table; + const_table: ConstGen.Table.table; + i_preds:Predicate.PredIds.t; + rule_id_gen:IntIdGen.t; + e_pred_to_rules: Rule.Rules.t Predicate.PredIdMap.t} + + type modifier = {modified_rules:Rule.Rules.t; + new_pred_table: Predicate.PredIdTable.table; + new_const_table: ConstGen.Table.table; + new_i_preds:Predicate.PredIds.t; + new_e_preds:Predicate.PredIds.t; + new_rule_id_gen:IntIdGen.t;} + + + val make_program : Proto_Program.t -> program + val extend : program -> Proto_Program.t -> program + val to_buffer : program -> Buffer.t + end +end + + diff --git a/src/s_datalog/db_lexer.mll b/src/s_datalog/db_lexer.mll new file mode 100644 index 0000000000000000000000000000000000000000..2d9d6422d4765ef1a4902dc0bace8c0f8c7b1e4d --- /dev/null +++ b/src/s_datalog/db_lexer.mll @@ -0,0 +1,40 @@ +{ + open Db_parser +} + +let newline = ('\010' | '\013' | "\013\010") +let letter = ['a'-'z' 'A'-'Z'] +let digit = ['0'-'9'] +let string = (letter|digit|'_')*'\''* + + rule lexer = + parse + | [' ' '\t'] {lexer lexbuf} + | newline {lexer lexbuf} + | "(*" {comment 1 lexbuf} + | "*)" {failwith "Unstarted comments"} + | eof {EOI} + | "," {COMMA} + | "." {DOT} + | "(" {LPAR} + | ")" {RPAR} + | ":-" {FROM} + | "/" {SLASH} + | "?" {QUESTION_MARK} + | letter string {IDENT (Lexing.lexeme lexbuf)} + | '-'?digit+ {let s = Lexing.lexeme lexbuf in + INT (int_of_string s)} +and comment level = + parse + | "*)" { + if level>1 then + comment (level -1) lexbuf + else + if level=1 then + lexer lexbuf + else + failwith "Unstarted comment" + } + | eof {failwith "Unclosed somment"} + | _ {comment level lexbuf} + diff --git a/src/s_datalog/db_parser.mly b/src/s_datalog/db_parser.mly new file mode 100644 index 0000000000000000000000000000000000000000..c82c731fcad34b9ebe66083c5631134173f24449 --- /dev/null +++ b/src/s_datalog/db_parser.mly @@ -0,0 +1,139 @@ +%{ + open IdGenerator + open Datalog_AbstractSyntax + + let check_arity pred_sym length = function + | Some a when a<>length -> + let () = flush stdout in + let () = Printf.fprintf stderr "The specified arity of predicate '%s/%d' does not match the actual number of arguments (%d)\n%!" pred_sym a length in + raise Parsing.Parse_error + | _ -> () +%} + +%token IDENT +%token INT +%token LPAR RPAR COMMA DOT FROM EOI SLASH QUESTION_MARK + + +%start rule program extensional_facts query +%type < Datalog_AbstractSyntax.AbstractSyntax.Proto_Program.t -> Datalog_AbstractSyntax.AbstractSyntax.Proto_Program.t > rule +%type < Datalog_AbstractSyntax.AbstractSyntax.Proto_Program.t -> Datalog_AbstractSyntax.AbstractSyntax.Proto_Program.t > program +%type < (Datalog_AbstractSyntax.AbstractSyntax.Predicate.PredIdTable.table * Datalog_AbstractSyntax.ConstGen.Table.table) -> (Datalog_AbstractSyntax.AbstractSyntax.Predicate.predicate * Datalog_AbstractSyntax.AbstractSyntax.Predicate.PredIdTable.table * Datalog_AbstractSyntax.ConstGen.Table.table) > query +%type < (Datalog_AbstractSyntax.AbstractSyntax.Predicate.PredIdTable.table * Datalog_AbstractSyntax.ConstGen.Table.table*IdGenerator.IntIdGen.t) -> (Datalog_AbstractSyntax.AbstractSyntax.Rule.rule list*Datalog_AbstractSyntax.ConstGen.Table.table*IdGenerator.IntIdGen.t) > extensional_facts + +%% + + program : + | rule EOI { fun prog -> $1 prog } + | rule program { fun prog -> + let new_prog = $1 prog in + $2 new_prog} + + rule : + | predicate DOT { fun prog -> + AbstractSyntax.Proto_Program.add_proto_rule ($1,fun t -> [],t) prog} + + | predicate FROM predicate_list DOT { fun prog -> + AbstractSyntax.Proto_Program.add_proto_rule ($1,$3) prog } + + predicate_list : + | predicate {fun (pred_id_table,tables) -> + let predicate,(new_pred_id_table,new_tables)= $1 (pred_id_table,tables) in + [predicate],(new_pred_id_table,new_tables) } + | predicate COMMA predicate_list {fun (pred_id_table,tables) -> + let predicate,(new_pred_id_table,new_tables)= $1 (pred_id_table,tables) in + let remaining_pred,(new_pred_id_table',new_tables')=$3 (new_pred_id_table,new_tables) in + predicate::remaining_pred,(new_pred_id_table',new_tables') } + + predicate : + | pred_id LPAR parameters RPAR {fun (pred_id_table,tables) -> + let pred_sym,arity = $1 in + let parameters,new_tables=$3 tables in + let length=List.length parameters in + let () = check_arity pred_sym length arity in + let new_sym = Printf.sprintf "%s/%d" pred_sym (List.length parameters) in + let pred_id,new_pred_id_table = AbstractSyntax.Predicate.PredIdTable.add_sym new_sym pred_id_table in + {AbstractSyntax.Predicate.p_id=pred_id; + AbstractSyntax.Predicate.arity=List.length parameters; + AbstractSyntax.Predicate.arguments=parameters},(new_pred_id_table,new_tables) } + + pred_id : + | IDENT SLASH INT {$1,Some $3} + | IDENT {$1,None} + + parameters: + | parameter {fun tables -> + let par,new_tables=$1 tables in + [par],new_tables} + | parameter COMMA parameters {fun tables -> + let par,new_tables=$1 tables in + let other_parameters,new_tables'=$3 new_tables in + par::other_parameters,new_tables'} + + parameter : + | INT {fun (var_table,const_table) -> + let cst,new_const_table=ConstGen.Table.add_sym (string_of_int $1) const_table in + AbstractSyntax.Predicate.Const cst,(var_table,new_const_table)} + | IDENT {fun (var_table,const_table) -> + let var,new_var_table=VarGen.Table.add_sym $1 var_table in + AbstractSyntax.Predicate.Var var,(new_var_table,const_table)} + + query: + | pred_id LPAR parameters RPAR QUESTION_MARK { fun (pred_id_table,const_table) -> + let pred_sym,arity = $1 in + let parameters,(_,new_const_table)=$3 (VarGen.Table.empty,const_table) in + let length=List.length parameters in + let () = check_arity pred_sym length arity in + let new_sym = Printf.sprintf "%s/%d" pred_sym length in + let pred_id,new_pred_id_table = AbstractSyntax.Predicate.PredIdTable.add_sym new_sym pred_id_table in + {AbstractSyntax.Predicate.p_id=pred_id; + AbstractSyntax.Predicate.arity=length; + AbstractSyntax.Predicate.arguments=parameters}, + new_pred_id_table,new_const_table} + + + + + + + extensional_facts : + | extensional_fact EOI {fun param -> + let r,new_cst_tble,new_gen = $1 param in + [r],new_cst_tble,new_gen} + | extensional_fact extensional_facts {fun (pred_id_table,cst_table,gen) -> + let r_lst,new_cst_tble,new_gen = $2 (pred_id_table,cst_table,gen) in + let r,new_cst_tble',new_gen' = $1 (pred_id_table,new_cst_tble,new_gen) in + r::r_lst,new_cst_tble',new_gen'} + + extensional_fact : + | pred_id LPAR parameters RPAR DOT { fun (pred_id_table,const_table,rule_id_gen) -> + let pred_sym,arity = $1 in + let parameters,(_,new_const_table)=$3 (VarGen.Table.empty,const_table) in + let length=List.length parameters in + let () = check_arity pred_sym length arity in + let new_sym = Printf.sprintf "%s/%d" pred_sym length in + try + let pred_id = AbstractSyntax.Predicate.PredIdTable.find_id_of_sym new_sym pred_id_table in + let rule_id,new_rule_id_gen=IntIdGen.get_fresh_id rule_id_gen in + let lhs = {AbstractSyntax.Predicate.p_id=pred_id; + AbstractSyntax.Predicate.arity=List.length parameters; + AbstractSyntax.Predicate.arguments=parameters} in + AbstractSyntax.Rule.({id=rule_id; + lhs=lhs; + e_rhs=[]; + i_rhs=[]; + i_rhs_num=0}), + new_const_table,new_rule_id_gen + with + | AbstractSyntax.Predicate.PredIdTable.Not_found -> + let () = flush stdout in + let () = Printf.fprintf stderr "You try to add a fact about a predicate \"%s\" that is not a predicate of the program yet\n%!" new_sym in + raise Parsing.Parse_error} + + + + + + + +%% diff --git a/src/s_datalog/db_test.ml b/src/s_datalog/db_test.ml new file mode 100644 index 0000000000000000000000000000000000000000..16e5b3a030cff0037f69c5395eb18799b86781cd --- /dev/null +++ b/src/s_datalog/db_test.ml @@ -0,0 +1,94 @@ +open IdGenerator +open Datalog_AbstractSyntax + +(*module Store = (*: UnionFind.Store with type 'a t ='a PersistentArray.PersistentArray.t *) +struct +(* module type PA_SIG=module type of PersistentArray.PersistentArray*) + include PersistentArray.PersistentArray (*: PA_SIG (*with type 'a t = ConstGen.id PersistentArray.PersistentArray.t*)*) + let empty i = + let value,_ = ConstGen.get_fresh_id (ConstGen.init ()) in + init i (fun _ -> value) + end +*) + +module Store = UnionFind.StoreAsMap +(*struct + include PersistentArray.PersistentArray + let empty i = + let value,_ = ConstGen.get_fresh_id (ConstGen.init ()) in + init i (fun _ -> value) +end +*) + + +module Datalog=Datalog.Make(Store) + +let parse_file query edb filename = + let in_ch = + let fullname = Utils.find_file filename [""] in + open_in fullname in + let lexbuf = Lexing.from_channel in_ch in + LOG "Parsing \"%s\"..." filename LEVEL INFO; + let prog=Db_parser.program Db_lexer.lexer lexbuf AbstractSyntax.Proto_Program.empty in + LOG "Done." LEVEL INFO; + LOG "Current symbol tables:" LEVEL DEBUG ; + Utils.log_iteration + (fun s -> LOG s LEVEL DEBUG) + (AbstractSyntax.Predicate.PredIdTable.to_string prog.AbstractSyntax.Proto_Program.pred_table); + let sep=String.make 15 '*' in + let () = Printf.printf "%s\n%!" sep in + let () = Printf.printf "Create the abstract program and print it...\n" in + let abs_program = AbstractSyntax.Program.make_program prog in + let () = Buffer.output_buffer stdout (AbstractSyntax.Program.to_buffer abs_program) in + let () = Printf.printf "Done.\n" in + let () = Printf.printf "%s\n" sep in + let () = Printf.printf "Create the internal program and print it...\n" in + let program=Datalog.Program.make_program abs_program in + let () = Buffer.output_buffer stdout (AbstractSyntax.Program.to_buffer (Datalog.Program.to_abstract program)) in + let () = Printf.printf "Done.\n" in + let () = Printf.printf "%s\n" sep in + let program = + match edb with + | None -> + LOG "I didn't find an edb file to parse." LEVEL DEBUG ; + program + | Some edb_filename -> + LOG "I found an edb file to parse." LEVEL DEBUG ; + let edb_in_ch = + let edb_fullname = Utils.find_file edb_filename [""] in + open_in edb_fullname in + let edb_lexbuf = Lexing.from_channel edb_in_ch in + LOG "Parsing \"%s\"..." edb_filename LEVEL INFO; + let to_be_added=Db_parser.extensional_facts Db_lexer.lexer edb_lexbuf Datalog.Program.(program.pred_table,program.const_table,program.rule_id_gen) in + LOG "Done." LEVEL INFO; + Datalog.Program.add_e_facts program to_be_added in + let derived_facts,derivations = Datalog.Program.seminaive program in + let () = Printf.printf "I could derive the following facts:\n%s\n" (Datalog.Predicate.facts_to_string derived_facts program.Datalog.Program.pred_table program.Datalog.Program.const_table) in + let buff = Buffer.create 80 in + let () = Datalog.Predicate.add_map_to_premises_to_buffer buff program.Datalog.Program.pred_table program.Datalog.Program.const_table derivations in + let () = Printf.printf "With the following derivations:\n%s\n" (Buffer.contents buff) in + let query,new_pred_table,new_cons_table = + match query with + | None -> + None,program.Datalog.Program.pred_table,program.Datalog.Program.const_table + | Some s -> + let q,t1,t2=Db_parser.query Db_lexer.lexer (Lexing.from_string s) Datalog.Program.(program.pred_table,program.const_table) in + Some q,t1,t2 in + let () = Datalog.Predicate.format_derivations2 ?query:query program.Datalog.Program.pred_table program.Datalog.Program.const_table derivations in + let () = Printf.printf "%s\n" (Buffer.contents (Format.stdbuf)) in + + () + + +let usage_msg="Usage: db_test [-edb edb_file] file" +let edb_file=ref None +let query=ref None + +let options = + [ + ("-edb",Arg.String (fun s -> edb_file:=Some s),"Add the specified file as an edb (it should include only extensional facts)."); + ("-q",Arg.String (fun s -> query:=Some s),"Only outputs the derivations satisfyin the specified query") + ] + +let () = + Arg.parse options (fun s -> parse_file !query !edb_file s) usage_msg diff --git a/src/s_datalog/essai.dl b/src/s_datalog/essai.dl new file mode 100644 index 0000000000000000000000000000000000000000..9eedccf17d3e8230e326df90e436717eba6ce40a --- /dev/null +++ b/src/s_datalog/essai.dl @@ -0,0 +1,9 @@ + +TUTU(i). + +TOUTOU(1,2,j):-titou(1,k),TOTO(k,j). + +TOTO(i,j):-TITI(i,j,k),TOTO(i,j),tagada(1). + +titou(i,j):- TUTU(i). + diff --git a/src/s_datalog/persistentArray.ml b/src/s_datalog/persistentArray.ml new file mode 100644 index 0000000000000000000000000000000000000000..644a5d8a7d4b7345c34c6d00a2040513891b8aa6 --- /dev/null +++ b/src/s_datalog/persistentArray.ml @@ -0,0 +1,136 @@ +open Utils + +module PersistentArray = +struct + type 'a t = 'a data ref + and 'a data = + | Arr of 'a array + | Diff of (int*'a*'a t) + | Invalid + + exception Unaccessible + exception Not_found + + let init n f = ref (Arr (Array.init n f)) + + + + let of_list_rev l = + let length,map= + List.fold_left + (fun (l,m) e -> l+1,IntMap.add l e m) + (0,IntMap.empty) + l in + init length (fun i -> IntMap.find i map) + + let rec get_v1 i t = + match !t with + | Arr a -> a.(i+1) + | Diff (j,v,_) when j=i -> v + | Diff (_,_,t') -> get_v1 i t' + | Invalid -> raise Unaccessible + + let set_v1 i v t = + match !t with + | Arr a as n -> + let old_v=a.(i) in + let () = a.(i) <- v in + let res = ref n in + let () = t := Diff(i,old_v,res) in + res + | Diff _ -> ref (Diff (i,v,t)) + | Invalid -> raise Unaccessible + + (* TODO: can it be made tail-recursive (see Filliatre & + Conchon's paper) *) + let rec reroot t = + match !t with + | Arr _ -> () + | Diff (i,v,t') -> + let () = reroot t' in + begin + match !t' with + | Arr a as n -> + let () = a.(i) <- v in + let () = t := n in + t' := Invalid + | Diff _ -> failwith "Bug: rerooted array shoul be a Arr of a" + | Invalid -> failwith "Bug: rerooted array shoul be a Arr of a" + end + | Invalid -> raise Unaccessible + + let rec get_aux i t = + match !t with + | Arr a -> a.(i) + | Diff (i,v,t') -> + let () = reroot t' in + begin + match !t' with + | Arr a as n -> + let () = a.(i) <- v in + let () = t := n in + let () = t' := Invalid in + a.(i) + | Diff _ -> failwith "Bug: rerooted array shoul be a Arr of a" + | Invalid -> failwith "Bug: rerooted array shoul be a Arr of a" + end + | Invalid -> raise Unaccessible + + let get i t = + try + get_aux (i-1) t + with + | Invalid_argument "index out of bounds" -> raise Not_found + + + let set_aux i v t = + let () = reroot t in + match !t with + | Arr a as n -> + let old_v=a.(i) in + let () = a.(i) <- v in + let res = ref n in + let () = t := Diff(i,old_v,res) in + res + | Diff _ -> failwith "Bug: rerooted array shoul be a Arr of a" + | Invalid -> failwith "Bug: rerooted array shoul be a Arr of a" + + let set i v t = set_aux (i-1) v t + + + let rec print f t = + match ! t with + | Arr a -> + Array.iteri (fun i v -> Printf.printf " %i:%s\n" i (f v)) a + | Diff (i,v,t') -> + let () = Printf.printf "d%i:%s\n" i (f v) in + print f t' + | Invalid -> Printf.printf "Inaccessible value\n" + + let print_and_reroot f t = + let () = reroot t in + match ! t with + | Arr a -> Array.iteri (fun i v -> Printf.printf "%i:%s" i (f v)) a + | _ -> failwith "Bug: rerooted array shoul be a Arr of a" + + let length t = + let () = reroot t in + match !t with + | Arr a -> Array.length a + | Diff _ -> failwith "Bug: rerooted array shoul be a Arr of a" + | Invalid -> failwith "Bug: rerooted array shoul be a Arr of a" + + let rec copy_aux t = + match !t with + | Arr a -> Array.copy a + | Diff (i,v,a) -> + let res = copy_aux a in + let () = res.(i) <- v in + res + | Invalid -> raise Unaccessible + + let copy t = ref (Arr (copy_aux t)) + + + +end diff --git a/src/s_datalog/persistentArray.mli b/src/s_datalog/persistentArray.mli new file mode 100644 index 0000000000000000000000000000000000000000..0b0a0b8695351c61f81b2033e6e9e0ec41356818 --- /dev/null +++ b/src/s_datalog/persistentArray.mli @@ -0,0 +1,70 @@ +(** This module implements a persistent array data structure as + described in {{: + http://www.lri.fr/~filliatr/ftp/publis/puf-wml07.ps}"A Persistent + Union-Find Data Structure" (Sylvain Concohn and Jean-Chrisophe + Filliâtre}. + + It is meant for managing quick access while keeping peristency in + backtracking algorithms such as in unification algorithms using + union find algorithms. + + In particular, when a persistent array [a_0] has been modified + several times, yielding arrays [a_1], [a_2], ... , [a_N], when + [a_i] is accessed using the [get] or [set] functions (with [0 <= i + < N]) than all [a_j] with [i < j <= N] become unaccessible, hence + a [Unacessible] exception is raised. +*) + + +module PersistentArray : +sig + + (** The type of the data structure *) + type 'a t + + (** This exception is raised in case a persistent array [a_0] has + been modified several times, yielding arrays [a_1], [a_2], ... , + [a_N], and that [a_i] is accessed using the [get] or [set] + functions (with [0 <= i < N]) when one tries to access [a_j] + with [i < j <= N]. *) + exception Unaccessible + + + exception Not_found + + (** [init n f] returns a persistent array [a] of length [n] such + that for all [i]. [a.(i)] is set to [f i]. Note that {ewe start + addressing at 1}*) + val init: int -> (int -> 'a) -> 'a t + + + (** [of_list_rev l] returns a persistent array of size the length pf + [l] and containing its elements {e in the reverse order}*) + val of_list_rev: 'a list -> 'a t + + (** [get i t] returns the value stored in [t] at address [i] + {e starting at 1}.*) + val get: int -> 'a t -> 'a + + (** [set i v t] returns a new persistent array [t'] equal to [t] + except that [t'.(i)=v].*) + val set: int -> 'a -> 'a t -> 'a t + + (** [length t] returns the length of [t].*) + val length: 'a t -> int + + (** [print f t] prints the content of [t] without rerooting it (so + the same arrays remain accessible. *) + val print : ('a -> string) -> 'a t -> unit + + (** [print_and_reroot f t] prints the content of [t] and reroots it, + so any further modifier version of this array becomes + unaccessible. *) + val print_and_reroot : ('a -> string) -> 'a t -> unit + + (** [copy t] returns a copy of [t], that is, a fresh array + containing the same elements as [t]. [t] is unchanged.*) + + val copy : 'a t -> 'a t + +end diff --git a/src/s_datalog/test.ml b/src/s_datalog/test.ml new file mode 100644 index 0000000000000000000000000000000000000000..4c2d77ca7b7667e1276398933ad270fde3b0c8a3 --- /dev/null +++ b/src/s_datalog/test.ml @@ -0,0 +1,86 @@ + + +let r1 = [ 1; 2; 3; 4] + +let r2 = [ 5;6] + +let r2' = [] + +let r3 = [7;8] + + +let a = [r1;r2;r3] + + +let string_of_res res = + Printf.sprintf + "%s" + (List.fold_left (fun acc s -> Printf.sprintf "%d %s" s acc) "" res) + +let rec string_of_array = function + | [] -> "" + | r::rows -> + Printf.sprintf + "%s\n%s" + (string_of_res (List.rev r)) + (string_of_array rows) + + +let ()=Printf.printf "r1: %s\n" (string_of_res r1) + +let ()=Printf.printf "a=\n%s\n" (string_of_array a) + +module AllIntArray = ArrayTraversal.Make( + struct + type state=int list + type cell=int + let cell_compare i j=i-j + let update s c = Some (c :: s) + end +) + +module EvenIntArray = ArrayTraversal.Make( + struct + type state=int list + let cell_compare i j=i-j + type cell=int + let update s c = if (c mod 2)=0 then Some (c :: s) else None + end +) +module OddIntArray = ArrayTraversal.Make( + struct + type state=int list + let cell_compare i j=i-j + type cell=int + let update s c = if (c mod 2)=1 then Some (c :: s) else None + end +) + +let () = + AllIntArray.collect_results + (fun _ res -> Printf.printf "State: %s\n%!" (string_of_res res)) + () + [] + a + +let () = print_newline() + +let () = + EvenIntArray.collect_results + (fun _ res -> Printf.printf "State: %s\n%!" (string_of_res res)) + () + [] + a +let () = print_newline() + +let () = + OddIntArray.collect_results + (fun _ res -> Printf.printf "State: %s\n%!" (string_of_res res)) + () + [] + a + + + + + diff --git a/src/s_datalog/unionFind.ml b/src/s_datalog/unionFind.ml new file mode 100644 index 0000000000000000000000000000000000000000..19430d8dc435a275b4236beda6869a3fdb9eaace --- /dev/null +++ b/src/s_datalog/unionFind.ml @@ -0,0 +1,341 @@ +open Utils + + +(** Modules with this module type should provide Union-Find algorithms + and the indexed storage data structure. Note that we take the + opportunity of implementing from scratch such algorithms to allow + the [find] function returns not only the index of the + representative and the values it indexes, but also the storage + data structure, so that the [find] algorithm can modify it, in + particular with path compression. +*) + +module type S = +sig + (** The type of the indexed data structure *) + type 'a t + + (** The type of the values (content) that are indexed. It is either + an actual value of type ['a] or a link to another indexed + value. If a content at an index [i] points to [i], it is meant + that to be a variable.*) + type 'a content = Link_to of int | Value of 'a + + (** Exception raised when a the union of to indexed value can not + happen. It should be raised by the [union] function when it + amounts to make the union between to actual values [Value a] and + [Value b] and [a != b]. *) + exception Union_Failure + + (** [create l] returns the corresponding indexed storage data + structure where each value (or link) is indexed by its position in [l] + (starting at 1 *) + val create : 'a content list -> 'a t + + (** [extract ~start:s i t] returns a list of the [i] first elements + of [t] starting from position [s] (default is 1, first + position) *) + val extract : ?start:int -> int -> 'a t -> 'a content list + + (** [find i h] returns not only the index of the representative and + the values it indexes, but also the storage data structure, so + that the [find] algorithm can modify it, in particular with path + compression. *) + val find : int -> 'a t -> ((int * 'a content) * 'a t) + (* the content returned by [find] should not be a link. Can we + enforce this using polymorphic variants and/or GADT? *) + + (** [union i j h] returns a new indexed storage data structure where + values indexed by [i] and [j] have been unified (ie one of the + two is now linked to the index of the representative of the + other. It fails and raises the {! UnionFind.Union_Failure} + exception if both [i] and [j] representatives index actual + values [Value a] and [Value b] and [a != b]. *) + val union : int -> int -> 'a t -> 'a t + + (** [instantiate i t h] returns a new indexed storage data structure + where the value indexed by [i] and [t] have been unified. It + fails and raises the {! UnionFind.Union_Failure} exception if + [i]'s representative indexes an actual values [Value a] such + that [a] differs from [t]. *) + val instantiate : int -> 'a -> 'a t -> 'a t + + (** [cyclic i h] returns a pair [(b,h')] where [b] is [true] if [h] + has a cycle (following the [Link_to] links) containing [i] and + [false] otherwise, and where [h'] contains the same information + as [h] (possibly differently stored, for instance using path + compression while checking [h] cyclicity. *) + val cyclic : int -> 'a t -> (bool * 'a t) + + val copy : 'a t -> 'a t + val to_string : 'a t -> string +end + +(** Modules with this module type should provide an indexed (by [int] + indexes) storage data structure for ['a] type values and access + and update functions. +*) + +module type Store = +sig + type 'a t + exception Store_Not_found + + (** [empty i] should return an empty indexed storage data structure + that will allow indexing {e with values from [1] to [i]}. *) + val empty : int -> 'a t + val get : int -> 'a t -> 'a + val set : int -> 'a -> 'a t -> 'a t + val copy : 'a t -> 'a t +(* val to_string : 'a t -> ('a -> string) -> string *) +end + +(** This (functor) module implements a {! UnionFind} data structure. The + [S] parameter is used to try different implementations of indexed + data structure, in particular eventually persistent arrays as + described in {{: + http://www.lri.fr/~filliatr/ftp/publis/puf-wml07.ps}"A Persistent + Union-Find Data Structure" (Sylvain Conchon and Jean-Chrisophe + Filliâtre} *) + + +module Make(S:Store) : S = +struct + + (** The type of the values (content) that are indexed. It is either + an actual value of type ['a] or a link to another indexed + value. If a content at an index [i] points to [i], it is meant + that to be a variable.*) + type 'a content = + | Link_to of int + | Value of 'a + + let content_to_string c = + match c with + | Link_to i -> Printf.sprintf "Linked to %d" i + | Value v -> Printf.sprintf "Some Value" + + (** The actual type of the data structure. The rank is used to + implement weighted union. See {{: + http://www.risc.jku.at/education/courses/ss2012/unification/slides/02_Syntactic_Unification_Improved_Algorithms.pdf} + Introduction to Unification Theory. Speeding Up (Temur + Kutsia)} *) + type 'a t = {rank:int S.t;parents:'a content S.t} + + exception Union_Failure + + + (* Indexing starts at 1, not at 0 *) + (* TODO: Should we check that indexes belong to the range, or that + links to belong the set of indexes? *) + (* TODO: specify the properties of the data structure (no cycle, + coherent numbering, [find] always returns a value, etc. *) + let create contents = + let ln = List.length contents in + let res,_= + List.fold_left + (fun ({rank=r;parents=p},k) content -> + LOG "Setting the following content at address %d:" k LEVEL DEBUG; + match content with + | Link_to i as c -> + LOG "Link to %d" i LEVEL DEBUG; + (* rank is unset for contents that are initially a link *) + ({rank= + (try + let rank=S.get i r in + S.set i (rank+1) (S.set k 0 r) + with + | S.Store_Not_found -> S.set i 1 r); + parents=S.set k c p},k+1) + | Value v as c -> + LOG "Some value" LEVEL DEBUG; + ({rank= + (try + let _ = S.get k r in + r + with + | S.Store_Not_found -> S.set k 0 r); + parents=S.set k c p},k+1)) + ({rank=S.empty ln;parents=S.empty ln},1) + contents in + for i = 1 to ln do + LOG "%d/%d\t<--->\t%s\t\t(%d)" i ln (content_to_string (S.get i res.parents)) (S.get i res.rank) LEVEL TRACE; + done; + res + + + (** [find_aux i f] returns a pair [(i',v),f'] where [i'] is the + index of the representative of the data indexed by [i]. [i=i'] + means that the [i]-th element is linked to itself: it is meant + to be a variable, not an actual value. It also performs path + compression *) + let rec find_aux i f = + match S.get i f with + | Value _ as v -> (i,v),f + (* An actual value was reached at index [i]. So [i] is returned + together with [v] and [f] *) + | Link_to next as v when next=i -> (i,v),f + (* The content indexed by [i] points to [i]. [i] is then the + representative for the variable it denotes. *) + | Link_to next -> + (* In the other cases, we follow the links to reach the + representative and the content it indexes *) + let (representative_index,representative_value),new_f = find_aux next f in + (* Then we update the storage data structure linking the context + indexed by [i] directly to the representative index *) + let updated_f = S.set i (Link_to representative_index) new_f in + LOG "the \"UnionFinf.find\" function indeed returns a Link_to itself: %b" (let ()=match representative_value with + | Link_to variable -> assert (representative_index=variable) + | _ -> () in true) LEVEL FATAL; + (representative_index,representative_value),updated_f + + (** [find i h] returns a pair [(i',v),f'] where [i'] is the index of + the representative of the data indexed by [i]. [i=i'] means that + the [i]-th element is linked to itself: it is meant to be a + variable, not an actual value. It also performs path + compression. The difference with [find_aux] is that it applyes + to the whole storage data structure (that includes data for + weighted union). *) + let find i h = + let rep_i,f = find_aux i h.parents in + rep_i,{h with parents=f} + + (** [extract ~start:s i t] returns a list of the [i] first elements + of [t] starting from position [s] (default is 1, first + position). It is ensured that the results only contain the + values of representatives (i.e it follows the [Link_to] links + until the value of the representative before returning it). *) + let extract ?(start=1) i {parents=p} = + LOG "Going to extract %d elements starting at %d..." i start LEVEL DEBUG; + let rec extract_aux k res = + match k-start with + | j when j>0 -> + let (_,c),_= find_aux (start-1+j) p in + extract_aux (start+j-1) (c :: res) + | _ -> res in + extract_aux (start+i) [] + + + + + + (** [union i j h] returns a new storage data structure [h'] where + [h'] has an equivalent content as [h] plus the unification + between the elements indexed by [i] and [j] and plus, possibly, + some path compression. *) + let union i j h = + let rep_i,h' = find i h in + let rep_j,h'' = find j h' in + match rep_i,rep_j with + (* in case [rep_i] (rexp. [rep_j]) is a [(i,Link_to i')] we should + have [i=i'], else there is a bug *) + | (_,v_i),(_,v_j) when v_i=v_j -> h'' + | (_,(Value _ as v_i)),(rep_j_index,Link_to _) -> + {h'' with parents=S.set rep_j_index v_i h''.parents} + | (rep_i_index,Link_to _),(_,(Value _ as v_j)) -> + {h'' with parents=S.set rep_i_index v_j h''.parents} + | (rep_i_index,Link_to i'),(rep_j_index,Link_to j') -> + let rk_i = S.get rep_i_index h''.rank in + let rk_j = S.get rep_j_index h''.rank in + if rk_i > rk_j then + {h'' with parents=S.set rep_j_index (Link_to rep_i_index) h''.parents} + else + if rk_i < rk_j then + {h'' with parents=S.set rep_i_index (Link_to rep_j_index) h''.parents} + else + {rank=S.set rep_i_index (rk_i+1) h''.rank;parents=S.set rep_j_index (Link_to rep_i_index) h''.parents} + | (_,Value v_i),(_,Value v_j) -> raise Union_Failure + (* v_i=v_j is caught by the first case *) + + (** [find_and_instantiate_aux i t f] returns a new indexed storage + datastructure [f'] where the content at index [i] (and the ones + it points to) has been set to [Value t]. If [i]'s representative + indexes a variable or a value equal to [Value t] then the + instantiation suceeds, otherwise it raises Union_failure. It + also performs path compression. *) + let rec find_and_instantiate_aux i term f = + match S.get i f with + | Value v when v=term -> f + | Value _ -> raise Union_Failure + (* An actual value was reached at index [i] and we're in the case + that it differs from [term]. So the union fails *) + | Link_to next when next=i -> S.set i (Value term) f + (* The content indexed by [i] points to [i]. [i] is then the + representative for the variable it denotes and can be unified + with [term]. [f] is updated. *) + | Link_to next -> + (* In the other cases, we follow the links to reach the + representative and the content it indexes *) + let new_f = find_and_instantiate_aux next term f in + (* Then we update the storage data structure linking the context + indexed by [i] directly to the representative index. We know + it's safe to do it now since unification succeeded. *) + let updated_f = S.set i (Value term) new_f in + updated_f + + + (** [instantiate i t h] returns a new indexed storage data structure + where the value indexed by [i] and [t] have been unified. It + fails and raises the {! UnionFind.Union_Failure} exception if + [i]'s representative indexes an actual values [Value a] such + that [a] differs from [t]. *) + let instantiate i t h = + let f = find_and_instantiate_aux i t h.parents in + {h with parents=f} + + + + (* cyclic_aux includes path compression *) + let rec cyclic_aux i f acc = + match S.get i f with + | Value v -> false,i,f + | Link_to next when next=i -> false,i,f + | Link_to next -> + if IntSet.mem next acc then + true,i,f + else + let cyclic,representative_index,new_f = cyclic_aux next f (IntSet.add next (IntSet.add i acc)) in + let updated_f = S.set i (Link_to representative_index) new_f in + cyclic,representative_index,updated_f + + (* the cyclic function, calling cyclic_aux, compress paths + (hence also returns the parents) *) + let cyclic i h = + let res,_,f = cyclic_aux i h.parents (IntSet.empty) in + res,{h with parents=f} + + let copy {rank=r;parents=p}={rank=S.copy r;parents=S.copy p} + + let to_string {rank=r;parents=p} = + let buff=Buffer.create 2 in + let to_string_aux i = + Printf.sprintf "%d\t<--->\t%s\t\t(%d)\n" i (content_to_string (S.get i p)) (S.get i r) in + let i=ref 1 in + try + let () = + while true do + let () = Buffer.add_string buff (to_string_aux !i) in + i:=!i+1 + done in + "Bug!" + with + | S.Store_Not_found -> Buffer.contents buff + + +end + +module StoreAsMap = +struct + type 'a t = 'a IntMap.t + exception Store_Not_found + let empty _ = IntMap.empty + let get k m = + try + IntMap.find k m + with + | Not_found -> raise Store_Not_found + let set k v m = IntMap.add k v m + let copy m=m +end + + diff --git a/src/s_datalog/unionFind.mli b/src/s_datalog/unionFind.mli new file mode 100644 index 0000000000000000000000000000000000000000..5b4fa763fb3582329d1d4c98cd5aaeb525eb435d --- /dev/null +++ b/src/s_datalog/unionFind.mli @@ -0,0 +1,103 @@ +(** Modules with this module type should provide Union-Find algorithms + and the indexed storage data structure. Note that we take the + opportunity of implementing from scratch such algorithms to allow + the [find] function returns not only the index of the + representative and the values it indexes, but also the storage + data structure, so that the [find] algorithm can modify it, in + particular with path compression. +*) + +module type S = +sig + (** The type of the indexed data structure *) + type 'a t + + (** The type of the values (content) that are indexed. It is either + an actual value of type ['a] or a link to another indexed + value. If a content at an index [i] points to [i], it is meant + that to be a variable.*) + type 'a content = Link_to of int | Value of 'a + + (** Exception raised when a the union of to indexed value can not + happen. It should be raised by the [union] function when it + amounts to make the union between to actual values [Value a] and + [Value b] and [a != b]. *) + exception Union_Failure + + (** [create l] returns the corresponding indexed storage data + structure where each value (or link) is indexed by its position in [l] + (starting at 1 *) + val create : 'a content list -> 'a t + + (** [extract ~start:s i t] returns a list of the [i] first elements + of [t] starting from position [s] (default is 1, first + position). It is ensured that the results only contain the + values of representatives (i.e it follows the [Link_to] links + until the value of the representative before returning it). *) + val extract : ?start:int -> int -> 'a t -> 'a content list + + (** [find i h] returns not only the index of the representative and + the values it indexes, but also the storage data structure, so + that the [find] algorithm can modify it, in particular with path + compression. If the returned content is a [Link_to j] then + [j=i].*) + val find : int -> 'a t -> ((int * 'a content) * 'a t) + (* the content returned by [find] should not be a link. Can we + enforce this using polymorphic variants and/or GADT? *) + + (** [union i j h] returns a new indexed storage data structure where + values indexed by [i] and [j] have been unified (ie one of the + two is now linked to the index of the representative of the + other. It fails and raises the {! Union_Failure} + exception if both [i] and [j] representatives index actual + values [Value a] and [Value b] and [a != b]. *) + val union : int -> int -> 'a t -> 'a t + + (** [instantiate i t h] returns a new indexed storage data structure + where the value indexed by [i] and [t] have been unified. It + fails and raises the {! Union_Failure} exception if + [i]'s representative indexes an actual values [Value a] such + that [a] differs from [t]. *) + val instantiate : int -> 'a -> 'a t -> 'a t + + (** [cyclic i h] returns a pair [(b,h')] where [b] is [true] if [h] + has a cycle (following the [Link_to] links) containing [i] and + [false] otherwise, and where [h'] contains the same information + as [h] (possibly differently stored, for instance using path + compression while checking [h] cyclicity. *) + val cyclic : int -> 'a t -> (bool * 'a t) + + val copy : 'a t -> 'a t + + val to_string : 'a t -> string +end + +(** Modules with this module type should provide an indexed (by [int] + indexes) storage data structure for ['a] type values and access + and update functions. +*) + +module type Store = +sig + type 'a t + exception Store_Not_found + + (** [empty i] should return an empty indexed storage data structure + that will allow indexing {e with values from [1] to [i]}. *) + val empty : int -> 'a t + val get : int -> 'a t -> 'a + val set : int -> 'a -> 'a t -> 'a t + val copy : 'a t -> 'a t +(* val to_string : 'a t -> ('a -> string) -> string*) +end + +(** This (functor) module implements a {! UnionFind} data structure. The + [S] parameter is used to try different implementations of indexed + data structure, in particular eventually persistent arrays as + described in {{: + http://www.lri.fr/~filliatr/ftp/publis/puf-wml07.ps}"A Persistent + Union-Find Data Structure" (Sylvain Conchon and Jean-Chrisophe + Filliâtre} *) +module Make(St:Store) : S (*with type 'a t='a ST.t*) + +module StoreAsMap:Store diff --git a/src/scripting/Makefile.in b/src/scripting/Makefile.in index b1810c825a961a296fd09d38123c53ce0996f046..fb027e32e92817f193dce340e5fcd4e5f90f1567 100644 --- a/src/scripting/Makefile.in +++ b/src/scripting/Makefile.in @@ -34,7 +34,7 @@ LIBS += dyp.cma str.cma LIBDIR += @DYPGEN_INCLUDE@ # Directories to which the current source files depend on -PREVIOUS_DIRS = ../utils ../logic ../grammars ../acg-data +PREVIOUS_DIRS = ../utils ../s_datalog ../logic ../grammars ../acg-data # Source files in the right order of dependance diff --git a/src/scripting/functions.ml b/src/scripting/functions.ml index 99d6a85d89a8fe745bd00654f1475db9807c2cf3..074a57fb90086d8bc05e4bfbc62e58ccb1142741 100644 --- a/src/scripting/functions.ml +++ b/src/scripting/functions.ml @@ -36,6 +36,8 @@ sig | Dont_trace | Print | Analyse + | Check + | Realize | Add | Compose | Dont_wait @@ -43,9 +45,15 @@ sig | Help of action option | Create | Save + | Parse + | Idb + | Query - type file_type = | Data | Script of (string -> string list -> env -> env) + type file_type = + | Data + | Object + | Script of (string -> string list -> env -> env) val load : file_type -> string -> string list -> env -> env @@ -61,6 +69,14 @@ sig val print : ?name:string -> env -> (Lexing.position * Lexing.position) -> unit val analyse : ?names:(string * (Lexing.position * Lexing.position)) list -> env -> ?offset:string -> string -> (Lexing.position * Lexing.position) -> unit + val check : ?names:(string * (Lexing.position * Lexing.position)) list -> env -> ?offset:string -> string -> (Lexing.position * Lexing.position) -> unit + val realize : ?names:(string * (Lexing.position * Lexing.position)) list -> env -> ?offset:string -> string -> (Lexing.position * Lexing.position) -> unit + + val parse : ?name:string -> env -> ?offset:string -> string -> (Lexing.position * Lexing.position) -> unit + + val idb : ?name:string -> env -> ?offset:string -> (Lexing.position * Lexing.position) -> unit + + val query : ?name:string -> env -> ?offset:string -> string -> (Lexing.position * Lexing.position) -> unit val add : ?names:(string * (Lexing.position * Lexing.position)) list -> env -> ?offset:string -> string -> (Lexing.position * Lexing.position) -> env @@ -100,14 +116,118 @@ struct let interactive = ref false - type file_type = | Data | Script of (string -> string list -> env -> env) + type file_type = + | Data + | Object + | Script of (string -> string list -> env -> env) module Data_parser = Data_parser.Make(E) + + type action = + | Load + | List + | Select + | Unselect + | Trace + | Dont_trace + | Print + | Analyse + | Check + | Realize + | Add + | Compose + | Dont_wait + | Wait + | Help of action option + | Create + | Save + | Parse + | Idb + | Query + + + let actions = [Load;List;Select;Unselect;Trace;Dont_trace;Print;Check;Realize;Parse;Idb;Query;Analyse;Add;Compose;Dont_wait;Wait;Help None;Create;Save] + + + + let rec action_to_string = function + | Load -> "load" + | List -> "list" + | Select -> "select" + | Unselect -> "unselect" + | Trace -> "trace" + | Dont_trace -> "don't trace" + | Print -> "print" + | Analyse -> "analyse" + | Check -> "check" + | Realize -> "realize" + | Add -> "add" + | Compose -> "compose" + | Dont_wait -> "don't wait" + | Wait -> "wait" + | Help None -> "help" + | Help (Some (Help a)) -> action_to_string (Help a) + | Help (Some a) -> Format.sprintf "%s help" (action_to_string a) + | Save -> "save" + | Create -> "create" + | Parse -> "parse" + | Idb -> "idb" + | Query -> "query" + + + + + let messages = function + | Load as command -> Format.sprintf "\t%s d|data|s|script|o|object file;\n\t\tloads the file \"file\" as data (d or data option), as an object (compiled data, o or object option), or as a script (script or s option)" (action_to_string command) + | List as command -> Format.sprintf "\t%s;\n\t\tlists the signatures and the lexicons of the current environment" (action_to_string command) + | Select as command -> Format.sprintf "\t%s name;\n\t\tselects the name signature or lexicon in the current environment and make it an implicit context for following commands" (action_to_string command) + | Unselect as command -> Format.sprintf "\t%s name;\n\t\tremoves any selected signature or lexicon from the context" (action_to_string command) + | Trace as command -> Format.sprintf "\t%s;\n\t\ttraces the interpretation (if a command is used in a context of a lexicon) and the beta-reduction process" (action_to_string command) + | Dont_trace as command -> Format.sprintf "\t%s;\n\t\tstops tracing" (action_to_string command) + | Wait as command -> Format.sprintf "\t%s;\n\t\twaits a keyboard return event before going on in executing a script" (action_to_string command) + | Dont_wait as command -> Format.sprintf "\t%s;\n\t\tstops waiting a keyboard return event before going on in executing a script" (action_to_string command) + | Print as command -> Format.sprintf "\t[name] %s;\n\t\toutputs the content of the \"name\" signature or lexicon of the current environment. If no \"name\" is specified, check whether there is a selected data in the environment" (action_to_string command) + | Analyse as command -> Format.sprintf "\t[name1 name2 ...] %s term:type;\n\t*DEPRECATED*\n\t\tanalyses the given \"term:type\" with respect to the given \"name1\" ... signatures or lexicons, or if no such name is given, with respect to the selected data in the environment. In the context of a signature, this command just typechecks the given entry. In the context of a lexicon, it typechecks it and interprets it with respect to this lexicon" (action_to_string command) + | Check as command -> Format.sprintf "\t[name1 name2 ...] %s term:type;\n@[\t@[\tcheck@ whether@ the@ given@ \"term:type\"@ typechecks@ with@ respect@ to@ the@ given@ \"name1\" ... signatures,@ or@ if@ no@ such@ name@ is@ given,@ with@ respect@ to@ the@ selected@ data@ in@ the@ environment,@ provided@ it@ is@ a@ signature.@]@]" (action_to_string command) + | Realize as command -> Format.sprintf "\t[name1 name2 ...] %s term:type;\n@[\t@[\tcheck@ whether@ the@ given@ \"term:type\"@ typechecks@ with@ respect@ to@ the@ abstract@ signatures@ of@ the@ \"name1\" ... lexicons,@ or@ if@ no@ such@ name@ is@ given,@ with@ respect@ to@ the@ selected@ data@ in@ the@ environment,@ provided@ it@ is@ a@ lexiocn.@ Then@ the@ interrpretetion@ of@ the@ input@ term@ by@ each@ lexicon@ is@ computed.@]@]" (action_to_string command) + | Parse as command -> Format.sprintf "\t[name] %s term:type;\n\t\tparse the object term \"term\" as the image of some abstract term of type \"type\" according to the lexicon \"name\". If no \"name\" is specified, check whether there is a selected data in the environment" (action_to_string command) + | Idb as command -> Format.sprintf "\t[name] %s;\n\t\toutputs the datalog program (intensional database) corresponding to the lexicon \"name\". If no \"name\" is specified, check whether there is a selected data in the environment" (action_to_string command) + | Query as command -> Format.sprintf "\t[name] %s term:type;\n\t\toutputs the facts (extensional database) and the query associated to the term \"term\" of distinguished type \"type\" with respect to the lexicon \"name\". If no \"name\" is specified, check whether there is a selected data in the environment" (action_to_string command) + | Add as command -> Format.sprintf "\t[name1 name2 ...] %s expression;\n\t\tadds the given \"expression\" with respect to the given \"name1\" ... signatures or lexicons to those signature or lexicons. \"expression\" must respect the syntax of signatures or lexicons" (action_to_string command) + | Compose as command -> Format.sprintf "\t%s name1 name2 as name3;\n\t\tcreates a new lexicon with name \"name3\" by composing the \"name1\" and \"name2\" lexicons" (action_to_string command) + | Help _ as command -> Format.sprintf "\t%s ;\n\t\tprints the help message" (action_to_string command) + | Create as command -> Format.sprintf "\t%s s|sig|l|lex name [name1 name2];\n\t\tcreates a new empty signature or lexicon (according to the s or sig, or l or lex option) with name \"name\" in the current environment.\"name1\" and \"name2\" are mandatory in case of creating a lexicon: they are respectively the abstract and the object signature. They of course are forbidden in case of creating a signature" (action_to_string command) + | Save as command -> Format.sprintf "\t[name1 name2 ...] %s filename;\n\t\toutputs the content of \"name1\", \"name2\"... into the same file \"filename\". If no \"name\" is specified, check whether there is a selected data in the environment" (action_to_string command) + + let rec help = function + | Help (Some (Help a)) -> help (Help a) + | Help (Some a) -> Format.printf "Usage:\n%s\n" (messages a) + | Help None -> Format.printf "Commands: For any command, its usage can be reminded by running the following command:\n\tcommand help;\nThe following commands are available. \n%s\n" (Utils.string_of_list "\n" (fun x -> x) (List.map messages actions)) + | _ as a -> Format.printf "Usage:@\n%s@\n" (messages a) + + let load t filename dirs e = try match t with - | Data -> Data_parser.parse_data ~override:true filename dirs e + | Data -> + (match Data_parser.parse_data ~override:true filename dirs e with + | None -> e + | Some e' -> e') + | Object -> + (try + let file =(Utils.find_file filename dirs) in + let in_ch = open_in file in + let () = Printf.printf "Loading \"%s\"...\n" file in + let new_env = input_value in_ch in + let () = Printf.printf "Done.\n" in + let () = close_in in_ch in + E.append e new_env + with + | Utils.No_file(f,msg) -> + let err = Error.System_error (Printf.sprintf "No such file \"%s\" in %s" f msg) in + let () = Printf.fprintf stderr "Error: %s\n%!" (Error.error_msg err filename) in + e) | Script f -> f filename dirs e with | Stop -> e @@ -147,6 +267,30 @@ struct let unselect = E.unselect + let get_entry name e l = + match name,E.focus e with + | None,None -> raise (Scripting_errors.Error (Scripting_errors.No_focus,l)) + | None,Some en -> en + | Some n,_ -> + (try + E.get n e + with + | E.Entry_not_found s -> raise (Scripting_errors.Error (Scripting_errors.Not_in_environment s,l))) + + let get_lex name cmd e l = + match get_entry name e l with + | E.Signature sg -> raise (Scripting_errors.Error (Scripting_errors.Accept_only ((Scripting_errors.Lex (fst (E.Signature1.name sg))),cmd),l)) + | E.Lexicon lex -> lex + + let get_sig name cmd e l = + match get_entry name e l with + | E.Lexicon lex -> raise (Scripting_errors.Error (Scripting_errors.Accept_only ((Scripting_errors.Sg (fst (E.Lexicon.name lex))),cmd),l)) + | E.Signature sg -> sg + + + + + let trace () = raise (Not_yet_implemented "trace") let dont_trace () = raise (Not_yet_implemented "don't trace") @@ -172,53 +316,228 @@ struct let analyse ?names e ?offset data l = - try - let additional_offset = "\t" in - let actual_offset = Printf.sprintf "%s%s" (match offset with | None -> "" | Some s -> s) additional_offset in - let entries = - match names,E.focus e with + if data="help" then + help (Help (Some Analyse)) + else + try + let additional_offset = "\t" in + let actual_offset = Printf.sprintf "%s%s" (match offset with | None -> "" | Some s -> s) additional_offset in + let entries = + match names,E.focus e with | None,None -> raise (Scripting_errors.Error (Scripting_errors.No_focus,l)) | None,Some en -> [en] - | Some ns,_ -> List.map (fun (n,l) -> - try - E.get n e - with - | E.Entry_not_found s -> raise (Scripting_errors.Error (Scripting_errors.Not_in_environment s,l))) ns in - let _ = List.fold_left - (fun (first,last_abs_sg) entry -> match entry with - | E.Signature sg -> - (match last_abs_sg with - | Some previous_sg when (E.Signature1.name sg) = (E.Signature1.name previous_sg) -> (false,last_abs_sg) - | _ -> - let () = if first then Format.printf "In %s:\n%s%!" (fst (E.Signature1.name sg)) additional_offset else () in - (match Data_parser.parse_term ~output:true ~offset:actual_offset data sg with - | None -> let () = in_sg sg in false, Some sg - | Some _ -> false,None)) - | E.Lexicon lex -> - let abs,obj=E.Lexicon.get_sig lex in + | Some ns,_ -> + List.map + (fun (n,l) -> + try + E.get n e + with + | E.Entry_not_found s -> raise (Scripting_errors.Error (Scripting_errors.Not_in_environment s,l))) + ns in + let _ = List.fold_left + (fun (first,last_abs_sg) entry -> match entry with + | E.Signature sg -> + (match last_abs_sg with + | Some previous_sg when (E.Signature1.name sg) = (E.Signature1.name previous_sg) -> (false,last_abs_sg) + | _ -> + let () = if first then Format.printf "In %s:\n%s%!" (fst (E.Signature1.name sg)) additional_offset else () in + (match Data_parser.parse_term ~output:true ~offset:actual_offset data sg with + | None -> let () = in_sg sg in false, Some sg + | Some _ -> false,None)) + | E.Lexicon lex -> + let abs,obj=E.Lexicon.get_sig lex in match last_abs_sg with - | Some previous_sg when (E.Signature1.name abs) = (E.Signature1.name previous_sg) -> (false,last_abs_sg) - | _ -> let () = if first then Format.printf "In %s:\n%s%!" (fst (E.Signature1.name abs)) additional_offset else () in - match Data_parser.parse_term ~output:first ~offset:actual_offset data abs with - | None -> false,Some abs - | Some (t,ty) -> - let t',ty' = E.Lexicon.interpret t ty lex in - let () = Format.printf - "Interpreted by %s in %s as:\n\t%s : %s\n%!" - (fst (E.Lexicon.name lex)) - (fst (E.Signature1.name obj)) - (E.Signature1.term_to_string t' obj) - (E.Signature1.type_to_string ty' obj) in - false,None) - (true,None) - entries in - Format.printf "\n%!" - with + | Some previous_sg when (E.Signature1.name abs) = (E.Signature1.name previous_sg) -> (false,last_abs_sg) + | _ -> let () = if first then Format.printf "In %s:\n%s%!" (fst (E.Signature1.name abs)) additional_offset else () in + match Data_parser.parse_term ~output:first ~offset:actual_offset data abs with + | None -> false,Some abs + | Some (t,ty) -> + let t',ty' = E.Lexicon.interpret t ty lex in + let () = Format.printf + "Interpreted by %s in %s as:\n\t%s : %s\n%!" + (fst (E.Lexicon.name lex)) + (fst (E.Signature1.name obj)) + (E.Signature1.term_to_string t' obj) + (E.Signature1.type_to_string ty' obj) in + false,None) + (true,None) + entries in + Format.printf "\n%!" + with | E.Signature_not_found n | E.Lexicon_not_found n | E.Entry_not_found n -> raise (Scripting_errors.Error (Scripting_errors.Not_in_environment n,l)) + + + let check ?names e ?offset data l = + if data="help" then + help (Help (Some Check)) + else + let additional_offset = "\t" in + let actual_offset = Printf.sprintf "%s%s" (match offset with | None -> "" | Some s -> s) additional_offset in + let signatures = + match names,E.focus e with + | None,None -> raise (Scripting_errors.Error (Scripting_errors.No_focus,l)) + | None,Some (E.Signature sg) -> [sg] + | None,Some (E.Lexicon lex) -> + raise (Scripting_errors.Error ( + Scripting_errors.Accept_only ( + Scripting_errors.Sg ( + fst (E.Lexicon.name lex)), + "check"), + l)) + | Some ns,_ -> List.map (fun (n,l) -> get_sig (Some n) "check" e l) ns in + let () = + List.iter + (fun sg -> + let () = Format.printf "In @[%s:@ \n@[%s@]@]%!" (fst (E.Signature1.name sg)) additional_offset in + let _ = Data_parser.parse_term ~output:true ~offset:actual_offset data sg in + ()) + signatures in + Format.printf "\n%!" + + + + let realize ?names e ?offset data l = + if data="help" then + help (Help (Some Realize)) + else + let additional_offset = "\t" in + let actual_offset = Printf.sprintf "%s%s" (match offset with | None -> "" | Some s -> s) additional_offset in + let lexicons = + match names,E.focus e with + | None,None -> raise (Scripting_errors.Error (Scripting_errors.No_focus,l)) + | None,Some (E.Lexicon lex) -> [lex] + | None,Some (E.Signature sg) -> + raise (Scripting_errors.Error ( + Scripting_errors.Accept_only ( + Scripting_errors.Lex ( + fst (E.Signature1.name sg)), + "realize"), + l)) + | Some ns,_ -> List.map (fun (n,l) -> get_lex (Some n) "realize" e l) ns in + let _ = List.fold_left + (fun (first,last_abs_sg) lex -> + let abs,obj=E.Lexicon.get_sig lex in + let () = + match last_abs_sg with + | None -> + Format.printf "In %s:\n%s%!" (fst (E.Signature1.name abs)) additional_offset + | Some previous_sg when (E.Signature1.name abs) <> (E.Signature1.name previous_sg) -> + Format.printf "In %s:\n%s%!" (fst (E.Signature1.name abs)) additional_offset + | _ -> () in + match Data_parser.parse_term ~output:first ~offset:actual_offset data abs with + | None -> false,Some abs + | Some (t,ty) -> + let t',ty' = E.Lexicon.interpret t ty lex in + let () = Format.printf + "Interpreted by %s in %s as:\n\t%s : %s\n%!" + (fst (E.Lexicon.name lex)) + (fst (E.Signature1.name obj)) + (E.Signature1.term_to_string t' obj) + (E.Signature1.type_to_string ty' obj) in + false,Some abs) + (true,None) + lexicons in + Format.printf "\n%!" + + type inputs = + | Stop + | Next + | All + + let return_input s = + let () = print_newline () in + match String.lowercase (String.trim s) with + | "y" | "yes"-> Some Next + | "n" | "no" -> Some Stop + | "a" | "all" -> Some All + | "" -> Some Next + | _ -> None + + + let rec interact message get_input = + let () = Printf.printf "%s%!" message in + match get_input (read_line ()) with + | Some v -> v + | None -> interact message get_input + + let rec ask_for_next_parse f param = + let rec no_interaction f p = + match f p with + | None -> Printf.printf "No other possible value\n" + | Some new_param -> no_interaction f new_param in + let msg = Printf.sprintf "Do you want to look for another solution?\n\ty/yes\n\tn/no\n\ta/all\n(Default: yes):" in + match interact msg return_input with + | Next -> + (match f param with + | None -> Printf.printf "No other possible value\n" + | Some new_param -> ask_for_next_parse f new_param) + | All -> no_interaction f param + | Stop -> () + + let get_parse_tree resume abs_ty lex = + let abs_sig,_=E.Lexicon.get_sig lex in + match E.Lexicon.get_analysis resume lex with + | Some t,resume -> + let () = Printf.printf "%s : %s \n%!" (E.Signature1.term_to_string t abs_sig) (E.Signature1.type_to_string abs_ty abs_sig) in + Some resume + | None,_ -> None + + let parse ?name e ?offset data l = + if data="help" then + help (Help (Some Realize)) + else + let additional_offset = "\t" in + let actual_offset = Printf.sprintf "%s%s" (match offset with | None -> "" | Some s -> s) additional_offset in + let lex = get_lex name "parse" e l in + let abs,obj=E.Lexicon.get_sig lex in + match Data_parser.parse_heterogenous_term ~output:false ~offset:actual_offset data lex with + | None -> () + | Some (obj_t,abs_ty) -> + let resume = get_parse_tree (E.Lexicon.parse obj_t abs_ty lex) abs_ty lex in + match resume with + | None -> Printf.printf "No solution.\n%!" + | Some resume -> + ask_for_next_parse (fun res -> get_parse_tree res abs_ty lex) resume + + + let idb ?name e ?offset l = + if name=Some ("help") then + help (Help (Some Realize)) + else + let additional_offset = "\t" in + let actual_offset = Printf.sprintf "%s%s" (match offset with | None -> "" | Some s -> s) additional_offset in + let lex = get_lex name "query" e l in + let buff=E.Lexicon.program_to_buffer lex in + Printf.printf + "The datalog program (intensional database) corresponding to the lexicon \"%s\" is:\n%s\n%!" + (fst (E.Lexicon.name lex)) + (Buffer.contents buff) + + + let query ?name e ?offset data l = + if data="help" then + help (Help (Some Realize)) + else + let additional_offset = "\t" in + let actual_offset = Printf.sprintf "%s%s" (match offset with | None -> "" | Some s -> s) additional_offset in + let lex = get_lex name "idb" e l in + let abs,obj=E.Lexicon.get_sig lex in + match Data_parser.parse_heterogenous_term ~output:false ~offset:actual_offset data lex with + | None -> () + | Some (obj_t,abs_ty) -> + let buff=E.Lexicon.query_to_buffer obj_t abs_ty lex in + Printf.printf + "The datalog program (intensional database) corresponding to the lexicon \"%s\" is:\n%s\n%!" + (fst (E.Lexicon.name lex)) + (Buffer.contents buff) + + + + let entry_name = function | E.Signature sg -> fst (E.Signature1.name sg) | E.Lexicon lex -> fst (E.Lexicon.name lex) @@ -322,72 +641,6 @@ struct let should_wait () = !interactive - type action = - | Load - | List - | Select - | Unselect - | Trace - | Dont_trace - | Print - | Analyse - | Add - | Compose - | Dont_wait - | Wait - | Help of action option - | Create - | Save - - - let actions = [Load;List;Select;Unselect;Trace;Dont_trace;Print;Analyse;Add;Compose;Dont_wait;Wait;Help None;Create;Save] - - - - let rec action_to_string = function - | Load -> "load" - | List -> "list" - | Select -> "select" - | Unselect -> "unselect" - | Trace -> "trace" - | Dont_trace -> "don't trace" - | Print -> "print" - | Analyse -> "analyse" - | Add -> "add" - | Compose -> "compose" - | Dont_wait -> "don't wait" - | Wait -> "wait" - | Help None -> "help" - | Help (Some (Help a)) -> action_to_string (Help a) - | Help (Some a) -> Format.sprintf "%s help" (action_to_string a) - | Save -> "save" - | Create -> "create" - - - - - let messages = function - | Load as command -> Format.sprintf "\t%s d|data|s|script file;\n\t\tloads the file \"file\" as data (d or data option) or as a script (script or s option)" (action_to_string command) - | List as command -> Format.sprintf "\t%s;\n\t\tlists the signatures and the lexicons of the current environment" (action_to_string command) - | Select as command -> Format.sprintf "\t%s name;\n\t\tselects the name signature or lexicon in the current environment and make it an implicit context for following commands" (action_to_string command) - | Unselect as command -> Format.sprintf "\t%s name;\n\t\tremoves any selected signature or lexicon from the context" (action_to_string command) - | Trace as command -> Format.sprintf "\t%s;\n\t\ttraces the interpretation (if a command is used in a context of a lexicon) and the beta-reduction process" (action_to_string command) - | Dont_trace as command -> Format.sprintf "\t%s;\n\t\tstops tracing" (action_to_string command) - | Wait as command -> Format.sprintf "\t%s;\n\t\twaits a keyboard return event before going on in executing a script" (action_to_string command) - | Dont_wait as command -> Format.sprintf "\t%s;\n\t\tstops waiting a keyboard return event before going on in executing a script" (action_to_string command) - | Print as command -> Format.sprintf "\t[name] %s;\n\t\toutputs the content of the \"name\" signature or lexicon of the current environment. If no \"name\" is specified, check whether there is a selected data in the environment" (action_to_string command) - | Analyse as command -> Format.sprintf "\t[name1 name2 ...] %s term:type;\n\tanalyses the given \"term:type\" with respect to the given \"name1\" ... signatures or lexicons, or if no such name is given, with respect to the selected data in the environment. In the context of a signature, this command just typechecks the given entry. In the context of a lexicon, it typechecks it and interprets it with respect to this lexicon" (action_to_string command) - | Add as command -> Format.sprintf "\t[name1 name2 ...] %s expression;\n\tadds the given \"expression\" with respect to the given \"name1\" ... signatures or lexicons to those signature or lexicons. \"expression\" must respect the syntax of signatures or lexicons" (action_to_string command) - | Compose as command -> Format.sprintf "\t%s name1 name2 as name3;\n\t\tcreates a new lexicon with name \"name3\" by composing the \"name1\" and \"name2\" lexicons" (action_to_string command) - | Help _ as command -> Format.sprintf "\t%s ;\n\t\tprints the help message" (action_to_string command) - | Create as command -> Format.sprintf "\t%s s|sig|l|lex name [name1 name2];\n\t\tcreates a new empty signature or lexicon (according to the s or sig, or l or lex option) with name \"name\" in the current environment.\"name1\" and \"name2\" are mandatory in case of creating a lexicon: they are respectively the abstract and the object signature. They of course are forbidden in case of creating a signature" (action_to_string command) - | Save as command -> Format.sprintf "\t[name1 name2 ...] %s filename;\n\t\toutputs the content of \"name1\", \"name2\"... into the same file \"filename\". If no \"name\" is specified, check whether there is a selected data in the environment" (action_to_string command) - - let rec help = function - | Help (Some (Help a)) -> help (Help a) - | Help (Some a) -> Format.printf "Usage:\n%s\n" (messages a) - | Help None -> Format.printf "Commands: For any command, its usage can be reminded by running the following command:\n\tcommand help;\nThe following commands are available. \n%s\n" (Utils.string_of_list "\n" (fun x -> x) (List.map messages actions)) - | _ as a -> Format.printf "Usage:@\n%s@\n" (messages a) let exit () = raise End_of_file diff --git a/src/scripting/functions.mli b/src/scripting/functions.mli index 5907dc5daca99e41649b6ea3b7fe5ad28bed5df2..01d90044b5a1e107c9c0510ce6fa77c2a79a8b24 100644 --- a/src/scripting/functions.mli +++ b/src/scripting/functions.mli @@ -36,6 +36,8 @@ sig | Dont_trace | Print | Analyse + | Check + | Realize | Add | Compose | Dont_wait @@ -43,11 +45,14 @@ sig | Help of action option | Create | Save + | Parse + | Idb + | Query - - - - type file_type = | Data | Script of (string -> string list -> env -> env) + type file_type = + | Data + | Object + | Script of (string -> string list -> env -> env) val load : file_type -> string -> string list -> env -> env @@ -64,6 +69,16 @@ sig val analyse : ?names:(string * (Lexing.position * Lexing.position)) list -> env -> ?offset:string -> string -> (Lexing.position * Lexing.position) -> unit + val check : ?names:(string * (Lexing.position * Lexing.position)) list -> env -> ?offset:string -> string -> (Lexing.position * Lexing.position) -> unit + + val realize : ?names:(string * (Lexing.position * Lexing.position)) list -> env -> ?offset:string -> string -> (Lexing.position * Lexing.position) -> unit + + val parse : ?name:string -> env -> ?offset:string -> string -> (Lexing.position * Lexing.position) -> unit + + val idb : ?name:string -> env -> ?offset:string -> (Lexing.position * Lexing.position) -> unit + + val query : ?name:string -> env -> ?offset:string -> string -> (Lexing.position * Lexing.position) -> unit + val add : ?names:(string * (Lexing.position * Lexing.position)) list -> env -> ?offset:string -> string -> (Lexing.position * Lexing.position) -> env val compose : diff --git a/src/scripting/script_lexer.mll b/src/scripting/script_lexer.mll index f3148028511c910e0c9b95c9df0909240496cd97..5fa02dac5cd2d1ba685ce15ec771afa5ab9abded 100644 --- a/src/scripting/script_lexer.mll +++ b/src/scripting/script_lexer.mll @@ -30,6 +30,7 @@ type token = | EOII | LOAD_DATA of (string*Abstract_syntax.location*string) | LOAD_SCRIPT of (string*Abstract_syntax.location*string) + | LOAD_OBJECT of (string*Abstract_syntax.location*string) | LOAD_HELP | LIST | SELECT @@ -37,6 +38,11 @@ type token = | TRACE | PRINT of Abstract_syntax.location | ANALYSE of (string*Abstract_syntax.location*string) + | CHECK of (string*Abstract_syntax.location*string) + | REALIZE of (string*Abstract_syntax.location*string) + | PARSE of (string*Abstract_syntax.location*string) + | IDB of Abstract_syntax.location + | QUERY of (string*Abstract_syntax.location*string) | ADD of (string*Abstract_syntax.location*string) | COMPOSE | SEMICOLONN of string @@ -105,6 +111,15 @@ let string = (letter|digit|'_')* | "print" as c {let () = echo_str c in PRINT (loc lexbuf)} | "analyse" as c {let () = echo_str c in let () = Buffer.reset string_content in string (fun x l -> ANALYSE (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf} + | "check" as c {let () = echo_str c in let () = Buffer.reset string_content in + string (fun x l -> CHECK (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf} + | "realize" as c {let () = echo_str c in let () = Buffer.reset string_content in + string (fun x l -> REALIZE (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf} + | "parse" as c {let () = echo_str c in let () = Buffer.reset string_content in + string (fun x l -> PARSE (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf} + | "idb" as c {let () = echo_str c in IDB (loc lexbuf)} + | "query" as c {let () = echo_str c in let () = Buffer.reset string_content in + string (fun x l -> QUERY (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf} | "add" as c {let () = echo_str c in let () = Buffer.reset string_content in string_wo_space (fun x l -> ADD (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf} | "compose" as c {let () = echo_str c in COMPOSE} @@ -139,6 +154,10 @@ let string = (letter|digit|'_')* string_wo_space (fun x l -> LOAD_DATA (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf} | "d" as c {let () = echo_chr c in let () = Buffer.reset string_content in string_wo_space (fun x l -> LOAD_DATA (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf} + | "object" as c {let () = echo_str c in let () = Buffer.reset string_content in + string_wo_space (fun x l -> LOAD_OBJECT (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf} + | "o" as c {let () = echo_chr c in let () = Buffer.reset string_content in + string_wo_space (fun x l -> LOAD_OBJECT (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf} | "script" as c {let () = echo_str c in let () = Buffer.reset string_content in string_wo_space (fun x l -> LOAD_SCRIPT (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf} | "s" as c {let () = echo_chr c in let () = Buffer.reset string_content in diff --git a/src/scripting/script_parser.dyp b/src/scripting/script_parser.dyp index 8a30572ef0158716406e1ec5c81c474b71c55132..78dfe6e2bbe3404278dd4cf46fcaa33ae863c1e9 100644 --- a/src/scripting/script_parser.dyp +++ b/src/scripting/script_parser.dyp @@ -49,6 +49,7 @@ EOII <(string*Abstract_syntax.Abstract_syntax.location*string)>LOAD_DATA <(string*Abstract_syntax.Abstract_syntax.location*string)>LOAD_SCRIPT +<(string*Abstract_syntax.Abstract_syntax.location*string)>LOAD_OBJECT LOAD_HELP LIST SELECT @@ -57,6 +58,11 @@ HELP PRINT <(string*Abstract_syntax.Abstract_syntax.location*string)>ANALYSE +<(string*Abstract_syntax.Abstract_syntax.location*string)>CHECK +<(string*Abstract_syntax.Abstract_syntax.location*string)>REALIZE +<(string*Abstract_syntax.Abstract_syntax.location*string)>PARSE +IDB +<(string*Abstract_syntax.Abstract_syntax.location*string)>QUERY <(string*Abstract_syntax.Abstract_syntax.location*string)>ADD COMPOSE SEMICOLONN @@ -106,6 +112,9 @@ | LOAD_DATA {fun e -> let () = echo dyp.global_data l in let _,_,incl = dyp.global_data in F.load F.Data s incl e} +| LOAD_OBJECT {fun e -> let () = echo dyp.global_data l in + let _,_,incl = dyp.global_data in + F.load F.Object s incl e} | LOAD_SCRIPT {fun e -> let () = echo dyp.global_data l in let _,_,includes = dyp.global_data in let new_env = F.load (F.Script (snd dyp.last_local_data)) s includes e in @@ -115,18 +124,48 @@ | UNSELECT SEMICOLONN { let () = echo dyp.global_data l in F.unselect} | TRACE SEMICOLONN { let () = echo dyp.global_data l in fun e -> let () = F.trace () in e} | DONT TRACE SEMICOLONN { let () = echo dyp.global_data l in fun e -> let () = F.dont_trace () in e} -| optional_ident PRINT

SEMICOLONN { let () = echo dyp.global_data l in fun e -> - let loc = - match name with - | None -> p - | Some (_,l) -> l in - match name with - | None -> let () = F.print e loc in e - | Some (n,l) -> let () = F.print ~name:n e loc in e} +| optional_ident PRINT

SEMICOLONN { + let () = echo dyp.global_data l in fun e -> + let loc = + match name with + | None -> p + | Some (_,l) -> l in + match name with + | None -> let () = F.print e loc in e + | Some (n,l) -> let () = F.print ~name:n e loc in e} | optional_idents ANALYSE { let () = echo dyp.global_data line in fun e -> match names with | [] -> let () = F.analyse e t l in e | _ -> let () = F.analyse ~names e t l in e} +| optional_idents CHECK { + let () = echo dyp.global_data line in fun e -> + match names with + | [] -> let () = F.check e t l in e + | _ -> let () = F.check ~names e t l in e} +| optional_idents REALIZE { + let () = echo dyp.global_data line in fun e -> + match names with + | [] -> let () = F.realize e t l in e + | _ -> let () = F.realize ~names e t l in e} +| optional_ident PARSE { + let () = echo dyp.global_data line in fun e -> + match name with + | None -> let () = F.parse e t l in e + | Some (n,lex_loc) -> let () = F.parse ~name:n e t lex_loc in e} +| optional_ident QUERY { + let () = echo dyp.global_data line in fun e -> + match name with + | None -> let () = F.query e t l in e + | Some (n,lex_loc) -> let () = F.query ~name:n e t lex_loc in e} +| optional_ident IDB

SEMICOLONN { + let () = echo dyp.global_data l in fun e -> + let loc = + match name with + | None -> p + | Some (_,l) -> l in + match name with + | None -> let () = F.idb e loc in e + | Some (n,l) -> let () = F.idb ~name:n e loc in e} | optional_idents ADD { let () = echo dyp.global_data line in fun e -> match names with | [] -> F.add e t l diff --git a/src/scripting/scripting_errors.ml b/src/scripting/scripting_errors.ml index bdc7238c8c130dff3a2ac5f515eafbf07ca34575..b1107843faa469fb25cf3a379411783735777795 100644 --- a/src/scripting/scripting_errors.ml +++ b/src/scripting/scripting_errors.ml @@ -29,6 +29,10 @@ type error = | Command_expected | Not_yet_implemented of string | No_focus + | Accept_only of data_type * string +and data_type = + | Lex of string + | Sg of string exception Error of (error * Abstract_syntax.location) @@ -40,5 +44,7 @@ let error_msg er (s,e) = | No_such_lexicon s -> Printf.sprintf "No lexicon \"%s\" in the current environmnet" s | Command_expected -> "Command expected" | No_focus -> "No data on which to apply the command" + | Accept_only (Lex s,cmd) -> Printf.sprintf "The %s command can only apply to lexicons. Here it is applied to a signature: \"%s\"" cmd s + | Accept_only (Sg s,cmd) -> Printf.sprintf "The %s command can only apply to signatures. Here it is applied to a lexicon: \"%s\"" cmd s | Not_yet_implemented s -> Printf.sprintf "\"%s\": Command not yet implemented" s in Printf.sprintf "%s:\n%s\n%!" loc msg diff --git a/src/scripting/scripting_errors.mli b/src/scripting/scripting_errors.mli index 2d948692620f5ba72ef99615df01ff45e79b4a34..6c1f816b5624a973e2913a515a7c6b0192101ef2 100644 --- a/src/scripting/scripting_errors.mli +++ b/src/scripting/scripting_errors.mli @@ -27,6 +27,10 @@ type error = | Command_expected | Not_yet_implemented of string | No_focus + | Accept_only of data_type * string +and data_type = +| Lex of string +| Sg of string exception Error of (error * (Lexing.position * Lexing.position)) diff --git a/src/utils/Makefile.in b/src/utils/Makefile.in index 7a1db70f683f920784d8cfefa941be49bbdc2b06..8af449f74d0b7fd8ff6b68efbb4e3576bba7c453 100644 --- a/src/utils/Makefile.in +++ b/src/utils/Makefile.in @@ -26,21 +26,22 @@ include ../Makefile.master ############################### # Used libraries -LIBS += gramlib.cma str.cma +LIBS += str.cma # The corresponding directories # (if not in the main ocaml lib directory, # ex. +campl4 -LIBDIR = -I +camlp4 +LIBDIR += # Directories to which the current source files depend on PREVIOUS_DIRS = # Source files in the right order of dependance -ML = utils.ml table.ml tries.ml version.ml +ML = utils.ml table.ml tries.ml version.ml focused_list.ml sharedForest.ml idGenerator.ml # Uncomment the next line and put the name of the exe of this directory, if relevant -# EXE_SOURCES = + +EXE_SOURCES =test_sharedForest.ml #################################### # # diff --git a/src/utils/focused_list.ml b/src/utils/focused_list.ml new file mode 100644 index 0000000000000000000000000000000000000000..4e6905c572d20b78ab33b21e562c3a5b9fdc83f3 --- /dev/null +++ b/src/utils/focused_list.ml @@ -0,0 +1,32 @@ +module Focused_list = +struct + type 'a t= List_zip of ('a list*'a*'a list) + (** This type aims to implement a zipper for lists. The context is + the first parameter. It represents the list of the elements {e + in reverse order} that has been traversed to reach the focused + element (the second parameter). The last element is the + remaining elements of the list. *) + + exception Empty_list + exception End_of_list + + + let init = function + | [] -> raise Empty_list + | h::tl -> List_zip([],h,tl) + + + let forward = function + | List_zip (c,f,h::tl) -> List_zip(f::c,h,tl) + | List_zip (_,_,[]) -> raise End_of_list + + + let backward = function + | List_zip (h::tl,f,r) -> List_zip(tl,h,f::r) + | List_zip ([],_,_) -> raise End_of_list + + + let rec fold f acc = function + | List_zip ((c,a,[]) as focus) -> f acc focus + | List_zip ((c,a,h::tl) as focus) as lst -> fold f (f acc focus) (forward lst) +end diff --git a/src/utils/focused_list.mli b/src/utils/focused_list.mli new file mode 100644 index 0000000000000000000000000000000000000000..4f566c933dd5d5a66132077a5fe11c1f5f3f0f8f --- /dev/null +++ b/src/utils/focused_list.mli @@ -0,0 +1,32 @@ +module Focused_list : +sig + type 'a t= List_zip of ('a list*'a*'a list) + (** This type aims to implement a zipper for lists. The context is + the first parameter. It represents the list of the elements {e + in reverse order} that has been traversed to reach the focused + element (the second parameter). The last element is the + remaining elements of the list. *) + + exception Empty_list + exception End_of_list + + (** [init l] inits a focused list. It raises an exception {! + Empty_list} if [l] is empty, hence has no element to + focus on. *) + val init : 'a list -> 'a t + + (** [forward z] returns a the new focused_list where the focuses + element is the next one in the initial list. It raises + {!End_of_list} if no such element is available *) + val forward : 'a t -> 'a t + + (** [backward z] returns a the new focused_list where the focuses + element is the previous one in the initial list. It raises + {!End_of_list} if no such element is available *) + val backward : 'a t -> 'a t + + (** [fold f a z] returns [f (... (f (f a z1) z2) ...) z_n] where + [z_1=z] and [z_{i+1}=forward z_i] and [forward z_n] would raise + an exception {!End_of_list}. *) + val fold : ('b -> ('a list*'a*'a list) -> 'b) -> 'b -> 'a t -> 'b +end diff --git a/src/utils/idGenerator.ml b/src/utils/idGenerator.ml new file mode 100644 index 0000000000000000000000000000000000000000..ca70fd01ff33f86cd402cafa0214f400d6bd7d5a --- /dev/null +++ b/src/utils/idGenerator.ml @@ -0,0 +1,170 @@ +(** This module implements various useful modules to generate IDs and + to keep track of there association with string as in a symbol table *) + +(** Signature of modules encoding symbol tables *) +module type CorrespondanceTableTYPE= +sig + (** [identifier] is the type of the identifier stored in the + table. It is meant to be associated with a [string] *) + type identifier + + (** The type of the table *) + type table + + (** This exception can be raised when some identifier or some symbol + is not found in a query *) + exception Not_found + + (** [empty] is an empty table *) + val empty:table + + (** [find_id_of_sym sym t] returns the identifier of the string + [sym] stored in [t]. Raises [Not_found] if no such identifier + exists. *) + val find_id_of_sym : string -> table -> identifier + + (** [find_sym_from_id id t] returns the string (i.e. the symbol) + corresponding to the identifier [id] in table [t] *) + val find_sym_from_id : identifier -> table -> string + + (** [add_sym sym t] returns a pair [(id,t')] where [id] is the + identifier associated with [sym] in [t']. If [sym] already was + in [t] then [t']=[t] and [id] is the identifier which it was + associated with. Otherwise, a new identifier is generated and + the new association is stored in [t'].*) + val add_sym : string -> table -> identifier*table + + (** [to_string t] outputs the table [t] in a string.*) + val to_string : table -> string + + (** [fold f table a] returns [f id1 sym1 (f id2 sym2 ( ... ( f idN + symN a) ... ))] where the [(id,sym)] pairs are the ones that are + stored in the table [table]. The order of these key-value pairs in + the table is unspecified. *) + val fold : (identifier -> string -> 'a -> 'a) -> table -> 'a -> 'a + +end + +(** Signature of modules encoding a generator of identifiers *) +module type IdGen_TYPE = +sig + (** The type of the identifier generated *) + type id + (** The type of the generator *) + type t + (** [init ()] returns a new generator *) + val init : unit -> t + (** [get_fresh_id gen] returnds a pair [(id,gen')] where [id] is a + fresh [id] and [gen'] a new generator that knows [id] was already + generated.*) + val get_fresh_id : t -> (id*t) + (** [eq id1 id2] returns [true] if [id1=id2] and [fase] otherwise. *) + val eq : id -> id -> bool + (** [compare id1 id2] returns an integer which is [0] if [id1=id2], + negative of [id1] is less than [id2] and positive otherwise. *) + val compare : id -> id -> int + + (** [IdMap] implements maps whose keys are identifiers *) + module IdMap : Map.S with type key=id + + (** [Table] implements correspondance tables with the current + identifiers *) + module Table : CorrespondanceTableTYPE with type identifier=id +end + +(** Signature of encoding identifiers *) +module type IdType= +sig + (** The type of the identifiers *) + type t + (** [compare id1 id2] returns an integer which is [0] if [id1=id2], + negative of [id1] is less than [id2] and positive otherwise. *) + val compare : t -> t -> int + + (** [succ id] returns a new identifer strictly greater than [id] *) + val succ: t -> t + + (** [start] is some identifer *) + val start: t + + (** [to_string id] returns a string describing the identifier *) + val to_string: t->string +end + +(** This module is a functor that generates a identifier generator + from a module implementing these identifiers *) + +module IdGen(ID:IdType) = +struct + type id=ID.t + type t=Generator of id + let init () = Generator ID.start + let get_fresh_id (Generator n) = n, Generator (ID.succ n) + let eq i j = ID.compare i j=0 + let compare = ID.compare + module IdMap=Map.Make(ID) + module Table= + struct + type identifier=id + type table= {symbols:id Tries.Tries.t; + ids:string IdMap.t; + gen: t} + exception Not_found + + let empty = {symbols=Tries.Tries.empty; + ids=IdMap.empty; + gen=init ()} + + let find_id_of_sym symbol {symbols=table} = + try + Tries.Tries.find symbol table + with + | Tries.Tries.Not_found -> raise Not_found + + let find_sym_from_id id {ids=table} = + try + IdMap.find id table + with + | Not_found -> raise Not_found + + let add_sym sym ({symbols=syms;ids=ids;gen=vargen} as table) = + try + Tries.Tries.find sym syms,table + with + | Tries.Tries.Not_found -> + let new_var,new_vargen=get_fresh_id vargen in + new_var,{symbols=Tries.Tries.add sym new_var syms; + ids=IdMap.add new_var sym ids; + gen=new_vargen} + + let to_string {symbols=syms;ids=ids} = + let buff=Buffer.create 20 in + let () = Buffer.add_string buff "Table from symbols to ids\n" in + let () = Tries.Tries.fold + (fun key value () -> Buffer.add_string buff (Printf.sprintf "\t%s\t<->\t%s\n" key (ID.to_string value))) + () + syms in + let () = Buffer.add_string buff "Table from symbols to ids\n" in + let () = + IdMap.iter + (fun key value -> Buffer.add_string buff (Printf.sprintf "\t%s\t<->\t%s\n%!" (ID.to_string key) value)) + ids in + Buffer.contents buff + + let fold f table start = + IdMap.fold f table.ids start + end +end + +module IntId= +struct + type t = int + let compare i j = i-j + let succ i = i+1 + let start =0 + let to_string = string_of_int +end + +(** Module implementing the special case where identifiers ar + integers. *) +module IntIdGen=IdGen(IntId) diff --git a/src/utils/idGenerator.mli b/src/utils/idGenerator.mli new file mode 100644 index 0000000000000000000000000000000000000000..a23792ab42409a9abe2a968fa7aaed974f050e0b --- /dev/null +++ b/src/utils/idGenerator.mli @@ -0,0 +1,100 @@ +(** This module implements various useful modules to generate IDs and + to keep track of there association with string as in a symbol table *) + +(** Signature of modules encoding symbol tables *) +module type CorrespondanceTableTYPE= +sig + (** [identifier] is the type of the identifier stored in the + table. It is meant to be associated with a [string] *) + type identifier + + (** The type of the table *) + type table + + (** This exception can be raised when some identifier or some symbol + is not found in a query *) + exception Not_found + + (** [empty] is an empty table *) + val empty:table + + (** [find_id_of_sym sym t] returns the identifier of the string + [sym] stored in [t]. Raises [Not_found] if no such identifier + exists. *) + val find_id_of_sym : string -> table -> identifier + + (** [find_sym_from_id id t] returns the string (i.e. the symbol) + corresponding to the identifier [id] in table [t] *) + val find_sym_from_id : identifier -> table -> string + + (** [add_sym sym t] returns a pair [(id,t')] where [id] is the + identifier associated with [sym] in [t']. If [sym] already was + in [t] then [t']=[t] and [id] is the identifier which it was + associated with. Otherwise, a new identifier is generated and + the new association is stored in [t'].*) + val add_sym : string -> table -> identifier*table + + (** [to_string t] outputs the table [t] in a string.*) + val to_string : table -> string + + (** [fold f table a] returns [f id1 sym1 (f id2 sym2 ( ... ( f idN + symN a) ... ))] where the [(id,sym)] pairs are the ones that are + stored in the table [table]. The order of these key-value pairs in + the table is unspecified. *) + val fold : (identifier -> string -> 'a -> 'a) -> table -> 'a -> 'a +end + +(** Signature of modules encoding a generator of identifiers *) +module type IdGen_TYPE = +sig + (** The type of the identifier generated *) + type id + (** The type of the generator *) + type t + (** [init ()] returns a new generator *) + val init : unit -> t + (** [get_fresh_id gen] returnds a pair [(id,gen')] where [id] is a + fresh [id] and [gen'] a new generator that knows [id] was already + generated.*) + val get_fresh_id : t -> (id*t) + (** [eq id1 id2] returns [true] if [id1=id2] and [fase] otherwise. *) + val eq : id -> id -> bool + (** [compare id1 id2] returns an integer which is [0] if [id1=id2], + negative of [id1] is less than [id2] and positive otherwise. *) + val compare : id -> id -> int + + (** [IdMap] implements maps whose keys are identifiers *) + module IdMap : Map.S with type key=id + + (** [Table] implements correspondance tables with the current + identifiers *) + module Table : CorrespondanceTableTYPE with type identifier=id +end + +(** Signature of encoding identifiers *) +module type IdType= +sig + (** The type of the identifiers *) + type t + (** [compare id1 id2] returns an integer which is [0] if [id1=id2], + negative of [id1] is less than [id2] and positive otherwise. *) + val compare : t -> t -> int + + (** [succ id] returns a new identifer strictly greater than [id] *) + val succ: t -> t + + (** [start] is some identifer *) + val start: t + + (** [to_string id] returns a string describing the identifier *) + val to_string: t -> string +end + + +(** This module is a functor that generates a identifier generator + from a module implementing these identifiers *) +module IdGen(ID:IdType) : IdGen_TYPE with type id=ID.t + +(** Module implementing the special case where identifiers ar + integers. *) +module IntIdGen:IdGen_TYPE with type id=int diff --git a/src/utils/sharedForest.ml b/src/utils/sharedForest.ml new file mode 100644 index 0000000000000000000000000000000000000000..5caddc64129ff2bcfda86c8e27dbfe12c70823e1 --- /dev/null +++ b/src/utils/sharedForest.ml @@ -0,0 +1,507 @@ +module SharedForest = +struct + (** This type is the type of addresses of forests. It is a list of + (position in the forest,position as a child). *) + type address=(int*int) list + (** This is the type of relative path from one forest to another + one. The first argument is the number of steps to move up, then + second argument is the address to reach from this point. *) + type relative_path=int*address + + let rec diff_aux add1 add2 back = + match add1,add2 with + | [],[] -> back,[] + | _,[] -> back+List.length add1,[] + | [],_ -> back,add2 + | (i,j)::tl1,(i',j')::tl2 when i=i' && j=j' -> diff_aux tl1 tl2 back + | _::_,_::_ -> back+List.length add1,add2 + + (** [diff add add'] returns the relative path to go from the + forest (subtree) wich occurs at address [add] to the forest + (subtree) wich occurs at address [add']. *) + let diff add1 add2 = diff_aux add1 add2 0 + + let address_to_string addr = + Printf.sprintf + "[%s]" + (Utils.string_of_list ";" (fun (i,j) -> Printf.sprintf "(%d,%d)" i j) addr) + + let path_to_string (i,add) = + Printf.sprintf "(-%d,%s)" i (address_to_string add) + + type 'a stack='a list + type 'a list_context ='a stack + + type 'a focused_list = 'a list_context * 'a list + + + (** Recursive definition of a shared forest. *) + type 'a forest = 'a tree focused_list + and 'a tree = Node of 'a * 'a child list + and 'a child = + | Forest of 'a forest + | Link_to of relative_path + + (** Defintion of a "forest zipper" *) + type 'a forest_zipper = + | Top of ('a tree) focused_list * int + | Zip of + 'a * + (* The first element is the label of the node *) + ('a child) focused_list * + (* the focused list of children of the tree. Just as for tree + zippers *) + ('a tree) focused_list * + (* the focused list of the focuses child: a forest *) + int * + (* the position of the tree under focus in the current forest *) + 'a forest_zipper * + (* the forest context *) + 'a forest_zipper option * + (* a local context describing the way to reach the current + tree from top in case it was reached after a [Link_to] move, + so that if some other [Link_to] is met under thus subtree that + points higher, it goes to the right place. *) + address + (* The address of the current tree. Actually not used. *) + + (** Type definition for the focused forests *) + type 'a focused_forest = 'a forest_zipper * 'a tree + + (** Type definition for standard trees *) + type 'a simple_tree = SimpleTree of 'a * 'a simple_tree list + + (** Type definition for standard tree zippers *) + type 'a zipper = ZTop | Zipper of ('a * 'a simple_tree focused_list * 'a zipper) + + (** Type definition for standard focused trees *) + type 'a focused_tree = 'a zipper * 'a simple_tree + + + let rec fold_depth_first ((transform,apply) as f) t = + match t with + | SimpleTree (v,[]) -> transform v + | SimpleTree (v,children) -> + List.fold_left + (fun acc child -> apply acc (fold_depth_first f child)) + (transform v) + children + + type 'a simple_resumption = ('a focused_forest * 'a focused_tree * int) list + + type 'a delayed_resumption = ('a simple_resumption) Utils.IntMap.t + + type 'a resumption = 'a simple_resumption * 'a delayed_resumption + + let empty = [],Utils.IntMap.empty + + exception Infinite_loop + + let extend_simple_resume (f_f,f_t,i) resume = (f_f,f_t,i)::resume + + let extend_sized_indexed_resume (f_f,f_t,i) resume = + try + Utils.IntMap.add i ((f_f,f_t,i)::(Utils.IntMap.find i resume)) resume + with + | Not_found -> Utils.IntMap.add i [(f_f,f_t,i)] resume + + let extend_resume ?actual ?delayed ((resume1,resume2):'a resumption) = + match actual,delayed with + | None,None -> resume1,resume2 + | Some v,None -> extend_simple_resume v resume1,resume2 + | None,Some v -> resume1,extend_sized_indexed_resume v resume2 + | Some v1,Some v2->extend_simple_resume v1 resume1,extend_sized_indexed_resume v2 resume2 + + type move = + | Up + | Down + | Right + | Forward + | Backward + | Cycle + + exception Move_failure of move + exception Not_well_defined + exception No_next_alt + exception No_previous_alt + exception Bad_argument + exception Bad_address + + let swap = function + | [],delayed -> + (try + (match Utils.IntMap.min_binding delayed with + | _,[] -> failwith "Bug: such a binding should be removed" + | i,[a] -> a,([], Utils.IntMap.remove i delayed) + | i,a::res -> a,(res,Utils.IntMap.remove i delayed)) + with + | Not_found -> raise No_next_alt) + | a::actual,delayed -> a,(actual,delayed) + + + let rec unstack = function + | [],l ->l + | a::tl,l -> unstack (tl,(a::l)) + + let rec f_list_up = function + | [],l -> [],l + | a::s,l-> f_list_up (s,a::l) + + let f_list_cycle = function + | [],[] -> raise (Move_failure Cycle) + | p,a::n -> a::p,n + | f_lst -> f_list_up f_lst + + let focus_of = function + | [],[] -> raise Not_well_defined + | p,a::n -> (p,n),a,1+List.length p + | p,[] -> + match List.rev p with + | [] -> raise Not_well_defined + | a::n -> ([],n),a,1 + + + let rec f_list_fold ((p,n),i) f acc = + match n with + | [] -> (p,[]),acc + | a::tl -> f_list_fold ((a::p,tl),i+1) f (f ((p,tl),i) a acc) + + let f_tree_up = function + | ZTop,t -> raise (Move_failure Up) + | Zipper (v,(l,r),z'),t -> z',SimpleTree (v,unstack (l,t::r)) + + let rec zip_up_aux f_tree = + try + zip_up_aux (f_tree_up f_tree) + with + | Move_failure Up -> f_tree + + let zip_up f_tree = + let _,t = zip_up_aux f_tree in + t + + let rec move_forward i (l,r) = + match i,r with + | 1,a::tl -> (l,tl),a + | i,a::tl when i>1 -> move_forward (i-1) (a::l,tl) + | _ -> raise Bad_address + + + let forest_address = function + | Top _ -> [] + | Zip (_,_,_,_,_,_,add) -> add + + let tree_address = function + | Top ((_,_),i) -> i,[] + | Zip (_,_,_,i,_,_,add) -> i,add + + + + + + (** [enter add (z,t)] returns the forest at address [add] starting + from the current forest of [z] [t] is belonging to. + + Invariant: the result is [(z,t),forest] where [t] belongs to the + forest [forest]. [t] is the focused element of the forest *) + let rec enter addr (z,(Node (v,children) as t)) = + LOG "Entering \"%s\" on a node with %d children%!" (address_to_string addr) (List.length children) LEVEL DEBUG; + match addr with + | [] -> + (match z with + | Top (([],[]),_) -> (z,t),([],[t]) + | Top ((p,[]),_) -> + (match unstack (p,[t]) with + | [] -> raise Not_well_defined + | a::n -> (Top (([],n),1),a),([],a::n)) + | Top ((p,a::n),i) -> (Top ((t::p,n),i+1),a),(t::p,a::n) + | Zip (_,_,([],[]),_,_,_,_) -> (z,t),([],[t]) + | Zip (v,sibling,(p,[]),i,z',l_c,add) -> + (match unstack (p,[t]) with + | [] -> raise Not_well_defined + | a::n -> (Zip (v,sibling,([],n),1,z',l_c,add),a),([],a::n)) + | Zip (v,sibling,(p,a::n),i,z',l_c,add) -> + (Zip (v,sibling,(t::p,n),i+1,z',l_c,add),a),(t::p,a::n)) + | (j_alt,i_child)::tl -> + let z,Node(v',children')= + match z with + | Top ((p,n),_) -> + let (p,n),t'= move_forward j_alt (f_list_up (p,t::n)) in + Top ((p,n),j_alt),t' + | Zip (v',(l,r),(p,n),_,z',l_c,add) -> + let (p,n),t'=move_forward j_alt (f_list_up (p,t::n)) in + Zip (v',(l,r),(p,n),j_alt,z',l_c,add),t' in + let (l',r'),f_forest=move_forward i_child ([],children') in + match f_forest with + | Forest f -> + let (p',n'), t'=move_forward 1 (f_list_up f) in + enter tl (Zip(v',(l',r'),(p',n'),1,z,None,(j_alt,i_child)::(forest_address z)),t') + | Link_to (back,addr) -> forest_at (back-1,addr) (z,Node(v',children')) + and forest_at (back,addr) (z,(Node (_,children) as t)) = + LOG "Look for forest at path %s\n%!" (path_to_string (back,addr)) LEVEL DEBUG; + LOG "current focused tree has %d children\n%!" (List.length children) LEVEL DEBUG; + if back < 0 then + failwith "Bug: looking for a forest with a negative back parameter" + else + match z,t with + | Top _ ,_ when back>0 -> raise (Move_failure Up) + | _,_ when back=0 -> enter addr (z,t) + | Zip (v,(l,r),(p,n),_,z',None,_),t -> + let children=unstack (l,(Forest (t::p,n))::r) in + forest_at (back-1,addr) (z',Node (v,children)) + | Zip (_,_,(p,n),_,_,Some local_context,_),t -> + (match local_context with + | Top ((p,n),i) -> failwith "want to move back on a top context" + | Zip (v,(l,r),(p,n),_,z',_,_) -> + let children=unstack (l,(Forest (t::p,n))::r) in + forest_at (back-1,addr) (z',Node (v,children))) + | _,_ -> raise Bad_address + + let set_local_context l_ctxt = function + | Top _ -> raise Bad_argument + | Zip (v,sibling,alt,i,z,_,add) -> Zip (v,sibling,alt,i,z,Some l_ctxt,add) + + (** [next_alt f_forest] returns the next possible focused forest + where the tree under focus in the forest has moved to the next + one. It raises [No_next_alt] if [f_forest] focuses on the last + one of the current forest. *) + let next_alt (z,t) = + match z with + | Top ((_,[]),_) -> raise No_next_alt + | Top ((p,a::tl),i) -> (Top ((t::p,tl),i+1),a) + | Zip (_,(_,_),(_,[]),_,_,_,_) -> raise No_next_alt + | Zip (v,(l,r),(p,a::n),i,z',local_context,add) -> + (Zip (v,(l,r),(t::p,n),i+1,z',local_context,add),a) + + (** [previous_alt f_forest] returns the previous possible focused + forest where the tree under focus in the forest has moved to the + previous one. It raises [No_next_alt] if [f_forest] focuses on + the first one of the current forest. *) + let previous_alt (z,t) = + match z with + | Top (([],n),_) -> raise No_previous_alt + | Top ((a::p,n),i) -> (Top ((p,t::n),i-1),a) + | Zip (_,(_,_),([],_),_,_,_,_) -> raise No_previous_alt + | Zip (v,(l,r),(a::p,n),i,z',local_context,add) -> + (Zip (v,(l,r),(p,t::n),i-1,z',local_context,add),a) + + + let rec get_all_next_alt_aux (z,t) acc = + try + let alt= next_alt (z,t) in + get_all_next_alt_aux alt (alt::acc) + with + | No_next_alt -> acc + + let rec get_all_previous_alt_aux (z,t) acc = + try + let alt= previous_alt (z,t) in + get_all_previous_alt_aux alt (alt::acc) + with + | No_previous_alt -> acc + + + let get_all_alt (z,t) acc = + let acc = get_all_next_alt_aux (z,t) acc in + let acc = get_all_previous_alt_aux (z,t) acc in + List.rev acc + + let simple_tree (Node (v,_)) = SimpleTree (v,[]) + + let rec down (z,t) (zipper,b_t) depth resume= + match t with + | Node (_,[]) -> raise (Move_failure Down) + | Node (v,forest::tl) -> + (match forest with + | Link_to (back,add) -> + let (z'',_),f = forest_at (back-1,add) (z,t) in + let (p,n),a = + match f with + | _,[] -> raise Bad_address + | p,a::n -> (p,n),a in + let foc_forest = Zip (v,([],tl),(p,n),1+List.length p,z,Some z'',forest_address z''),a in + let zipper=Zipper(v,([],[]),zipper) in + let foc_tree=zipper,simple_tree a in + (match add with + | [] -> + let resume = + let all_alt = get_all_alt foc_forest [foc_forest] in + List.fold_left + (fun acc (z,t) -> + extend_resume ~delayed:((z,t),(zipper,simple_tree t),depth+1) acc) + resume + all_alt in + let (foc_forest,foc_tree,depth'),resume = swap resume in + foc_forest,foc_tree,depth',resume + | _ -> + let resume = + let all_alt = get_all_alt foc_forest [] in + List.fold_left + (fun acc (z,t) -> + extend_resume ~actual:((z,t),(zipper,simple_tree t),depth+1) acc) + resume + all_alt in + foc_forest,foc_tree,depth+1,resume) + | Forest ([],[]) -> raise Not_well_defined + | Forest l_f -> + let t_alt,add=tree_address z in + let (p,n),a,pos=focus_of l_f in + let foc_forest=Zip (v,([],tl),(p,n),pos,z,None,(t_alt,1)::add),a in + let zipper=Zipper(v,([],[]),zipper) in + let foc_tree=zipper,simple_tree a in + let resume = + let all_alt = get_all_alt foc_forest [] in + List.fold_left + (fun acc (z,t) -> extend_resume ~actual:((z,t),(zipper,simple_tree t),depth+1) acc) + resume + all_alt in + foc_forest,foc_tree,depth+1,resume) + + let right (z,t) (zipper,b_t) depth resume = + match z,zipper with + | _ ,ZTop -> raise (Move_failure Right) + | Top _,_ -> raise (Move_failure Right) + | Zip (v,(_,[]),_,_,_,_,_), Zipper(v',_,_) when v=v'-> raise (Move_failure Right) + | Zip (v,(l,a::r),(p,n),i,z',_,add), Zipper(v',(l',r'),z'') when v=v'-> + let l_c,f,loop = + match a with + | Forest f -> None,f_list_up f,false + | Link_to (back,[]) -> + let new_ctx = z', Node(v,unstack (l,(Forest(t::p,n))::a::r)) in + let (z,_),f=forest_at (back-1,[]) new_ctx in + Some z,f,true + | Link_to (back,add) -> + let new_ctx = z', Node(v,unstack (l,(Forest(t::p,n))::a::r)) in + let (z,_),f=forest_at (back-1,add) new_ctx in + Some z,f,false in + let (p',n'),t' = + match f with + | _,[] -> raise Bad_address + | p,a::n -> (p,n),a in + let foc_forest = Zip (v,((Forest(p,t::n))::l,r),(p',n'),1,z',l_c,add),t' in + let zipper= Zipper(v',(b_t::l',r'),z'') in + let foc_tree=zipper,simple_tree t' in + (match loop with + | true -> + let resume = + let all_alt = get_all_alt foc_forest [foc_forest] in + List.fold_left + (fun acc (z,t) -> + extend_resume ~delayed:((z,t),(zipper,simple_tree t),depth) acc) + resume + all_alt in + let (foc_forest,foc_tree,depth'),resume = swap resume in + foc_forest,foc_tree,depth',resume + | false -> + let resume = + let all_alt = get_all_alt foc_forest [] in + List.fold_left + (fun acc (z,t) -> + extend_resume ~actual:((z,t),(zipper,simple_tree t),depth) acc) + resume + all_alt in + foc_forest,foc_tree,depth,resume) + | _ -> failwith "Bug: alt_tree and Simpletree are not representing the same trees" + + + let up (z,t) (zipper,b_t) depth = + match z,zipper with + | Top _,ZTop -> raise (Move_failure Up) + | _,ZTop -> failwith "Bug: both forest and tree context should be top" + | Top _,_ -> failwith "Bug: both forest and tree context should be top" + | Zip (v,(l,r),(p,n),_,z',_,_),Zipper(v',_,_) when v=v' -> + (z',Node (v,unstack (l,(Forest(p,t::n))::r))), + f_tree_up (zipper,b_t), + depth-1 + | _ -> failwith "Bug: alt_tree and Simpletree are not representing the same trees" + + + let rec close_forest_context_up f_forest f_tree depth resume = + let f_forest,f_tree,depth = up f_forest f_tree depth in + try + right f_forest f_tree depth resume + with + | Move_failure Right -> + (try + close_forest_context_up f_forest f_tree depth resume + with + | Move_failure Up -> f_forest,f_tree,depth,resume) + + + let rec build_tree_aux f_forest f_tree depth resume= + try + LOG "Trying to go down" LEVEL DEBUG; + let f_forest,f_tree,depth,resume = down f_forest f_tree depth resume in + LOG "Succeeded" LEVEL DEBUG; + build_tree_aux f_forest f_tree depth resume + with + | Move_failure Down -> + (try + LOG "Trying to go right" LEVEL DEBUG; + let f_forest,f_tree,depth,resume = right f_forest f_tree depth resume in + LOG "Succeeded" LEVEL DEBUG; + build_tree_aux f_forest f_tree depth resume + with + | Move_failure Right -> + LOG "Trying to close up" LEVEL DEBUG; + (match close_forest_context_up f_forest f_tree depth resume with + | ((Top _ ,_),(ZTop,_),_,_) as res -> + LOG "Succeeded" LEVEL DEBUG; + res + | (Zip _,_) as l_f_forest,((Zipper _,_) as l_f_tree),depth',resume' -> + LOG "Succeeded" LEVEL DEBUG; + LOG "Trying to restart a building" LEVEL DEBUG; + build_tree_aux l_f_forest l_f_tree depth' resume' + | _ -> failwith "Bug: not representing the same tree")) + + let build_tree f_forest f_tree depth resume = build_tree_aux f_forest f_tree depth resume + + let rec build_trees_aux f_forest f_tree depth resume acc = + let _,(_,tree),_,resume = build_tree f_forest f_tree depth resume in + try + let (f_forest,f_tree,depth),resume = swap resume in + build_trees_aux f_forest f_tree depth resume (tree::acc) + with + | No_next_alt -> tree::acc + + + + let init alt_trees = + (snd (f_list_fold + (([],alt_trees),1) + (fun ((p,n),i) t acc -> ((Top ((p,n),i),t),(ZTop,simple_tree t),1)::acc) + [])), + Utils.IntMap.empty + + let build_trees forest = + match init forest with + | [],_ -> failwith "Bug" + | (f_forest,f_tree,depth)::res1,res2 -> + let res = build_trees_aux f_forest f_tree depth (res1,res2) [] in + res + + let resumption (res) = + match res with + | [],_ -> + (try + let (f_forest,f_tree,depth),resume=swap res in + let _,(_,tree),_,res'=build_tree f_forest f_tree depth resume in + Some tree,(res') + with + | No_next_alt -> None,res) + | (f_forest,f_tree,depth)::resume,delayed -> + let _,(_,tree),_,res'=build_tree f_forest f_tree depth (resume,delayed) in + Some tree,(res') + + + let is_empty = function + | ([],_) as res -> + (try + let _ =swap res in + false + with + | No_next_alt -> true) + | _ -> false +end + + diff --git a/src/utils/sharedForest.mli b/src/utils/sharedForest.mli new file mode 100644 index 0000000000000000000000000000000000000000..d0daf89295de12b4b17c62e286b59f5a2293b96b --- /dev/null +++ b/src/utils/sharedForest.mli @@ -0,0 +1,102 @@ +module SharedForest : +sig + (** This type is the type of addresses of forests. It is a list of + (position in the forest,position as a child). *) + type address=(int*int) list + (** This is the type of relative path from one forest to another + one. The first argument is the number of steps to move up, then + second argument is the address to reach from this point. *) + type relative_path=int*address + + (** [diff add add'] returns the relative path to go from the + forest (subtree) wich occurs at address [add] to the forest + (subtree) wich occurs at address [add']. *) + val diff : address -> address -> relative_path + + (** [path_to_string p] returns a string describing the path [p].*) + val path_to_string : relative_path -> string + + (** [address_to_string add] returns a string describing the + address [add]. *) + val address_to_string : address -> string + + (** The type of a stack. *) + type 'a stack='a list + (** A list context is a stack *) + type 'a list_context ='a stack + + (** a focused list is a pair of a list context and of a list *) + type 'a focused_list = 'a list_context * 'a list + + + (** Recursive definition of a shared forest. *) + type 'a forest = 'a tree focused_list + and 'a tree = Node of 'a * 'a child list + and 'a child = + | Forest of 'a forest + | Link_to of relative_path + + (** Defintion of a "forest zipper" *) + type 'a forest_zipper = + | Top of ('a tree) focused_list * int + | Zip of + 'a * + (* The first element is the label of the node *) + ('a child) focused_list * + (* the focused list of children of the tree. Just as for tree + zippers *) + ('a tree) focused_list * + (* the focused list of the focuses child: a forest *) + int * + (* the position of the tree under focus in the current forest *) + 'a forest_zipper * + (* the forest context *) + 'a forest_zipper option * + (* a local context describing the way to reach the current + tree from top in case it was reached after a [Link_to] move, + so that if some other [Link_to] is met under thus subtree that + points higher, it goes to the right place. *) + address + (* The address of the current tree. Actually not used. *) + + (** Type definition for the focused forests *) + type 'a focused_forest = 'a forest_zipper * 'a tree + + (** Type definition for standard trees *) + type 'a simple_tree = SimpleTree of 'a * 'a simple_tree list + + (** Type definition for standard tree zippers *) + type 'a zipper = ZTop | Zipper of ('a * 'a simple_tree focused_list * 'a zipper) + + (** Type definition for standard focused trees *) + type 'a focused_tree = 'a zipper * 'a simple_tree + + (** An abstract type to give access to resumption when + trees are built from a forest *) + type 'a resumption (*= 'a simple_resumption * 'a delayed_resumption *) + + (** [empty] is the empty resumption *) + val empty : 'a resumption + + (** [fold_depth_first (f,g) t] recursively computes [(g a) b_1 + .... b_n] where [a=f t_0] and [b_i= f t_i] and [t] is a tree of + node [t_0] and of children [t_1...t_n]*) + val fold_depth_first: (('a -> 'b) * ('b -> 'b -> 'b)) -> 'a simple_tree -> 'b + + (** [init forest] builds the resumption with all the focused + forest focusing on each of the tree of [forest] *) + val init : 'a tree list -> 'a resumption + + (** [resumption resume] returns a pair [(Some t,resume')] where + [t] is extracted from [resume], the latter being updated with + possible alternatives met in building [t] to produce + [resume']. It returns [(None,[])] if no tree can be + extracted *) + val resumption : 'a resumption -> 'a simple_tree option * ('a resumption) + + (** [is_empty resume] returns [true] if [resume] does not propose + any other value on which to resume, [false] otherwise *) + val is_empty : 'a resumption -> bool + + +end diff --git a/src/utils/table.mli b/src/utils/table.mli index 3d3110780be27b3a2dc320b6a74520deef9dc9a1..a9760b952964234625ef0d5a547df511a40a2d0e 100644 --- a/src/utils/table.mli +++ b/src/utils/table.mli @@ -40,7 +40,7 @@ sig (** The type of the key *) type key - + (** [empty] returns the empty table *) val empty : 'a t @@ -54,15 +54,15 @@ sig val add : ?override:bool -> key -> 'a -> 'a t -> 'a t (** [find k t] returns the element associated with the key [k] in - [t]. Raises {!Table.TABLE.Not_found} if no such element exists - *) - val find : key -> 'a t -> 'a - - (** [fold f a t] returns [f kn vn (f kn-1 vn-1 (...(f k1 v1 a) - ...))] where the [ki] and [vi] are the associated values in - [t]. The elements are listed in order wrt. to the key *) - val fold : (key -> 'a -> 'b -> 'b) -> 'b -> 'a t -> 'b - end + [t]. Raises {!Table.TABLE.Not_found} if no such element + exists *) + val find : key -> 'a t -> 'a + + (** [fold f a t] returns [f kn vn (f kn-1 vn-1 (...(f k1 v1 a) + ...))] where the [ki] and [vi] are the associated values in + [t]. The elements are listed in order wrt. to the key *) + val fold : (key -> 'a -> 'b -> 'b) -> 'b -> 'a t -> 'b +end (** This modules provides the functor *) module Make_table (Base : BASE) : TABLE with type key=int diff --git a/src/utils/test_sharedForest.ml b/src/utils/test_sharedForest.ml new file mode 100644 index 0000000000000000000000000000000000000000..2c045c6ec5826d34fb33819c813ef2458139ba4c --- /dev/null +++ b/src/utils/test_sharedForest.ml @@ -0,0 +1,170 @@ +open SharedForest.SharedForest + +let init_f_list l = Forest ([],l) + +let tree0= + Node ("tree0.(0,1)", + [ + init_f_list + [ + Node ("tree0.(0,1).(1,1)",[]); + Node ("tree0.(0,1).(1,2)",[]); + Node ("tree0.(0,1).(1,3)",[]); + ]; + init_f_list + [ + Node ("tree0.(0,1).(2,1)",[]); + Node ("tree0.(0,1).(2,2)",[]); + Node ("tree0.(0,1).(2,3)",[]); + ]; + ] + ) + + +let tree = + Node ("(0,1)", + [ + init_f_list + [ + Node ("(0,1).(1,1)",[]); + Node ("(0,1).(1,2)",[]); + Node ("(0,1).(1,3)",[]); + ]; + init_f_list + [ + Node ("(0,1).(2,1)", + [ + init_f_list + [ + Node ("(0,1).(2,1),(1,1)",[]); + Node ("(0,1).(2,1),(1,2)",[]); + ]; + init_f_list + [ + Node ("(0,1).(2,1),(2,1)",[]); + ]; + Link_to (2,[(1,4)]); +(* Link_to (2,[(1,2)]); *) + ]); + Node ("(0,1).(2,2)",[]); + ]; + init_f_list + [ + Node ("(0,1).(3,1)",[]); + Node ("(0,1).(3,2)",[]); + Node ("(0,1).(3,3)",[]); + Node ("(0,1).(3,4)",[]); + ]; + init_f_list + [ + Node ("(0,1).(4,1)",[]); + tree0; + ]; + ] + ) + + +let tree1 = + [ + + Node ("2", + [ + Link_to (1,[]); + ]); + + + Node ("1", + [ + init_f_list + [ + Node ("2.1",[]); + ]; + ]); + + ] + +let rec print_tree prefix buffer tree = + match tree with + | SimpleTree (v,[]) -> + Printf.bprintf buffer "%s -- %s\n" prefix v + | SimpleTree (v,a::children) -> + let () = print_tree (Printf.sprintf "%s -- %s" prefix v) buffer a in + List.iter + (fun child -> print_tree (String.make (4+String.length prefix + String.length v) ' ') buffer child) + children + + +(* +let trees= build_trees [tree0] in +let buff=Buffer.create 80 in +let () = Printf.bprintf buff "Found %d trees:\n" (List.length trees) in +let () = + List.iter + (fun t -> + let () = print_tree "" buff t in + Printf.bprintf buff "\n\n") + trees in +Printf.printf "%s" (Buffer.contents buff) +*) +let output_tree t = + let buff=Buffer.create 80 in + let () = print_tree "" buff t in + let () = Printf.bprintf buff "\n\n" in + Printf.printf "%s" (Buffer.contents buff) + + +type inputs = +| Stop +| Next +| All + +let return_input s = + match String.lowercase (String.trim s) with + | "y" | "yes"-> Some Next + | "n" | "no" -> Some Stop + | "a" | "all" -> Some All + | "" -> Some Next + | _ -> None + + +let interact_aux get_input = + get_input (read_line ()) + + +let rec interact message get_input = + let () = Printf.printf "%s %!" message in + match interact_aux get_input with + | Some v -> v + | None -> interact message get_input + +let rec ask_for_next_parse f param = + let rec all_results l_par = + match f l_par with + | None -> Printf.printf "No other returned value\n" + | Some new_par -> all_results new_par in + let msg = Printf.sprintf "Do you want to look for another solution?\n\ty/yes\n\tn/no\n\ta/all\n(Default: yes):" in + match interact msg return_input with + | Next -> + let () = Printf.printf "Going to get a term\n%!" in + (match f param with + | None -> Printf.printf "No other returned value\n" + | Some new_param -> ask_for_next_parse f new_param) + | All -> all_results param + | Stop -> () + + + + +(*let resume= init [tree;tree0] in*) +(*let resume= init [tree] in*) +let resume= init tree1 in +let () = Printf.printf "**********************************\n%!" in +ask_for_next_parse + (fun (res,i) -> + match resumption res with + | None,_ -> None + | Some t,resume -> + let () = Printf.printf "Got result %i\n%!" i in + let () = output_tree t in + Some (resume,i+1)) + (resume,1) diff --git a/src/utils/utils.ml b/src/utils/utils.ml index b5baa02bfe2581bf7c1166a09634de7bcb767e22..78cfaaed2eec06b1900be7db3b7ec2617e9add21 100644 --- a/src/utils/utils.ml +++ b/src/utils/utils.ml @@ -21,6 +21,9 @@ module StringSet = Set.Make (String) module StringMap = Map.Make (String) +module IntMap = Map.Make (struct type t=int let compare i j = i-j end) +module IntSet = Set.Make (struct type t=int let compare i j = i-j end) + let string_of_list sep to_string = function | [] -> "" @@ -90,3 +93,10 @@ let find_file name dirs = | Sys_error("Is a directory") -> failwith (Printf.sprintf "Failed while trying to trace file '%s'" name ) + +let (>>) f g = fun x -> f (g x) + +let log_iteration log_function s = + List.iter + log_function + (Bolt.Utils.split "\n" s) diff --git a/src/utils/utils.mli b/src/utils/utils.mli index 32b47b4cdce7009a78224c354639ee3e12d03428..d0e93181f280aa19b497ea2257639f9e1e5c7e11 100644 --- a/src/utils/utils.mli +++ b/src/utils/utils.mli @@ -19,11 +19,17 @@ (** This module provides some useful modules or functions *) -(** [StringSet] is a module for set of [strings] *) +(** [StringSet] is a module for sets of [strings] *) module StringSet : Set.S with type elt = String.t -(** [StringMap] is a map from [strings] to type ['a] *) +(** [StringMap] is module for maps from [strings] to type ['a] *) module StringMap : Map.S with type key = String.t + +(** [IntMap] is a module for maps from [int] to type ['a] *) +module IntMap : Map.S with type key = int + +(** [IntSet] is a module for sets of [int] *) +module IntSet : Set.S with type elt = int (** [string_of_list sep to_string [a_1;...;a_n]] returns a string made of the strings [to_string a_1] ... [to_string a_n] concatenated with @@ -52,3 +58,7 @@ exception No_file of (string * string) where [msg] contains a string describing where the file [f] was looked for.*) val find_file : string -> string list -> string + +val (>>) : ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c) + +val log_iteration : (string -> unit) -> string -> unit diff --git a/src/utils/version.ml b/src/utils/version.ml index 4dc190209d6cae03196ebfe4ddb2c43f72c61950..d7db6309191b851d822f53f751917ea87fd49a39 100644 --- a/src/utils/version.ml +++ b/src/utils/version.ml @@ -20,4 +20,5 @@ DEFINE VERSION = "20131127" + let version = VERSION