├── .gitignore ├── LICENSE ├── META ├── Makefile ├── OCamlMakefile ├── README.md ├── examples ├── infer.ml ├── intuitive.ml └── while.ml ├── opal.ml ├── opal.mli └── opam /.gitignore: -------------------------------------------------------------------------------- 1 | ._bcdi/ 2 | ._ncdi/ 3 | _build/* 4 | .ocamlinit 5 | *.byte 6 | *.native 7 | setup.log 8 | setup.data 9 | ._d/* 10 | *.a 11 | *.o 12 | *.cma 13 | *.cmi 14 | *.cmx 15 | *.cmxa 16 | *.cmo 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 Linjie Ding 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /META: -------------------------------------------------------------------------------- 1 | version = "0.1.1" 2 | description = "Self-contained monadic parser combinators for OCaml" 3 | archive(byte) = "opal.cma" 4 | archive(native) = "opal.cmxa" 5 | exists_if = "opal.cma" 6 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | SOURCES = opal.mli opal.ml 2 | RESULT = opal 3 | LIBINSTALL_FILES = META opal.cma opal.cmxa opal.cmx opal.cmi opal.a 4 | 5 | all: ncl bcl 6 | 7 | -include OCamlMakefile 8 | -------------------------------------------------------------------------------- /OCamlMakefile: -------------------------------------------------------------------------------- 1 | ########################################################################### 2 | # OCamlMakefile 3 | # Copyright (C) 1999- Markus Mottl 4 | # 5 | # For updates see: 6 | # http://www.ocaml.info/home/ocaml_sources.html 7 | # 8 | ########################################################################### 9 | 10 | # Modified by damien for .glade.ml compilation 11 | 12 | # Set these variables to the names of the sources to be processed and 13 | # the result variable. Order matters during linkage! 14 | 15 | ifndef SOURCES 16 | SOURCES := foo.ml 17 | endif 18 | export SOURCES 19 | 20 | ifndef RES_CLIB_SUF 21 | RES_CLIB_SUF := _stubs 22 | endif 23 | export RES_CLIB_SUF 24 | 25 | ifndef RESULT 26 | RESULT := foo 27 | endif 28 | export RESULT := $(strip $(RESULT)) 29 | 30 | export LIB_PACK_NAME 31 | 32 | ifndef DOC_FILES 33 | DOC_FILES := $(filter %.mli, $(SOURCES)) 34 | endif 35 | export DOC_FILES 36 | FIRST_DOC_FILE := $(firstword $(DOC_FILES)) 37 | 38 | export BCSUFFIX 39 | export NCSUFFIX 40 | 41 | ifndef TOPSUFFIX 42 | TOPSUFFIX := .top 43 | endif 44 | export TOPSUFFIX 45 | 46 | # Eventually set include- and library-paths, libraries to link, 47 | # additional compilation-, link- and ocamlyacc-flags 48 | # Path- and library information needs not be written with "-I" and such... 49 | # Define THREADS if you need it, otherwise leave it unset (same for 50 | # USE_CAMLP4)! 51 | 52 | export THREADS 53 | export VMTHREADS 54 | export ANNOTATE 55 | export USE_CAMLP4 56 | 57 | export INCDIRS 58 | export LIBDIRS 59 | export EXTLIBDIRS 60 | export RESULTDEPS 61 | export OCAML_DEFAULT_DIRS 62 | 63 | export LIBS 64 | export CLIBS 65 | export CFRAMEWORKS 66 | 67 | export OCAMLFLAGS 68 | export OCAMLNCFLAGS 69 | export OCAMLBCFLAGS 70 | 71 | export OCAMLLDFLAGS 72 | export OCAMLNLDFLAGS 73 | export OCAMLBLDFLAGS 74 | 75 | export OCAMLMKLIB_FLAGS 76 | 77 | ifndef OCAMLCPFLAGS 78 | OCAMLCPFLAGS := a 79 | endif 80 | export OCAMLCPFLAGS 81 | 82 | ifndef DOC_DIR 83 | DOC_DIR := doc 84 | endif 85 | export DOC_DIR 86 | 87 | export PPFLAGS 88 | 89 | export LFLAGS 90 | export YFLAGS 91 | export IDLFLAGS 92 | 93 | export OCAMLDOCFLAGS 94 | 95 | export OCAMLFIND_INSTFLAGS 96 | 97 | export DVIPSFLAGS 98 | 99 | export STATIC 100 | 101 | # Add a list of optional trash files that should be deleted by "make clean" 102 | export TRASH 103 | 104 | ECHO := echo 105 | 106 | ifdef REALLY_QUIET 107 | export REALLY_QUIET 108 | ECHO := true 109 | LFLAGS := $(LFLAGS) -q 110 | YFLAGS := $(YFLAGS) -q 111 | endif 112 | 113 | #################### variables depending on your OCaml-installation 114 | 115 | SYSTEM := $(shell ocamlc -config 2>/dev/null | grep system | sed 's/system: //') 116 | # This may be 117 | # - mingw 118 | # - mingw64 119 | # - win32 120 | # - cygwin 121 | # - some other string means Unix 122 | # - empty means ocamlc does not support -config 123 | 124 | ifeq ($(SYSTEM),$(filter $(SYSTEM),mingw mingw64)) 125 | MINGW=1 126 | endif 127 | ifeq ($(SYSTEM),win32) 128 | MSVC=1 129 | endif 130 | 131 | ifdef MINGW 132 | export MINGW 133 | WIN32 := 1 134 | # The default value 'cc' makes 'ocamlc -cc "cc"' raises the error 'The 135 | # NTVDM CPU has encountered an illegal instruction'. 136 | ifndef CC 137 | MNO_CYGWIN := $(shell gcc -Wextra -v --help 2>/dev/null | grep -q '\-mno-cygwin'; echo $$?) 138 | CC := gcc 139 | else 140 | MNO_CYGWIN := $(shell $$CC -Wextra -v --help 2>/dev/null | grep -q '\-mno-cygwin'; echo $$?) 141 | endif 142 | # We are compiling with cygwin tools: 143 | ifeq ($(MNO_CYGWIN),0) 144 | CFLAGS_WIN32 := -mno-cygwin 145 | endif 146 | # The OCaml C header files use this flag: 147 | CFLAGS += -D__MINGW32__ 148 | endif 149 | ifdef MSVC 150 | export MSVC 151 | WIN32 := 1 152 | ifndef STATIC 153 | CPPFLAGS_WIN32 := -DCAML_DLL 154 | endif 155 | CFLAGS_WIN32 += -nologo 156 | EXT_OBJ := obj 157 | EXT_LIB := lib 158 | ifeq ($(CC),gcc) 159 | # work around GNU Make default value 160 | ifdef THREADS 161 | CC := cl -MT 162 | else 163 | CC := cl 164 | endif 165 | endif 166 | ifeq ($(CXX),g++) 167 | # work around GNU Make default value 168 | CXX := $(CC) 169 | endif 170 | CFLAG_O := -Fo 171 | endif 172 | ifdef WIN32 173 | EXT_CXX := cpp 174 | EXE := .exe 175 | endif 176 | 177 | ifndef EXT_OBJ 178 | EXT_OBJ := o 179 | endif 180 | ifndef EXT_LIB 181 | EXT_LIB := a 182 | endif 183 | ifndef EXT_CXX 184 | EXT_CXX := cc 185 | endif 186 | ifndef EXE 187 | EXE := # empty 188 | endif 189 | ifndef CFLAG_O 190 | CFLAG_O := -o # do not delete this comment (preserves trailing whitespace)! 191 | endif 192 | 193 | export CC 194 | export CXX 195 | export CFLAGS 196 | export CXXFLAGS 197 | export LDFLAGS 198 | export CPPFLAGS 199 | 200 | ifndef RPATH_FLAG 201 | ifdef ELF_RPATH_FLAG 202 | RPATH_FLAG := $(ELF_RPATH_FLAG) 203 | else 204 | RPATH_FLAG := -R 205 | endif 206 | endif 207 | export RPATH_FLAG 208 | 209 | ifndef MSVC 210 | ifndef PIC_CFLAGS 211 | PIC_CFLAGS := -fPIC 212 | endif 213 | ifndef PIC_CPPFLAGS 214 | PIC_CPPFLAGS := -DPIC 215 | endif 216 | endif 217 | 218 | export PIC_CFLAGS 219 | export PIC_CPPFLAGS 220 | 221 | BCRESULT := $(addsuffix $(BCSUFFIX), $(RESULT)) 222 | NCRESULT := $(addsuffix $(NCSUFFIX), $(RESULT)) 223 | TOPRESULT := $(addsuffix $(TOPSUFFIX), $(RESULT)) 224 | 225 | ifndef OCAMLFIND 226 | OCAMLFIND := ocamlfind 227 | endif 228 | export OCAMLFIND 229 | 230 | ifndef OCAML 231 | OCAML := ocaml 232 | endif 233 | export OCAML 234 | 235 | ifndef OCAMLC 236 | OCAMLC := ocamlc 237 | endif 238 | export OCAMLC 239 | 240 | ifndef OCAMLOPT 241 | OCAMLOPT := ocamlopt 242 | endif 243 | export OCAMLOPT 244 | 245 | ifndef OCAMLMKTOP 246 | OCAMLMKTOP := ocamlmktop 247 | endif 248 | export OCAMLMKTOP 249 | 250 | ifndef OCAMLCP 251 | OCAMLCP := ocamlcp 252 | endif 253 | export OCAMLCP 254 | 255 | ifndef OCAMLDEP 256 | OCAMLDEP := ocamldep 257 | endif 258 | export OCAMLDEP 259 | 260 | ifndef OCAMLLEX 261 | OCAMLLEX := ocamllex 262 | endif 263 | export OCAMLLEX 264 | 265 | ifndef OCAMLYACC 266 | OCAMLYACC := ocamlyacc 267 | endif 268 | export OCAMLYACC 269 | 270 | ifndef OCAMLMKLIB 271 | OCAMLMKLIB := ocamlmklib 272 | endif 273 | export OCAMLMKLIB 274 | 275 | ifndef OCAML_GLADECC 276 | OCAML_GLADECC := lablgladecc2 277 | endif 278 | export OCAML_GLADECC 279 | 280 | ifndef OCAML_GLADECC_FLAGS 281 | OCAML_GLADECC_FLAGS := 282 | endif 283 | export OCAML_GLADECC_FLAGS 284 | 285 | ifndef CAMELEON_REPORT 286 | CAMELEON_REPORT := report 287 | endif 288 | export CAMELEON_REPORT 289 | 290 | ifndef CAMELEON_REPORT_FLAGS 291 | CAMELEON_REPORT_FLAGS := 292 | endif 293 | export CAMELEON_REPORT_FLAGS 294 | 295 | ifndef CAMELEON_ZOGGY 296 | CAMELEON_ZOGGY := camlp4o pa_zog.cma pr_o.cmo 297 | endif 298 | export CAMELEON_ZOGGY 299 | 300 | ifndef CAMELEON_ZOGGY_FLAGS 301 | CAMELEON_ZOGGY_FLAGS := 302 | endif 303 | export CAMELEON_ZOGGY_FLAGS 304 | 305 | ifndef OXRIDL 306 | OXRIDL := oxridl 307 | endif 308 | export OXRIDL 309 | 310 | ifndef CAMLIDL 311 | CAMLIDL := camlidl 312 | endif 313 | export CAMLIDL 314 | 315 | ifndef CAMLIDLDLL 316 | CAMLIDLDLL := camlidldll 317 | endif 318 | export CAMLIDLDLL 319 | 320 | ifndef NOIDLHEADER 321 | MAYBE_IDL_HEADER := -header 322 | endif 323 | export NOIDLHEADER 324 | 325 | export NO_CUSTOM 326 | 327 | ifndef CAMLP4 328 | CAMLP4 := camlp4 329 | endif 330 | export CAMLP4 331 | 332 | ifndef REAL_OCAMLFIND 333 | ifdef PACKS 334 | ifndef CREATE_LIB 335 | ifdef THREADS 336 | PACKS += threads 337 | endif 338 | endif 339 | empty := 340 | space := $(empty) $(empty) 341 | comma := , 342 | ifdef PREDS 343 | PRE_OCAML_FIND_PREDICATES := $(subst $(space),$(comma),$(PREDS)) 344 | PRE_OCAML_FIND_PACKAGES := $(subst $(space),$(comma),$(PACKS)) 345 | OCAML_FIND_PREDICATES := -predicates $(PRE_OCAML_FIND_PREDICATES) 346 | # OCAML_DEP_PREDICATES := -syntax $(PRE_OCAML_FIND_PREDICATES) 347 | OCAML_FIND_PACKAGES := $(OCAML_FIND_PREDICATES) -package $(PRE_OCAML_FIND_PACKAGES) 348 | OCAML_DEP_PACKAGES := $(OCAML_DEP_PREDICATES) -package $(PRE_OCAML_FIND_PACKAGES) 349 | else 350 | OCAML_FIND_PACKAGES := -package $(subst $(space),$(comma),$(PACKS)) 351 | OCAML_DEP_PACKAGES := 352 | endif 353 | OCAML_FIND_LINKPKG := -linkpkg 354 | REAL_OCAMLFIND := $(OCAMLFIND) 355 | endif 356 | endif 357 | 358 | export OCAML_FIND_PACKAGES 359 | export OCAML_DEP_PACKAGES 360 | export OCAML_FIND_LINKPKG 361 | export REAL_OCAMLFIND 362 | 363 | ifndef OCAMLDOC 364 | OCAMLDOC := ocamldoc 365 | endif 366 | export OCAMLDOC 367 | 368 | ifndef LATEX 369 | LATEX := latex 370 | endif 371 | export LATEX 372 | 373 | ifndef DVIPS 374 | DVIPS := dvips 375 | endif 376 | export DVIPS 377 | 378 | ifndef PS2PDF 379 | PS2PDF := ps2pdf 380 | endif 381 | export PS2PDF 382 | 383 | ifndef OCAMLMAKEFILE 384 | OCAMLMAKEFILE := OCamlMakefile 385 | endif 386 | export OCAMLMAKEFILE 387 | 388 | ifndef OCAMLLIBPATH 389 | OCAMLLIBPATH := \ 390 | $(shell $(OCAMLC) 2>/dev/null -where || echo /usr/local/lib/ocaml) 391 | endif 392 | export OCAMLLIBPATH 393 | 394 | ifndef OCAML_LIB_INSTALL 395 | OCAML_LIB_INSTALL := $(OCAMLLIBPATH)/contrib 396 | endif 397 | export OCAML_LIB_INSTALL 398 | 399 | ########################################################################### 400 | 401 | #################### change following sections only if 402 | #################### you know what you are doing! 403 | 404 | # delete target files when a build command fails 405 | .PHONY: .DELETE_ON_ERROR 406 | .DELETE_ON_ERROR: 407 | 408 | # for pedants using "--warn-undefined-variables" 409 | export MAYBE_IDL 410 | export REAL_RESULT 411 | export CAMLIDLFLAGS 412 | export THREAD_FLAG 413 | export RES_CLIB 414 | export MAKEDLL 415 | export ANNOT_FLAG 416 | export C_OXRIDL 417 | export SUBPROJS 418 | export CFLAGS_WIN32 419 | export CPPFLAGS_WIN32 420 | 421 | INCFLAGS := 422 | 423 | SHELL := /bin/sh 424 | 425 | MLDEPDIR := ._d 426 | BCDIDIR := ._bcdi 427 | NCDIDIR := ._ncdi 428 | 429 | FILTER_EXTNS := %.mli %.ml %.mll %.mly %.idl %.oxridl %.c %.m %.$(EXT_CXX) %.rep %.zog %.glade 430 | 431 | FILTERED := $(filter $(FILTER_EXTNS), $(SOURCES)) 432 | SOURCE_DIRS := $(filter-out ./, $(sort $(dir $(FILTERED)))) 433 | 434 | FILTERED_REP := $(filter %.rep, $(FILTERED)) 435 | DEP_REP := $(FILTERED_REP:%.rep=$(MLDEPDIR)/%.d) 436 | AUTO_REP := $(FILTERED_REP:.rep=.ml) 437 | 438 | FILTERED_ZOG := $(filter %.zog, $(FILTERED)) 439 | DEP_ZOG := $(FILTERED_ZOG:%.zog=$(MLDEPDIR)/%.d) 440 | AUTO_ZOG := $(FILTERED_ZOG:.zog=.ml) 441 | 442 | FILTERED_GLADE := $(filter %.glade, $(FILTERED)) 443 | DEP_GLADE := $(FILTERED_GLADE:%.glade=$(MLDEPDIR)/%.d) 444 | AUTO_GLADE := $(FILTERED_GLADE:.glade=.ml) 445 | 446 | FILTERED_ML := $(filter %.ml, $(FILTERED)) 447 | DEP_ML := $(FILTERED_ML:%.ml=$(MLDEPDIR)/%.d) 448 | 449 | FILTERED_MLI := $(filter %.mli, $(FILTERED)) 450 | DEP_MLI := $(FILTERED_MLI:.mli=.di) 451 | 452 | FILTERED_MLL := $(filter %.mll, $(FILTERED)) 453 | DEP_MLL := $(FILTERED_MLL:%.mll=$(MLDEPDIR)/%.d) 454 | AUTO_MLL := $(FILTERED_MLL:.mll=.ml) 455 | 456 | FILTERED_MLY := $(filter %.mly, $(FILTERED)) 457 | DEP_MLY := $(FILTERED_MLY:%.mly=$(MLDEPDIR)/%.d) $(FILTERED_MLY:.mly=.di) 458 | AUTO_MLY := $(FILTERED_MLY:.mly=.mli) $(FILTERED_MLY:.mly=.ml) 459 | 460 | FILTERED_IDL := $(filter %.idl, $(FILTERED)) 461 | DEP_IDL := $(FILTERED_IDL:%.idl=$(MLDEPDIR)/%.d) $(FILTERED_IDL:.idl=.di) 462 | C_IDL := $(FILTERED_IDL:%.idl=%_stubs.c) 463 | ifndef NOIDLHEADER 464 | C_IDL += $(FILTERED_IDL:.idl=.h) 465 | endif 466 | OBJ_C_IDL := $(FILTERED_IDL:%.idl=%_stubs.$(EXT_OBJ)) 467 | AUTO_IDL := $(FILTERED_IDL:.idl=.mli) $(FILTERED_IDL:.idl=.ml) $(C_IDL) 468 | 469 | FILTERED_OXRIDL := $(filter %.oxridl, $(FILTERED)) 470 | DEP_OXRIDL := $(FILTERED_OXRIDL:%.oxridl=$(MLDEPDIR)/%.d) $(FILTERED_OXRIDL:.oxridl=.di) 471 | AUTO_OXRIDL := $(FILTERED_OXRIDL:.oxridl=.mli) $(FILTERED_OXRIDL:.oxridl=.ml) $(C_OXRIDL) 472 | 473 | FILTERED_C_CXX := $(filter %.c %.m %.$(EXT_CXX), $(FILTERED)) 474 | OBJ_C_CXX := $(FILTERED_C_CXX:.c=.$(EXT_OBJ)) 475 | OBJ_C_CXX := $(OBJ_C_CXX:.m=.$(EXT_OBJ)) 476 | OBJ_C_CXX := $(OBJ_C_CXX:.$(EXT_CXX)=.$(EXT_OBJ)) 477 | 478 | PRE_TARGETS += $(AUTO_MLL) $(AUTO_MLY) $(AUTO_IDL) $(AUTO_OXRIDL) $(AUTO_ZOG) $(AUTO_REP) $(AUTO_GLADE) 479 | 480 | ALL_DEPS := $(DEP_ML) $(DEP_MLI) $(DEP_MLL) $(DEP_MLY) $(DEP_IDL) $(DEP_OXRIDL) $(DEP_ZOG) $(DEP_REP) $(DEP_GLADE) 481 | 482 | MLDEPS := $(filter %.d, $(ALL_DEPS)) 483 | MLIDEPS := $(filter %.di, $(ALL_DEPS)) 484 | BCDEPIS := $(MLIDEPS:%.di=$(BCDIDIR)/%.di) 485 | NCDEPIS := $(MLIDEPS:%.di=$(NCDIDIR)/%.di) 486 | 487 | ALLML := $(filter %.mli %.ml %.mll %.mly %.idl %.oxridl %.rep %.zog %.glade, $(FILTERED)) 488 | 489 | IMPLO_INTF := $(ALLML:%.mli=%.mli.__) 490 | IMPLO_INTF := $(foreach file, $(IMPLO_INTF), \ 491 | $(basename $(file)).cmi $(basename $(file)).cmo) 492 | IMPLO_INTF := $(filter-out %.mli.cmo, $(IMPLO_INTF)) 493 | IMPLO_INTF := $(IMPLO_INTF:%.mli.cmi=%.cmi) 494 | 495 | IMPLX_INTF := $(IMPLO_INTF:.cmo=.cmx) 496 | 497 | INTF := $(filter %.cmi, $(IMPLO_INTF)) 498 | IMPL_CMO := $(filter %.cmo, $(IMPLO_INTF)) 499 | IMPL_CMX := $(IMPL_CMO:.cmo=.cmx) 500 | IMPL_ASM := $(IMPL_CMO:.cmo=.asm) 501 | IMPL_S := $(IMPL_CMO:.cmo=.s) 502 | 503 | OBJ_LINK := $(OBJ_C_IDL) $(OBJ_C_CXX) 504 | OBJ_FILES := $(IMPL_CMO:.cmo=.$(EXT_OBJ)) $(OBJ_LINK) 505 | 506 | EXECS := $(addsuffix $(EXE), \ 507 | $(sort $(TOPRESULT) $(BCRESULT) $(NCRESULT))) 508 | ifdef WIN32 509 | EXECS += $(BCRESULT).dll $(NCRESULT).dll 510 | endif 511 | 512 | CLIB_BASE := $(RESULT)$(RES_CLIB_SUF) 513 | ifneq ($(strip $(OBJ_LINK)),) 514 | RES_CLIB := lib$(CLIB_BASE).$(EXT_LIB) 515 | endif 516 | 517 | ifdef WIN32 518 | DLLSONAME := dll$(CLIB_BASE).dll 519 | else 520 | DLLSONAME := dll$(CLIB_BASE).so 521 | endif 522 | 523 | NONEXECS := $(INTF) $(IMPL_CMO) $(IMPL_CMX) $(IMPL_ASM) $(IMPL_S) \ 524 | $(OBJ_FILES) $(PRE_TARGETS) $(BCRESULT).cma $(NCRESULT).cmxa \ 525 | $(NCRESULT).$(EXT_LIB) $(BCRESULT).cmi $(BCRESULT).cmo \ 526 | $(NCRESULT).cmi $(NCRESULT).cmx $(NCRESULT).$(EXT_OBJ) \ 527 | $(RES_CLIB) $(IMPL_CMO:.cmo=.annot) \ 528 | $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmo $(LIB_PACK_NAME).cmx \ 529 | $(LIB_PACK_NAME).$(EXT_OBJ) 530 | 531 | ifndef STATIC 532 | NONEXECS += $(DLLSONAME) 533 | endif 534 | 535 | ifndef LIBINSTALL_FILES 536 | LIBINSTALL_FILES := $(RESULT).mli $(RESULT).cmi $(RESULT).cma \ 537 | $(RESULT).cmxa $(RESULT).$(EXT_LIB) $(RES_CLIB) 538 | ifndef STATIC 539 | ifneq ($(strip $(OBJ_LINK)),) 540 | LIBINSTALL_FILES += $(DLLSONAME) 541 | endif 542 | endif 543 | endif 544 | 545 | export LIBINSTALL_FILES 546 | 547 | ifdef WIN32 548 | # some extra stuff is created while linking DLLs 549 | NONEXECS += $(BCRESULT).$(EXT_LIB) $(BCRESULT).exp $(NCRESULT).exp $(CLIB_BASE).exp $(CLIB_BASE).lib 550 | endif 551 | 552 | TARGETS := $(EXECS) $(NONEXECS) 553 | 554 | # If there are IDL-files 555 | ifneq ($(strip $(FILTERED_IDL)),) 556 | MAYBE_IDL := -cclib -lcamlidl 557 | endif 558 | 559 | ifdef USE_CAMLP4 560 | CAMLP4PATH := \ 561 | $(shell $(CAMLP4) -where 2>/dev/null || echo /usr/local/lib/camlp4) 562 | INCFLAGS := -I $(CAMLP4PATH) 563 | CINCFLAGS := -I$(CAMLP4PATH) 564 | endif 565 | 566 | INCFLAGS := $(INCFLAGS) $(INCDIRS:%=-I %) $(SOURCE_DIRS:%=-I %) $(OCAML_DEFAULT_DIRS:%=-I %) 567 | CINCFLAGS += $(SOURCE_DIRS:%=-I%) $(INCDIRS:%=-I%) $(OCAML_DEFAULT_DIRS:%=-I%) 568 | 569 | ifndef MSVC 570 | CLIBFLAGS += $(SOURCE_DIRS:%=-L%) $(LIBDIRS:%=-L%) \ 571 | $(EXTLIBDIRS:%=-L%) $(OCAML_DEFAULT_DIRS:%=-L%) 572 | 573 | ifeq ($(ELF_RPATH), yes) 574 | CLIBFLAGS += $(EXTLIBDIRS:%=-Wl,$(RPATH_FLAG)%) 575 | endif 576 | endif 577 | 578 | ifndef PROFILING 579 | INTF_OCAMLC := $(OCAMLC) 580 | else 581 | ifndef THREADS 582 | INTF_OCAMLC := $(OCAMLCP) -p $(OCAMLCPFLAGS) 583 | else 584 | # OCaml does not support profiling byte code 585 | # with threads (yet), therefore we force an error. 586 | ifndef REAL_OCAMLC 587 | $(error Profiling of multithreaded byte code not yet supported by OCaml) 588 | endif 589 | INTF_OCAMLC := $(OCAMLC) 590 | endif 591 | endif 592 | 593 | ifndef MSVC 594 | COMMON_LDFLAGS := $(LDFLAGS:%=-ccopt %) $(SOURCE_DIRS:%=-ccopt -L%) \ 595 | $(LIBDIRS:%=-ccopt -L%) $(EXTLIBDIRS:%=-ccopt -L%) \ 596 | $(EXTLIBDIRS:%=-ccopt -Wl $(OCAML_DEFAULT_DIRS:%=-ccopt -L%)) 597 | 598 | ifeq ($(ELF_RPATH),yes) 599 | COMMON_LDFLAGS += $(EXTLIBDIRS:%=-ccopt -Wl,$(RPATH_FLAG)%) 600 | endif 601 | else 602 | COMMON_LDFLAGS := -ccopt "/link -NODEFAULTLIB:LIBC $(LDFLAGS:%=%) $(SOURCE_DIRS:%=-LIBPATH:%) \ 603 | $(LIBDIRS:%=-LIBPATH:%) $(EXTLIBDIRS:%=-LIBPATH:%) \ 604 | $(OCAML_DEFAULT_DIRS:%=-LIBPATH:%) " 605 | endif 606 | 607 | CLIBS_OPTS := $(CLIBS:%=-cclib -l%) $(CFRAMEWORKS:%=-cclib '-framework %') 608 | ifdef MSVC 609 | ifndef STATIC 610 | # MSVC libraries do not have 'lib' prefix 611 | CLIBS_OPTS := $(CLIBS:%=-cclib %.lib) 612 | endif 613 | endif 614 | 615 | ifneq ($(strip $(OBJ_LINK)),) 616 | ifdef CREATE_LIB 617 | OBJS_LIBS := -cclib -l$(CLIB_BASE) $(CLIBS_OPTS) $(MAYBE_IDL) 618 | else 619 | OBJS_LIBS := $(OBJ_LINK) $(CLIBS_OPTS) $(MAYBE_IDL) 620 | endif 621 | else 622 | OBJS_LIBS := $(CLIBS_OPTS) $(MAYBE_IDL) 623 | endif 624 | 625 | ifdef LIB_PACK_NAME 626 | FOR_PACK_NAME := $(shell echo $(LIB_PACK_NAME) | awk '{print toupper(substr($$0,1,1))substr($$0,2)}') 627 | endif 628 | 629 | # If we have to make byte-code 630 | ifndef REAL_OCAMLC 631 | BYTE_OCAML := y 632 | 633 | # EXTRADEPS is added dependencies we have to insert for all 634 | # executable files we generate. Ideally it should be all of the 635 | # libraries we use, but it's hard to find the ones that get searched on 636 | # the path since I don't know the paths built into the compiler, so 637 | # just include the ones with slashes in their names. 638 | EXTRADEPS := $(addsuffix .cma,$(foreach i,$(LIBS),$(if $(findstring /,$(i)),$(i)))) 639 | 640 | 641 | ifndef LIB_PACK_NAME 642 | SPECIAL_OCAMLFLAGS := $(OCAMLBCFLAGS) 643 | else 644 | SPECIAL_OCAMLFLAGS := -for-pack $(FOR_PACK_NAME) $(OCAMLBCFLAGS) 645 | endif 646 | 647 | REAL_OCAMLC := $(INTF_OCAMLC) 648 | 649 | REAL_IMPL := $(IMPL_CMO) 650 | REAL_IMPL_INTF := $(IMPLO_INTF) 651 | IMPL_SUF := .cmo 652 | 653 | DEPFLAGS := 654 | MAKE_DEPS := $(MLDEPS) $(BCDEPIS) 655 | 656 | ifdef CREATE_LIB 657 | override CFLAGS := $(PIC_CFLAGS) $(CFLAGS) 658 | override CPPFLAGS := $(PIC_CPPFLAGS) $(CPPFLAGS) 659 | ifndef STATIC 660 | ifneq ($(strip $(OBJ_LINK)),) 661 | MAKEDLL := $(DLLSONAME) 662 | ALL_LDFLAGS := -dllib $(DLLSONAME) 663 | endif 664 | endif 665 | endif 666 | 667 | ifndef NO_CUSTOM 668 | ifneq "$(strip $(OBJ_LINK) $(THREADS) $(MAYBE_IDL) $(CLIBS) $(CFRAMEWORKS))" "" 669 | ALL_LDFLAGS += -custom 670 | endif 671 | endif 672 | 673 | ALL_LDFLAGS += $(INCFLAGS) $(OCAMLLDFLAGS) $(OCAMLBLDFLAGS) \ 674 | $(COMMON_LDFLAGS) $(LIBS:%=%.cma) 675 | CAMLIDLDLLFLAGS := 676 | 677 | ifdef THREADS 678 | ifdef VMTHREADS 679 | THREAD_FLAG := -vmthread 680 | else 681 | THREAD_FLAG := -thread 682 | endif 683 | ALL_LDFLAGS := $(THREAD_FLAG) $(ALL_LDFLAGS) 684 | ifndef CREATE_LIB 685 | ifndef REAL_OCAMLFIND 686 | ALL_LDFLAGS := unix.cma threads.cma $(ALL_LDFLAGS) 687 | endif 688 | endif 689 | endif 690 | 691 | # we have to make native-code 692 | else 693 | EXTRADEPS := $(addsuffix .cmxa,$(foreach i,$(LIBS),$(if $(findstring /,$(i)),$(i)))) 694 | ifndef PROFILING 695 | SPECIAL_OCAMLFLAGS := $(OCAMLNCFLAGS) 696 | PLDFLAGS := 697 | else 698 | SPECIAL_OCAMLFLAGS := -p $(OCAMLNCFLAGS) 699 | PLDFLAGS := -p 700 | endif 701 | 702 | ifndef LIB_PACK_NAME 703 | SPECIAL_OCAMLFLAGS := $(OCAMLNCFLAGS) 704 | else 705 | SPECIAL_OCAMLFLAGS := -for-pack $(FOR_PACK_NAME) $(OCAMLNCFLAGS) 706 | endif 707 | REAL_IMPL := $(IMPL_CMX) 708 | REAL_IMPL_INTF := $(IMPLX_INTF) 709 | IMPL_SUF := .cmx 710 | 711 | override CPPFLAGS := -DNATIVE_CODE $(CPPFLAGS) 712 | 713 | DEPFLAGS := -native 714 | MAKE_DEPS := $(MLDEPS) $(NCDEPIS) 715 | 716 | ALL_LDFLAGS := $(PLDFLAGS) $(INCFLAGS) $(OCAMLLDFLAGS) \ 717 | $(OCAMLNLDFLAGS) $(COMMON_LDFLAGS) 718 | CAMLIDLDLLFLAGS := -opt 719 | 720 | ifndef CREATE_LIB 721 | ALL_LDFLAGS += $(LIBS:%=%.cmxa) 722 | else 723 | override CFLAGS := $(PIC_CFLAGS) $(CFLAGS) 724 | override CPPFLAGS := $(PIC_CPPFLAGS) $(CPPFLAGS) 725 | endif 726 | 727 | ifdef THREADS 728 | THREAD_FLAG := -thread 729 | ALL_LDFLAGS := $(THREAD_FLAG) $(ALL_LDFLAGS) 730 | ifndef CREATE_LIB 731 | ifndef REAL_OCAMLFIND 732 | ALL_LDFLAGS := unix.cmxa threads.cmxa $(ALL_LDFLAGS) 733 | endif 734 | endif 735 | endif 736 | endif 737 | 738 | export MAKE_DEPS 739 | 740 | ifdef ANNOTATE 741 | ANNOT_FLAG := -annot 742 | else 743 | endif 744 | 745 | ALL_OCAMLCFLAGS := $(THREAD_FLAG) $(ANNOT_FLAG) $(OCAMLFLAGS) \ 746 | $(INCFLAGS) $(SPECIAL_OCAMLFLAGS) 747 | 748 | ifdef make_deps 749 | -include $(MAKE_DEPS) 750 | PRE_TARGETS := 751 | endif 752 | 753 | ########################################################################### 754 | # USER RULES 755 | 756 | # Call "OCamlMakefile QUIET=" to get rid of all of the @'s. 757 | QUIET=@ 758 | 759 | # generates byte-code (default) 760 | byte-code: $(PRE_TARGETS) 761 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ 762 | REAL_RESULT="$(BCRESULT)" make_deps=yes 763 | bc: byte-code 764 | 765 | byte-code-nolink: $(PRE_TARGETS) 766 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ 767 | REAL_RESULT="$(BCRESULT)" make_deps=yes 768 | bcnl: byte-code-nolink 769 | 770 | top: $(PRE_TARGETS) 771 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(TOPRESULT) \ 772 | REAL_RESULT="$(BCRESULT)" make_deps=yes 773 | 774 | # generates native-code 775 | 776 | native-code: $(PRE_TARGETS) 777 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(NCRESULT) \ 778 | REAL_RESULT="$(NCRESULT)" \ 779 | REAL_OCAMLC="$(OCAMLOPT)" \ 780 | make_deps=yes 781 | nc: native-code 782 | 783 | native-code-nolink: $(PRE_TARGETS) 784 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ 785 | REAL_RESULT="$(NCRESULT)" \ 786 | REAL_OCAMLC="$(OCAMLOPT)" \ 787 | make_deps=yes 788 | ncnl: native-code-nolink 789 | 790 | # generates byte-code libraries 791 | byte-code-library: $(PRE_TARGETS) 792 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 793 | $(RES_CLIB) $(BCRESULT).cma \ 794 | REAL_RESULT="$(BCRESULT)" \ 795 | CREATE_LIB=yes \ 796 | make_deps=yes 797 | bcl: byte-code-library 798 | 799 | # generates native-code libraries 800 | native-code-library: $(PRE_TARGETS) 801 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 802 | $(RES_CLIB) $(NCRESULT).cmxa \ 803 | REAL_RESULT="$(NCRESULT)" \ 804 | REAL_OCAMLC="$(OCAMLOPT)" \ 805 | CREATE_LIB=yes \ 806 | make_deps=yes 807 | ncl: native-code-library 808 | 809 | ifdef WIN32 810 | # generates byte-code dll 811 | byte-code-dll: $(PRE_TARGETS) 812 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 813 | $(RES_CLIB) $(BCRESULT).dll \ 814 | REAL_RESULT="$(BCRESULT)" \ 815 | make_deps=yes 816 | bcd: byte-code-dll 817 | 818 | # generates native-code dll 819 | native-code-dll: $(PRE_TARGETS) 820 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 821 | $(RES_CLIB) $(NCRESULT).dll \ 822 | REAL_RESULT="$(NCRESULT)" \ 823 | REAL_OCAMLC="$(OCAMLOPT)" \ 824 | make_deps=yes 825 | ncd: native-code-dll 826 | endif 827 | 828 | # generates byte-code with debugging information 829 | debug-code: $(PRE_TARGETS) 830 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ 831 | REAL_RESULT="$(BCRESULT)" make_deps=yes \ 832 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 833 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 834 | dc: debug-code 835 | 836 | debug-code-nolink: $(PRE_TARGETS) 837 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ 838 | REAL_RESULT="$(BCRESULT)" make_deps=yes \ 839 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 840 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 841 | dcnl: debug-code-nolink 842 | 843 | # generates byte-code with debugging information (native code) 844 | debug-native-code: $(PRE_TARGETS) 845 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(NCRESULT) \ 846 | REAL_RESULT="$(NCRESULT)" make_deps=yes \ 847 | REAL_OCAMLC="$(OCAMLOPT)" \ 848 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 849 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 850 | dnc: debug-native-code 851 | 852 | debug-native-code-nolink: $(PRE_TARGETS) 853 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ 854 | REAL_RESULT="$(NCRESULT)" make_deps=yes \ 855 | REAL_OCAMLC="$(OCAMLOPT)" \ 856 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 857 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 858 | dncnl: debug-native-code-nolink 859 | 860 | # generates byte-code libraries with debugging information 861 | debug-code-library: $(PRE_TARGETS) 862 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 863 | $(RES_CLIB) $(BCRESULT).cma \ 864 | REAL_RESULT="$(BCRESULT)" make_deps=yes \ 865 | CREATE_LIB=yes \ 866 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 867 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 868 | dcl: debug-code-library 869 | 870 | # generates byte-code libraries with debugging information (native code) 871 | debug-native-code-library: $(PRE_TARGETS) 872 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 873 | $(RES_CLIB) $(NCRESULT).cmxa \ 874 | REAL_RESULT="$(NCRESULT)" make_deps=yes \ 875 | REAL_OCAMLC="$(OCAMLOPT)" \ 876 | CREATE_LIB=yes \ 877 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 878 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 879 | dncl: debug-native-code-library 880 | 881 | # generates byte-code for profiling 882 | profiling-byte-code: $(PRE_TARGETS) 883 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ 884 | REAL_RESULT="$(BCRESULT)" PROFILING="y" \ 885 | make_deps=yes 886 | pbc: profiling-byte-code 887 | 888 | # generates native-code 889 | 890 | profiling-native-code: $(PRE_TARGETS) 891 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(NCRESULT) \ 892 | REAL_RESULT="$(NCRESULT)" \ 893 | REAL_OCAMLC="$(OCAMLOPT)" \ 894 | PROFILING="y" \ 895 | make_deps=yes 896 | pnc: profiling-native-code 897 | 898 | # generates byte-code libraries 899 | profiling-byte-code-library: $(PRE_TARGETS) 900 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 901 | $(RES_CLIB) $(BCRESULT).cma \ 902 | REAL_RESULT="$(BCRESULT)" PROFILING="y" \ 903 | CREATE_LIB=yes \ 904 | make_deps=yes 905 | pbcl: profiling-byte-code-library 906 | 907 | # generates native-code libraries 908 | profiling-native-code-library: $(PRE_TARGETS) 909 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 910 | $(RES_CLIB) $(NCRESULT).cmxa \ 911 | REAL_RESULT="$(NCRESULT)" PROFILING="y" \ 912 | REAL_OCAMLC="$(OCAMLOPT)" \ 913 | CREATE_LIB=yes \ 914 | make_deps=yes 915 | pncl: profiling-native-code-library 916 | 917 | # packs byte-code objects 918 | pack-byte-code: $(PRE_TARGETS) 919 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT).cmo \ 920 | REAL_RESULT="$(BCRESULT)" \ 921 | PACK_LIB=yes make_deps=yes 922 | pabc: pack-byte-code 923 | 924 | # packs native-code objects 925 | pack-native-code: $(PRE_TARGETS) 926 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 927 | $(NCRESULT).cmx $(NCRESULT).$(EXT_OBJ) \ 928 | REAL_RESULT="$(NCRESULT)" \ 929 | REAL_OCAMLC="$(OCAMLOPT)" \ 930 | PACK_LIB=yes make_deps=yes 931 | panc: pack-native-code 932 | 933 | # generates HTML-documentation 934 | htdoc: $(DOC_DIR)/$(RESULT)/html/index.html 935 | 936 | # generates Latex-documentation 937 | ladoc: $(DOC_DIR)/$(RESULT)/latex/doc.tex 938 | 939 | # generates PostScript-documentation 940 | psdoc: $(DOC_DIR)/$(RESULT)/latex/doc.ps 941 | 942 | # generates PDF-documentation 943 | pdfdoc: $(DOC_DIR)/$(RESULT)/latex/doc.pdf 944 | 945 | # generates all supported forms of documentation 946 | doc: htdoc ladoc psdoc pdfdoc 947 | 948 | ########################################################################### 949 | # LOW LEVEL RULES 950 | 951 | $(REAL_RESULT): $(REAL_IMPL_INTF) $(OBJ_LINK) $(EXTRADEPS) $(RESULTDEPS) 952 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) \ 953 | $(OCAML_FIND_PACKAGES) $(OCAML_FIND_LINKPKG) \ 954 | $(OBJS_LIBS) $(ALL_LDFLAGS) -o $@$(EXE) \ 955 | $(REAL_IMPL) 956 | 957 | nolink: $(REAL_IMPL_INTF) $(OBJ_LINK) 958 | 959 | ifdef WIN32 960 | $(REAL_RESULT).dll: $(REAL_IMPL_INTF) $(OBJ_LINK) 961 | $(CAMLIDLDLL) $(CAMLIDLDLLFLAGS) $(OBJ_LINK) $(CLIBS) \ 962 | -o $@ $(REAL_IMPL) 963 | endif 964 | 965 | %$(TOPSUFFIX): $(REAL_IMPL_INTF) $(OBJ_LINK) $(EXTRADEPS) 966 | $(REAL_OCAMLFIND) $(OCAMLMKTOP) \ 967 | $(OCAML_FIND_PACKAGES) $(OCAML_FIND_LINKPKG) \ 968 | $(OBJS_LIBS) $(ALL_LDFLAGS) -o $@$(EXE) \ 969 | $(REAL_IMPL) 970 | 971 | .SUFFIXES: .mli .ml .cmi .cmo .cmx .cma .cmxa .$(EXT_OBJ) \ 972 | .mly .di .d .$(EXT_LIB) .idl %.oxridl .c .m .$(EXT_CXX) .h .so \ 973 | .rep .zog .glade 974 | 975 | ifndef STATIC 976 | ifdef MINGW 977 | # From OCaml 3.11.0, ocamlmklib is available on windows 978 | OCAMLMLIB_EXISTS = $(shell which $(OCAMLMKLIB)) 979 | ifeq ($(strip $(OCAMLMLIB_EXISTS)),) 980 | $(DLLSONAME): $(OBJ_LINK) 981 | $(CC) $(CFLAGS) $(CFLAGS_WIN32) $(OBJ_LINK) -shared -o $@ \ 982 | $(wildcard $(foreach dir,$(LIBDIRS),$(CLIBS:%=$(dir)/lib%.a))) \ 983 | '$(OCAMLLIBPATH)/ocamlrun.a' \ 984 | -Wl,--whole-archive \ 985 | -Wl,--export-all-symbols \ 986 | -Wl,--allow-multiple-definition \ 987 | -Wl,--enable-auto-import 988 | else 989 | $(DLLSONAME): $(OBJ_LINK) 990 | $(OCAMLMKLIB) $(INCFLAGS) $(CLIBFLAGS) \ 991 | -o $(CLIB_BASE) $(OBJ_LINK) $(CLIBS:%=-l%) \ 992 | $(CFRAMEWORKS:%=-framework %) \ 993 | $(OCAMLMKLIB_FLAGS) 994 | endif 995 | else 996 | ifdef MSVC 997 | $(DLLSONAME): $(OBJ_LINK) 998 | link /NOLOGO /DLL /OUT:$@ $(OBJ_LINK) \ 999 | $(wildcard $(foreach dir,$(LIBDIRS),$(CLIBS:%=$(dir)/%.lib))) \ 1000 | '$(OCAMLLIBPATH)/ocamlrun.lib' 1001 | 1002 | else 1003 | $(DLLSONAME): $(OBJ_LINK) 1004 | $(OCAMLMKLIB) $(INCFLAGS) $(CLIBFLAGS) \ 1005 | -o $(CLIB_BASE) $(OBJ_LINK) $(CLIBS:%=-l%) $(CFRAMEWORKS:%=-framework %) \ 1006 | $(OCAMLMKLIB_FLAGS) 1007 | endif 1008 | endif 1009 | endif 1010 | 1011 | ifndef LIB_PACK_NAME 1012 | $(RESULT).cma: $(REAL_IMPL_INTF) $(MAKEDLL) $(EXTRADEPS) $(RESULTDEPS) 1013 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) -a $(OBJS_LIBS) $(ALL_LDFLAGS) -o $@ $(REAL_IMPL) 1014 | 1015 | $(RESULT).cmxa $(RESULT).$(EXT_LIB): $(REAL_IMPL_INTF) $(EXTRADEPS) $(RESULTDEPS) 1016 | $(REAL_OCAMLFIND) $(OCAMLOPT) -a $(OBJS_LIBS) $(ALL_LDFLAGS) -o $@ $(REAL_IMPL) 1017 | else 1018 | # Packing a bytecode library 1019 | LIB_PACK_NAME_MLI = $(wildcard $(LIB_PACK_NAME).mli) 1020 | ifeq ($(LIB_PACK_NAME_MLI),) 1021 | LIB_PACK_NAME_CMI = $(LIB_PACK_NAME).cmi 1022 | else 1023 | # $(LIB_PACK_NAME).mli exists, it likely depends on other compiled interfaces 1024 | LIB_PACK_NAME_CMI = 1025 | $(LIB_PACK_NAME).cmi: $(REAL_IMPL_INTF) 1026 | endif 1027 | ifdef BYTE_OCAML 1028 | $(LIB_PACK_NAME_CMI) $(LIB_PACK_NAME).cmo: $(REAL_IMPL_INTF) 1029 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) -pack -o $(LIB_PACK_NAME).cmo $(OCAMLLDFLAGS) $(REAL_IMPL) 1030 | # Packing into a unit which can be transformed into a library 1031 | # Remember the .ml's must have been compiled with -for-pack $(LIB_PACK_NAME) 1032 | else 1033 | $(LIB_PACK_NAME_CMI) $(LIB_PACK_NAME).cmx: $(REAL_IMPL_INTF) 1034 | $(REAL_OCAMLFIND) $(OCAMLOPT) -pack -o $(LIB_PACK_NAME).cmx $(OCAMLLDFLAGS) $(REAL_IMPL) 1035 | endif 1036 | 1037 | $(RESULT).cma: $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmo $(MAKEDLL) $(EXTRADEPS) $(RESULTDEPS) 1038 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) -a $(OBJS_LIBS) $(ALL_LDFLAGS) -o $@ $(LIB_PACK_NAME).cmo 1039 | 1040 | $(RESULT).cmxa $(RESULT).$(EXT_LIB): $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmx $(EXTRADEPS) $(RESULTDEPS) 1041 | $(REAL_OCAMLFIND) $(OCAMLOPT) -a $(OBJS_LIBS) $(filter-out -custom, $(ALL_LDFLAGS)) -o $@ $(LIB_PACK_NAME).cmx 1042 | endif 1043 | 1044 | $(RES_CLIB): $(OBJ_LINK) 1045 | ifndef MSVC 1046 | ifneq ($(strip $(OBJ_LINK)),) 1047 | $(AR) rcs $@ $(OBJ_LINK) 1048 | endif 1049 | else 1050 | ifneq ($(strip $(OBJ_LINK)),) 1051 | lib -nologo -debugtype:cv -out:$(RES_CLIB) $(OBJ_LINK) 1052 | endif 1053 | endif 1054 | 1055 | %.cmi: %.mli $(EXTRADEPS) 1056 | $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ 1057 | if [ -z "$$pp" ]; then \ 1058 | $(ECHO) $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1059 | -c $(THREAD_FLAG) $(ANNOT_FLAG) \ 1060 | $(OCAMLFLAGS) $(INCFLAGS) $<; \ 1061 | $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1062 | -c $(THREAD_FLAG) $(ANNOT_FLAG) \ 1063 | $(OCAMLFLAGS) $(INCFLAGS) $<; \ 1064 | else \ 1065 | $(ECHO) $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1066 | -c -pp \"$$pp $(PPFLAGS)\" $(THREAD_FLAG) $(ANNOT_FLAG) \ 1067 | $(OCAMLFLAGS) $(INCFLAGS) $<; \ 1068 | $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1069 | -c -pp "$$pp $(PPFLAGS)" $(THREAD_FLAG) $(ANNOT_FLAG) \ 1070 | $(OCAMLFLAGS) $(INCFLAGS) $<; \ 1071 | fi 1072 | 1073 | %.cmi: %$(IMPL_SUF); 1074 | 1075 | %$(IMPL_SUF) %.$(EXT_OBJ): %.ml $(EXTRADEPS) 1076 | $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ 1077 | if [ -z "$$pp" ]; then \ 1078 | $(ECHO) $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1079 | -c $(ALL_OCAMLCFLAGS) $<; \ 1080 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1081 | -c $(ALL_OCAMLCFLAGS) $<; \ 1082 | else \ 1083 | $(ECHO) $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1084 | -c -pp \"$$pp $(PPFLAGS)\" $(ALL_OCAMLCFLAGS) $<; \ 1085 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1086 | -c -pp "$$pp $(PPFLAGS)" $(ALL_OCAMLCFLAGS) $<; \ 1087 | fi 1088 | 1089 | .PRECIOUS: %.ml 1090 | %.ml: %.mll 1091 | $(OCAMLLEX) $(LFLAGS) $< 1092 | 1093 | .PRECIOUS: %.ml %.mli 1094 | %.ml %.mli: %.mly 1095 | $(OCAMLYACC) $(YFLAGS) $< 1096 | $(QUIET)pp=`sed -n -e 's/.*(\*pp \([^*]*\) \*).*/\1/p;q' $<`; \ 1097 | if [ ! -z "$$pp" ]; then \ 1098 | mv $*.ml $*.ml.temporary; \ 1099 | echo "(*pp $$pp $(PPFLAGS)*)" > $*.ml; \ 1100 | cat $*.ml.temporary >> $*.ml; \ 1101 | rm $*.ml.temporary; \ 1102 | mv $*.mli $*.mli.temporary; \ 1103 | echo "(*pp $$pp $(PPFLAGS)*)" > $*.mli; \ 1104 | cat $*.mli.temporary >> $*.mli; \ 1105 | rm $*.mli.temporary; \ 1106 | fi 1107 | 1108 | 1109 | .PRECIOUS: %.ml 1110 | %.ml: %.rep 1111 | $(CAMELEON_REPORT) $(CAMELEON_REPORT_FLAGS) -gen $< 1112 | 1113 | .PRECIOUS: %.ml 1114 | %.ml: %.zog 1115 | $(CAMELEON_ZOGGY) $(CAMELEON_ZOGGY_FLAGS) -impl $< > $@ 1116 | 1117 | .PRECIOUS: %.ml 1118 | %.ml: %.glade 1119 | $(OCAML_GLADECC) $(OCAML_GLADECC_FLAGS) $< > $@ 1120 | 1121 | .PRECIOUS: %.ml %.mli 1122 | %.ml %.mli: %.oxridl 1123 | $(OXRIDL) $< 1124 | 1125 | .PRECIOUS: %.ml %.mli %_stubs.c %.h 1126 | %.ml %.mli %_stubs.c %.h: %.idl 1127 | $(CAMLIDL) $(MAYBE_IDL_HEADER) $(IDLFLAGS) \ 1128 | $(CAMLIDLFLAGS) $< 1129 | $(QUIET)if [ $(NOIDLHEADER) ]; then touch $*.h; fi 1130 | 1131 | %.$(EXT_OBJ): %.c 1132 | $(OCAMLC) -c -cc "$(CC)" -ccopt "$(CFLAGS) \ 1133 | $(CPPFLAGS) $(CPPFLAGS_WIN32) \ 1134 | $(CFLAGS_WIN32) $(CINCFLAGS) $(CFLAG_O)$@ " $< 1135 | 1136 | %.$(EXT_OBJ): %.m 1137 | $(CC) -c $(CFLAGS) $(CINCFLAGS) $(CPPFLAGS) \ 1138 | -I'$(OCAMLLIBPATH)' \ 1139 | $< $(CFLAG_O)$@ 1140 | 1141 | %.$(EXT_OBJ): %.$(EXT_CXX) 1142 | $(CXX) -c $(CXXFLAGS) $(CINCFLAGS) $(CPPFLAGS) \ 1143 | -I'$(OCAMLLIBPATH)' \ 1144 | $< $(CFLAG_O)$@ 1145 | 1146 | $(MLDEPDIR)/%.d: %.ml 1147 | $(QUIET)if [ ! -d $(@D) ]; then mkdir -p $(@D); fi 1148 | $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ 1149 | if [ -z "$$pp" ]; then \ 1150 | $(ECHO) $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ 1151 | $(INCFLAGS) $< \> $@; \ 1152 | $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ 1153 | $(INCFLAGS) $< > $@; \ 1154 | else \ 1155 | $(ECHO) $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ 1156 | -pp \"$$pp $(PPFLAGS)\" $(INCFLAGS) $< \> $@; \ 1157 | $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ 1158 | -pp "$$pp $(PPFLAGS)" $(INCFLAGS) $< > $@; \ 1159 | fi 1160 | 1161 | $(BCDIDIR)/%.di $(NCDIDIR)/%.di: %.mli 1162 | $(QUIET)if [ ! -d $(@D) ]; then mkdir -p $(@D); fi 1163 | $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ 1164 | if [ -z "$$pp" ]; then \ 1165 | $(ECHO) $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) $(INCFLAGS) $< \> $@; \ 1166 | $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) $(INCFLAGS) $< > $@; \ 1167 | else \ 1168 | $(ECHO) $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) \ 1169 | -pp \"$$pp $(PPFLAGS)\" $(INCFLAGS) $< \> $@; \ 1170 | $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) \ 1171 | -pp "$$pp $(PPFLAGS)" $(INCFLAGS) $< > $@; \ 1172 | fi 1173 | 1174 | $(DOC_DIR)/$(RESULT)/html: 1175 | mkdir -p $@ 1176 | 1177 | $(DOC_DIR)/$(RESULT)/html/index.html: $(DOC_DIR)/$(RESULT)/html $(DOC_FILES) 1178 | rm -rf $ implode % int_of_string 22 | let add = exactly '+' >> return ( + ) 23 | let sub = exactly '-' >> return ( - ) 24 | let mul = exactly '*' >> return ( * ) 25 | let div = exactly '/' >> return ( / ) 26 | 27 | let rec expr input = chainl1 term (add <|> sub) input 28 | and term input = chainl1 factor (mul <|> div) input 29 | and factor input = (parens expr <|> integer) input 30 | 31 | let () = 32 | let input = LazyStream.of_channel stdin in 33 | match parse expr input with 34 | | Some ans -> Printf.printf "%d\n" ans 35 | | None -> print_endline "ERROR!" 36 | ~~~ 37 | 38 | For non-trivial examples, see Hackerrank challenge solutions using opal in 39 | `examples/`. 40 | 41 | ## Documentation 42 | 43 | The expressiveness of parser combinators are attributed to higher-order 44 | functions and the extensive use of currying. However, due to lack of `do` 45 | syntax, the bind operation of monad would not be as succinct as that in Haskell. 46 | 47 | A parser monad is either `None` (indicates failure), or `Some` pair of result 48 | and unconsumed input, where the result is a user-defined value. The input is a 49 | lazy stream of arbitrary token type. A parser is a function that accepts an 50 | input and returns a parser monad. Although most parsers in opal is polymorphic 51 | over token type and result type, some useful parsers only accepts `char` as 52 | input token type. 53 | 54 | Since combinators in opal are roughly based on Haskell's Parsec. The following 55 | documentation is somehow a rip-off of Parsec's doc. 56 | 57 | ### Lazy Stream 58 | 59 | **`type 'a LazyStream t`** 60 | 61 | Polymorphic lazy stream type. 62 | 63 | **`val LazyStream.of_stream : 'a Stream.t -> 'a LazyStream.t`** 64 | 65 | Build a lazy stream from stream. 66 | 67 | **`val LazyStream.of_function : (unit -> 'a) -> 'a LazyStream.t`** 68 | 69 | Build a lazy stream from a function `f`. The elements in the stream is populated 70 | by calling `f ()`. 71 | 72 | **`val LazyStream.of_string : string -> char LazyStream.t`** 73 | 74 | Build a char lazy stream from string. 75 | 76 | **`val LazyStream.of_channel : in_channel -> char LazyStream.t`** 77 | 78 | Build a char lazy stream from a input channel. 79 | 80 | ### Utilities 81 | 82 | **`val implode : char list -> bytes`** 83 | 84 | Implode character list into a string. Useful when used with `many`. 85 | 86 | **`val explode : bytes -> char list`** 87 | 88 | Explode a string into a character list. 89 | 90 | **`val ( % ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c`** 91 | 92 | Infix operator for left-to-right function composition. `(f % g % h) x` is 93 | equivalent to `h (g (f x))`. 94 | 95 | **`val parse : ('token, 'result) parser -> 'token LazyStream -> 'result option`** 96 | 97 | `parse parser input` parses `input` with `parser`, and returns `Some result` if 98 | succeed, or `None` on failure. 99 | 100 | ### Primitives 101 | 102 | **`type 'token input = 'token LazyStream.t`** 103 | 104 | **`type ('token, 'result) monad = ('result * 'token input) option`** 105 | 106 | **`type ('token, 'result) parser = 'token input -> ('token, 'result) monad`** 107 | 108 | A parser is a function that accepts an input and returns either `None` on 109 | failure, or `Some (result, input')`, where `result` is user-defined value and 110 | `input'` is unconsumed input after parsing. 111 | 112 | **`val return : 'result -> 'token input -> ('token, 'result) monad`** 113 | 114 | Accepts a value and an input, and returns a monad. 115 | 116 | **`val ( >>= ) : ('t, 'r) parser -> ('r -> ('t, 'r) monad) -> ('t, 'r) parser`** 117 | 118 | `x >>= f` returns a new parser that if parser `x` succeeds, applies function `f` 119 | on monad produced by `x`, and produces a new monad (a.k.a. `bind`). 120 | 121 | **`val ( let* ) : ('t, 'r) parser -> ('r -> ('t, 'r) monad) -> ('t, 'r) parser`** 122 | 123 | This operator is the same as `>>=` but using the `let` notation. 124 | It is usefull to avoid ugly sequences of bindings. For exemple, `p >>= fun x -> f x` can 125 | be rewritten `let* x = p in f x`. Combined with the `return` function, we can define complex parsers : 126 | 127 | ```ocaml 128 | let tuple_parser = 129 | let* x = digit in 130 | let* _ = exactly ',' in 131 | let* y = digit in 132 | return (x, y) 133 | ``` 134 | 135 | **`val ( <|> ) : ('t, 'r) parser -> ('t, 'r) parser -> ('t, 'r) parser`** 136 | 137 | Choice combinator. The parser `p <|> q` first applies `p`. If it succeeds, the 138 | value of `p` is returned. If `p` fails, parser `q` is tried. 139 | 140 | **`val mzero : 'a -> ('t, 'r) monad`** 141 | 142 | A parser that always fails. 143 | 144 | **`val any : ('t, 'r) parser`** 145 | 146 | The parser succeeds for any token in the input. Consumes a token and returns it. 147 | 148 | **`val satisfy : ('t -> bool) -> ('t, 'r) parser`** 149 | 150 | The parser `satisfy test` succeeds for any token for which the supplied function 151 | `test` returns `true`. Returns the token that is actually parsed. 152 | 153 | **`val eof : 'a -> ('t, 'a) parser`** 154 | 155 | The parser `eof x` succeeds if the input is exhausted. Returns value `x`. 156 | 157 | ### Derived 158 | 159 | **`val ( => ) : ('t, 'r) parser -> ('r -> 'a) -> ('t, 'a) parser`** 160 | 161 | Map combinator. `x => f` parses `x`. If it succeeds, returns the value of `x` 162 | applied with `f`. 163 | 164 | **`val ( >> ) : ('t, 'a) parser -> ('t, 'b) parser -> ('t, 'b) parser`** 165 | 166 | Ignore-left combinator. `x >> y` parses `x` and then `y`. Returns the value 167 | returned by `y`. 168 | 169 | **`val ( << ) : ('t, 'a) parser -> ('t, 'b) parser -> ('t, 'a) parser`** 170 | 171 | Ignore-right combinator. `x >> y` parses `x` and then `y`. Returns the value 172 | returned by `x`. 173 | 174 | **`val ( <~> ) : ('t, 'r) parser -> ('t, 'r list) parser -> 't input -> ('t, 'r list) monad`** 175 | 176 | Cons combinator. `x <~> y` parses `x` and then `y`. Returns the value of `x` 177 | prepended to the value of `y` (a list). 178 | 179 | ~~~ocaml 180 | let ident = letter <~> many alpha_num 181 | ~~~ 182 | 183 | **`val choice : ('t, 'r) parser list -> ('t, 'r) parser`** 184 | 185 | `choice ps` tries to apply the parsers in the list `ps` in order, until one of 186 | them succeeds. Returns the value of the succeeding parser. 187 | 188 | **`val count : int -> ('t, 'r) parser -> 't input -> ('t, 'r list) monad`** 189 | 190 | `count n` parses `n` occurrences of `p`. If `n` is smaller or equal to zero, the 191 | parser equals to `return []`. Returns a list of `n` values returned by `p`. 192 | 193 | **`between : ('t, 'a) parser -> ('t, 'b) parser -> ('t, 'r) parser -> ('t, 'r) parser`** 194 | 195 | `between open close p` parses `open`, followed by `p` and `close`. Returns the 196 | value returned by `p`. 197 | 198 | ~~~ocaml 199 | let braces = between (exactly '{') (exactly '}') 200 | ~~~ 201 | 202 | **`val option : 'r -> ('t, 'r) parser -> ('t, 'r) parser`** 203 | 204 | `option default p` tries to apply parser `p`. If `p` fails, it returns the 205 | value `default`, otherwise the value returned by `p`. 206 | 207 | ~~~ocaml 208 | let priority = option 0 (digit => String.make 1 % int_of_string) 209 | ~~~ 210 | 211 | **`val optional : 'r -> ('t, 'r) parser -> ('t, unit) parser`** 212 | 213 | `optional p` tries to apply parser `p`. It will parse `p` or nothing. It only 214 | fails if `p` fails. Discard the result of `p`. 215 | 216 | **`val skip_many : ('t, 'r) parser -> ('t, unit) parser`** 217 | 218 | `skip_many p` applies `p` *zero or more* times, skipping its result. 219 | 220 | ~~~ocaml 221 | let spaces = skip_many space 222 | ~~~ 223 | 224 | **`val skip_many1 : ('t, 'r) parser -> ('t, unit) parser`** 225 | 226 | `skip_many1 p` applies `p` *one or more* times, skipping its result. 227 | 228 | **`val many : ('t, 'r) parser -> 't input -> ('t, 'r list) monad`** 229 | 230 | `many p` applies the parser `p` *zero or more* times. Returns a list of returned 231 | values of `p`. 232 | 233 | **`val many1 : ('t, 'r) parser -> 't input -> ('t, 'r list) monad`** 234 | 235 | `many1 p` applies the parser `p` *one or more* times. Returns a list of returned 236 | values of `p`. 237 | 238 | **`val sep_by : ('t, 'r) parser -> ('t, 'a) parser -> 't input -> ('t, 'r list) monad`** 239 | 240 | `sep_by p sep` parses *zero or more* occurrences of `p`, separated by `sep`. 241 | Returns a list of values returned by `p`. 242 | 243 | ~~~ocaml 244 | let comma_sep p = sep_by p (token ",") 245 | ~~~ 246 | 247 | **`val sep_by1 : ('t, 'r) parser -> ('t, 'a) parser -> 't input -> ('t, 'r list) monad`** 248 | 249 | `sep_by1 p sep` parses *one or more* occurrences of `p`, separated by `sep`. 250 | Returns a list of values returned by `p`. 251 | 252 | **`val end_by: ('t, 'r) parser -> ('t, 'a) parser -> ('t, 'r) parser`** 253 | 254 | `end_by p sep` parses *zero or more* ocurrences of `p`, separated and ended by 255 | `sep`. Returns a list of values returned by `p`. 256 | 257 | ~~~ocaml 258 | let statements = end_by statement (token ";") 259 | ~~~ 260 | 261 | **`val end_by1: ('t, 'r) parser -> ('t, 'a) parser -> ('t, 'r) parser`** 262 | 263 | `end_by1 p sep` parses *one or more* ocurrences of `p`, separated and ended by 264 | `sep`. Returns a list of values returned by `p`. 265 | 266 | **`val chainl : ('t, 'r) parser -> ('t, 'r -> 'r -> 'r) parser -> 'r -> ('t, 'r) parser`** 267 | 268 | `chainl p op default` parses *zero or more* occurrences of `p`, separated by 269 | `op`. Returns a value obtained by a *left* associative application of all 270 | functions by `op` to the values returned by `p`. If there are zero occurences 271 | of `p`, the value `default` is returned. 272 | 273 | **`val chainl1 : ('t, 'r) parser -> ('t, 'r -> 'r -> 'r) parser -> ('t, 'r) parser`** 274 | 275 | `chainl1 p op` parses *one or more* occurrences of `p`, separate by `op`. 276 | Returns a value obtained by a *left* associative application of all functions 277 | returned by `op` to the values returned by `p`. This parser can be used to 278 | eliminate left recursion which typically occurs in expression grammars. See 279 | the arithmetic caculator example above. 280 | 281 | **`val chainr : ('t, 'r) parser -> ('t, 'r -> 'r -> 'r) parser -> 'r -> ('t, 'r) parser`** 282 | 283 | `chainr p op default` parses *zero or more* occurrences of `p`, separated by 284 | `op`. Returns a value obtained by *right* associative application of all 285 | functions returned by `op` to the values returned by `p`. If there are no 286 | occurrences of `p`, the value `x` is returned. 287 | 288 | **`val chainr1 : ('t, 'r) parser -> ('t, 'r -> 'r -> 'r) parser -> ('t, 'r) parser`** 289 | 290 | `chainr p op` parses *one or more* occurrences of `p`, separated by `op`. 291 | Returns a value obtained by *right* associative application of all functions 292 | returned by `op` to the values returned by `p`. 293 | 294 | ### Singletons 295 | 296 | **`val exactly : 'r -> ('t, 'r) parser`** 297 | 298 | `exactly x` parses a single token `x`. Returns the parsed token (i.e. `x`). 299 | 300 | ~~~ocaml 301 | let semi_colon = exactly ';' 302 | ~~~ 303 | 304 | **`val one_of : 'r list -> ('t, 'r) parser`** 305 | 306 | `one_of xs` succeeds if the current token is in the supplied list of tokens 307 | `xs`. Returns the parsed token. 308 | 309 | ~~~ocaml 310 | let vowel = one_of ['a'; 'e'; 'i'; 'o'; 'u'] 311 | ~~~ 312 | 313 | **`val none_of : 'r list -> ('t, 'r) parser`** 314 | 315 | As the dual of `one_of`, `none_of xs` succeeds if the current token *not* in 316 | the supplied list of tokens `xs`. Returns the parsed token. 317 | 318 | ~~~ocaml 319 | let consonant = none_of ['a'; 'e'; 'i'; 'o'; 'u'] 320 | ~~~ 321 | 322 | **`val range : 'r -> 'r -> ('t, 'r) parser`** 323 | 324 | `range low high` succeeds if the current token is in the range between `low` 325 | and `high` (inclusive). Returns the parsed token. 326 | 327 | ### Char Parsers 328 | 329 | **`val space = (char, char) parser`** 330 | 331 | Parses a white space character (`'\s\t\r\n'`). Returns the parsed character. 332 | 333 | **`val spaces = (char, unit) parser`** 334 | 335 | Skip *zero or more* white spaces characters. 336 | 337 | **`val newline = (char, char) parser`** 338 | 339 | Parses a newline character (`'\n'`). Returns a newline character. 340 | 341 | **`val tab = (char, char) parser`** 342 | 343 | Parses a tab character (`'\t'`). Returns a tab character. 344 | 345 | **`val upper = (char, char) parser`** 346 | 347 | Parses an upper case letter (a character between 'A' and 'Z'). Returns the 348 | parsed character. 349 | 350 | **`val lower = (char, char) parser`** 351 | 352 | Parses a lower case letter (a character between 'a' and 'z'). Returns the parsed 353 | character. 354 | 355 | **`val digit : (char, char) parser`** 356 | 357 | Parses a digit. Returns the parsed character. 358 | 359 | **`val letter = (char, char) parser`** 360 | 361 | Parses a letter (an upper case or lower case letter). Returns the parsed 362 | character. 363 | 364 | **`val alpha_num = (char, char) parser`** 365 | 366 | Parses a letter or digit. Returns the parser character. 367 | 368 | **`val hex_digit = (char, char) parser`** 369 | 370 | Parses a hexadecimal digit (a digit or a letter between 'a' and 'f' or 'A' and 371 | 'F'). Returns the parsed character. 372 | 373 | **`val oct_digit = (char, char) parser`** 374 | 375 | Parses an octal digit (a character between '0' and '7'). Returns the parsed 376 | character. 377 | 378 | ### Lex Helper 379 | 380 | **`val lexeme : (char, 'r) parser -> (char, 'r) parser`** 381 | 382 | `lexeme p` first applies `skip_many space` and then parser `p`. Returns the 383 | value returned by `p`. 384 | 385 | **`val token : string -> char input -> (char, char list) monad`** 386 | 387 | `token s` skips leading white spaces and parses a sequence of characters given 388 | by string `s`. Returns the parsed character sequence as a list. 389 | 390 | ~~~ocaml 391 | div_or_mod = token "div" <|> token "mod" 392 | ~~~ 393 | -------------------------------------------------------------------------------- /examples/infer.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Infer - a Hackerrank FP challenge: 3 | * https://www.hackerrank.com/challenges/infer 4 | *) 5 | 6 | (* ----------------------------- opal.ml START ------------------------------ *) 7 | module LazyStream = struct 8 | type 'a t = Cons of 'a * 'a t Lazy.t | Nil 9 | let of_stream stream = 10 | let rec next stream = 11 | try Cons(Stream.next stream, lazy (next stream)) 12 | with Stream.Failure -> Nil 13 | in 14 | next stream 15 | let of_string str = str |> Stream.of_string |> of_stream 16 | let of_channel ic = ic |> Stream.of_channel |> of_stream 17 | let of_function f = 18 | let rec next f = 19 | match f () with 20 | | Some x -> Cons(x, lazy (next f)) 21 | | None -> Nil 22 | in 23 | next f 24 | end 25 | let implode l = String.concat "" (List.map (String.make 1) l) 26 | let explode s = 27 | let l = ref [] in 28 | String.iter (fun c -> l := c :: !l) s; 29 | List.rev !l 30 | let (%) f g = fun x -> g (f x) 31 | type 'token input = 'token LazyStream.t 32 | type ('token, 'result) parser = 'token input -> ('result * 'token input) option 33 | let parse parser input = 34 | match parser input with 35 | | Some(res, _) -> Some res 36 | | None -> None 37 | let return x input = Some(x, input) 38 | let (>>=) x f = 39 | fun input -> 40 | match x input with 41 | | Some(result', input') -> f result' input' 42 | | None -> None 43 | let (<|>) x y = 44 | fun input -> 45 | match x input with 46 | | Some _ as ret -> ret 47 | | None -> y input 48 | let rec scan x input = 49 | match x input with 50 | | Some(result', input') -> LazyStream.Cons(result', lazy (scan x input')) 51 | | None -> LazyStream.Nil 52 | let mzero _ = None 53 | let any = function 54 | | LazyStream.Cons(token, input') -> Some(token, Lazy.force input') 55 | | LazyStream.Nil -> None 56 | let satisfy test = any >>= (fun res -> if test res then return res else mzero) 57 | let eof x = function LazyStream.Nil -> Some(x, LazyStream.Nil) | _ -> None 58 | let (=>) x f = x >>= fun r -> return (f r) 59 | let (>>) x y = x >>= fun _ -> y 60 | let (<<) x y = x >>= fun r -> y >>= fun _ -> return r 61 | let (<~>) x xs = x >>= fun r -> xs >>= fun rs -> return (r :: rs) 62 | let rec choice = function [] -> mzero | h :: t -> (h <|> choice t) 63 | let rec count n x = if n > 0 then x <~> count (n - 1) x else return [] 64 | let between op ed x = op >> x << ed 65 | let option default x = x <|> return default 66 | let optional x = option () (x >> return ()) 67 | let rec skip_many x = option () (x >>= fun _ -> skip_many x) 68 | let skip_many1 x = x >> skip_many x 69 | let rec many x = option [] (x >>= fun r -> many x >>= fun rs -> return (r :: rs)) 70 | let many1 x = x <~> many x 71 | let sep_by1 x sep = x <~> many (sep >> x) 72 | let sep_by x sep = sep_by1 x sep <|> return [] 73 | let end_by1 x sep = sep_by1 x sep << sep 74 | let end_by x sep = end_by1 x sep <|> return [] 75 | let chainl1 x op = 76 | let rec loop a = (op >>= fun f -> x >>= fun b -> loop (f a b)) <|> return a in 77 | x >>= loop 78 | let chainl x op default = chainl1 x op <|> return default 79 | let rec chainr1 x op = 80 | x >>= fun a -> (op >>= fun f -> chainr1 x op >>= f a) <|> return a 81 | let chainr x op default = chainr1 x op <|> return default 82 | let exactly x = satisfy ((=) x) 83 | let one_of l = satisfy (fun x -> List.mem x l) 84 | let none_of l = satisfy (fun x -> not (List.mem l x)) 85 | let range l r = satisfy (fun x -> l <= x && x <= r) 86 | let space = one_of [' '; '\t'; '\r'; '\n'] 87 | let spaces = skip_many space 88 | let newline = exactly '\n' 89 | let tab = exactly '\t' 90 | let upper = range 'A' 'Z' 91 | let lower = range 'a' 'z' 92 | let digit = range '0' '9' 93 | let letter = lower <|> upper 94 | let alpha_num = letter <|> digit 95 | let hex_digit = range 'a' 'f' <|> range 'A' 'F' 96 | let oct_digit = range '0' '7' 97 | let lexeme x = spaces >> x 98 | let token s = 99 | let rec loop s i = 100 | if i >= String.length s 101 | then return s 102 | else exactly s.[i] >> loop s (i + 1) 103 | in 104 | lexeme (loop s 0) 105 | (* ------------------------------ opal.ml END ------------------------------- *) 106 | 107 | open Printf 108 | 109 | type exp = 110 | | Var of string 111 | | Let of string * exp * exp 112 | | Fun of string list * exp 113 | | App of exp * exp list 114 | 115 | exception Syntax_error 116 | exception Runtime_error of string 117 | 118 | (* parser *) 119 | 120 | let reserved = ["let"; "in"; "fun"] 121 | 122 | let initial = letter <|> exactly '_' 123 | let subseqt = alpha_num <|> exactly '_' 124 | let ident = (spaces >> initial <~> many subseqt) => implode >>= function 125 | | s when List.mem s reserved -> mzero 126 | | s -> return s 127 | 128 | let parens = between (token "(") (token ")") 129 | let bracks = between (token "[") (token "]") 130 | let comma_list x = sep_by x (token ",") 131 | let comma_list1 x = sep_by1 x (token ",") 132 | 133 | let rec expr input = 134 | (let_expr <|> fun_expr <|> simple_expr) input 135 | and let_expr input = 136 | (token "let" >> 137 | ident >>= fun name -> 138 | token "=" >> 139 | expr >>= fun value -> 140 | token "in" >> 141 | expr >>= fun body -> 142 | return (Let(name, value, body))) input 143 | and fun_expr input = 144 | (token "fun" >> 145 | many ident >>= fun params -> 146 | token "->" >> 147 | expr >>= fun body -> 148 | return (Fun(params, body))) input 149 | and simple_expr input = 150 | let rec foldl fn = 151 | (args >>= fun args -> foldl (App(fn, args))) <|> return fn 152 | in 153 | (caller >>= foldl) input 154 | and caller input = 155 | (parens expr <|> (ident => fun v -> Var v)) input 156 | and args input = (parens (comma_list1 expr)) input 157 | 158 | let parse_expr = parse expr 159 | 160 | (* destructive-unification based implementation of algorithm W *) 161 | 162 | type ty = 163 | | TConst of string 164 | | TApp of ty * ty list 165 | | TFun of ty list * ty 166 | | TVar of tvar ref 167 | 168 | and tvar = 169 | | Poly of int 170 | | Bound of ty 171 | | Unbound of int * level 172 | 173 | (* level: nested level of let-expression used by generalization *) 174 | and level = int 175 | 176 | module Env = Map.Make(String) 177 | type env = ty Env.t 178 | 179 | let id_counter = ref (-1) 180 | let gen_id = fun () -> incr id_counter; !id_counter 181 | let reset_id = fun () -> id_counter := (-1) 182 | 183 | let fresh_var level = 184 | TVar(ref @@ Unbound(gen_id (), level)) 185 | 186 | let fresh_poly_var () = 187 | TVar(ref @@ Poly(gen_id ())) 188 | 189 | (* printer for type *) 190 | let rec string_of_ty (t: ty) : string = 191 | (* keep track of poly variables' id -> name *) 192 | let id_name_map = Hashtbl.create 26 in 193 | (* assume we only use a to z *) 194 | let gensym = 195 | let counter = ref (-1) in 196 | fun () -> incr counter; char_of_int (97 + !counter) |> String.make 1 197 | in 198 | let rec walk = function 199 | | TConst k -> k 200 | | TApp(t1, args) -> 201 | let t1 = walk t1 in 202 | let args = String.concat ", " (List.map walk args) in 203 | sprintf "%s[%s]" t1 args 204 | | TFun([(TFun _) as p], t1) -> 205 | let lhs = walk p in 206 | let rhs = walk t1 in 207 | sprintf "(%s) -> %s" lhs rhs 208 | | TFun([param], t1) -> 209 | let lhs = walk param in 210 | let rhs = walk t1 in 211 | sprintf "%s -> %s" lhs rhs 212 | | TFun(params, t1) -> 213 | let lhs = String.concat ", " @@ List.map walk params in 214 | let rhs = walk t1 in 215 | sprintf "(%s) -> %s" lhs rhs 216 | | TVar {contents = Poly id} -> 217 | begin try 218 | Hashtbl.find id_name_map id 219 | with Not_found -> 220 | let name = gensym () in 221 | Hashtbl.add id_name_map id name; 222 | name 223 | end 224 | | TVar {contents = Unbound(id, _)} -> "_" ^ string_of_int id 225 | | TVar {contents = Bound t} -> walk t 226 | in 227 | let s = walk t in 228 | if Hashtbl.length id_name_map > 0 then 229 | let vars = Hashtbl.fold (fun _ v l -> v :: l) id_name_map [] in 230 | let vars = Array.of_list vars in 231 | Array.sort compare vars; 232 | let vars = Array.to_list vars in 233 | sprintf "forall[%s] %s" (String.concat " " vars) s 234 | else 235 | s 236 | 237 | (* generalize unbound type variable *) 238 | let rec generalize (level: level) (t: ty) : ty = 239 | match t with 240 | (* only generalize unbound variables in let-binding expression *) 241 | | TVar {contents = Unbound(id, lv)} when lv > level -> TVar(ref @@ Poly id) 242 | | TVar {contents = Bound t'} -> generalize level t' 243 | | TApp(t1, args) -> TApp(generalize level t1, List.map (generalize level) args) 244 | | TFun(args, t1) -> TFun(List.map (generalize level) args, generalize level t1) 245 | | _ -> t 246 | 247 | (* replace polymorphic type variable with unbound type variable *) 248 | and instantiate (level: level) (t: ty) : ty = 249 | (* same poly var should be replaced into same unbound var. *) 250 | let id_var_map = Hashtbl.create 16 in 251 | let rec walk t = match t with 252 | | TVar {contents = Poly id} -> 253 | begin try Hashtbl.find id_var_map id 254 | with Not_found -> 255 | let var = fresh_var level in 256 | Hashtbl.add id_var_map id var; 257 | var 258 | end 259 | | TVar {contents = Bound t} -> walk t 260 | | TApp(t1, args) -> TApp(walk t1, List.map walk args) 261 | | TFun(params, t1) -> TFun(List.map walk params, walk t1) 262 | | _ -> t 263 | in 264 | walk t 265 | 266 | (* destructive unification *) 267 | let rec unify (t1: ty) (t2: ty) : unit = 268 | match t1, t2 with 269 | | _ when t1 = t2 -> () 270 | (* recursive unification *) 271 | | TApp(x, args), TApp(x', args') -> (unify x x'; List.iter2 unify args args') 272 | | TFun(params, t), TFun(params', t') -> (List.iter2 unify params params'; unify t t') 273 | (* either is bounded, unify with bounded value instead *) 274 | | TVar {contents = Bound t1}, t2 275 | | t1, TVar {contents = Bound t2} -> unify t1 t2 276 | (* either one is unbounded, occurs check and update binding *) 277 | | TVar ({contents = Unbound(id, level)} as v), t 278 | | t, TVar ({contents = Unbound(id, level)} as v) -> (occurs_check id level t; v := Bound t) 279 | (* all other cases fail *) 280 | | _ -> raise @@ Runtime_error(sprintf "cannot unify %s and %s" (string_of_ty t1) (string_of_ty t2)) 281 | 282 | (* occurence check, raise exception when failed *) 283 | and occurs_check (id: int) (level: level) (t: ty) : unit = 284 | let rec check = function 285 | | TVar {contents = Bound t} -> check t 286 | | TVar {contents = Unbound(id', _)} when id' = id -> 287 | raise @@ Runtime_error("recursive type") 288 | (* unify two unbounds: lift the level of the other one *) 289 | | TVar ({contents = Unbound(id', level')} as v) when level' > level -> 290 | v := Unbound(id', level) 291 | | TApp(t1, args) -> check t1; List.iter check args 292 | | TFun(args, t1) -> List.iter check args; check t1 293 | | _ -> () 294 | in 295 | check t 296 | 297 | (* W *) 298 | let rec w (env: env) (level: level) (exp: exp) : ty = 299 | match exp with 300 | (* var *) 301 | | Var v -> 302 | begin try 303 | instantiate level (Env.find v env) 304 | with Not_found -> 305 | raise @@ Runtime_error("unbound type variable " ^ v) 306 | end 307 | (* abs *) 308 | | Fun(params, body) -> 309 | let t_params = List.map (fun _ -> fresh_var level) params in 310 | let fun_env = List.fold_left2 311 | (fun env param t_param -> Env.add param t_param env) 312 | env params t_params 313 | in 314 | let t_ret = w fun_env level body in 315 | TFun(t_params, t_ret) 316 | (* app *) 317 | | App(fn, args) -> 318 | let t_fn = w env level fn in 319 | let t_args = List.map (w env level) args in 320 | let arity = List.length args in 321 | let t_params, t_return = match_fun_type arity t_fn in 322 | List.iter2 unify t_params t_args; 323 | t_return 324 | (* let *) 325 | | Let(name, value, body) -> 326 | (* create a deeper-level scope *) 327 | let t_value = w env (level + 1) value in 328 | let t_value_poly = generalize level t_value in 329 | w (Env.add name t_value_poly env) level body 330 | 331 | and match_fun_type arity = function 332 | | TFun(t_params, t_return) -> 333 | if (List.length t_params <> arity) 334 | then raise @@ Runtime_error("function arity mismatch") 335 | else (t_params, t_return) 336 | | TVar {contents = Bound t} -> match_fun_type arity t 337 | | TVar ({contents = Unbound(id, level)} as v) -> 338 | let rec loop = function 339 | | 0 -> [] 340 | | n -> (fresh_var level) :: loop (n - 1) 341 | in 342 | let t_params = loop arity in 343 | let t_return = fresh_var level in 344 | v := Bound (TFun(t_params, t_return)); 345 | (t_params, t_return) 346 | | _ -> raise @@ Runtime_error("application with non-function") 347 | 348 | (* type parser *) 349 | 350 | let replace_consts vars t = 351 | let env = List.fold_left 352 | (fun env v -> Env.add v (fresh_poly_var ()) env) 353 | Env.empty vars 354 | in 355 | let rec walk = function 356 | | TConst k when Env.mem k env -> Env.find k env 357 | | TApp(fn, args) -> TApp(walk fn, List.map walk args) 358 | | TFun(params, body) -> TFun(List.map walk params, walk body) 359 | | t -> t 360 | in 361 | walk t 362 | 363 | let ty_ident = (spaces >> initial <~> many subseqt) => implode >>= function 364 | | "forall" -> mzero 365 | | s -> return s 366 | 367 | let rec ty input = 368 | (fun_or_simple <|> paren_fun_ty) input 369 | and fun_or_simple input = 370 | let maybe_fun t = 371 | (token "->" >> ty >>= fun body -> return (TFun([t], body))) <|> return t 372 | in 373 | (simple_ty >>= maybe_fun) input 374 | and simple_ty input = 375 | let rec foldl t = 376 | (bracks (comma_list1 ty) >>= fun a -> foldl (TApp(t, a))) <|> return t 377 | in 378 | (prim_ty >>= foldl) input 379 | and prim_ty input = 380 | ((ty_ident => fun k -> TConst k) <|> (token "(" >> ty << token ")")) input 381 | and paren_fun_ty input = 382 | (parens (comma_list ty) >>= fun params -> 383 | token "->" >> 384 | ty >>= fun body -> 385 | return (TFun(params, body))) input 386 | 387 | let ty_forall = 388 | token "forall" >> 389 | token "[" >> 390 | many ty_ident >>= fun vars -> 391 | token "]" >> 392 | ty >>= fun body -> 393 | return (replace_consts vars body) 394 | 395 | let parse_ty = parse (ty_forall <|> ty) 396 | 397 | (* infer *) 398 | 399 | let make_env () = 400 | let assume name ty_str env = 401 | match parse_ty (LazyStream.of_string ty_str) with 402 | | None -> raise Syntax_error 403 | | Some t -> Env.add name t env 404 | in 405 | Env.empty 406 | |> assume "head" "forall[a] list[a] -> a" 407 | |> assume "tail" "forall[a] list[a] -> list[a]" 408 | |> assume "nil" "forall[a] list[a]" 409 | |> assume "cons" "forall[a] (a, list[a]) -> list[a]" 410 | |> assume "cons_curry" "forall[a] a -> list[a] -> list[a]" 411 | |> assume "map" "forall[a b] (a -> b, list[a]) -> list[b]" 412 | |> assume "map_curry" "forall[a b] (a -> b) -> list[a] -> list[b]" 413 | |> assume "one" "int" 414 | |> assume "zero" "int" 415 | |> assume "succ" "int -> int" 416 | |> assume "plus" "(int, int) -> int" 417 | |> assume "eq" "forall[a] (a, a) -> bool" 418 | |> assume "eq_curry" "forall[a] a -> a -> bool" 419 | |> assume "not" "bool -> bool" 420 | |> assume "true" "bool" 421 | |> assume "false" "bool" 422 | |> assume "pair" "forall[a b] (a, b) -> pair[a, b]" 423 | |> assume "pair_curry" "forall[a b] a -> b -> pair[a, b]" 424 | |> assume "first" "forall[a b] pair[a, b] -> a" 425 | |> assume "second" "forall[a b] pair[a, b] -> b" 426 | |> assume "id" "forall[a] a -> a" 427 | |> assume "const" "forall[a b] a -> b -> a" 428 | |> assume "apply" "forall[a b] (a -> b, a) -> b" 429 | |> assume "apply_curry" "forall[a b] (a -> b) -> a -> b" 430 | |> assume "choose" "forall[a] (a, a) -> a" 431 | |> assume "choose_curry" "forall[a] a -> a -> a" 432 | 433 | (* main *) 434 | let () = 435 | match parse_expr (LazyStream.of_channel stdin) with 436 | | None -> raise Syntax_error 437 | | Some exp -> 438 | let env = make_env () in 439 | reset_id (); 440 | exp |> w env 0 |> generalize (-1) |> string_of_ty |> print_endline 441 | -------------------------------------------------------------------------------- /examples/intuitive.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Intuitive Language - Hackerrank FP Contest Challenge: 3 | * https://www.hackerrank.com/contests/lambda-calculi-jun14/challenges/intuitive-language 4 | * 5 | * The language is case-INSENSITIVE! 6 | * 7 | * letter ::= [a-zA-Z] 8 | * ident ::= ( | )* 9 | * 10 | * kwd ::= function | is | of | assign | and | to | do | what 11 | * int ::= + 12 | * num ::= [ / ] 13 | * var ::= 14 | * func ::= function of : (, )* 15 | * | 16 | * decl ::= is . 17 | * 18 | * assn ::= Assign to ( AND to )* ! 19 | * 20 | * loop ::= do { } 21 | * 22 | * ask ::= what is ( ) ( AND )* ? 23 | * 24 | * exp ::= ( ( + | - ) )? 25 | * term ::= ( ( * | / ) )? 26 | * value ::= [+ | -] | | \( exp \) 27 | * call ::= ( \[ \] )* 28 | * 29 | * program ::= ( decl | assn | loop | ask )* 30 | * 31 | *) 32 | 33 | (* ----------------------------- opal.ml START ------------------------------ *) 34 | module LazyStream = struct 35 | type 'a t = Cons of 'a * 'a t Lazy.t | Nil 36 | let of_stream stream = 37 | let rec next stream = 38 | try Cons(Stream.next stream, lazy (next stream)) 39 | with Stream.Failure -> Nil 40 | in 41 | next stream 42 | let of_string str = str |> Stream.of_string |> of_stream 43 | let of_channel ic = ic |> Stream.of_channel |> of_stream 44 | let of_function f = 45 | let rec next f = 46 | match f () with 47 | | Some x -> Cons(x, lazy (next f)) 48 | | None -> Nil 49 | in 50 | next f 51 | end 52 | let implode l = String.concat "" (List.map (String.make 1) l) 53 | let explode s = 54 | let l = ref [] in 55 | String.iter (fun c -> l := c :: !l) s; 56 | List.rev !l 57 | let (%) f g = fun x -> g (f x) 58 | type 'token input = 'token LazyStream.t 59 | type ('token, 'result) parser = 'token input -> ('result * 'token input) option 60 | let parse parser input = 61 | match parser input with 62 | | Some(res, _) -> Some res 63 | | None -> None 64 | let return x input = Some(x, input) 65 | let (>>=) x f = 66 | fun input -> 67 | match x input with 68 | | Some(result', input') -> f result' input' 69 | | None -> None 70 | let (<|>) x y = 71 | fun input -> 72 | match x input with 73 | | Some _ as ret -> ret 74 | | None -> y input 75 | let rec scan x input = 76 | match x input with 77 | | Some(result', input') -> LazyStream.Cons(result', lazy (scan x input')) 78 | | None -> LazyStream.Nil 79 | let mzero _ = None 80 | let any = function 81 | | LazyStream.Cons(token, input') -> Some(token, Lazy.force input') 82 | | LazyStream.Nil -> None 83 | let satisfy test = any >>= (fun res -> if test res then return res else mzero) 84 | let eof x = function LazyStream.Nil -> Some(x, LazyStream.Nil) | _ -> None 85 | let (=>) x f = x >>= fun r -> return (f r) 86 | let (>>) x y = x >>= fun _ -> y 87 | let (<<) x y = x >>= fun r -> y >>= fun _ -> return r 88 | let (<~>) x xs = x >>= fun r -> xs >>= fun rs -> return (r :: rs) 89 | let rec choice = function [] -> mzero | h :: t -> (h <|> choice t) 90 | let rec count n x = if n > 0 then x <~> count (n - 1) x else return [] 91 | let between op ed x = op >> x << ed 92 | let option default x = x <|> return default 93 | let optional x = option () (x >> return ()) 94 | let rec skip_many x = option () (x >>= fun _ -> skip_many x) 95 | let skip_many1 x = x >> skip_many x 96 | let rec many x = option [] (x >>= fun r -> many x >>= fun rs -> return (r :: rs)) 97 | let many1 x = x <~> many x 98 | let sep_by1 x sep = x <~> many (sep >> x) 99 | let sep_by x sep = sep_by1 x sep <|> return [] 100 | let end_by1 x sep = sep_by1 x sep << sep 101 | let end_by x sep = end_by1 x sep <|> return [] 102 | let chainl1 x op = 103 | let rec loop a = (op >>= fun f -> x >>= fun b -> loop (f a b)) <|> return a in 104 | x >>= loop 105 | let chainl x op default = chainl1 x op <|> return default 106 | let rec chainr1 x op = 107 | x >>= fun a -> (op >>= fun f -> chainr1 x op >>= f a) <|> return a 108 | let chainr x op default = chainr1 x op <|> return default 109 | let exactly x = satisfy ((=) x) 110 | let one_of l = satisfy (fun x -> List.mem x l) 111 | let none_of l = satisfy (fun x -> not (List.mem l x)) 112 | let range l r = satisfy (fun x -> l <= x && x <= r) 113 | let space = one_of [' '; '\t'; '\r'; '\n'] 114 | let spaces = skip_many space 115 | let newline = exactly '\n' 116 | let tab = exactly '\t' 117 | let upper = range 'A' 'Z' 118 | let lower = range 'a' 'z' 119 | let digit = range '0' '9' 120 | let letter = lower <|> upper 121 | let alpha_num = letter <|> digit 122 | let hex_digit = range 'a' 'f' <|> range 'A' 'F' 123 | let oct_digit = range '0' '7' 124 | let lexeme x = spaces >> x 125 | let token s = 126 | let rec loop s i = 127 | if i >= String.length s 128 | then return s 129 | else exactly s.[i] >> loop s (i + 1) 130 | in 131 | lexeme (loop s 0) 132 | (* ------------------------------ opal.ml END ------------------------------- *) 133 | 134 | (* rational number *) 135 | type num = Ratio of int * int 136 | 137 | let rec num_of_string s = 138 | if String.contains s '/' then 139 | let len = String.length s in 140 | let delim = String.index s '/' in 141 | let numer = String.sub s 0 delim 142 | and denom = String.sub s (delim + 1) (len - delim - 1) in 143 | Ratio (int_of_string numer, int_of_string denom) |> simplify 144 | else 145 | Ratio ((int_of_string s), 1) |> simplify 146 | 147 | and sign x = 148 | if x < 0 then 149 | -1 150 | else if x = 0 then 151 | 0 152 | else 153 | 1 154 | 155 | and string_of_num (Ratio (numer, denom)) = 156 | if denom = 1 then 157 | string_of_int numer 158 | else 159 | Format.sprintf "%s/%s" (string_of_int numer) (string_of_int denom) 160 | 161 | and simplify (Ratio (numer, denom)) = 162 | if numer = 0 || denom = 0 then 163 | Ratio (0, 1) 164 | else 165 | let sign = (sign numer) * (sign denom) in 166 | let numer = abs numer in 167 | let denom = abs denom in 168 | let divisor = gcd numer denom in 169 | Ratio (sign * numer / divisor, denom / divisor) 170 | 171 | and gcd a b = 172 | if a = 0 then b 173 | else if b = 0 then a 174 | else if a > b then gcd b (a mod b) 175 | else gcd a (b mod a) 176 | 177 | (* 178 | a c ad + bc 179 | - + - = ------- 180 | b d b*d 181 | *) 182 | let ( +/ ) (Ratio (a, b)) (Ratio (c, d)) = 183 | Ratio (a * d + b * c, b * d) |> simplify 184 | 185 | (* 186 | a c ad - bc 187 | - - - = ------- 188 | b d b*d 189 | *) 190 | let ( -/ ) (Ratio (a, b)) (Ratio (c, d)) = 191 | Ratio (a * d - b * c, b * d) |> simplify 192 | 193 | (* 194 | a c ac 195 | - * - = -- 196 | b d bd 197 | *) 198 | let ( */ ) (Ratio (a, b)) (Ratio (c, d)) = 199 | Ratio (a * c, b * d) |> simplify 200 | 201 | (* 202 | a c ad 203 | - / - = -- 204 | b d bc 205 | *) 206 | let ( // ) (Ratio (a, b)) (Ratio (c, d)) = 207 | Ratio (a * d, b * c) |> simplify 208 | 209 | let minus_num (Ratio (a, b)) = Ratio (-a, b) 210 | 211 | let is_integer_num (Ratio (a, b)) = b = 1 212 | 213 | let sign_num (Ratio (a, b)) = sign a 214 | 215 | let int_of_num (Ratio(a, b)) = a / b 216 | 217 | (* interpreter *) 218 | 219 | type exp = AddExp of exp * exp 220 | | SubExp of exp * exp 221 | | MulExp of exp * exp 222 | | DivExp of exp * exp 223 | | PosExp of exp 224 | | NegExp of exp 225 | | Number of num 226 | | Call of call 227 | 228 | and func = exp array 229 | and call = string * exp list 230 | and assign = (string * exp) list 231 | 232 | and stmt = Decl of string * func 233 | | Assign of assign 234 | | Loop of exp * assign 235 | | Ask of call list 236 | 237 | type program = stmt list 238 | 239 | type value = NumVal of num 240 | | FuncVal of num * num list 241 | 242 | exception Syntax_error 243 | exception Runtime_error 244 | 245 | (* parser *) 246 | 247 | let kwd s = 248 | let rec loop s i = 249 | if i >= String.length s 250 | then return s 251 | else satisfy (fun c -> Char.lowercase c = s.[i]) >> loop s (i + 1) 252 | in 253 | lexeme (loop s 0) 254 | let comma_list x = sep_by1 x (token ",") 255 | let parens = between (token "(") (token ")") 256 | let bracks = between (token "[") (token "]") 257 | let braces = between (token "{") (token "}") 258 | 259 | let reserved = ["function"; "is"; "of"; "assign"; "and"; "to"; "do"; "what"] 260 | let ident = (spaces >> letter <~> many alpha_num) => 261 | implode % String.lowercase >>= function 262 | | s when List.mem s reserved -> mzero 263 | | s -> return s 264 | let digits = spaces >> many1 digit => implode 265 | let integer = digits => int_of_string 266 | let number = digits => num_of_string 267 | 268 | let add = token "+" >> return (fun x y -> AddExp(x, y)) 269 | let sub = token "-" >> return (fun x y -> SubExp(x, y)) 270 | let mul = token "*" >> return (fun x y -> MulExp(x, y)) 271 | let div = token "/" >> return (fun x y -> DivExp(x, y)) 272 | let pos = token "+" >> return (fun x -> PosExp(x)) 273 | let neg = token "-" >> return (fun x -> NegExp(x)) 274 | 275 | let rec expr input = (chainl1 term (add <|> sub)) input 276 | and term input = (chainl1 value (mul <|> div)) input 277 | and unary input = ((pos <|> neg) >>= fun op -> num_val => fun x -> op x) input 278 | and value input = (unary <|> call_val <|> num_val <|> parens expr) input 279 | and call_val input = (call => fun c -> Call c) input 280 | and num_val input = (number => fun x -> Number x) input 281 | and args input = (many (bracks expr)) input 282 | and call input = (ident >>= fun fn -> args => fun args -> (fn, args)) input 283 | 284 | let func_1 = expr => fun x -> [|x|] 285 | let func_n = 286 | kwd "function" >> 287 | kwd "of" >> 288 | integer >>= fun argc -> 289 | token ":" >> 290 | comma_list expr >>= fun argv -> 291 | let args = Array.of_list argv in 292 | if argc + 1 <> Array.length args then mzero else return args 293 | let func = func_1 <|> func_n 294 | let decl = 295 | ident >>= fun name -> 296 | kwd "is" >> 297 | func >>= fun func -> 298 | token "." >> 299 | return (Decl (name, func)) 300 | 301 | let pair = expr >>= fun rhs -> kwd "to" >> ident => fun lhs -> (lhs, rhs) 302 | let assign_impl = kwd "assign" >> sep_by1 pair (kwd "and") << token "!" 303 | let assign = assign_impl => fun x -> Assign(x) 304 | 305 | let loop = 306 | kwd "do" >> 307 | braces expr >>= fun times -> 308 | assign_impl >>= fun body -> 309 | return (Loop(times, body)) 310 | 311 | let queries = sep_by1 call (kwd "and") 312 | let ask = kwd "what" >> kwd "is" >> queries << token "?" => fun q -> Ask(q) 313 | 314 | let program = many (decl <|> assign <|> loop <|> ask) 315 | let parser = parse program 316 | 317 | (* eval *) 318 | 319 | let rec evlis env l = 320 | List.iter (function 321 | | Decl (name, func) -> eval_decl env name func 322 | | Assign pairs -> eval_assign env pairs 323 | | Loop (times, body) -> eval_loop env times body 324 | | Ask queries -> eval_ask env queries 325 | ) l 326 | 327 | and eval_decl env name func = 328 | let value = eval_func env func in 329 | Hashtbl.replace env name value 330 | 331 | and eval_assign env pairs = 332 | List.iter (function (name, exp) -> 333 | let value = eval_exp env exp in 334 | Hashtbl.replace env name value 335 | ) pairs 336 | 337 | and eval_loop env times body = 338 | match eval_exp env times with 339 | | NumVal n when is_integer_num n -> 340 | let times' = int_of_num n in 341 | for i = 1 to times' do 342 | eval_assign env body 343 | done 344 | | _ -> raise Runtime_error 345 | 346 | and eval_ask env queries = 347 | List.iter (function query -> 348 | let value = eval_call env query in 349 | value |> string_of_value |> print_endline 350 | ) queries 351 | 352 | and string_of_value v = 353 | match v with 354 | | NumVal n -> string_of_num n 355 | | FuncVal (k0, ki) -> 356 | (ki @ [k0]) |> List.map string_of_num |> String.concat ", " 357 | 358 | and eval_func env f = 359 | match f with 360 | | [|k0|] -> eval_exp env k0 361 | | _ -> 362 | let f' = Array.map (eval_num env) f in 363 | let k0 = f'.(Array.length f' - 1) in 364 | let ki = Array.sub f' 0 (Array.length f' - 1) |> Array.to_list in 365 | FuncVal (k0, ki) 366 | 367 | and eval_num env exp = 368 | match eval_exp env exp with 369 | | NumVal n -> n 370 | | _ -> raise Runtime_error 371 | 372 | and binary_op f l r = 373 | match (l, r) with 374 | | (NumVal l, NumVal r) -> NumVal (f l r) 375 | | _ -> raise Runtime_error 376 | 377 | and unary_op f e = 378 | match e with 379 | | NumVal e -> NumVal (f e) 380 | | _ -> raise Runtime_error 381 | 382 | and ( +++ ) l r = binary_op ( +/ ) l r 383 | and ( --- ) l r = binary_op ( -/ ) l r 384 | and ( *** ) l r = binary_op ( */ ) l r 385 | and ( /// ) l r = binary_op ( // ) l r 386 | 387 | and eval_exp env exp = 388 | match exp with 389 | | AddExp (l, r) -> (eval_exp env l) +++ (eval_exp env r) 390 | | SubExp (l, r) -> (eval_exp env l) --- (eval_exp env r) 391 | | MulExp (l, r) -> (eval_exp env l) *** (eval_exp env r) 392 | | DivExp (l, r) -> (eval_exp env l) /// (eval_exp env r) 393 | | PosExp e -> unary_op (function x -> x) (eval_exp env e) 394 | | NegExp e -> unary_op minus_num (eval_exp env e) 395 | | Number n -> NumVal n 396 | | Call c -> eval_call env c 397 | 398 | and eval_call env (name, args) = 399 | let value = Hashtbl.find env name in 400 | match value with 401 | | NumVal n when args = [] -> value 402 | | NumVal _ -> raise Runtime_error 403 | | FuncVal (k0, ki) -> 404 | let args' = List.map (eval_num env) args in 405 | let f' = List.fold_left apply (k0, ki) args' in 406 | match f' with 407 | | (k0, []) -> NumVal k0 408 | | (k0, ki) -> FuncVal (k0, ki) 409 | 410 | and apply (k0, ki) x = 411 | match ki with 412 | | k :: rest -> (k0 +/ x */ k, rest) 413 | | _ -> raise Runtime_error 414 | 415 | and num_of_value v = 416 | match v with 417 | | NumVal n -> n 418 | | _ -> raise Runtime_error 419 | 420 | and make_env () = Hashtbl.create 10 421 | 422 | (* parse & eval *) 423 | let rec run src = 424 | match parser src with 425 | | None -> raise Syntax_error 426 | | Some ast -> 427 | let env = make_env () in 428 | evlis env ast 429 | 430 | and run_of_channel channel = 431 | channel |> LazyStream.of_channel |> run 432 | 433 | and run_of_string str = 434 | str |> LazyStream.of_string |> run 435 | 436 | let () = run_of_channel stdin 437 | -------------------------------------------------------------------------------- /examples/while.ml: -------------------------------------------------------------------------------- 1 | (* 2 | While Language - a Hackerrank FP challenge: 3 | https://www.hackerrank.com/challenges/while-language-fp 4 | 5 | Program ::= Stmts 6 | Stmts ::= Stmt | Stmt ';' Stmts 7 | Stmt ::= Assign | IfElse | While 8 | Assign ::= Identifier ':=' AExp 9 | IfElse ::= 'if' BExp 'then' '{' Stmts '}' 'else' '{' Stmts '}' 10 | While ::= 'while' BExp 'do' '{' Stmts '}' 11 | 12 | Exp ::= OrExp 13 | OrExp ::= AndExp ( 'or' AndExp )* 14 | AndExp ::= ROpExp (' and' ROpExp )* 15 | ROpExp ::= PlusSubExp [ ('>' | '<') PlusSubExp ] 16 | PlusSubExp ::= MulDivExp ( ['+' | '-'] MulDivExp )* 17 | MulDivExp ::= PrimaryExp ( ['*' | '/'] PrimaryExp )* 18 | PrimaryExp ::= '(' Exp ')' | Identifier | Number | Bool 19 | 20 | Bool ::= 'true' | 'false' 21 | Number ::= ([0-9])+ 22 | Identifier ::= [A-Za-z][a-zA-Z0-9]* 23 | *) 24 | 25 | (* ----------------------------- opal.ml START ------------------------------ *) 26 | module LazyStream = struct 27 | type 'a t = Cons of 'a * 'a t Lazy.t | Nil 28 | let of_stream stream = 29 | let rec next stream = 30 | try Cons(Stream.next stream, lazy (next stream)) 31 | with Stream.Failure -> Nil 32 | in 33 | next stream 34 | let of_string str = str |> Stream.of_string |> of_stream 35 | let of_channel ic = ic |> Stream.of_channel |> of_stream 36 | let of_function f = 37 | let rec next f = 38 | match f () with 39 | | Some x -> Cons(x, lazy (next f)) 40 | | None -> Nil 41 | in 42 | next f 43 | end 44 | let implode l = String.concat "" (List.map (String.make 1) l) 45 | let explode s = 46 | let l = ref [] in 47 | String.iter (fun c -> l := c :: !l) s; 48 | List.rev !l 49 | let (%) f g = fun x -> g (f x) 50 | type 'token input = 'token LazyStream.t 51 | type ('token, 'result) parser = 'token input -> ('result * 'token input) option 52 | let parse parser input = 53 | match parser input with 54 | | Some(res, _) -> Some res 55 | | None -> None 56 | let return x input = Some(x, input) 57 | let (>>=) x f = 58 | fun input -> 59 | match x input with 60 | | Some(result', input') -> f result' input' 61 | | None -> None 62 | let (<|>) x y = 63 | fun input -> 64 | match x input with 65 | | Some _ as ret -> ret 66 | | None -> y input 67 | let rec scan x input = 68 | match x input with 69 | | Some(result', input') -> LazyStream.Cons(result', lazy (scan x input')) 70 | | None -> LazyStream.Nil 71 | let mzero _ = None 72 | let any = function 73 | | LazyStream.Cons(token, input') -> Some(token, Lazy.force input') 74 | | LazyStream.Nil -> None 75 | let satisfy test = any >>= (fun res -> if test res then return res else mzero) 76 | let eof x = function LazyStream.Nil -> Some(x, LazyStream.Nil) | _ -> None 77 | let (=>) x f = x >>= fun r -> return (f r) 78 | let (>>) x y = x >>= fun _ -> y 79 | let (<<) x y = x >>= fun r -> y >>= fun _ -> return r 80 | let (<~>) x xs = x >>= fun r -> xs >>= fun rs -> return (r :: rs) 81 | let rec choice = function [] -> mzero | h :: t -> (h <|> choice t) 82 | let rec count n x = if n > 0 then x <~> count (n - 1) x else return [] 83 | let between op ed x = op >> x << ed 84 | let option default x = x <|> return default 85 | let optional x = option () (x >> return ()) 86 | let rec skip_many x = option () (x >>= fun _ -> skip_many x) 87 | let skip_many1 x = x >> skip_many x 88 | let rec many x = option [] (x >>= fun r -> many x >>= fun rs -> return (r :: rs)) 89 | let many1 x = x <~> many x 90 | let sep_by1 x sep = x <~> many (sep >> x) 91 | let sep_by x sep = sep_by1 x sep <|> return [] 92 | let end_by1 x sep = sep_by1 x sep << sep 93 | let end_by x sep = end_by1 x sep <|> return [] 94 | let chainl1 x op = 95 | let rec loop a = (op >>= fun f -> x >>= fun b -> loop (f a b)) <|> return a in 96 | x >>= loop 97 | let chainl x op default = chainl1 x op <|> return default 98 | let rec chainr1 x op = 99 | x >>= fun a -> (op >>= fun f -> chainr1 x op >>= f a) <|> return a 100 | let chainr x op default = chainr1 x op <|> return default 101 | let exactly x = satisfy ((=) x) 102 | let one_of l = satisfy (fun x -> List.mem x l) 103 | let none_of l = satisfy (fun x -> not (List.mem l x)) 104 | let range l r = satisfy (fun x -> l <= x && x <= r) 105 | let space = one_of [' '; '\t'; '\r'; '\n'] 106 | let spaces = skip_many space 107 | let newline = exactly '\n' 108 | let tab = exactly '\t' 109 | let upper = range 'A' 'Z' 110 | let lower = range 'a' 'z' 111 | let digit = range '0' '9' 112 | let letter = lower <|> upper 113 | let alpha_num = letter <|> digit 114 | let hex_digit = range 'a' 'f' <|> range 'A' 'F' 115 | let oct_digit = range '0' '7' 116 | let lexeme x = spaces >> x 117 | let token s = 118 | let rec loop s i = 119 | if i >= String.length s 120 | then return s 121 | else exactly s.[i] >> loop s (i + 1) 122 | in 123 | lexeme (loop s 0) 124 | (* ------------------------------ opal.ml END ------------------------------- *) 125 | 126 | 127 | type exp = PlusExp of exp * exp 128 | | SubExp of exp * exp 129 | | MulExp of exp * exp 130 | | DivExp of exp * exp 131 | | Variable of string 132 | | Number of int 133 | | LTExp of exp * exp 134 | | GTExp of exp * exp 135 | | AndExp of exp * exp 136 | | OrExp of exp * exp 137 | | Bool of bool 138 | 139 | type prog = Stmts of prog list 140 | | Assign of string * exp 141 | | IfElse of exp * prog * prog 142 | | While of exp * prog 143 | 144 | exception Syntax_error 145 | exception Runtime_error 146 | 147 | (* parser *) 148 | 149 | let reserved = [ 150 | "true"; 151 | "false"; 152 | "if"; 153 | "then"; 154 | "else"; 155 | "while"; 156 | "do"; 157 | "and"; 158 | "or"; 159 | ] 160 | 161 | let ident = (spaces >> letter <~> many alpha_num) => implode >>= function 162 | | s when List.mem s reserved -> mzero 163 | | s -> return s 164 | 165 | let number = spaces >> many1 digit => implode % int_of_string 166 | 167 | let parens = between (token "(") (token ")") 168 | let addop = token "+" >> return (fun x y -> PlusExp(x, y)) 169 | let subop = token "-" >> return (fun x y -> SubExp(x, y)) 170 | let mulop = token "*" >> return (fun x y -> MulExp(x, y)) 171 | let divop = token "/" >> return (fun x y -> DivExp(x, y)) 172 | let ltop = token "<" >> return (fun x y -> LTExp(x, y)) 173 | let gtop = token ">" >> return (fun x y -> GTExp(x, y)) 174 | let orop = token "or" >> return (fun x y -> OrExp(x, y)) 175 | let andop = token "and" >> return (fun x y -> AndExp(x, y)) 176 | let atom = (ident => (fun s -> Variable s)) 177 | <|> (number => (fun x -> Number x)) 178 | <|> (token "true" >> return (Bool true)) 179 | <|> (token "false" >> return (Bool false)) 180 | 181 | let rec expr input = (chainl1 and_expr orop) input 182 | and and_expr input = (chainl1 rop_expr andop) input 183 | and rop_expr input = (chainl1 add_expr (ltop <|> gtop)) input 184 | and add_expr input = (chainl1 mul_expr (addop <|> subop)) input 185 | and mul_expr input = (chainl1 prm_expr (mulop <|> divop)) input 186 | and prm_expr input = (parens expr <|> atom) input 187 | 188 | let rec stmts input = (sep_by1 stmt (token ";") => (fun l -> Stmts l)) input 189 | and stmt input = (if_stmt <|> while_stmt <|> assign_stmt) input 190 | and if_stmt input = 191 | (token "if" >> (* if *) 192 | expr >>= fun pred -> 193 | token "then" >> (* then *) 194 | token "{" >> (* { *) 195 | stmts >>= fun thn -> 196 | token "}" >> (* } *) 197 | token "else" >> (* else *) 198 | token "{" >> (* { *) 199 | stmts >>= fun els -> 200 | token "}" >> 201 | return (IfElse (pred, thn, els))) input 202 | and while_stmt input = 203 | (token "while" >> (* while *) 204 | expr >>= fun guard -> 205 | token "do" >> (* do *) 206 | token "{" >> (* { *) 207 | stmts >>= fun body -> 208 | token "}" >> 209 | return (While (guard, body))) input 210 | and assign_stmt input = 211 | (ident >>= fun lhs -> 212 | token ":=" >> 213 | expr >>= fun rhs -> 214 | return (Assign (lhs, rhs))) input 215 | 216 | let prog = stmts << (spaces << eof ()) 217 | let parse_prog input = parse prog input 218 | 219 | (* eval *) 220 | let rec eval prog env = 221 | match prog with 222 | | Stmts [] -> () 223 | | Stmts (x::xs) -> 224 | eval x env; 225 | eval (Stmts xs) env 226 | | Assign (lhs, rhs) -> 227 | let value = eval_aexp rhs env in 228 | Hashtbl.replace env lhs value 229 | | IfElse (pred, thn, els) -> 230 | if (eval_bexp pred env) then 231 | eval thn env 232 | else 233 | eval els env 234 | | While (guard, body) -> 235 | let rec loop () = 236 | if (eval_bexp guard env) then 237 | begin 238 | eval body env; 239 | loop () 240 | end 241 | else () 242 | in 243 | loop () 244 | 245 | and eval_aexp aexp env = 246 | match aexp with 247 | | PlusExp (l, r) -> 248 | let l' = eval_aexp l env 249 | and r' = eval_aexp r env in 250 | l' + r' 251 | | SubExp (l, r) -> 252 | let l' = eval_aexp l env 253 | and r' = eval_aexp r env in 254 | l' - r' 255 | | MulExp (l, r) -> 256 | let l' = eval_aexp l env 257 | and r' = eval_aexp r env in 258 | l' * r' 259 | | DivExp (l, r) -> 260 | let l' = eval_aexp l env 261 | and r' = eval_aexp r env in 262 | l' / r' 263 | | Variable x -> Hashtbl.find env x 264 | | Number n -> n 265 | | _ -> raise Runtime_error 266 | 267 | and eval_bexp bexp env = 268 | match bexp with 269 | | LTExp (l, r) -> 270 | let l' = eval_aexp l env 271 | and r' = eval_aexp r env in 272 | l' < r' 273 | | GTExp (l, r) -> 274 | let l' = eval_aexp l env 275 | and r' = eval_aexp r env in 276 | l' > r' 277 | | AndExp (l, r) -> 278 | let l' = eval_bexp l env 279 | and r' = eval_bexp r env in 280 | l' && r' 281 | | OrExp (l, r) -> 282 | let l' = eval_bexp l env 283 | and r' = eval_bexp r env in 284 | l' || r' 285 | | Bool b -> b 286 | | _ -> raise Runtime_error 287 | 288 | let () = 289 | let src = LazyStream.of_channel stdin in 290 | match parse_prog src with 291 | | None -> raise Syntax_error 292 | | Some prog -> 293 | let env = Hashtbl.create 16 in 294 | eval prog env; 295 | let pairs = Hashtbl.fold (fun k v acc -> (k, v) :: acc) env [] in 296 | let pairs' = List.sort (fun (k1, _) (k2, _) -> compare k1 k2) pairs in 297 | List.iter (fun (k, v) -> Printf.printf "%s %d\n" k v) pairs' 298 | -------------------------------------------------------------------------------- /opal.ml: -------------------------------------------------------------------------------- 1 | (* lazy stream -------------------------------------------------------------- *) 2 | 3 | module LazyStream = struct 4 | type 'a t = Cons of 'a * 'a t Lazy.t | Nil 5 | 6 | let of_stream stream = 7 | let rec next stream = 8 | try Cons(Stream.next stream, lazy (next stream)) 9 | with Stream.Failure -> Nil 10 | in 11 | next stream 12 | 13 | let of_function f = 14 | let rec next f = 15 | match f () with 16 | | Some x -> Cons(x, lazy (next f)) 17 | | None -> Nil 18 | in 19 | next f 20 | 21 | let of_string str = str |> Stream.of_string |> of_stream 22 | let of_channel ic = ic |> Stream.of_channel |> of_stream 23 | end 24 | 25 | (* utilities ---------------------------------------------------------------- *) 26 | 27 | let implode l = String.concat "" (List.map (String.make 1) l) 28 | 29 | let explode s = 30 | let l = ref [] in 31 | String.iter (fun c -> l := c :: !l) s; 32 | List.rev !l 33 | 34 | let (%) f g = fun x -> g (f x) 35 | 36 | let parse parser input = 37 | match parser input with 38 | | Some(res, _) -> Some res 39 | | None -> None 40 | 41 | (* primitives --------------------------------------------------------------- *) 42 | 43 | type 'token input = 'token LazyStream.t 44 | type ('token, 'result) monad = ('result * 'token input) option 45 | type ('token, 'result) parser = 'token input -> ('result * 'token input) option 46 | 47 | let return x input = Some(x, input) 48 | 49 | let (>>=) x f = 50 | fun input -> 51 | match x input with 52 | | Some(result', input') -> f result' input' 53 | | None -> None 54 | 55 | let (let*) = (>>=) 56 | 57 | let (<|>) x y = 58 | fun input -> 59 | match x input with 60 | | Some _ as ret -> ret 61 | | None -> y input 62 | 63 | let rec scan x input = 64 | match x input with 65 | | Some(result', input') -> LazyStream.Cons(result', lazy (scan x input')) 66 | | None -> LazyStream.Nil 67 | 68 | let mzero _ = None 69 | 70 | let any = function 71 | | LazyStream.Cons(token, input') -> Some(token, Lazy.force input') 72 | | LazyStream.Nil -> None 73 | 74 | let satisfy test = 75 | any >>= (fun res -> if test res then return res else mzero) 76 | 77 | let eof x = function 78 | | LazyStream.Nil -> Some(x, LazyStream.Nil) 79 | | _ -> None 80 | 81 | (* derived combinators ------------------------------------------------------ *) 82 | 83 | let (=>) x f = x >>= fun r -> return (f r) 84 | let (>>) x y = x >>= fun _ -> y 85 | let (<<) x y = x >>= fun r -> y >>= fun _ -> return r 86 | let (<~>) x xs = x >>= fun r -> xs >>= fun rs -> return (r :: rs) 87 | 88 | let rec choice = function 89 | | [] -> mzero 90 | | h :: t -> h <|> choice t 91 | 92 | let rec count n x = 93 | if n > 0 94 | then x <~> count (n - 1) x 95 | else return [] 96 | 97 | let between op ed x = op >> x << ed 98 | 99 | let option default x = x <|> return default 100 | let optional x = option () (x >> return ()) 101 | 102 | let rec skip_many x = option () (x >>= fun _ -> skip_many x) 103 | let skip_many1 x = x >> skip_many x 104 | 105 | let rec many x = option [] (x >>= fun r -> many x >>= fun rs -> return (r :: rs)) 106 | let many1 x = x <~> many x 107 | 108 | let sep_by1 x sep = x <~> many (sep >> x) 109 | let sep_by x sep = sep_by1 x sep <|> return [] 110 | 111 | let end_by1 x sep = sep_by1 x sep << sep 112 | let end_by x sep = end_by1 x sep <|> return [] 113 | 114 | let chainl1 x op = 115 | let rec loop a = 116 | (op >>= fun f -> x >>= fun b -> loop (f a b)) <|> return a 117 | in 118 | x >>= loop 119 | let chainl x op default = chainl1 x op <|> return default 120 | 121 | let rec chainr1 x op = 122 | x >>= fun a -> (op >>= fun f -> chainr1 x op => f a) <|> return a 123 | let chainr x op default = chainr1 x op <|> return default 124 | 125 | (* singletons --------------------------------------------------------------- *) 126 | 127 | let exactly x = satisfy ((=) x) 128 | let one_of l = satisfy (fun x -> List.mem x l) 129 | let none_of l = satisfy (fun x -> not (List.mem x l)) 130 | let range l r = satisfy (fun x -> l <= x && x <= r) 131 | 132 | (* char parsers ------------------------------------------------------------- *) 133 | 134 | let space = one_of [' '; '\t'; '\r'; '\n'] 135 | let spaces = skip_many space 136 | let newline = exactly '\n' 137 | let tab = exactly '\t' 138 | let upper = range 'A' 'Z' 139 | let lower = range 'a' 'z' 140 | let digit = range '0' '9' 141 | let letter = lower <|> upper 142 | let alpha_num = letter <|> digit 143 | let hex_digit = range 'a' 'f' <|> range 'A' 'F' <|> digit 144 | let oct_digit = range '0' '7' 145 | 146 | (* lex helper --------------------------------------------------------------- *) 147 | 148 | let lexeme x = spaces >> x 149 | 150 | let token s = 151 | let rec loop s i = 152 | if i >= String.length s 153 | then return s 154 | else exactly s.[i] >> loop s (i + 1) 155 | in 156 | lexeme (loop s 0) 157 | -------------------------------------------------------------------------------- /opal.mli: -------------------------------------------------------------------------------- 1 | module LazyStream : 2 | sig 3 | type 'a t = Cons of 'a * 'a t Lazy.t | Nil 4 | val of_stream : 'a Stream.t -> 'a t 5 | val of_function : (unit -> 'a option) -> 'a t 6 | val of_string : string -> char t 7 | val of_channel : in_channel -> char t 8 | end 9 | 10 | val implode : char list -> string 11 | val explode : string -> char list 12 | val ( % ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c 13 | 14 | type ('token, 'result) parser 15 | val parse : ('token, 'a) parser -> 'token LazyStream.t -> 'a option 16 | 17 | val return : 'a -> ('token, 'a) parser 18 | val ( >>= ) : 19 | ('token, 'a) parser -> ('a -> ('token, 'b) parser) -> ('token, 'b) parser 20 | val ( let* ) : 21 | ('token, 'a) parser -> ('a -> ('token, 'b) parser) -> ('token, 'b) parser 22 | val ( <|> ) : ('token, 'a) parser -> ('token, 'a) parser -> ('token, 'a) parser 23 | val scan : ('token, 'a) parser -> 'token LazyStream.t -> 'a LazyStream.t 24 | val mzero : ('token, 'a) parser 25 | val any : ('token, 'token) parser 26 | val satisfy : ('token -> bool) -> ('token, 'token) parser 27 | val eof : 'a -> ('token, 'a) parser 28 | 29 | val ( => ) : ('token, 'a) parser -> ('a -> 'b) -> ('token, 'b) parser 30 | val ( << ) : ('token, 'a) parser -> ('token, 'b) parser -> ('token, 'a) parser 31 | val ( >> ) : ('token, 'a) parser -> ('token, 'b) parser -> ('token, 'b) parser 32 | val ( <~> ) : 33 | ('token, 'a) parser -> ('token, 'a list) parser -> ('token, 'a list) parser 34 | 35 | val choice : ('token, 'a) parser list -> ('token, 'a) parser 36 | val count : int -> ('token, 'a) parser -> ('token, 'a list) parser 37 | val between : 38 | ('token, 'a) parser -> ('token, 'b) parser -> 39 | ('token, 'c) parser -> ('token, 'c) parser 40 | val option : 'a -> ('token, 'a) parser -> ('token, 'a) parser 41 | val optional : ('token, 'a) parser -> ('token, unit) parser 42 | val skip_many1 : ('token, 'a) parser -> ('token, unit) parser 43 | val skip_many : ('token, 'a) parser -> ('token, unit) parser 44 | val many1 : ('token, 'a) parser -> ('token, 'a list) parser 45 | val many : ('token, 'a) parser -> ('token, 'a list) parser 46 | val sep_by1 : 47 | ('token, 'a) parser -> ('token, 'b) parser -> ('token, 'a list) parser 48 | val sep_by : 49 | ('token, 'a) parser -> ('token, 'b) parser -> ('token, 'a list) parser 50 | val end_by1 : 51 | ('token, 'a) parser -> ('token, 'b) parser -> ('token, 'a list) parser 52 | val end_by : 53 | ('token, 'a) parser -> ('token, 'b) parser -> ('token, 'a list) parser 54 | val chainl1 : 55 | ('token, 'a) parser -> ('token, 'a -> 'a -> 'a) parser -> ('token, 'a) parser 56 | val chainl : 57 | ('token, 'a) parser -> ('token, 'a -> 'a -> 'a) parser -> 'a -> ('token, 'a) parser 58 | val chainr1 : 59 | ('token, 'a) parser -> ('token, 'a -> 'a -> 'a) parser -> ('token, 'a) parser 60 | val chainr : 61 | ('token, 'a) parser -> ('token, 'a -> 'a -> 'a) parser -> 'a -> ('token, 'a) parser 62 | 63 | val exactly : 'token -> ('token, 'token) parser 64 | val one_of : 'token list -> ('token, 'token) parser 65 | val none_of : 'token list -> ('token, 'token) parser 66 | val range : 'token -> 'token -> ('token, 'token) parser 67 | 68 | val space : (char, char) parser 69 | val spaces : (char, unit) parser 70 | val newline : (char, char) parser 71 | val tab : (char, char) parser 72 | val upper : (char, char) parser 73 | val lower : (char, char) parser 74 | val digit : (char, char) parser 75 | val letter : (char, char) parser 76 | val alpha_num : (char, char) parser 77 | val hex_digit : (char, char) parser 78 | val oct_digit : (char, char) parser 79 | 80 | val lexeme : (char, 'a) parser -> (char, 'a) parser 81 | val token : string -> (char, string) parser 82 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "opal" 3 | version: "0.1.1" 4 | maintainer: "Linjie Ding " 5 | authors: "Linjie Ding " 6 | homepage: "https://github.com/pyrocat101/opal" 7 | bug-reports: "https://github.com/pyrocat101/opal/issues" 8 | license: "MIT" 9 | dev-repo: "https://github.com/pyrocat101/opal.git" 10 | available: [ ocaml-version >= "4.08.0" ] 11 | build: [ 12 | ["%{make}%" "ncl" "bcl"] 13 | ] 14 | install: [ 15 | ["%{make}%" "libinstall"] 16 | ] 17 | remove: [ 18 | ["ocamlfind" "remove" "opal"] 19 | ] 20 | depends: [ 21 | "ocamlfind" {build} 22 | ] 23 | --------------------------------------------------------------------------------