├── .appveyor.yml ├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── .readthedocs.yaml ├── CONTRIBUTING.rst ├── ChangeLog.md ├── DEVELOPER.md ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── app └── Main.lhs ├── build-windows-dist.sh ├── cabal.haskell-ci ├── cabal.project ├── doc ├── .gitignore ├── Happy.gif ├── Makefile ├── attribute-grammars.rst ├── conf.py ├── contributing.rst ├── glr.rst ├── index.rst ├── info-files.rst ├── introduction.rst ├── invoking.rst ├── make.bat ├── obtaining.rst ├── requirements.txt ├── syntax.rst ├── tips.rst └── using.rst ├── examples ├── Calc.ly ├── DavesExample.ly ├── ErlParser.ly ├── ErrorTest.ly ├── LexerTest.ly ├── MonadTest.ly ├── PgnParser.ly ├── README ├── SimonsExample.ly ├── glr │ ├── .gitignore │ ├── Makefile │ ├── Makefile.defs │ ├── bio-eg │ │ ├── 1-1200.dna │ │ ├── 1-600.dna │ │ ├── Bio.y │ │ ├── Main.lhs │ │ ├── Makefile │ │ └── README │ ├── common │ │ ├── DV_lhs │ │ └── DaVinciTypes.hs │ ├── expr-eval │ │ ├── Expr.y │ │ ├── Hugs.lhs │ │ ├── Main.lhs │ │ ├── Makefile │ │ └── README │ ├── expr-monad │ │ ├── Expr.y │ │ ├── Hugs.lhs │ │ ├── Main.lhs │ │ ├── Makefile │ │ └── README │ ├── expr-tree │ │ ├── Expr.y │ │ ├── Hugs.lhs │ │ ├── Main.lhs │ │ ├── Makefile │ │ ├── README │ │ └── Tree.lhs │ ├── hidden-leftrec │ │ ├── Expr.y │ │ ├── Hugs.lhs │ │ ├── Main.lhs │ │ ├── Makefile │ │ └── README │ ├── highly-ambiguous │ │ ├── Expr.y │ │ ├── Hugs.lhs │ │ ├── Main.lhs │ │ ├── Makefile │ │ └── README │ ├── nlp │ │ ├── English.y │ │ ├── Hugs.lhs │ │ ├── Main.lhs │ │ ├── Makefile │ │ └── README │ └── packing │ │ ├── Expr.y │ │ ├── Hugs.lhs │ │ ├── Main.lhs │ │ ├── Makefile │ │ └── README └── igloo │ ├── Foo.hs │ ├── Lexer.x │ ├── Makefile │ ├── Parser.y │ ├── ParserM.hs │ └── README ├── hackage-upload.sh ├── happy.cabal ├── lib ├── ChangeLog.md ├── README.md ├── backend-glr │ ├── LICENSE │ ├── Setup.hs │ └── src │ │ └── Happy │ │ └── Backend │ │ ├── GLR.hs │ │ └── GLR │ │ └── ProduceCode.lhs ├── backend-lalr │ ├── LICENSE │ ├── Setup.hs │ └── src │ │ └── Happy │ │ └── Backend │ │ ├── LALR.hs │ │ └── LALR │ │ └── ProduceCode.lhs ├── data │ ├── GLR_Base.hs │ ├── GLR_Lib.hs │ └── HappyTemplate.hs ├── frontend │ ├── LICENSE │ ├── Setup.hs │ ├── boot-src │ │ ├── AttrGrammarParser.ly │ │ └── Parser.ly │ ├── bootstrap.sh │ └── src │ │ └── Happy │ │ ├── Frontend.hs │ │ └── Frontend │ │ ├── AbsSyn.lhs │ │ ├── AttrGrammar.lhs │ │ ├── AttrGrammar │ │ ├── Mangler.lhs │ │ └── Parser.hs │ │ ├── Lexer.lhs │ │ ├── Mangler.lhs │ │ ├── Mangler │ │ └── Monad.lhs │ │ ├── ParamRules.hs │ │ ├── ParseMonad.hs │ │ ├── ParseMonad │ │ └── Class.hs │ │ ├── Parser.hs │ │ └── PrettyGrammar.hs ├── grammar │ ├── LICENSE │ ├── Setup.hs │ └── src │ │ └── Happy │ │ ├── Grammar.lhs │ │ └── Grammar │ │ └── ExpressionWithHole.hs ├── hackage-upload.sh ├── happy-lib.cabal └── tabular │ ├── LICENSE │ ├── Setup.hs │ └── src │ └── Happy │ ├── Tabular.lhs │ └── Tabular │ ├── First.lhs │ ├── Info.lhs │ ├── LALR.lhs │ └── NameSet.hs ├── test.hs └── tests ├── .gitignore ├── AttrGrammar001.y ├── AttrGrammar002.y ├── Makefile ├── ParGF.y ├── Partial.ly ├── Test.ly ├── TestMulti.ly ├── TestPrecedence.ly ├── bogus-token.y ├── bug001.ly ├── bug002.y ├── catch-shift-reduce.y ├── error001.stderr ├── error001.stdout ├── error001.y ├── issue131.y ├── issue265.y ├── issue91.y ├── issue93.y ├── issue94.y ├── issue95.y ├── monad001.y ├── monad002.ly ├── monaderror-explist.y ├── monaderror-lexer-explist.y ├── monaderror-newexplist.y ├── monaderror-resume.y ├── monaderror.y ├── precedence001.ly ├── precedence002.y ├── rank2.y ├── shift01.y ├── test_rules.y ├── typeclass_monad001.y ├── typeclass_monad002.ly └── typeclass_monad_lexer.y /.appveyor.yml: -------------------------------------------------------------------------------- 1 | version: "{build}" 2 | clone_folder: "c:/WORK" 3 | 4 | environment: 5 | global: 6 | CABOPTS: "--store-dir=c:/SR --http-transport=plain-http" 7 | C_INCLUDE_PATH: "c:/msys64/mingw64/include" 8 | LIBRARY_PATH: "c:/msys64/mingw64/lib;c:/msys64/mingw64/bin" 9 | APPVEYOR_SAVE_CACHE_ON_ERROR: true 10 | matrix: 11 | - GHCVER: "8.4.3" 12 | - GHCVER: "8.2.2" 13 | - GHCVER: "8.0.2" 14 | - GHCVER: "7.10.3.2" 15 | - GHCVER: "7.8.4.1" 16 | - GHCVER: "7.6.3.1" 17 | 18 | cache: 19 | - "c:/SR" 20 | 21 | install: 22 | - "cd c:/" 23 | - "choco install -y cabal" 24 | - "choco install -y ghc --version %GHCVER%" 25 | - "refreshenv" 26 | - "set PATH=C:\\msys64\\mingw64\\bin;C:\\msys64\\usr\\bin;%PATH%;C:\\ghc\\ghc-%GHCVERSION%\\bin;C:\\hsbin" 27 | - "cabal --version" 28 | - "ghc --version" 29 | - "cabal %CABOPTS% v2-update -vverbose+nowrap" 30 | 31 | build: off 32 | 33 | test_script: 34 | - "cd %APPVEYOR_BUILD_FOLDER%" 35 | - "cabal install happy -f -bootstrap --installdir=./bootstrap-root" 36 | - "cabal build happy -f +bootstrap --with-happy=%APPVEYOR_BUILD_FOLDER%/bootstrap-root/happy" 37 | - "cabal test -f +bootstrap" 38 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | .ghc.environment.* 4 | cabal-dev 5 | .cabal-sandbox 6 | cabal.sandbox.config 7 | .*.swp 8 | .*.swo 9 | /.vscode/ 10 | tests/*.hs 11 | -------------------------------------------------------------------------------- /.readthedocs.yaml: -------------------------------------------------------------------------------- 1 | # Read the Docs configuration file for Sphinx projects 2 | # See https://docs.readthedocs.io/en/stable/config-file/v2.html for details 3 | 4 | # Required 5 | version: 2 6 | 7 | # Set the OS, Python version and other tools you might need 8 | build: 9 | os: ubuntu-22.04 10 | tools: 11 | python: "3" 12 | # Latest 3.x 13 | # You can also specify other tool versions: 14 | # nodejs: "19" 15 | # rust: "1.64" 16 | # golang: "1.19" 17 | 18 | # Build documentation in the "doc/" directory with Sphinx 19 | sphinx: 20 | configuration: doc/conf.py 21 | 22 | # Optionally build your docs in additional formats such as PDF and ePub 23 | # formats: 24 | # - pdf 25 | # - epub 26 | 27 | # Declare the Python requirements required to build your documentation 28 | # See https://docs.readthedocs.io/en/stable/guides/reproducible-builds.html 29 | python: 30 | install: 31 | - requirements: doc/requirements.txt 32 | -------------------------------------------------------------------------------- /CONTRIBUTING.rst: -------------------------------------------------------------------------------- 1 | doc/contributing.rst -------------------------------------------------------------------------------- /DEVELOPER.md: -------------------------------------------------------------------------------- 1 | This document holds some useful information for developing Happy. 2 | 3 | CI on GitHub Actions 4 | ==================== 5 | 6 | 2024-07-15 7 | ---------- 8 | 9 | The GHC workflow file `.github/workflows/haskell-ci.yml` is generated by: 10 | 11 | haskell-ci regenerate 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The Happy License 2 | ----------------- 3 | 4 | Copyright 2001, Simon Marlow and Andy Gill. All rights reserved. 5 | 6 | Extensions to implement Tomita's Generalized LR parsing: 7 | Copyright 2004, University of Durham, Paul Callaghan and Ben Medlock. 8 | All rights reserved. 9 | 10 | Redistribution and use in source and binary forms, with or without 11 | modification, are permitted provided that the following conditions are met: 12 | 13 | - Redistributions of source code must retain the above copyright notice, 14 | this list of conditions and the following disclaimer. 15 | 16 | - Redistributions in binary form must reproduce the above copyright notice, 17 | this list of conditions and the following disclaimer in the documentation 18 | and/or other materials provided with the distribution. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY 21 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 23 | PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE 24 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 25 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 26 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR 27 | BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 28 | WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 29 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN 30 | IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | CABAL = cabal 2 | 3 | HAPPY_VER = `awk '/^version:/ { print $$2 }' happy.cabal` 4 | 5 | SDIST_DIR=dist-newstyle/sdist 6 | 7 | sdist :: 8 | @case "`$(CABAL) --numeric-version`" in \ 9 | 2.[2-9].* | [3-9].* ) ;; \ 10 | * ) echo "Error: needs cabal 2.2.0.0 or later (but got : `$(CABAL) --numeric-version`)" ; exit 1 ;; \ 11 | esac 12 | @if [ "`git status -s`" != '' ]; then \ 13 | echo "Error: Tree is not clean"; \ 14 | exit 1; \ 15 | fi 16 | $(CABAL) v2-sdist all 17 | @if [ ! -f "${SDIST_DIR}/happy-$(HAPPY_VER).tar.gz" ]; then \ 18 | echo "Error: source tarball not found: dist/happy-$(HAPPY_VER).tar.gz"; \ 19 | exit 1; \ 20 | fi 21 | git checkout . 22 | git clean -f 23 | 24 | sdist-test :: sdist sdist-test-only 25 | @rm -rf "${SDIST_DIR}/happy-${HAPPY_VER}/" 26 | 27 | sdist-test-only :: 28 | @if [ ! -f "${SDIST_DIR}/happy-$(HAPPY_VER).tar.gz" ]; then \ 29 | echo "Error: source tarball not found: ${SDIST_DIR}/happy-$(HAPPY_VER).tar.gz"; \ 30 | exit 1; \ 31 | fi 32 | rm -rf "${SDIST_DIR}/happy-$(HAPPY_VER)/" 33 | tar -xf "${SDIST_DIR}/happy-$(HAPPY_VER).tar.gz" -C ${SDIST_DIR}/ 34 | echo "packages: ." > "${SDIST_DIR}/happy-$(HAPPY_VER)/cabal.project" 35 | echo "tests: True" >> "${SDIST_DIR}/happy-$(HAPPY_VER)/cabal.project" 36 | cd "${SDIST_DIR}/happy-$(HAPPY_VER)/" \ 37 | && cabal v2-build all \ 38 | && cabal v2-test all -j 39 | @echo "" 40 | @echo "Success! ${SDIST_DIR}/happy-$(HAPPY_VER).tar.gz is ready for distribution!" 41 | @echo "" 42 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Happy 2 | 3 | [![Build Status](https://github.com/haskell/happy/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/haskell/happy/actions) 4 | 5 | Happy is a parser generator for Haskell 98 (and later). 6 | 7 | Happy Parsing! 8 | 9 | ## Documentation 10 | 11 | Documentation is hosted on [Read the Docs](https://haskell-happy.readthedocs.io): 12 | 13 | - [Online (HTML)](https://haskell-happy.readthedocs.io) 14 | - [PDF](https://haskell-happy.readthedocs.io/_/downloads/en/latest/pdf/) 15 | - [Downloadable HTML](https://haskell-happy.readthedocs.io/_/downloads/en/latest/htmlzip/) 16 | 17 | For basic information of the sort typically found in a read-me, see the following sections of the docs: 18 | 19 | - [Introduction](https://haskell-happy.readthedocs.io/en/latest/introduction.html) 20 | - [Obtaining Happy](https://haskell-happy.readthedocs.io/en/latest/obtaining.html) 21 | - [Contributing](https://haskell-happy.readthedocs.io/en/latest/contributing.html) 22 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /build-windows-dist.sh: -------------------------------------------------------------------------------- 1 | # mini script for building the relocatable Windows binary distribution. 2 | # 3 | # sh build-windows-dist.sh 4 | # 5 | # NB. the Cabal that shipped with GHC 6.6 isn't enough for this, because it 6 | # is missing this patch: 7 | # 8 | # Fri Oct 13 11:09:41 BST 2006 Simon Marlow 9 | # * Fix getDataDir etc. when bindir=$prefix 10 | # 11 | # So you need to use a more recent Cabal. GHC 6.6 is fine for building the 12 | # package, though. 13 | 14 | ghc --make Setup 15 | ./Setup configure --prefix=`pwd`/install --bindir='$prefix' --libdir='$prefix' --datadir='$prefix' 16 | ./Setup build 17 | ./Setup install 18 | echo Now zip up `pwd`/install as "happy--Win32.zip" 19 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | -- Specify 'constraint: ... installed' packages 2 | installed: +all -containers -mtl -transformers 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | lib/happy-lib.cabal 3 | happy.cabal 4 | -------------------------------------------------------------------------------- /doc/.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | -------------------------------------------------------------------------------- /doc/Happy.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell/happy/6596a2a193dfbfa694d67a05e5dfa6012c21cabe/doc/Happy.gif -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | # Minimal makefile for Sphinx documentation 2 | # 3 | 4 | # You can set these variables from the command line, and also 5 | # from the environment for the first two. 6 | SPHINXOPTS ?= 7 | SPHINXBUILD ?= sphinx-build 8 | SOURCEDIR = . 9 | BUILDDIR = _build 10 | 11 | # Flag -n ("nitpick") warns about broken references 12 | # Flag -W turns warnings into errors 13 | # Flag --keep-going continues after errors 14 | SPHINXOPTS := -n -W --keep-going -E 15 | 16 | .PHONY: help html Makefile 17 | 18 | # default goal, first 19 | html: Makefile 20 | @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) 21 | 22 | help: 23 | @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) 24 | 25 | # Catch-all target: route all unknown targets to Sphinx using the new 26 | # "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS). 27 | %: Makefile 28 | @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) 29 | -------------------------------------------------------------------------------- /doc/conf.py: -------------------------------------------------------------------------------- 1 | # Configuration file for the Sphinx documentation builder. 2 | # 3 | # This file only contains a selection of the most common options. For a full 4 | # list see the documentation: 5 | # https://www.sphinx-doc.org/en/master/usage/configuration.html 6 | 7 | # -- Path setup -------------------------------------------------------------- 8 | 9 | # If extensions (or modules to document with autodoc) are in another directory, 10 | # add these directories to sys.path here. If the directory is relative to the 11 | # documentation root, use os.path.abspath to make it absolute, like shown here. 12 | # 13 | # import os 14 | # import sys 15 | # sys.path.insert(0, os.path.abspath('.')) 16 | 17 | 18 | # -- Project information ----------------------------------------------------- 19 | 20 | project = 'Happy' 21 | copyright = '2022, Simon Marlow and the Happy developers' 22 | author = 'Simon Marlow and the Happy developers' 23 | 24 | 25 | # -- General configuration --------------------------------------------------- 26 | 27 | # Add any Sphinx extension module names here, as strings. They can be 28 | # extensions coming with Sphinx (named 'sphinx.ext.*') or your custom 29 | # ones. 30 | extensions = [ 31 | ] 32 | 33 | # Add any paths that contain templates here, relative to this directory. 34 | templates_path = ['_templates'] 35 | 36 | # List of patterns, relative to source directory, that match files and 37 | # directories to ignore when looking for source files. 38 | # This pattern also affects html_static_path and html_extra_path. 39 | exclude_patterns = ['_build', 'Thumbs.db', '.DS_Store'] 40 | 41 | 42 | # -- Options for HTML output ------------------------------------------------- 43 | 44 | # The theme to use for HTML and HTML Help pages. See the documentation for 45 | # a list of builtin themes. 46 | # 47 | html_theme = 'sphinx_rtd_theme' 48 | 49 | # # Add any paths that contain custom static files (such as style sheets) here, 50 | # # relative to this directory. They are copied after the builtin static files, 51 | # # so a file named "default.css" will overwrite the builtin "default.css". 52 | # html_static_path = ['_static'] 53 | 54 | # The name of the Pygments (syntax highlighting) style to use. 55 | pygments_style = 'sphinx' 56 | highlight_language = 'Peg' 57 | # Andreas Abel, 2022-02-27: Peg looked best from the "grammar" highlighters. 58 | # I also tried 'Bnf' and 'Abnf'. 59 | 60 | html_logo = "Happy.gif" 61 | -------------------------------------------------------------------------------- /doc/contributing.rst: -------------------------------------------------------------------------------- 1 | .. _contributing: 2 | 3 | Contributing to Happy 4 | ===================== 5 | 6 | .. highlight:: bash 7 | 8 | Source Code Repository 9 | ---------------------- 10 | 11 | Happy is hosted on `GitHub `__. 12 | As previously discussed in `bug-reports`_, we use the built-in `GitHub issue tracker `__ for Happy. 13 | We also use `GitHub pull requests `__ for managing changes; 14 | feel free to submit them! 15 | 16 | Repo Layout 17 | ----------- 18 | 19 | - ``app``: The source code for the Happy executable itself 20 | 21 | - ``lib/*``: The various internal libraries that make up the ``happy-lib`` 22 | package. This library is used to implement the ``happy`` executable behind the 23 | scenes, and is available for reuse for other purposes. 24 | 25 | - ``doc``: The documentation 26 | 27 | This is in reStructured Text format as is common for many Haskell tools' documentation. 28 | To build the documentation, use [Sphinx](https://www.sphinx-doc.org/). 29 | 30 | - ``examples``: Various examples of using Happy 31 | 32 | Build Instructions 33 | ------------------ 34 | 35 | Happy is mostly a normal Cabal-packaged Haskell executable:: 36 | 37 | $ cabal build 38 | 39 | The only wrinkle is that changing Happy's own parser (i.e. the frontend 40 | component that parses ``.y`` files) requires an existing Happy executable on 41 | the PATH to run ``lib/frontend/boostrap.sh``. 42 | 43 | Do *not* modify these files by hand:: 44 | 45 | lib/frontend/src/Happy/Frontend/Parser.hs 46 | lib/frontend/src/Happy/Frontend/AttrGrammar/Parser.hs 47 | 48 | Instead, edit these files:: 49 | 50 | lib/frontend/boot-src/Parser.ly 51 | lib/frontend/boot-src/AttrGrammarParser.ly 52 | 53 | and regenerate the ``.hs``-files with:: 54 | 55 | $ lib/frontend/bootstrap.sh 56 | -------------------------------------------------------------------------------- /doc/index.rst: -------------------------------------------------------------------------------- 1 | .. Happy documentation master file, created by sphinx-quickstart on Mon Feb 28 00:21:03 2022. 2 | You can adapt this file completely to your liking, but it should at least contain the root `toctree` directive. 3 | 4 | Welcome to Happy's documentation! 5 | ================================= 6 | 7 | .. toctree:: 8 | :maxdepth: 2 9 | :caption: Contents 10 | 11 | introduction 12 | obtaining 13 | using 14 | glr 15 | attribute-grammars 16 | invoking 17 | syntax 18 | info-files 19 | tips 20 | contributing 21 | 22 | 23 | 24 | Indices and tables 25 | ================== 26 | 27 | * :ref:`genindex` 28 | * :ref:`search` 29 | -------------------------------------------------------------------------------- /doc/invoking.rst: -------------------------------------------------------------------------------- 1 | 2 | .. _sec-invoking: 3 | 4 | Invoking Happy 5 | ============== 6 | 7 | An invocation of Happy has the following syntax: 8 | 9 | :: 10 | 11 | $ happy [ options ] filename [ options ] 12 | 13 | All the command line options are optional (!) and may occur either before or after the input file name. 14 | Options that take arguments may be given multiple times, and the last occurrence will be the value used. 15 | 16 | There are two types of grammar files, ``file.y`` and ``file.ly``, 17 | with the latter observing the reverse comment (or literate) convention 18 | (i.e. each code line must begin with the character ``>``, lines which don't begin with ``>`` are treated as comments). 19 | The examples distributed with Happy are all of the ``.ly`` form. 20 | 21 | .. index:: literate grammar files 22 | 23 | The flags accepted by Happy are as follows: 24 | 25 | ``-o ``; ``--outfile=`` 26 | Specifies the destination of the generated parser module. 27 | If omitted, the parser will be placed in \ ``.hs``, where is the name of the input file with any extension removed. 28 | 29 | ``-i []``; ``--info[=]`` 30 | 31 | .. index:: info file 32 | 33 | Directs Happy to produce an info file containing detailed information about the grammar, parser states, parser actions, and conflicts. 34 | Info files are vital during the debugging of grammars. 35 | The filename argument is optional. 36 | (note that there's no space between ``-i`` and the filename in the short version), 37 | and if omitted the info file will be written to \ ``.info`` 38 | (where is the input file name with any extension removed). 39 | 40 | ``-p []``; ``--pretty[=]`` 41 | 42 | .. index:: pretty print 43 | 44 | Directs Happy to produce a file containing a pretty-printed form of the grammar, containing only the productions, without any semantic actions or type signatures. 45 | If no file name is provided, then the file name will be computed by replacing the extension of the input file with ``.grammar``. 46 | 47 | ``-t ``; ``--template=`` 48 | 49 | .. index:: template files 50 | 51 | Instructs Happy to use this directory when looking for template files: these files contain the static code that Happy includes in every generated parser. 52 | You shouldn't need to use this option if Happy is properly configured for your computer. 53 | 54 | ``-m ``; ``--magic-name=`` 55 | Happy prefixes all the symbols it uses internally with either ``happy`` or ``Happy``. 56 | To use a different string, for example if the use of ``happy`` is conflicting with one of your own functions, specify the prefix using the ``-m`` option. 57 | 58 | ``-s``; ``--strict`` 59 | 60 | .. warning:: 61 | The ``--strict`` option is experimental and may cause unpredictable results. 62 | 63 | This option causes the right hand side of each production (the semantic value) to be evaluated eagerly at the moment the production is reduced. 64 | If the lazy behaviour is not required, then using this option will improve performance and may reduce space leaks. 65 | Note that the parser as a whole is never lazy - the whole input will always be consumed before any input is produced, regardless of the setting of the ``--strict`` flag. 66 | 67 | ``-g``; ``--ghc`` 68 | 69 | .. index:: 70 | single: GHC 71 | single: back-ends; GHC 72 | 73 | Instructs Happy to generate a parser that uses GHC-specific extensions to obtain faster code. 74 | 75 | ``-c``; ``--coerce`` 76 | 77 | .. index:: 78 | single: coerce 79 | single: back-ends; coerce 80 | 81 | Use GHC's ``unsafeCoerce#`` extension to generate smaller faster parsers. 82 | Type-safety isn't compromised. 83 | 84 | This option may only be used in conjunction with ``-g``. 85 | 86 | ``-a``; ``--arrays`` 87 | 88 | .. index:: 89 | single: arrays 90 | single: back-ends; arrays 91 | 92 | Instructs Happy to generate a parser using an array-based shift reduce parser. 93 | When used in conjunction with ``-g``, the arrays will be encoded as strings, resulting in faster parsers. 94 | Without ``-g``, standard Haskell arrays will be used. 95 | 96 | ``-d``; ``--debug`` 97 | 98 | .. index:: 99 | single: debug 100 | single: back-ends; debug 101 | 102 | Generate a parser that will print debugging information to ``stderr`` at run-time, including all the shifts, reductions, state transitions and token inputs performed by the parser. 103 | 104 | This option can only be used in conjunction with ``-a``. 105 | 106 | ``-l``; ``--glr`` 107 | 108 | .. index:: 109 | single: glr 110 | single: back-ends; glr 111 | 112 | Generate a GLR parser for ambiguous grammars. 113 | 114 | ``-k``; ``--decode`` 115 | 116 | .. index:: decode 117 | 118 | Generate simple decoding code for GLR result. 119 | 120 | ``-f``; ``--filter`` 121 | 122 | .. index:: filter 123 | 124 | Filter the GLR parse forest with respect to semantic usage. 125 | 126 | ``-?``; ``--help`` 127 | Print usage information on standard output then exit successfully. 128 | 129 | ``-V``; ``--version`` 130 | Print version information on standard output then exit successfully. 131 | Note that for legacy reasons ``-v`` is supported, too, but the use of it is deprecated. 132 | ``-v`` will be used for verbose mode when it is actually implemented. 133 | -------------------------------------------------------------------------------- /doc/make.bat: -------------------------------------------------------------------------------- 1 | @ECHO OFF 2 | 3 | pushd %~dp0 4 | 5 | REM Command file for Sphinx documentation 6 | 7 | if "%SPHINXBUILD%" == "" ( 8 | set SPHINXBUILD=sphinx-build 9 | ) 10 | set SOURCEDIR=. 11 | set BUILDDIR=_build 12 | 13 | if "%1" == "" goto help 14 | 15 | %SPHINXBUILD% >NUL 2>NUL 16 | if errorlevel 9009 ( 17 | echo. 18 | echo.The 'sphinx-build' command was not found. Make sure you have Sphinx 19 | echo.installed, then set the SPHINXBUILD environment variable to point 20 | echo.to the full path of the 'sphinx-build' executable. Alternatively you 21 | echo.may add the Sphinx directory to PATH. 22 | echo. 23 | echo.If you don't have Sphinx installed, grab it from 24 | echo.http://sphinx-doc.org/ 25 | exit /b 1 26 | ) 27 | 28 | %SPHINXBUILD% -M %1 %SOURCEDIR% %BUILDDIR% %SPHINXOPTS% %O% 29 | goto end 30 | 31 | :help 32 | %SPHINXBUILD% -M help %SOURCEDIR% %BUILDDIR% %SPHINXOPTS% %O% 33 | 34 | :end 35 | popd 36 | -------------------------------------------------------------------------------- /doc/obtaining.rst: -------------------------------------------------------------------------------- 1 | .. _sec-obtaining: 2 | 3 | Obtaining Happy 4 | =============== 5 | 6 | .. highlight:: bash 7 | 8 | If you just want to *use* Happy, you can build from a release. 9 | This should work the same as any other Haskell package. 10 | 11 | Happy itself and its examples are intended to work with GHC >= 7.0. 12 | 13 | Haskell-specific way 14 | -------------------- 15 | 16 | From `Hackage `__ via `Cabal Install `__:: 17 | 18 | $ cabal install happy 19 | 20 | From `Stackage `__ via `Stack `__:: 21 | 22 | $ stack install happy 23 | 24 | Moreover, ``cabal`` will automatically install the required version of ``happy`` based on ``build-tools``/``build-tool-depends`` `declarations `__. 25 | 26 | Operating System way 27 | -------------------- 28 | 29 | Because Happy is a dependency of GHC, it is often packaged by operating systems. 30 | `Repology `__ aggregates this info across many distros and operating systems, and Happy is actually listed twice: 31 | 32 | - https://repology.org/project/haskell:happy/versions 33 | - https://repology.org/project/happy/versions 34 | 35 | The table contains links to the individual OS packages, which should provide installation instructions. 36 | -------------------------------------------------------------------------------- /doc/requirements.txt: -------------------------------------------------------------------------------- 1 | Sphinx >= 7.2.5 2 | sphinx_rtd_theme >= 1.3.0 3 | -------------------------------------------------------------------------------- /examples/Calc.ly: -------------------------------------------------------------------------------- 1 | > { 2 | > module Calc where 3 | > import Char 4 | > } 5 | 6 | First thing to declare is the name of your parser, 7 | and the type of the tokens the parser reads. 8 | 9 | > %name calc 10 | > %tokentype { Token } 11 | 12 | The parser will be of type [Token] -> ?, where ? is determined by the 13 | production rules. Now we declare all the possible tokens: 14 | 15 | > %token 16 | > let { TokenLet } 17 | > in { TokenIn } 18 | > int { TokenInt $$ } 19 | > var { TokenVar $$ } 20 | > '=' { TokenEq } 21 | > '+' { TokenPlus } 22 | > '-' { TokenMinus } 23 | > '*' { TokenTimes } 24 | > '/' { TokenDiv } 25 | > '(' { TokenOB } 26 | > ')' { TokenCB } 27 | 28 | The left hand side are the names of the terminals or tokens, 29 | and the right hand side is how to pattern match them. 30 | 31 | Like yacc, we include %% here, for no real reason. 32 | 33 | > %% 34 | 35 | Now we have the production rules. 36 | 37 | > Exp :: { Exp } 38 | > Exp : let var '=' Exp in Exp { Let $2 $4 $6 } 39 | > | Exp1 { Exp1 $1 } 40 | > 41 | > Exp1 : Exp1 '+' Term { Plus $1 $3 } 42 | > | Exp1 '-' Term { Minus $1 $3 } 43 | > | Term { Term $1 } 44 | > 45 | > Term : Term '*' Factor { Times $1 $3 } 46 | > | Term '/' Factor { Div $1 $3 } 47 | > | Factor { Factor $1 } 48 | > 49 | > Factor : int { Int $1 } 50 | > | var { Var $1 } 51 | > | '(' Exp ')' { Brack $2 } 52 | 53 | We are simply returning the parsed data structure ! 54 | Now we need some extra code, to support this parser, 55 | and make in complete: 56 | 57 | > { 58 | 59 | All parsers must declare this function, 60 | which is called when an error is detected. 61 | Note that currently we do no error recovery. 62 | 63 | > happyError :: [Token] -> a 64 | > happyError _ = error ("Parse error\n") 65 | 66 | Now we declare the datastructure that we are parsing. 67 | 68 | > data Exp = Let String Exp Exp | Exp1 Exp1 69 | > data Exp1 = Plus Exp1 Term | Minus Exp1 Term | Term Term 70 | > data Term = Times Term Factor | Div Term Factor | Factor Factor 71 | > data Factor = Int Int | Var String | Brack Exp 72 | 73 | The datastructure for the tokens... 74 | 75 | > data Token 76 | > = TokenLet 77 | > | TokenIn 78 | > | TokenInt Int 79 | > | TokenVar String 80 | > | TokenEq 81 | > | TokenPlus 82 | > | TokenMinus 83 | > | TokenTimes 84 | > | TokenDiv 85 | > | TokenOB 86 | > | TokenCB 87 | 88 | .. and a simple lexer that returns this datastructure. 89 | 90 | > lexer :: String -> [Token] 91 | > lexer [] = [] 92 | > lexer (c:cs) 93 | > | isSpace c = lexer cs 94 | > | isAlpha c = lexVar (c:cs) 95 | > | isDigit c = lexNum (c:cs) 96 | > lexer ('=':cs) = TokenEq : lexer cs 97 | > lexer ('+':cs) = TokenPlus : lexer cs 98 | > lexer ('-':cs) = TokenMinus : lexer cs 99 | > lexer ('*':cs) = TokenTimes : lexer cs 100 | > lexer ('/':cs) = TokenDiv : lexer cs 101 | > lexer ('(':cs) = TokenOB : lexer cs 102 | > lexer (')':cs) = TokenCB : lexer cs 103 | 104 | > lexNum cs = TokenInt (read num) : lexer rest 105 | > where (num,rest) = span isDigit cs 106 | 107 | > lexVar cs = 108 | > case span isAlpha cs of 109 | > ("let",rest) -> TokenLet : lexer rest 110 | > ("in",rest) -> TokenIn : lexer rest 111 | > (var,rest) -> TokenVar var : lexer rest 112 | 113 | To run the program, call this in gofer, or use some code 114 | to print it. 115 | 116 | runCalc :: String -> Exp 117 | runCalc = calc . lexer 118 | 119 | Here we test our parser. 120 | 121 | main = case runCalc "1 + 2 + 3" of { 122 | (Exp1 (Plus (Plus (Term (Factor (Int 1))) (Factor (Int 2))) (Factor (Int 3)))) -> 123 | case runCalc "1 * 2 + 3" of { 124 | (Exp1 (Plus (Term (Times (Factor (Int 1)) (Int 2))) (Factor (Int 3)))) -> 125 | case runCalc "1 + 2 * 3" of { 126 | (Exp1 (Plus (Term (Factor (Int 1))) (Times (Factor (Int 2)) (Int 3)))) -> 127 | case runCalc "let x = 2 in x * (x - 2)" of { 128 | (Let "x" (Exp1 (Term (Factor (Int 2)))) (Exp1 (Term (Times (Factor (Var "x")) (Brack (Exp1 (Minus (Term (Factor (Var "x"))) (Factor (Int 2))))))))) -> print "AndysTest works\n" ; 129 | _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } 130 | quit = print "runCalc failed\n" 131 | 132 | > } 133 | -------------------------------------------------------------------------------- /examples/DavesExample.ly: -------------------------------------------------------------------------------- 1 | Parses simple lambda expressions to combinators 2 | 3 | > { 4 | 5 | > module Parser where 6 | 7 | > import Lexer 8 | > import Convert 9 | > import PreludeGlaArray 10 | 11 | > } 12 | 13 | > %name parse 14 | > %tokentype { Token } 15 | > %token idT { Ident $$ } 16 | > numT { Number $$ } 17 | > boolT { Boolean $$ } 18 | > "(" { LeftBracket } 19 | > ")" { RightBracket } 20 | > "[" { LeftSquare } 21 | > "]" { RightSquare } 22 | > "[]" { EmptyList } 23 | > ";" { SemiColon } 24 | > ":" { Colon } 25 | > "+" { Infix "+" } 26 | > "-" { Infix "-" } 27 | > "/" { Infix "/" } 28 | > "*" { Infix "*" } 29 | > "==" { Infix "==" } 30 | > "/=" { Infix "/=" } 31 | > ">" { Infix ">" } 32 | > "<" { Infix "<" } 33 | > ">=" { Infix ">=" } 34 | > "<=" { Infix "<=" } 35 | > "=" { Builtin "=" } 36 | > "else" { Builtin "else" } 37 | > "if" { Builtin "if" } 38 | > "in" { Builtin "in" } 39 | > "let" { Builtin "let" } 40 | > "then" { Builtin "then" } 41 | > "end" { Builtin "end" } 42 | > %% 43 | 44 | > P : "let" Dec "in" B { mkLet $2 $4} 45 | > | "if" B "then" B "else" B { mkIf $2 $4 $6} 46 | > | B { $1 } 47 | 48 | > B :: { Seq (Ptr Exp) } 49 | > B : E "==" E { mkOp $1 Equ $3 } 50 | > | E "/=" E { mkOp $1 NEq $3 } 51 | > | E ">" E { mkOp $1 GT $3 } 52 | > | E "<" E { mkOp $1 LT $3 } 53 | > | E ">=" E { mkOp $1 GTE $3 } 54 | > | E "<=" E { mkOp $1 LTE $3 } 55 | > | E { $1 } 56 | 57 | > E :: { Seq (Ptr Exp) } 58 | > E : E "+" T { mkOp $1 Add $3} 59 | > | E "-" T { mkOp $1 Sub $3} 60 | > | T { $1 } 61 | 62 | > T :: { Seq (Ptr Exp) } 63 | > T : T "*" F { mkOp $1 Mul $3 } 64 | > | T "/" F { mkOp $1 Quo $3 } 65 | > | F { $1 } 66 | 67 | > F :: { Seq (Ptr Exp) } 68 | > F : "(" B ")" { $2 } 69 | > | numT { mkNum $1 } 70 | > | boolT { mkBool $1 } 71 | > | idT { newPtr (mkVar $1) } 72 | > | Apps { mkApps $1 } 73 | 74 | > Apps :: { Seq [Ptr Exp] } 75 | > Apps : F Apps { mkApp $1 $2 } 76 | > | F { mkAtom $1 } 77 | 78 | > Dec :: { (Token,Seq (Ptr Exp)) } 79 | > Dec : idT Args "=" B { ($1, mkFun $1 $2 $4) } 80 | 81 | > Args :: { [Exp] } 82 | > Args : idT Args { mkVar $1 : $2} 83 | > | { [] } 84 | 85 | > { 86 | 87 | > happyError :: Text a => a -> b 88 | > happyError x = error ("Parse error, line " ++ show x ++ "\n") 89 | 90 | > } 91 | -------------------------------------------------------------------------------- /examples/ErrorTest.ly: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | Test for monadic Happy Parsers, Simon Marlow 1996. 3 | 4 | > { 5 | > import Data.Char 6 | > } 7 | 8 | > %name calc 9 | > %tokentype { Token } 10 | 11 | > %monad { P } { thenP } { returnP } 12 | > %lexer { lexer } { TokenEOF } 13 | 14 | > %token 15 | > let { TokenLet } 16 | > in { TokenIn } 17 | > int { TokenInt $$ } 18 | > var { TokenVar $$ } 19 | > '=' { TokenEq } 20 | > '+' { TokenPlus } 21 | > '-' { TokenMinus } 22 | > '*' { TokenTimes } 23 | > '/' { TokenDiv } 24 | > '(' { TokenOB } 25 | > ')' { TokenCB } 26 | 27 | > %% 28 | 29 | > Exp :: {Exp} 30 | > : let var '=' Exp in Exp {% \s l -> ParseOk (Let l $2 $4 $6) } 31 | > | Exp1 { Exp1 $1 } 32 | > 33 | > Exp1 :: {Exp1} 34 | > : Exp1 '+' Term { Plus $1 $3 } 35 | > | Exp1 '-' Term { Minus $1 $3 } 36 | > | Term { Term $1 } 37 | > | error { Term (Factor (Int 1)) } 38 | > 39 | > Term :: {Term} 40 | > : Term '*' Factor { Times $1 $3 } 41 | > | Term '/' Factor { Div $1 $3 } 42 | > | Factor { Factor $1 } 43 | > 44 | 45 | > Factor :: {Factor} 46 | > : int { Int $1 } 47 | > | var { Var $1 } 48 | > | '(' Exp ')' { Brack $2 } 49 | 50 | > { 51 | 52 | ----------------------------------------------------------------------------- 53 | The monad serves three purposes: 54 | 55 | * it passes the input string around 56 | * it passes the current line number around 57 | * it deals with success/failure. 58 | 59 | > data ParseResult a 60 | > = ParseOk a 61 | > | ParseFail String 62 | 63 | > type P a = String -> Int -> ParseResult a 64 | 65 | > thenP :: P a -> (a -> P b) -> P b 66 | > m `thenP` k = \s l -> 67 | > case m s l of 68 | > ParseFail s -> ParseFail s 69 | > ParseOk a -> k a s l 70 | 71 | > returnP :: a -> P a 72 | > returnP a = \s l -> ParseOk a 73 | 74 | ----------------------------------------------------------------------------- 75 | 76 | Now we declare the datastructure that we are parsing. 77 | 78 | > data Exp = Let Int String Exp Exp | Exp1 Exp1 79 | > data Exp1 = Plus Exp1 Term | Minus Exp1 Term | Term Term 80 | > data Term = Times Term Factor | Div Term Factor | Factor Factor 81 | > data Factor = Int Int | Var String | Brack Exp 82 | 83 | The datastructure for the tokens... 84 | 85 | > data Token 86 | > = TokenLet 87 | > | TokenIn 88 | > | TokenInt Int 89 | > | TokenVar String 90 | > | TokenEq 91 | > | TokenPlus 92 | > | TokenMinus 93 | > | TokenTimes 94 | > | TokenDiv 95 | > | TokenOB 96 | > | TokenCB 97 | > | TokenEOF 98 | 99 | .. and a simple lexer that returns this datastructure. 100 | 101 | > lexer :: (Token -> P a) -> P a 102 | > lexer cont s = case s of 103 | > [] -> cont TokenEOF [] 104 | > ('\n':cs) -> \line -> lexer cont cs (line+1) 105 | > (c:cs) 106 | > | isSpace c -> lexer cont cs 107 | > | isAlpha c -> lexVar (c:cs) 108 | > | isDigit c -> lexNum (c:cs) 109 | > ('=':cs) -> cont TokenEq cs 110 | > ('+':cs) -> cont TokenPlus cs 111 | > ('-':cs) -> cont TokenMinus cs 112 | > ('*':cs) -> cont TokenTimes cs 113 | > ('/':cs) -> cont TokenDiv cs 114 | > ('(':cs) -> cont TokenOB cs 115 | > (')':cs) -> cont TokenCB cs 116 | > where 117 | > lexNum cs = cont (TokenInt (read num)) rest 118 | > where (num,rest) = span isDigit cs 119 | > lexVar cs = 120 | > case span isAlpha cs of 121 | > ("let",rest) -> cont TokenLet rest 122 | > ("in",rest) -> cont TokenIn rest 123 | > (var,rest) -> cont (TokenVar var) rest 124 | 125 | > runCalc :: String -> Exp 126 | > runCalc s = case calc s 1 of 127 | > ParseOk e -> e 128 | > ParseFail s -> error s 129 | 130 | ----------------------------------------------------------------------------- 131 | The following functions should be defined for all parsers. 132 | 133 | This is the overall type of the parser. 134 | 135 | > type Parse = P Exp 136 | > calc :: Parse 137 | 138 | The next function is called when a parse error is detected. It has 139 | the same type as the top-level parse function. 140 | 141 | > happyError :: P a 142 | > happyError = \s i -> error ( 143 | > "Parse error in line " ++ show (i::Int) ++ "\n") 144 | 145 | ----------------------------------------------------------------------------- 146 | 147 | Here we test our parser. 148 | 149 | > main = case runCalc "1 + 2 + 3" of { 150 | > (Exp1 (Plus (Plus (Term (Factor (Int 1))) (Factor (Int 2))) (Factor (Int 3)))) -> 151 | > case runCalc "1 * 2 + 3" of { 152 | > (Exp1 (Plus (Term (Times (Factor (Int 1)) (Int 2))) (Factor (Int 3)))) -> 153 | > case runCalc "1 + 2 * 3" of { 154 | > (Exp1 (Plus (Term (Factor (Int 1))) (Times (Factor (Int 2)) (Int 3)))) -> 155 | > case runCalc "+ 2 * 3" of { 156 | > (Exp1 (Plus (Term (Factor (Int 1))) (Times (Factor (Int 2)) (Int 3)))) -> 157 | > case runCalc "let x = 2 in x * (x - 2)" of { 158 | > (Let 1 "x" (Exp1 (Term (Factor (Int 2)))) (Exp1 (Term (Times (Factor (Var "x")) (Brack (Exp1 (Minus (Term (Factor (Var "x"))) (Factor (Int 2))))))))) -> print "Test works\n"; 159 | > _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } 160 | > quit = print "Test failed\n" 161 | > } 162 | -------------------------------------------------------------------------------- /examples/LexerTest.ly: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | Test for monadic Happy Parsers, Simon Marlow 1996. 3 | 4 | > { 5 | > import Data.Char 6 | > } 7 | 8 | > %name calc 9 | > %tokentype { Token } 10 | 11 | > %monad { P } { thenP } { returnP } 12 | > %lexer { lexer } { TokenEOF } 13 | 14 | > %token 15 | > let { TokenLet } 16 | > in { TokenIn } 17 | > int { TokenInt $$ } 18 | > var { TokenVar $$ } 19 | > '=' { TokenEq } 20 | > '+' { TokenPlus } 21 | > '-' { TokenMinus } 22 | > '*' { TokenTimes } 23 | > '/' { TokenDiv } 24 | > '(' { TokenOB } 25 | > ')' { TokenCB } 26 | 27 | > %% 28 | 29 | > Exp :: {Exp} 30 | > : let var '=' Exp in Exp {% \s l -> ParseOk (Let l $2 $4 $6) } 31 | > | Exp1 { Exp1 $1 } 32 | > 33 | > Exp1 :: {Exp1} 34 | > : Exp1 '+' Term { Plus $1 $3 } 35 | > | Exp1 '-' Term { Minus $1 $3 } 36 | > | Term { Term $1 } 37 | > 38 | > Term :: {Term} 39 | > : Term '*' Factor { Times $1 $3 } 40 | > | Term '/' Factor { Div $1 $3 } 41 | > | Factor { Factor $1 } 42 | > 43 | 44 | > Factor :: {Factor} 45 | > : int { Int $1 } 46 | > | var { Var $1 } 47 | > | '(' Exp ')' { Brack $2 } 48 | 49 | > { 50 | 51 | ----------------------------------------------------------------------------- 52 | The monad serves three purposes: 53 | 54 | * it passes the input string around 55 | * it passes the current line number around 56 | * it deals with success/failure. 57 | 58 | > data ParseResult a 59 | > = ParseOk a 60 | > | ParseFail String 61 | 62 | > type P a = String -> Int -> ParseResult a 63 | 64 | > thenP :: P a -> (a -> P b) -> P b 65 | > m `thenP` k = \s l -> 66 | > case m s l of 67 | > ParseFail s -> ParseFail s 68 | > ParseOk a -> k a s l 69 | 70 | > returnP :: a -> P a 71 | > returnP a = \s l -> ParseOk a 72 | 73 | ----------------------------------------------------------------------------- 74 | 75 | Now we declare the datastructure that we are parsing. 76 | 77 | > data Exp = Let Int String Exp Exp | Exp1 Exp1 78 | > data Exp1 = Plus Exp1 Term | Minus Exp1 Term | Term Term 79 | > data Term = Times Term Factor | Div Term Factor | Factor Factor 80 | > data Factor = Int Int | Var String | Brack Exp 81 | 82 | The datastructure for the tokens... 83 | 84 | > data Token 85 | > = TokenLet 86 | > | TokenIn 87 | > | TokenInt Int 88 | > | TokenVar String 89 | > | TokenEq 90 | > | TokenPlus 91 | > | TokenMinus 92 | > | TokenTimes 93 | > | TokenDiv 94 | > | TokenOB 95 | > | TokenCB 96 | > | TokenEOF 97 | 98 | .. and a simple lexer that returns this datastructure. 99 | 100 | > lexer :: (Token -> P a) -> P a 101 | > lexer cont s = case s of 102 | > [] -> cont TokenEOF [] 103 | > ('\n':cs) -> \line -> lexer cont cs (line+1) 104 | > (c:cs) 105 | > | isSpace c -> lexer cont cs 106 | > | isAlpha c -> lexVar (c:cs) 107 | > | isDigit c -> lexNum (c:cs) 108 | > ('=':cs) -> cont TokenEq cs 109 | > ('+':cs) -> cont TokenPlus cs 110 | > ('-':cs) -> cont TokenMinus cs 111 | > ('*':cs) -> cont TokenTimes cs 112 | > ('/':cs) -> cont TokenDiv cs 113 | > ('(':cs) -> cont TokenOB cs 114 | > (')':cs) -> cont TokenCB cs 115 | > where 116 | > lexNum cs = cont (TokenInt (read num)) rest 117 | > where (num,rest) = span isDigit cs 118 | > lexVar cs = 119 | > case span isAlpha cs of 120 | > ("let",rest) -> cont TokenLet rest 121 | > ("in",rest) -> cont TokenIn rest 122 | > (var,rest) -> cont (TokenVar var) rest 123 | 124 | > runCalc :: String -> Exp 125 | > runCalc s = case calc s 1 of 126 | > ParseOk e -> e 127 | > ParseFail s -> error s 128 | 129 | ----------------------------------------------------------------------------- 130 | The following functions should be defined for all parsers. 131 | 132 | This is the overall type of the parser. 133 | 134 | > calc :: P Exp 135 | 136 | The next function is called when a parse error is detected. It has 137 | the same type as the top-level parse function. 138 | 139 | > happyError :: P a 140 | > happyError = \s i -> error ( 141 | > "Parse error in line " ++ show (i::Int) ++ "\n") 142 | 143 | ----------------------------------------------------------------------------- 144 | 145 | Here we test our parser. 146 | 147 | > main = case runCalc "1 + 2 + 3" of { 148 | > (Exp1 (Plus (Plus (Term (Factor (Int 1))) (Factor (Int 2))) (Factor (Int 3)))) -> 149 | > case runCalc "1 * 2 + 3" of { 150 | > (Exp1 (Plus (Term (Times (Factor (Int 1)) (Int 2))) (Factor (Int 3)))) -> 151 | > case runCalc "1 + 2 * 3" of { 152 | > (Exp1 (Plus (Term (Factor (Int 1))) (Times (Factor (Int 2)) (Int 3)))) -> 153 | > case runCalc "let x = 2 in x * (x - 2)" of { 154 | > (Let 1 "x" (Exp1 (Term (Factor (Int 2)))) (Exp1 (Term (Times (Factor (Var "x")) (Brack (Exp1 (Minus (Term (Factor (Var "x"))) (Factor (Int 2))))))))) -> print "Test works\n"; 155 | > _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } 156 | > quit = print "Test failed\n" 157 | > } 158 | -------------------------------------------------------------------------------- /examples/MonadTest.ly: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | Tests %monad without %lexer. 3 | 4 | > { 5 | > import Data.Char 6 | > } 7 | 8 | > %name calc 9 | > %tokentype { Token } 10 | 11 | > %monad { P } { thenP } { returnP } 12 | 13 | > %token 14 | > let { TokenLet } 15 | > in { TokenIn } 16 | > int { TokenInt $$ } 17 | > var { TokenVar $$ } 18 | > '=' { TokenEq } 19 | > '+' { TokenPlus } 20 | > '-' { TokenMinus } 21 | > '*' { TokenTimes } 22 | > '/' { TokenDiv } 23 | > '(' { TokenOB } 24 | > ')' { TokenCB } 25 | 26 | > %% 27 | 28 | > Exp :: {Exp} 29 | > : let var '=' Exp in Exp { Let $2 $4 $6 } 30 | > | Exp1 { Exp1 $1 } 31 | > 32 | > Exp1 :: {Exp1} 33 | > : Exp1 '+' Term { Plus $1 $3 } 34 | > | Exp1 '-' Term { Minus $1 $3 } 35 | > | Term { Term $1 } 36 | > 37 | > Term :: {Term} 38 | > : Term '*' Factor { Times $1 $3 } 39 | > | Term '/' Factor { Div $1 $3 } 40 | > | Factor { Factor $1 } 41 | > 42 | 43 | > Factor :: {Factor} 44 | > : int { Int $1 } 45 | > | var { Var $1 } 46 | > | '(' Exp ')' { Brack $2 } 47 | 48 | > { 49 | 50 | ----------------------------------------------------------------------------- 51 | The monad serves two purposes: 52 | 53 | * it passes the current line number around 54 | * it deals with success/failure. 55 | 56 | > data ParseResult a 57 | > = ParseOk a 58 | > | ParseFail String 59 | 60 | > type P a = Int -> ParseResult a 61 | 62 | > thenP :: P a -> (a -> P b) -> P b 63 | > m `thenP` k = \l -> 64 | > case m l of 65 | > ParseFail s -> ParseFail s 66 | > ParseOk a -> k a l 67 | 68 | > returnP :: a -> P a 69 | > returnP a = \l -> ParseOk a 70 | 71 | ----------------------------------------------------------------------------- 72 | 73 | Now we declare the datastructure that we are parsing. 74 | 75 | > data Exp = Let String Exp Exp | Exp1 Exp1 76 | > data Exp1 = Plus Exp1 Term | Minus Exp1 Term | Term Term 77 | > data Term = Times Term Factor | Div Term Factor | Factor Factor 78 | > data Factor = Int Int | Var String | Brack Exp 79 | 80 | The datastructure for the tokens... 81 | 82 | > data Token 83 | > = TokenLet 84 | > | TokenIn 85 | > | TokenInt Int 86 | > | TokenVar String 87 | > | TokenEq 88 | > | TokenPlus 89 | > | TokenMinus 90 | > | TokenTimes 91 | > | TokenDiv 92 | > | TokenOB 93 | > | TokenCB 94 | > | TokenEOF 95 | 96 | .. and a simple lexer that returns this datastructure. 97 | 98 | > lexer :: String -> [Token] 99 | > lexer [] = [] 100 | > lexer (c:cs) 101 | > | isSpace c = lexer cs 102 | > | isAlpha c = lexVar (c:cs) 103 | > | isDigit c = lexNum (c:cs) 104 | > lexer ('=':cs) = TokenEq : lexer cs 105 | > lexer ('+':cs) = TokenPlus : lexer cs 106 | > lexer ('-':cs) = TokenMinus : lexer cs 107 | > lexer ('*':cs) = TokenTimes : lexer cs 108 | > lexer ('/':cs) = TokenDiv : lexer cs 109 | > lexer ('(':cs) = TokenOB : lexer cs 110 | > lexer (')':cs) = TokenCB : lexer cs 111 | 112 | > lexNum cs = TokenInt (read num) : lexer rest 113 | > where (num,rest) = span isDigit cs 114 | 115 | > lexVar cs = 116 | > case span isAlpha cs of 117 | > ("let",rest) -> TokenLet : lexer rest 118 | > ("in",rest) -> TokenIn : lexer rest 119 | > (var,rest) -> TokenVar var : lexer rest 120 | 121 | > runCalc :: String -> Exp 122 | > runCalc s = case calc (lexer s) 1 of 123 | > ParseOk e -> e 124 | > ParseFail s -> error s 125 | 126 | > happyError = \tks i -> error ( 127 | > "Parse error in line " ++ show (i::Int) ++ "\n") 128 | 129 | ----------------------------------------------------------------------------- 130 | 131 | Here we test our parser. 132 | 133 | > main = case runCalc "1 + 2 + 3" of { 134 | > (Exp1 (Plus (Plus (Term (Factor (Int 1))) (Factor (Int 2))) (Factor (Int 3)))) -> 135 | > case runCalc "1 * 2 + 3" of { 136 | > (Exp1 (Plus (Term (Times (Factor (Int 1)) (Int 2))) (Factor (Int 3)))) -> 137 | > case runCalc "1 + 2 * 3" of { 138 | > (Exp1 (Plus (Term (Factor (Int 1))) (Times (Factor (Int 2)) (Int 3)))) -> 139 | > case runCalc "let x = 2 in x * (x - 2)" of { 140 | > (Let "x" (Exp1 (Term (Factor (Int 2)))) (Exp1 (Term (Times (Factor (Var "x")) (Brack (Exp1 (Minus (Term (Factor (Var "x"))) (Factor (Int 2))))))))) -> print "Test works\n"; 141 | > _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } 142 | > quit = print "Test failed\n" 143 | > } 144 | -------------------------------------------------------------------------------- /examples/PgnParser.ly: -------------------------------------------------------------------------------- 1 | > { 2 | > module PgnParser (pgnMoveParser,pgnParser) where 3 | 4 | > import GenUtils 5 | > import OrdFM 6 | > import Board 7 | > import PgnTypes 8 | > } 9 | 10 | > %name pgnMoveParser 11 | > %tokentype { Token } 12 | > %token 13 | > str { StringToken $$ } 14 | > result { ResultToken $$ } 15 | > nag { NAGToken $$ } 16 | > tag { TagToken $$ } 17 | > comment { CommentToken $$ } 18 | > ']' { RightSBToken } 19 | > '(' { LeftRBToken } 20 | > ')' { RightRBToken } 21 | > '<' { LeftABToken } 22 | > '>' { RightABToken } 23 | > num { IntToken $$ } 24 | > '.' { PeriodToken } 25 | > move { PlyToken $$ } 26 | > %newline { NewlineToken } 27 | 28 | > %% 29 | 30 | You either parse a set of PGN games, 31 | or just a set of moves. 32 | 33 | > moves :: { AbsMove } 34 | > moves : opt_mv_num line_no move nags opt_comment analmoves opt_comment 35 | > more_moves 36 | > { AbsMove $1 $2 $3 $4 ($5++$7) $6 Nothing $8 } 37 | > | opt_mv_num line_no move nags opt_comment more_moves 38 | > { AbsMove $1 $2 $3 $4 $5 [] Nothing $6 } 39 | > | opt_mv_num line_no move '<' raw_moves '>' more_moves 40 | > { AbsMove $1 $2 $3 [] [] [] (Just $5) $7 } 41 | 42 | > more_moves :: { AbsMove } 43 | > more_moves 44 | > : moves { $1 } 45 | > | result { AbsResult $1 } 46 | > | { AbsEnd } 47 | 48 | > nags :: { [Int] } 49 | > nags : nag nags { $1 : $2 } 50 | > | { [] } 51 | 52 | > opt_mv_num :: { Maybe MoveNumber } 53 | > opt_mv_num 54 | > : num '.' '.' '.' { Just (MoveNumber $1 Black) } 55 | > | num '.' { Just (MoveNumber $1 White) } 56 | > | { Nothing } 57 | 58 | > mv_num :: { MoveNumber } 59 | > mv_num 60 | > : num '.' '.' '.' { (MoveNumber $1 Black) } 61 | > | num '.' { (MoveNumber $1 White) } 62 | 63 | > opt_comment :: { [String] } 64 | > opt_comment 65 | > : comment { $1 } 66 | > | { [] } 67 | 68 | > analmoves :: { [AbsMove] } 69 | > analmoves 70 | > : '(' moves ')' analmoves { $2 : $4 } 71 | > | '(' moves ')' { [$2] } 72 | 73 | > line_no :: { LineNo } 74 | > line_no 75 | > : { $# } 76 | 77 | > raw_moves :: { [AbsPly] } 78 | > raw_moves 79 | > : move raw_moves { $1 : $2 } 80 | > | { [] } 81 | 82 | 83 | 84 | 85 | > { 86 | 87 | > pgnParser = pgnGameMap pgnMoveParser 88 | 89 | > happyError :: Int -> [Token] -> a 90 | > happyError i xs = 91 | > error ("Parse error in line " ++ show i ++ "\n" 92 | > ++ show (take 10 xs)) 93 | 94 | > } 95 | 96 | -------------------------------------------------------------------------------- /examples/README: -------------------------------------------------------------------------------- 1 | These are a few examples of Happy parsers, taken from various sources. 2 | The are intended as illustrations, not as working, complete examples, 3 | as some require functions and datatypes imported from other sources. 4 | 5 | Calc.ly : The calculator example from the Happy manual 6 | DavesExample.ly : Parses simple lambda expressions to combinators 7 | SimonsExample.ly : Another lambda expression parser 8 | ErlParser.ly : A parser for Erlang 9 | MonadTest.ly : Demonstrates use of %monad 10 | LexerTest.ly : Demonstrates use of %monad and %lexer 11 | ErrorTest.ly : Demonstrates use of the 'error' token 12 | 13 | There are also a few more examples under happy/tests. 14 | 15 | A full Haskell 98 parser written using Happy is available from the GHC 16 | CVS repository in fptools/hslibs/hssource. See 17 | http://www.haskell.org/ghc/ for instructions on how to access the GHC 18 | CVS repository. 19 | 20 | -- 21 | Simon Marlow 22 | -------------------------------------------------------------------------------- /examples/SimonsExample.ly: -------------------------------------------------------------------------------- 1 | > { 2 | > module Parser (parse) where 3 | > import Type 4 | > import Lexer 5 | > } 6 | 7 | > %token 8 | > backslash { Builtin "\\" } 9 | > var { Ident $$ } 10 | > rightarrow { Builtin "->" } 11 | > caseT { Builtin "case" } 12 | > letT { Builtin "let" } 13 | > ofT { Builtin "of" } 14 | > inT { Builtin "in" } 15 | > letnT { Builtin "letn" } 16 | > leftcurly { LeftCurly } 17 | > rightcurly { RightCurly } 18 | > equals { Builtin "=" } 19 | > colon { Builtin ":" } 20 | > cons { Constructor $$ } 21 | > leftbracket { LeftBracket } 22 | > rightbracket { RightBracket } 23 | > semicolon { SemiColon } 24 | > percent { Percent } 25 | 26 | > %name parse 27 | > %tokentype { Token } 28 | 29 | > %% 30 | 31 | > expr 32 | > : backslash var binders rightarrow expr 33 | > { foldr Lambda $5 ($2: reverse $3) } 34 | > | caseT var ofT leftcurly patterns rightcurly 35 | > { Case $2 (reverse $5) } 36 | > | letT var equals var expr inT expr 37 | > { LetApp ($2,$4,$5) $7 } 38 | > | letT var equals expr inT expr 39 | > { Let ($2,$4) $6 } 40 | > | letnT var equals expr inT expr 41 | > { LetN ($2,$4) $6 } 42 | > 43 | > | labelref colon expr { Label $1 $3 } 44 | > | simpleexpr { $1 } 45 | 46 | > simpleexpr 47 | > : cons simpleexprs { Cons $1 (reverse $2) } 48 | > | simpleexpr0 { $1 } 49 | > 50 | > simpleexprs 51 | > : simpleexprs simpleexpr0 { $2 : $1 } 52 | > | { [] } 53 | > 54 | > simpleexpr0 55 | > : var { Var $1 } 56 | > | labelref { LabelRef $1 } 57 | > | leftbracket expr rightbracket { $2 } 58 | > 59 | > patterns 60 | > : patterns pattern { $2 : $1 } 61 | > | pattern { [ $1 ] } 62 | > 63 | > pattern : cons binders rightarrow expr semicolon 64 | > { ($1, reverse $2, $4) } 65 | > 66 | > binders : binders var { $2 : $1 } 67 | > | { [ ] } 68 | > 69 | > labelref 70 | > : percent var { $2 } 71 | 72 | > { 73 | > happyError :: Int -> a 74 | > happyError x = error ("Error at LINE " ++ show x) 75 | > } 76 | -------------------------------------------------------------------------------- /examples/glr/.gitignore: -------------------------------------------------------------------------------- 1 | */*.hi 2 | */*.o 3 | */*.hs 4 | */*.info 5 | bio-eg/bio-eg 6 | bio-eg/out.daVinci 7 | bio-eg/out.1200 8 | expr-eval/expr 9 | expr-monad/expr 10 | expr-monad/out.daVinci 11 | expr-tree/expr 12 | hidden-leftrec/expr 13 | hidden-leftrec/out.daVinci 14 | highly-ambiguous/expr 15 | highly-ambiguous/out.daVinci 16 | highly-ambiguous/out20 17 | nlp/english 18 | nlp/out.daVinci 19 | packing/expr 20 | packing/out.daVinci 21 | -------------------------------------------------------------------------------- /examples/glr/Makefile: -------------------------------------------------------------------------------- 1 | 2 | all : 3 | make loop CMD=run 4 | 5 | clean : 6 | make loop CMD=clean 7 | 8 | DIRS = expr-eval expr-tree expr-monad \ 9 | hidden-leftrec highly-ambiguous packing \ 10 | nlp bio-eg 11 | 12 | loop : 13 | for d in ${DIRS}; do (cd $$d && make ${CMD}) || exit 1; done 14 | -------------------------------------------------------------------------------- /examples/glr/Makefile.defs: -------------------------------------------------------------------------------- 1 | .SUFFIXES: .y .hs .exe 2 | 3 | OPT= 4 | GHC=ghc -rtsopts -I../common -i../common -fno-warn-tabs ${OPT} 5 | # -dshow-passes 6 | HAPPY=happy 7 | 8 | FILTER = --filter 9 | FILTER = 10 | 11 | DECODE = 12 | H_OPT = 13 | 14 | .y.hs : 15 | ${HAPPY} -i -l ${DECODE} ${FILTER} ${H_OPT} $*.y 16 | 17 | -------------------------------------------------------------------------------- /examples/glr/bio-eg/1-1200.dna: -------------------------------------------------------------------------------- 1 | agcttttcattctgactgcaacgggcaatatgtctctgtgtggattaaaaaaagagtgtctgatagcagcttctgaactggttacctgccgtgagtaaattaaaattttattgacttaggtcactaaatactttaaccaatataggcatagcgcacagacagataaaaattacagagtacacaacatccatgaaacgcattagcaccaccattaccaccaccatcaccattaccacaggtaacggtgcgggctgacgcgtacaggaaacacagaaaaaagcccgcacctgacagtgcgggctttttttttcgaccaaaggtaacgaggtaacaaccatgcgagtgttgaagttcggcggtacatcagtggcaaatgcagaacgttttctgcgtgttgccgatattctggaaagcaatgccaggcaggggcaggtggccaccgtcctctctgcccccgccaaaatcaccaaccacctggtggcgatgattgaaaaaaccattagcggccaggatgctttacccaatatcagcgatgccgaacgtatttttgccgaacttttgacgggactcgccgccgcccagccggggttcccgctggcgcaattgaaaactttcgtcgatcaggaatttgcccaaataaaacatgtcctgcatggcattagtttgttggggcagtgcccggatagcatcaacgctgcgctgatttgccgtggcgagaaaatgtcgatcgccattatggccggcgtattagaagcgcgcggtcacaacgttactgttatcgatccggtcgaaaaactgctggcagtggggcattacctcgaatctaccgtcgatattgctgagtccacccgccgtattgcggcaagccgcattccggctgatcacatggtgctgatggcaggtttcaccgccggtaatgaaaaaggcgaactggtggtgcttggacgcaacggttccgactactctgctgcggtgctggctgcctgtttacgcgccgattgttgcgagatttggacggacgttgacggggtctatacctgcgacccgcgtcaggtgcccgatgcgaggttgttgaagtcgatgtcctaccaggaagcgatggagctttcctacttcggcgctaaagttcttcacccccgcaccattacccccatcgcccagttccagatcccttgcctgattaaaaataccggaaatcct 2 | -------------------------------------------------------------------------------- /examples/glr/bio-eg/1-600.dna: -------------------------------------------------------------------------------- 1 | agcttttcattctgactgcaacgggcaatatgtctctgtgtggattaaaaaaagagtgtctgatagcagcttctgaactggttacctgccgtgagtaaattaaaattttattgacttaggtcactaaatactttaaccaatataggcatagcgcacagacagataaaaattacagagtacacaacatccatgaaacgcattagcaccaccattaccaccaccatcaccattaccacaggtaacggtgcgggctgacgcgtacaggaaacacagaaaaaagcccgcacctgacagtgcgggctttttttttcgaccaaaggtaacgaggtaacaaccatgcgagtgttgaagttcggcggtacatcagtggcaaatgcagaacgttttctgcgtgttgccgatattctggaaagcaatgccaggcaggggcaggtggccaccgtcctctctgcccccgccaaaatcaccaaccacctggtggcgatgattgaaaaaaccattagcggccaggatgctttacccaatatcagcgatgccgaacgtatttttgccgaacttttgacgggactcgccgccgcccagccggggttcccgctggcg 2 | -------------------------------------------------------------------------------- /examples/glr/bio-eg/Main.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | > import System.Environment(getArgs) 3 | > import Data.Maybe(fromJust) 4 | > import Bio 5 | > import qualified Data.Map as Map 6 | > import Control.Monad.State 7 | 8 | #include "DV_lhs" 9 | 10 | > main 11 | > = do 12 | > [s] <- getArgs 13 | > case doParse $ map (:[]) $ lexer s of 14 | > ParseOK r f -> do 15 | > let f_ = filter_noise $ Map.toList f 16 | > putStrLn $ "Ok " ++ show r ++ "\n" 17 | > ++ unlines (map show f_) 18 | > --writeFile "full" (unlines $ map show f) 19 | > toDV (trim_graph f_ r) 20 | > ParseEOF f -> do 21 | > let f_ = filter_noise $ Map.toList f 22 | > putStrLn $ "Premature end of input:\n" 23 | > ++ unlines (map show f_) 24 | > toDV f_ 25 | > --writeFile "full" (unlines $ map show f) 26 | > ParseError ts f -> do 27 | > let f_ = filter_noise $ Map.toList f 28 | > putStrLn $ "Error: " ++ show ts 29 | > toDV f_ 30 | > --writeFile "full" (unlines $ map show f) 31 | 32 | > forest_lookup f i 33 | > = fromJust $ Map.lookup i f 34 | 35 | --- 36 | remove intergenic things, to make graph small enough for drawing 37 | -- (prefer to do this with filtering in parser...) 38 | 39 | > filter_noise f 40 | > = [ (i, map filter_branch bs) 41 | > | (i@(s_i,e_i,l), bs) <- f, not_igs i ] 42 | > where 43 | > igs = Map.fromList [ (i,False) | i@(_,_,G_Intergenic_noise) <- map fst f ] 44 | > not_igs i = Map.findWithDefault True i igs 45 | > filter_branch (Branch s ns) = Branch s [ n | n <- ns, not_igs n ] 46 | 47 | > trim_graph :: NodeMap -> RootNode -> NodeMap 48 | > trim_graph f r 49 | > = [ (i,n) | (i,n) <- f, Map.findWithDefault False i wanted ] 50 | > where 51 | > table = Map.fromList f 52 | > wanted = snd $ runState (follow r) Map.empty 53 | > follow :: ForestId -> State (Map.Map ForestId Bool) () 54 | > follow i = do 55 | > visited <- get 56 | > if Map.findWithDefault False i visited 57 | > then return () 58 | > else do 59 | > case Map.lookup i table of 60 | > Nothing 61 | > -> error $ "bad node: " ++ show i 62 | > Just bs 63 | > -> do 64 | > modify (\s -> Map.insert i True s) 65 | > mapM_ follow $ concatMap b_nodes bs 66 | 67 | -------------------------------------------------------------------------------- /examples/glr/bio-eg/Makefile: -------------------------------------------------------------------------------- 1 | TOP=.. 2 | include ${TOP}/Makefile.defs 3 | 4 | PROG=bio-eg 5 | 6 | # filtering causes this example to fail... 7 | FILTER = --filter 8 | FILTER = 9 | 10 | .hi.o : 11 | @ dummy 12 | 13 | ${PROG} : Bio.o Main.lhs 14 | ${GHC} -cpp -fglasgow-exts -o ${PROG} --make Main.lhs 15 | 16 | BioData.hs Bio.hs : Bio.y 17 | ${HAPPY} --info --glr --ghc ${FILTER} $< 18 | 19 | Bio.o : Bio.hs BioData.hi 20 | ${GHC} -cpp -fglasgow-exts -O2 -c Bio.hs 21 | 22 | DATA_FLAGS = -funfolding-use-threshold0 -fno-strictness 23 | BioData.hi BioData.o : BioData.hs 24 | @echo "Making BioData.hs WITHOUT optimisation (for speed)" 25 | ${GHC} -cpp -fglasgow-exts ${DATA_FLAGS} -c $< 26 | 27 | run : run12 28 | 29 | run6 : ${PROG} 30 | ./${PROG} +RTS -s -K5M -RTS `cat 1-600.dna` 31 | 32 | run12 : ${PROG} 33 | rm -f out.1200 34 | ./${PROG} +RTS -s -K15M -RTS `cat 1-1200.dna` > out.1200 2>&1 35 | echo Expect NINE matches, got `grep '^[(,0-9]*G_Match' out.1200 | wc -l` 36 | 37 | clean : 38 | rm -rf ${PROG} Bio.info Bio.hs BioData.hs *.o *.hi out.daVinci \ 39 | out.1200 out.600 40 | -------------------------------------------------------------------------------- /examples/glr/bio-eg/README: -------------------------------------------------------------------------------- 1 | 2 | A more complex example - looking for patterns in DNA sequences. 3 | 4 | This example derived from undergraduate project work by Julia Fischer 5 | at the University of Durham. Some of the grammar is based on the ones 6 | developed by Siu-wai Leung, Chris Mellish, and Dave Robertson at the 7 | University of Edinburgh. (Contact Paul Callaghan for details, and 8 | see the accompanying paper.) 9 | 10 | Files 1-600.dna and 1-1200.dna contain 600 (1200) bases from the sequence 11 | for E. coli. The first sequence parses in a few minutes, the second takes 12 | a bit longer. 13 | 14 | There are issues about how to efficiently skip over "noise" in the data. 15 | This would make the parser faster. 16 | 17 | Use "make run" to parse the 1-1200.dna sequence - it should take under 15 18 | seconds 19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /examples/glr/common/DV_lhs: -------------------------------------------------------------------------------- 1 | 2 | 3 | import DaVinciTypes hiding (Edge(..) , Node(..)) 4 | import qualified DaVinciTypes (Edge(..) , Node(..)) 5 | 6 | -- 7 | 8 | toDV :: NodeMap -> IO () 9 | toDV nodes 10 | = writeFile "out.daVinci" (show $ map g2n nodes) 11 | 12 | 13 | -- 14 | 15 | show_gsymbol (HappyTok x) = show x 16 | show_gsymbol t = show t 17 | 18 | g2n (n@(s,e,x), []) 19 | = mk_rhombus id (show_gsymbol x ++ show (s,e)) [] 20 | where 21 | id = show n 22 | 23 | g2n (n@(s,e,x), [Branch _ bs]) 24 | = mk_box id (show_gsymbol x ++ show (s,e)) 25 | $ [ DaVinciTypes.R (NodeId $ show j) | j <- bs ] 26 | where 27 | id = show n 28 | 29 | g2n (n@(s,e,x), bss) 30 | = mk_circle id (show_gsymbol x ++ show (s,e)) 31 | $ [ mk_box (id ++ "." ++ show i) (show_gsymbol x ++ show (s,e)) 32 | [ DaVinciTypes.R (NodeId $ show j) 33 | | j <- js ] 34 | | (i,Branch _ js) <- zip [0..] bss ] 35 | where 36 | id = show n 37 | 38 | --- 39 | 40 | mk_box = mk_node box_t 41 | mk_circle = mk_node circle_t 42 | mk_plain = mk_node text_t 43 | mk_rhombus = mk_node rhombus_t 44 | 45 | mk_node :: Attribute -> String -> String -> [DaVinciTypes.Node] 46 | -> DaVinciTypes.Node 47 | mk_node a id nm ts 48 | = DaVinciTypes.N (NodeId id) (Type "") [a,text nm] 49 | $ [ (mk_edge id n) t | (n,t) <- zip [1..] ts ] 50 | 51 | mk_edge id child_no t@(DaVinciTypes.R (NodeId id2)) 52 | = DaVinciTypes.E (EdgeId eId) (Type "") [] t 53 | where 54 | eId = concat [id,":",id2,"(",show child_no,")"] 55 | 56 | mk_edge id child_no t@(DaVinciTypes.N (NodeId id2) _ _ _) 57 | = DaVinciTypes.E (EdgeId eId) (Type "") [] t 58 | where 59 | eId = concat [id,":",id2,"(",show child_no,")"] 60 | 61 | --- 62 | 63 | nodeStyle = A "_GO" 64 | 65 | box_t, circle_t, ellipse_t, rhombus_t, text_t, icon_t :: Attribute 66 | box_t = nodeStyle "box" 67 | circle_t = nodeStyle "circle" 68 | ellipse_t = nodeStyle "ellipse" 69 | rhombus_t = nodeStyle "rhombus" 70 | text_t = nodeStyle "text" 71 | icon_t = nodeStyle "icon" 72 | 73 | text :: String -> Attribute 74 | text = A "OBJECT" 75 | 76 | 77 | 78 | -------------------------------------------------------------------------------- /examples/glr/expr-eval/Expr.y: -------------------------------------------------------------------------------- 1 | { 2 | -- only list imports here 3 | import Data.Char 4 | } 5 | 6 | %tokentype { Token } 7 | 8 | %lexer { lexer } { TokenEOF } 9 | 10 | %token 11 | '*' { Sym '*' } 12 | '+' { Sym '+' } 13 | '-' { Sym '-' } 14 | '(' { Sym '(' } 15 | ')' { Sym ')' } 16 | i { AnInt $$ } 17 | 18 | %% 19 | 20 | E :: {Int} 21 | : E '+' E { $1 + $3 } 22 | | E '*' E { $1 * $3 } 23 | | E '-' E { $1 - $3 } 24 | | '(' E ')' { $2 } 25 | | i { $1 } 26 | 27 | 28 | 29 | 30 | { 31 | 32 | data Token 33 | = TokenEOF 34 | | Sym Char 35 | | AnInt Int 36 | deriving (Show,Eq, Ord) 37 | 38 | 39 | lexer :: String -> [Token] 40 | lexer [] = [] 41 | lexer (' ':cs) = lexer cs 42 | 43 | lexer (c:cs) | c `elem` "+*-()" 44 | = Sym c : lexer cs 45 | 46 | lexer (c:cs) | isDigit c 47 | = let (yes,no) = span isDigit cs in AnInt (read $ c:yes) : lexer no 48 | 49 | } 50 | -------------------------------------------------------------------------------- /examples/glr/expr-eval/Hugs.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | > import System(getArgs) 3 | > import Data.Maybe(fromJust) 4 | > import FiniteMap(fmToList,lookupFM) 5 | > import Expr 6 | 7 | 8 | > main 9 | > = do 10 | > [s] <- getArgs 11 | > test s 12 | 13 | > test s 14 | > = do 15 | > case doParse $ map (:[]) $ lexer s of 16 | > ParseOK r f -> do 17 | > putStrLn $ "Ok " ++ show r ++ "\n" 18 | > ++ unlines (map show $ fmToList f) 19 | > putStrLn $ show (decode (forest_lookup f) r ::[Int]) 20 | > ParseEOF f -> do 21 | > putStrLn $ "Premature end of input:\n" 22 | > ++ unlines (map show $ fmToList f) 23 | > ParseError ts f -> do 24 | > putStrLn $ "Error: " ++ show ts 25 | 26 | > forest_lookup f i 27 | > = fromJust $ lookupFM f i 28 | -------------------------------------------------------------------------------- /examples/glr/expr-eval/Main.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | > import System.Environment(getArgs) 3 | > import Data.Maybe(fromJust) 4 | > import qualified Data.Map as Map 5 | > import Expr 6 | 7 | #include "DV_lhs" 8 | 9 | This requires CPP / preprocessing; use Hugs.lhs for tests with Hugs 10 | 11 | > main 12 | > = do 13 | > (s:o) <- getArgs 14 | > let x = concat o 15 | > case doParse $ map (:[]) $ lexer s of 16 | > ParseOK r f -> do 17 | > putStrLn $ "Ok " ++ show r ++ "\n" 18 | > ++ (if 'f' `elem` x then unlines (map show $ Map.toList f) else "") 19 | > ++ (if 'r' `elem` x then unlines (map show (decode (forest_lookup f) r ::[Int])) else "") 20 | > if 'g' `elem` x then toDV (Map.toList f) else return () 21 | > ParseEOF f -> do 22 | > putStrLn $ "Premature end of input:\n" 23 | > ++ unlines (map show $ Map.toList f) 24 | > toDV $ Map.toList f 25 | > ParseError ts f -> do 26 | > putStrLn $ "Error: " ++ show ts 27 | > toDV $ Map.toList f 28 | 29 | > forest_lookup f i 30 | > = fromJust $ Map.lookup i f 31 | -------------------------------------------------------------------------------- /examples/glr/expr-eval/Makefile: -------------------------------------------------------------------------------- 1 | TOP=.. 2 | include ${TOP}/Makefile.defs 3 | 4 | OPT = -O 5 | DECODE = --decode 6 | 7 | expr : Expr.hs Main.lhs 8 | # might want to run happy with --ghc 9 | ${GHC} -cpp -fglasgow-exts -o expr --make Main.lhs 10 | 11 | run : expr 12 | ./expr "1+2*4-3" 13 | 14 | runn : expr 15 | ./expr +RTS -s -RTS `perl -e 'print join ("+", (1 .. ${NUM}));'` | tee out-${NUM} 16 | cat expr.stat >> out-${NUM} 17 | 18 | eof : expr 19 | echo testing premature eof 20 | ./expr "1+2*" 21 | 22 | err : expr 23 | echo testing syntax error 24 | ./expr "1+2*2++3" 25 | 26 | test : run eof err 27 | 28 | clean : 29 | rm -rf expr Expr.info Expr.hs ExprData.hs *.o *.hi out.daVinci 30 | -------------------------------------------------------------------------------- /examples/glr/expr-eval/README: -------------------------------------------------------------------------------- 1 | 2 | Example of arithmetic expression parsing, with decoding of semantic 3 | values (ie it gives a list of possible results of computation). 4 | 5 | "make run" to run the test case. 6 | 7 | For Hugs, load up Hugs.lhs - it doesn't produce graphs, and has easy entry 8 | point "test :: String -> IO () 9 | -------------------------------------------------------------------------------- /examples/glr/expr-monad/Expr.y: -------------------------------------------------------------------------------- 1 | { 2 | -- only list imports here 3 | import Data.Char 4 | } 5 | 6 | %tokentype { Token } 7 | 8 | %monad { IO } { (>>=) } { return } 9 | %lexer { lexer } { TokenEOF } 10 | 11 | %token 12 | '*' { Sym '*' } 13 | '+' { Sym '+' } 14 | '-' { Sym '-' } 15 | '(' { Sym '(' } 16 | ')' { Sym ')' } 17 | i { AnInt $$ } 18 | 19 | %% 20 | 21 | E :: {Int} 22 | : E '+' E {% {-print ($1,$3) >>-} if odd $3 then fail "odd num" else return ($1 + $3) } 23 | | E '*' E { $1 * $3 } 24 | | E '-' E { $1 - $3 } 25 | | '(' E ')' { $2 } 26 | | i { $1 } 27 | 28 | 29 | 30 | 31 | { 32 | 33 | data Token 34 | = TokenEOF 35 | | Sym Char 36 | | AnInt Int 37 | deriving (Show,Eq, Ord) 38 | 39 | 40 | lexer :: String -> [Token] 41 | lexer [] = [] 42 | lexer (' ':cs) = lexer cs 43 | 44 | lexer (c:cs) | c `elem` "+*-()" 45 | = Sym c : lexer cs 46 | 47 | lexer (c:cs) | isDigit c 48 | = let (yes,no) = span isDigit cs in AnInt (read $ c:yes) : lexer no 49 | 50 | } 51 | -------------------------------------------------------------------------------- /examples/glr/expr-monad/Hugs.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | > import System(getArgs) 3 | > import Data.Maybe(fromJust) 4 | > import FiniteMap(fmToList,lookupFM) 5 | > import Expr 6 | 7 | 8 | > main 9 | > = do 10 | > [s] <- getArgs 11 | > test s 12 | 13 | > test s 14 | > = do 15 | > case doParse $ map (:[]) $ lexer s of 16 | > ParseOK r f -> do 17 | > putStrLn $ "Ok " ++ show r ++ "\n" 18 | > ++ unlines (map show $ fmToList f) 19 | > let ms = decode (forest_lookup f) r ::[IO Int] 20 | > mapM_ (\ma -> catch ma (\_ -> return 0) >>= print) ms 21 | > ParseEOF f -> do 22 | > putStrLn $ "Premature end of input:\n" 23 | > ++ unlines (map show $ fmToList f) 24 | > ParseError ts f -> do 25 | > putStrLn $ "Error: " ++ show ts 26 | 27 | > forest_lookup f i 28 | > = fromJust $ lookupFM f i 29 | -------------------------------------------------------------------------------- /examples/glr/expr-monad/Main.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | > import System.IO.Error(catchIOError) 3 | > import System.Environment(getArgs) 4 | > import Data.Maybe(fromJust) 5 | > import qualified Data.Map as Map 6 | > import Expr 7 | 8 | #include "DV_lhs" 9 | 10 | This requires CPP / preprocessing; use Hugs.lhs for tests with Hugs 11 | 12 | > main 13 | > = do 14 | > [s] <- getArgs 15 | > case doParse $ map (:[]) $ lexer s of 16 | > ParseOK r f -> do 17 | > putStrLn $ "Ok " ++ show r ++ "\n" 18 | > ++ unlines (map show $ Map.toList f) 19 | > let ms = decode (forest_lookup f) r ::[IO Int] 20 | > mapM_ (\ma -> catchIOError ma (\_ -> return 0) >>= print) ms 21 | > toDV $ Map.toList f 22 | > ParseEOF f -> do 23 | > putStrLn $ "Premature end of input:\n" 24 | > ++ unlines (map show $ Map.toList f) 25 | > toDV $ Map.toList f 26 | > ParseError ts f -> do 27 | > putStrLn $ "Error: " ++ show ts 28 | > toDV $ Map.toList f 29 | 30 | > forest_lookup f i 31 | > = fromJust $ Map.lookup i f 32 | -------------------------------------------------------------------------------- /examples/glr/expr-monad/Makefile: -------------------------------------------------------------------------------- 1 | TOP=.. 2 | include ${TOP}/Makefile.defs 3 | 4 | DECODE = --decode 5 | 6 | 7 | expr : Expr.hs Main.lhs 8 | ${GHC} -cpp -fglasgow-exts -o expr --make Main.lhs 9 | 10 | run : expr 11 | ./expr "1+2*4-3" 12 | 13 | eof : expr 14 | echo testing premature eof 15 | ./expr "1+2*" 16 | 17 | err : expr 18 | echo testing syntax error 19 | ./expr "1+2*2++3" 20 | 21 | test : run eof err 22 | 23 | clean : 24 | rm -rf expr Expr.info Expr.hs ExprData.hs *.o *.hi out.daVinci 25 | -------------------------------------------------------------------------------- /examples/glr/expr-monad/README: -------------------------------------------------------------------------------- 1 | 2 | Example of arithmetic expression parsing, with decoding of semantic 3 | values (ie it gives a list of possible results of computation). 4 | 5 | BUT: it runs the computations under a monad. In this example, certain 6 | cases of addition fail, which are caught and shown as zeros. 7 | 8 | "make run" to run the test case. 9 | 10 | For Hugs, load up Hugs.lhs - it doesn't produce graphs, and has easy entry 11 | point "test :: String -> IO () 12 | -------------------------------------------------------------------------------- /examples/glr/expr-tree/Expr.y: -------------------------------------------------------------------------------- 1 | { 2 | -- only list imports here 3 | import Data.Char 4 | import Tree 5 | } 6 | 7 | %tokentype { Token } 8 | 9 | %lexer { lexer } { TokenEOF } 10 | 11 | %token 12 | '*' { Sym '*' } 13 | '+' { Sym '+' } 14 | '-' { Sym '-' } 15 | '(' { Sym '(' } 16 | ')' { Sym ')' } 17 | i { AnInt $$ } 18 | 19 | %% 20 | 21 | E :: {Tree ForestId Int} 22 | : E '+' E { Plus $1 $3 } 23 | | E '*' E { Times $1 $3 } 24 | | E '-' E { Minus $1 $3 } 25 | | '(' E ')' { Pars $2 } 26 | | i { Const $1 } 27 | 28 | 29 | 30 | { 31 | 32 | data Token 33 | = TokenEOF 34 | | Sym Char 35 | | AnInt {getInt :: Int} 36 | deriving (Show,Eq, Ord) 37 | 38 | 39 | lexer :: String -> [Token] 40 | lexer [] = [] 41 | lexer (' ':cs) = lexer cs 42 | 43 | lexer (c:cs) | c `elem` "+*-()" 44 | = Sym c : lexer cs 45 | 46 | lexer (c:cs) | isDigit c 47 | = let (yes,no) = span isDigit cs in AnInt (read $ c:yes) : lexer no 48 | 49 | } 50 | -------------------------------------------------------------------------------- /examples/glr/expr-tree/Hugs.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | > import System(getArgs) 3 | > import Data.Maybe(fromJust) 4 | > import FiniteMap(fmToList,lookupFM) 5 | > import Expr 6 | 7 | 8 | > main 9 | > = do 10 | > [s] <- getArgs 11 | > test s 12 | 13 | > test s 14 | > = do 15 | > case doParse $ map (:[]) $ lexer s of 16 | > ParseOK r f -> do 17 | > putStrLn $ "Ok " ++ show r ++ "\n" 18 | > ++ unlines (map show $ fmToList f) 19 | > ParseEOF f -> do 20 | > putStrLn $ "Premature end of input:\n" 21 | > ++ unlines (map show $ fmToList f) 22 | > ParseError ts f -> do 23 | > putStrLn $ "Error: " ++ show ts 24 | 25 | > forest_lookup f i 26 | > = fromJust $ lookupFM f i 27 | -------------------------------------------------------------------------------- /examples/glr/expr-tree/Main.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | > import System.Environment(getArgs) 3 | > import Data.Maybe(fromJust) 4 | > import qualified Data.Map as Map 5 | > import Expr 6 | 7 | #include "DV_lhs" 8 | 9 | This requires CPP / preprocessing; use Hugs.lhs for tests with Hugs 10 | 11 | 12 | > main 13 | > = do 14 | > (s:o) <- getArgs 15 | > let x = concat o 16 | > case doParse $ map (:[]) $ lexer s of 17 | > ParseOK r f -> do 18 | > putStrLn $ "Ok " ++ show r ++ "\n" 19 | > ++ (if 'f' `elem` x then unlines (map show $ Map.toList f) else "") 20 | > if 'g' `elem` x then toDV (Map.toList f) else return () 21 | > ParseEOF f -> do 22 | > putStrLn $ "Premature end of input:\n" 23 | > ++ unlines (map show $ Map.toList f) 24 | > toDV $ Map.toList f 25 | > ParseError ts f -> do 26 | > putStrLn $ "Error: " ++ show ts 27 | > toDV $ Map.toList f 28 | 29 | > forest_lookup f i 30 | > = fromJust $ Map.lookup f i 31 | -------------------------------------------------------------------------------- /examples/glr/expr-tree/Makefile: -------------------------------------------------------------------------------- 1 | TOP=.. 2 | include ${TOP}/Makefile.defs 3 | 4 | OPT = -O2 5 | 6 | expr : Expr.hs Main.lhs 7 | # might want to run happy with --ghc 8 | ${GHC} -cpp -fglasgow-exts -o expr --make Main.lhs 9 | 10 | run : expr 11 | ./expr "1+2*4-3" 12 | 13 | runn : expr 14 | ./expr +RTS -s -RTS `perl -e 'print join ("+", (1 .. ${NUM}));'` | tee out-${NUM} 15 | cat expr.stat >> out-${NUM} 16 | 17 | 18 | eof : expr 19 | echo testing premature eof 20 | ./expr "1+2*" 21 | 22 | err : expr 23 | echo testing syntax error 24 | ./expr "1+2*2++3" 25 | 26 | test : run eof err 27 | 28 | clean : 29 | rm -rf expr Expr.info Expr.hs ExprData.hs *.o *.hi out.daVinci 30 | -------------------------------------------------------------------------------- /examples/glr/expr-tree/README: -------------------------------------------------------------------------------- 1 | 2 | Example of arithmetic expression parsing, but producing a labelled 3 | forest. 4 | 5 | Note use of polymorphic type in the labels. See the code more more 6 | discussion. 7 | 8 | "make run" to run the test case. 9 | 10 | For Hugs, load up Hugs.lhs - it is a simplified version of Main, with entry 11 | point "test :: String -> IO ()" 12 | 13 | NOTE: you need the -98 flag on Hugs, owing to non-standard class use 14 | -------------------------------------------------------------------------------- /examples/glr/expr-tree/Tree.lhs: -------------------------------------------------------------------------------- 1 | > module Tree where 2 | 3 | > data Tree a b 4 | > = Plus a a 5 | > | Times a a 6 | > | Minus a a 7 | > | Pars a 8 | > | Const b 9 | > deriving (Show) 10 | 11 | Note: 12 | + we need a construct for the location of parentheses 13 | + sometimes it is useful to keep this information anyway -- eg ghc's 14 | implementation of customisable prec & assoc. 15 | + I've left Trees polymorphic in the "branch" type - this supports labelling 16 | the forest with Int-based trees then switching to Tree-based trees later 17 | + But this might require some non-Haskell-98 flags for the related class 18 | instances. 19 | 20 | -------------------------------------------------------------------------------- /examples/glr/hidden-leftrec/Expr.y: -------------------------------------------------------------------------------- 1 | { 2 | -- only list imports here 3 | import Data.Char 4 | } 5 | 6 | %tokentype { Token } 7 | 8 | %lexer { lexer } { TokenEOF } 9 | 10 | %token 11 | '+' { Sym '+' } 12 | i { AnInt $$ } 13 | 14 | %% 15 | 16 | R : Q {} 17 | Q : B Q i {} | S {} 18 | S : A S i {} | '+' {} | Q i {} 19 | B : {} 20 | A : {} 21 | 22 | 23 | { 24 | 25 | data Token 26 | = TokenEOF 27 | | Sym Char 28 | | AnInt Int 29 | deriving (Show,Eq, Ord) 30 | 31 | 32 | lexer :: String -> [Token] 33 | lexer [] = [] 34 | lexer (' ':cs) = lexer cs 35 | 36 | lexer (c:cs) | c `elem` "+*-()" 37 | = Sym c : lexer cs 38 | 39 | lexer (c:cs) | isDigit c 40 | = let (yes,no) = span isDigit cs in AnInt (read $ c:yes) : lexer no 41 | 42 | } 43 | -------------------------------------------------------------------------------- /examples/glr/hidden-leftrec/Hugs.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | > import System(getArgs) 3 | > import Data.Maybe(fromJust) 4 | > import FiniteMap(fmToList,lookupFM) 5 | > import Expr 6 | 7 | 8 | > main 9 | > = do 10 | > [s] <- getArgs 11 | > test s 12 | 13 | > test s 14 | > = do 15 | > case doParse $ map (:[]) $ lexer s of 16 | > ParseOK r f -> do 17 | > putStrLn $ "Ok " ++ show r ++ "\n" 18 | > ++ unlines (map show $ fmToList f) 19 | > ParseEOF f -> do 20 | > putStrLn $ "Premature end of input:\n" 21 | > ++ unlines (map show $ fmToList f) 22 | > ParseError ts f -> do 23 | > putStrLn $ "Error: " ++ show ts 24 | 25 | > forest_lookup f i 26 | > = fromJust $ lookupFM f i 27 | -------------------------------------------------------------------------------- /examples/glr/hidden-leftrec/Main.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | > import System.Environment(getArgs) 3 | > import Data.Maybe(fromJust) 4 | > import qualified Data.Map as Map 5 | > import Expr 6 | 7 | #include "DV_lhs" 8 | 9 | This requires CPP / preprocessing; use Hugs.lhs for tests with Hugs 10 | 11 | 12 | > main 13 | > = do 14 | > [s] <- getArgs 15 | > case doParse $ map (:[]) $ lexer s of 16 | > ParseOK r f -> do 17 | > putStrLn $ "Ok " ++ show r ++ "\n" 18 | > ++ unlines (map show $ Map.toList f) 19 | > toDV $ Map.toList f 20 | > ParseEOF f -> do 21 | > putStrLn $ "Premature end of input:\n" 22 | > ++ unlines (map show $ Map.toList f) 23 | > toDV $ Map.toList f 24 | > ParseError ts f -> do 25 | > putStrLn $ "Error: " ++ show ts 26 | > toDV $ Map.toList f 27 | 28 | > forest_lookup f i 29 | > = fromJust $ Map.lookup f i 30 | -------------------------------------------------------------------------------- /examples/glr/hidden-leftrec/Makefile: -------------------------------------------------------------------------------- 1 | TOP=.. 2 | include ${TOP}/Makefile.defs 3 | 4 | expr : Expr.hs Main.lhs 5 | ${GHC} -cpp -fglasgow-exts -o expr --make Main.lhs 6 | 7 | run : expr 8 | ./expr "+ 1 1 1 1 1 1 " 9 | 10 | eof : expr 11 | echo testing premature eof 12 | ./expr "" 13 | 14 | err : expr 15 | echo testing syntax error 16 | ./expr "+ 1 +" 17 | 18 | test : run eof err 19 | 20 | clean : 21 | rm -rf expr Expr.info Expr.hs ExprData.hs *.o *.hi out.daVinci 22 | -------------------------------------------------------------------------------- /examples/glr/hidden-leftrec/README: -------------------------------------------------------------------------------- 1 | 2 | Example of hidden left recursion 3 | 4 | The key point is that it has rules of form (X -> A X z), where A may match 5 | the empty string. The original GLR algorithm will loop on such productions, 6 | since the reduction (A -> empty) is always possible. 7 | 8 | The grammar is based on the one in Rekers[1], pointed out to me by Joost 9 | Visser. 10 | Q -> A Q i | + 11 | A -> 12 | 13 | I have made it a bit more complex, adding a second layer of hidden recursion 14 | and allowing jumps from the second layer to the first. 15 | 16 | 17 | --- 18 | 19 | "make run" to run the test case. 20 | 21 | For Hugs, load up Hugs.lhs - it doesn't produce graphs, and has easy entry 22 | point "test :: String -> IO () 23 | 24 | Don't forget to look at the graphs! 25 | 26 | --- 27 | 28 | [1] J. Rekers, "Parser Generation for Interactive Environments", PhD thesis, 29 | University of Amsterdam 1992. 30 | -------------------------------------------------------------------------------- /examples/glr/highly-ambiguous/Expr.y: -------------------------------------------------------------------------------- 1 | { 2 | -- only list imports here 3 | import Data.Char 4 | } 5 | 6 | %tokentype { Token } 7 | 8 | %lexer { lexer } { TokenEOF } 9 | 10 | %token 11 | 'b' { Sym _ } 12 | 13 | %% 14 | -- grammar taken from 15 | -- "Generalised LR Parsing in Haskell" 16 | -- Joao Fernandes, Joao Saraiva, and Joost Visser 17 | -- Universidade do Minho, Braga, Portugal 18 | -- submitted to AFP'04 summer school 19 | -- (Original source of grammar not identified by them) 20 | 21 | S : T {} 22 | T : A 'b' {} | T T T {} 23 | A : T 'b' A A A {} | T T 'b' {} | {} 24 | 25 | { 26 | 27 | data Token 28 | = TokenEOF 29 | | Sym Char 30 | | AnInt Int 31 | deriving (Show,Eq, Ord) 32 | 33 | 34 | lexer :: String -> [Token] 35 | lexer [] = [] 36 | lexer (' ':cs) = lexer cs 37 | 38 | lexer (c:cs) | c `elem` "+*-()" 39 | = Sym c : lexer cs 40 | 41 | lexer (c:cs) | isDigit c 42 | = let (yes,no) = span isDigit cs in AnInt (read $ c:yes) : lexer no 43 | 44 | } 45 | -------------------------------------------------------------------------------- /examples/glr/highly-ambiguous/Hugs.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | > import System(getArgs) 3 | > import Data.Maybe(fromJust) 4 | > import FiniteMap(fmToList,lookupFM) 5 | > import Expr 6 | 7 | 8 | > main 9 | > = do 10 | > [s] <- getArgs 11 | > test (read s :: Int) 12 | 13 | > test n 14 | > = do 15 | > case doParse $ map (:[]) $ lexer $ replicate n '+' of 16 | > ParseOK r f -> do 17 | > putStrLn $ "Ok " ++ show r ++ "\n" 18 | > ++ unlines (map show $ fmToList f) 19 | > ParseEOF f -> do 20 | > putStrLn $ "Premature end of input:\n" 21 | > ++ unlines (map show $ fmToList f) 22 | > ParseError ts f -> do 23 | > putStrLn $ "Error: " ++ show ts 24 | 25 | > forest_lookup f i 26 | > = fromJust $ lookupFM f i 27 | -------------------------------------------------------------------------------- /examples/glr/highly-ambiguous/Main.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | > import System.Environment(getArgs) 3 | > import Data.Maybe(fromJust) 4 | > import qualified Data.Map as Map 5 | > import Expr 6 | 7 | #include "DV_lhs" 8 | 9 | This requires CPP / preprocessing; use Hugs.lhs for tests with Hugs 10 | 11 | 12 | > main 13 | > = do 14 | > [s] <- getArgs 15 | > case doParse $ map (:[]) $ lexer $ replicate (read s) '+' of 16 | > ParseOK r f -> do 17 | > putStrLn $ "Ok " ++ show r ++ "\n" 18 | > ++ unlines (map show $ Map.toList f) 19 | > toDV $ Map.toList f 20 | > ParseEOF f -> do 21 | > putStrLn $ "Premature end of input:\n" 22 | > ++ unlines (map show $ Map.toList f) 23 | > toDV $ Map.toList f 24 | > ParseError ts f -> do 25 | > putStrLn $ "Error: " ++ show ts 26 | > toDV $ Map.toList f 27 | 28 | > forest_lookup f i 29 | > = fromJust $ Map.lookup f i 30 | -------------------------------------------------------------------------------- /examples/glr/highly-ambiguous/Makefile: -------------------------------------------------------------------------------- 1 | TOP=.. 2 | include ${TOP}/Makefile.defs 3 | 4 | expr : Expr.hs Main.lhs 5 | ${GHC} -cpp -fglasgow-exts -o expr --make Main.lhs 6 | 7 | NUM=20 8 | run : expr 9 | ./expr +RTS -s -RTS ${NUM} | grep ^Ok 10 | 11 | run30 : 12 | make run NUM=30 13 | 14 | test : run eof err 15 | 16 | clean : 17 | rm -rf expr Expr.info Expr.hs ExprData.hs *.o *.hi out.daVinci 18 | 19 | tar : 20 | tar chzf aj2.tgz Expr*hs Expr*y Main*hs D*hs 21 | 22 | -------------------------------------------------------------------------------- /examples/glr/highly-ambiguous/README: -------------------------------------------------------------------------------- 1 | 2 | Example of a highly ambiguous grammar 3 | 4 | It is a grammar taken from [1], although it is an example from the literature 5 | (the draft paper didn't mention which source). 6 | 7 | There is an explosion of possibilities because many parse stacks need to be 8 | kept active. Inputs of sizes above 25 will get very expensive to parse, with 9 | the current parser driver; but this seems no worse (if not better) than other 10 | implementations that produce a packed forest. 11 | 12 | 13 | --- 14 | 15 | "make run" to run the test case. 16 | 17 | For Hugs, load up Hugs.lhs - it doesn't produce graphs, and has easy entry 18 | point "test :: String -> IO () 19 | 20 | --- 21 | 22 | [1] "Generalised LR Parsing in Haskell" 23 | Joao Fernandes, Joao Saraiva, and Joost Visser 24 | Universidade do Minho, Braga, Portugal 25 | submitted to AFP'04 summer school 26 | 27 | -------------------------------------------------------------------------------- /examples/glr/nlp/English.y: -------------------------------------------------------------------------------- 1 | { 2 | -- only list imports here 3 | import Data.Char 4 | } 5 | 6 | %tokentype { Token } 7 | 8 | %lexer { lexer } { TokenEOF } 9 | 10 | %token 11 | det { Det $$ } 12 | prep { Prep $$ } 13 | noun { Noun $$ } 14 | transvb { Verb Trans $$ } 15 | intransvb { Verb Intrans $$ } 16 | 17 | %% 18 | 19 | S 20 | : NP VP {} 21 | 22 | NP 23 | : det noun {} 24 | | NP PP {} 25 | 26 | PP 27 | : prep NP {} 28 | 29 | VP 30 | : transvb NP {} 31 | | intransvb {} 32 | | VP PP {} 33 | 34 | { 35 | 36 | data Token 37 | = TokenEOF 38 | | Noun String 39 | | Verb Arity String 40 | | Prep String 41 | | Det String 42 | deriving (Show,Eq,Ord) 43 | 44 | data Arity = Trans | Intrans deriving (Show,Eq,Ord) 45 | 46 | lexer :: String -> [[Token]] 47 | lexer = map lex_word . words 48 | 49 | -- simple lexicon 50 | -- (no claims to accuracy) 51 | 52 | lex_word w@"the" = [Det w] 53 | lex_word w@"a" = [Det w] 54 | lex_word w@"some" = [Det w] 55 | lex_word w@"in" = [Prep w] 56 | lex_word w@"with" = [Prep w] 57 | lex_word w@"park" = [Verb Trans w, Noun w] 58 | lex_word w@"man" = [Verb Trans w, Noun w] 59 | lex_word w@"saw" = [Verb Trans w, Verb Intrans w, Noun w] 60 | lex_word w@"run" = [Verb Trans w, Verb Intrans w, Noun w] 61 | lex_word w@"race" = [Verb Trans w, Verb Intrans w, Noun w] 62 | lex_word w@"telescope" = [Verb Trans w, Verb Intrans w, Noun w] 63 | lex_word w = error $ "Not know: " ++ show w 64 | } 65 | -------------------------------------------------------------------------------- /examples/glr/nlp/Hugs.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | > import System(getArgs) 3 | > import Data.Maybe(fromJust) 4 | > import FiniteMap(fmToList,lookupFM) 5 | > import English 6 | 7 | 8 | > main 9 | > = do 10 | > [s] <- getArgs 11 | > test s 12 | 13 | > test s 14 | > = do 15 | > case doParse $ lexer s of 16 | > ParseOK r f -> do 17 | > putStrLn $ "Ok " ++ show r ++ "\n" 18 | > ++ unlines (map show $ fmToList f) 19 | > ParseEOF f -> do 20 | > putStrLn $ "Premature end of input:\n" 21 | > ++ unlines (map show $ fmToList f) 22 | > ParseError ts f -> do 23 | > putStrLn $ "Error: " ++ show ts 24 | 25 | > forest_lookup f i 26 | > = fromJust $ lookupFM f i 27 | -------------------------------------------------------------------------------- /examples/glr/nlp/Main.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | > import System.Environment(getArgs) 3 | > import Data.Maybe(fromJust) 4 | > import qualified Data.Map as Map 5 | > import English 6 | 7 | #include "DV_lhs" 8 | 9 | This requires CPP / preprocessing; use Hugs.lhs for tests with Hugs 10 | 11 | 12 | > main 13 | > = do 14 | > [s] <- getArgs 15 | > case doParse $ lexer s of 16 | > ParseOK r f -> do 17 | > putStrLn $ "Ok " ++ show r ++ "\n" 18 | > ++ unlines (map show $ Map.toList f) 19 | > toDV $ Map.toList f 20 | > ParseEOF f -> do 21 | > putStrLn $ "Premature end of input:\n" 22 | > ++ unlines (map show $ Map.toList f) 23 | > toDV $ Map.toList f 24 | > ParseError ts f -> do 25 | > putStrLn $ "Error: " ++ show ts 26 | > toDV $ Map.toList f 27 | 28 | -------------------------------------------------------------------------------- /examples/glr/nlp/Makefile: -------------------------------------------------------------------------------- 1 | TOP=.. 2 | include ${TOP}/Makefile.defs 3 | 4 | english : English.hs Main.lhs 5 | ${GHC} -cpp -fglasgow-exts -o english --make Main.lhs 6 | 7 | run : english 8 | ./english "the man saw the race with a telescope" 9 | 10 | eof : english 11 | echo testing premature eof 12 | ./english "the man saw a" 13 | 14 | err : english 15 | echo testing syntax error 16 | ./english "the the man saw race" 17 | 18 | test : run eof err 19 | 20 | clean : 21 | rm -rf english English.info English.hs EnglishData.hs *.o *.hi out.daVinci 22 | -------------------------------------------------------------------------------- /examples/glr/nlp/README: -------------------------------------------------------------------------------- 1 | 2 | Obligatory NL ambiguity example. 3 | 4 | The grammar is small and simple, but exhibits prepositional phrase attachment 5 | ambiguity. 6 | 7 | Example: "the man saw the race with a telescope" 8 | Can be bracketed as the following 9 | (a) "the man saw (the race with a telescope)" 10 | (b) "(the man saw the race) with a telescope" 11 | 12 | Note: the "lexicon" contains some ambiguous words too - see if you can extend 13 | the grammar so this comes into play. 14 | 15 | 16 | "make run" to run the test case. 17 | 18 | For Hugs, load up Hugs.lhs - it is a simplified version, with entry point 19 | "test :: String -> IO ()" 20 | -------------------------------------------------------------------------------- /examples/glr/packing/Expr.y: -------------------------------------------------------------------------------- 1 | { 2 | -- only list imports here 3 | import Data.Char 4 | } 5 | 6 | %tokentype { Token } 7 | 8 | %lexer { lexer } { TokenEOF } 9 | 10 | %token 11 | i { Thing } 12 | 13 | %% 14 | 15 | S : A S {} | {} 16 | 17 | A : B {} 18 | B : C {} 19 | C : D {} | E {} 20 | D : i {} 21 | E : i F {} 22 | F : {} 23 | 24 | 25 | { 26 | 27 | data Token 28 | = TokenEOF 29 | | Thing 30 | deriving (Show,Eq, Ord) 31 | 32 | 33 | lexer :: String -> [Token] 34 | lexer [] = [] 35 | lexer (' ':cs) = lexer cs 36 | 37 | lexer (c:cs) = Thing : lexer cs 38 | 39 | 40 | } 41 | -------------------------------------------------------------------------------- /examples/glr/packing/Hugs.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | > import System(getArgs) 3 | > import Data.Maybe(fromJust) 4 | > import FiniteMap(fmToList,lookupFM) 5 | > import Expr 6 | 7 | 8 | > main 9 | > = do 10 | > [s] <- getArgs 11 | > test s 12 | 13 | > test s 14 | > = do 15 | > case doParse $ map (:[]) $ lexer s of 16 | > ParseOK r f -> do 17 | > putStrLn $ "Ok " ++ show r ++ "\n" 18 | > ++ unlines (map show $ fmToList f) 19 | > ParseEOF f -> do 20 | > putStrLn $ "Premature end of input:\n" 21 | > ++ unlines (map show $ fmToList f) 22 | > ParseError ts f -> do 23 | > putStrLn $ "Error: " ++ show ts 24 | 25 | > forest_lookup f i 26 | > = fromJust $ lookupFM f i 27 | -------------------------------------------------------------------------------- /examples/glr/packing/Main.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | > import System.Environment(getArgs) 3 | > import Data.Maybe(fromJust) 4 | > import qualified Data.Map as Map 5 | > import Expr 6 | 7 | #include "DV_lhs" 8 | 9 | This requires CPP / preprocessing; use Hugs.lhs for tests with Hugs 10 | 11 | 12 | > main 13 | > = do 14 | > [s] <- getArgs 15 | > case doParse $ map (:[]) $ lexer s of 16 | > ParseOK r f -> do 17 | > putStrLn $ "Ok " ++ show r ++ "\n" 18 | > ++ unlines (map show $ Map.toList f) 19 | > toDV $ Map.toList f 20 | > ParseEOF f -> do 21 | > putStrLn $ "Premature end of input:\n" 22 | > ++ unlines (map show $ Map.toList f) 23 | > toDV $ Map.toList f 24 | > ParseError ts f -> do 25 | > putStrLn $ "Error: " ++ show ts 26 | > toDV $ Map.toList f 27 | 28 | > forest_lookup f i 29 | > = fromJust $ Map.lookup f i 30 | -------------------------------------------------------------------------------- /examples/glr/packing/Makefile: -------------------------------------------------------------------------------- 1 | TOP = .. 2 | include $(TOP)/Makefile.defs 3 | 4 | FILTER = --filter 5 | FILTER = 6 | 7 | .y.hs : 8 | ${HAPPY} -i -l $*.y ${FILTER} 9 | 10 | expr : Expr.hs Main.lhs 11 | ${GHC} -cpp -fglasgow-exts -o expr --make Main.lhs 12 | 13 | run : expr 14 | ./expr "+ 1 1 1 1 1 1 " 15 | 16 | eof : expr 17 | echo testing premature eof 18 | ./expr "" 19 | 20 | err : expr 21 | echo testing syntax error 22 | ./expr "+ 1 +" 23 | 24 | test : run eof err 25 | 26 | clean : 27 | rm -rf expr Expr.info Expr.hs ExprData.hs *.o *.hi out.daVinci 28 | -------------------------------------------------------------------------------- /examples/glr/packing/README: -------------------------------------------------------------------------------- 1 | 2 | Test case for packing 3 | 4 | Grammar allows different (asymmetric) routes for category C, which may get 5 | packed at different times 6 | 7 | 8 | --- 9 | 10 | "make run" to run the test case. 11 | 12 | For Hugs, load up Hugs.lhs - it doesn't produce graphs, and has easy entry 13 | point "test :: String -> IO () 14 | 15 | correct behaviour is packing of ambiguity for all C nodes (for D and E). 16 | 17 | -------------------------------------------------------------------------------- /examples/igloo/Foo.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main (main) where 3 | 4 | import Parser (parse) 5 | import System.IO (hPutStrLn, stderr) 6 | 7 | main :: IO () 8 | main = do x <- getContents 9 | case parse x of 10 | Left e -> hPutStrLn stderr $ "Failed with: " ++ e 11 | Right t -> print t 12 | 13 | -------------------------------------------------------------------------------- /examples/igloo/Lexer.x: -------------------------------------------------------------------------------- 1 | 2 | { 3 | module Lexer (lex_tok) where 4 | 5 | import Control.Monad.State (StateT, get) 6 | import ParserM (ParserM (..), mkT, Token(..), St, start_code, 7 | StartCode, Action, set_start_code, 8 | show_pos, position, input, 9 | AlexInput, alexGetByte, alexInputPrevChar) 10 | } 11 | 12 | words :- 13 | 14 | <0> $white+ ; 15 | <0> fork { mkT TFork } 16 | <0> leaf { mkT TLeaf } 17 | 18 | { 19 | get_tok :: AlexInput -> StateT St (Either String) (Token, AlexInput) 20 | get_tok = \i -> 21 | do st <- get 22 | case alexScan i (start_code st) of 23 | AlexEOF -> return (TEOF, i) 24 | AlexError _ -> fail $ "Lexical error at " ++ show_pos (position i) 25 | AlexSkip i' _ -> get_tok i' 26 | AlexToken i' l a -> a (i', take l (input i)) 27 | 28 | begin :: StartCode -> Action 29 | begin sc (i, _) = do set_start_code sc 30 | get_tok i 31 | 32 | lex_tok :: (Token -> ParserM a) -> ParserM a 33 | lex_tok cont = ParserM $ \i -> 34 | do (tok, iz) <- get_tok i 35 | case cont tok of 36 | ParserM x -> x iz 37 | } 38 | 39 | -------------------------------------------------------------------------------- /examples/igloo/Makefile: -------------------------------------------------------------------------------- 1 | 2 | all: 3 | alex Lexer.x 4 | happy Parser.y 5 | ghc --make Foo -o foo 6 | 7 | test: 8 | echo fork leaf leaf | ./foo 9 | -echo fork leaf leafqleaf | ./foo 10 | -echo leaf leaf leaf leaf leaf | ./foo 11 | @echo ok 12 | 13 | clean: 14 | rm -f *.o *.hi Parser.hs Lexer.hs foo 15 | 16 | -------------------------------------------------------------------------------- /examples/igloo/Parser.y: -------------------------------------------------------------------------------- 1 | 2 | { 3 | module Parser (parse) where 4 | 5 | import Lexer (lex_tok) 6 | import ParserM (Token(..), Tree(..), ParserM, run_parser, get_pos, show_pos, 7 | happyError) 8 | } 9 | 10 | %name parsex tree 11 | %tokentype { Token } 12 | %monad { ParserM } 13 | %lexer { lex_tok } { TEOF } 14 | 15 | %token 16 | fork { TFork } 17 | leaf { TLeaf } 18 | 19 | %% 20 | 21 | tree :: { Tree } 22 | tree : leaf { Leaf } 23 | | fork tree tree { Fork $2 $3 } 24 | 25 | { 26 | parse :: String -> Either String Tree 27 | parse = run_parser parsex 28 | } 29 | 30 | -------------------------------------------------------------------------------- /examples/igloo/ParserM.hs: -------------------------------------------------------------------------------- 1 | 2 | module ParserM ( 3 | -- Parser Monad 4 | ParserM(..), AlexInput, run_parser, 5 | -- Parser state 6 | St, StartCode, start_code, set_start_code, 7 | -- Tokens 8 | Token(..), 9 | -- Tree 10 | Tree(..), 11 | -- Actions 12 | Action, andBegin, mkT, 13 | -- Positions 14 | get_pos, show_pos, 15 | -- Input 16 | alexGetByte, alexInputPrevChar, input, position, 17 | -- Other 18 | happyError 19 | ) where 20 | 21 | import Control.Applicative (Applicative(..)) 22 | import Control.Monad (ap, liftM) 23 | import Control.Monad.Except (throwError) 24 | import Control.Monad.State (StateT, evalStateT, get, put) 25 | import Control.Monad.Trans (lift) 26 | import Data.Char (ord) 27 | import Data.Word (Word8) 28 | 29 | -- Parser Monad 30 | newtype ParserM a = ParserM (AlexInput -> StateT St (Either String) (AlexInput, a)) 31 | 32 | instance Functor ParserM where 33 | fmap = liftM 34 | 35 | instance Applicative ParserM where 36 | pure a = ParserM $ \i -> return (i, a) 37 | (<*>) = ap 38 | 39 | instance Monad ParserM where 40 | return = pure 41 | ParserM m >>= k = ParserM $ \i -> do (i', x) <- m i 42 | case k x of 43 | ParserM y -> y i' 44 | fail err = ParserM $ \_ -> fail err 45 | 46 | run_parser :: ParserM a -> (String -> Either String a) 47 | run_parser (ParserM p) 48 | = \s -> case evalStateT (p (AlexInput init_pos s)) init_state of 49 | Left es -> throwError es 50 | Right (_, x) -> return x 51 | 52 | -- Parser state 53 | 54 | data St = St {start_code :: !StartCode} 55 | type StartCode = Int 56 | 57 | init_state :: St 58 | init_state = St 0 59 | 60 | -- Tokens 61 | 62 | data Token = TEOF 63 | | TFork 64 | | TLeaf 65 | 66 | -- Tree 67 | 68 | data Tree = Leaf 69 | | Fork Tree Tree 70 | deriving Show 71 | 72 | -- Actions 73 | 74 | type Action = (AlexInput, String) -> StateT St (Either String) (Token, AlexInput) 75 | 76 | set_start_code :: StartCode -> StateT St (Either String) () 77 | set_start_code sc = do st <- get 78 | put $ st { start_code = sc } 79 | 80 | andBegin :: Action -> StartCode -> Action 81 | (act `andBegin` sc) x = do set_start_code sc 82 | act x 83 | 84 | mkT :: Token -> Action 85 | mkT t (p,_) = lift $ return (t, p) 86 | 87 | -- Positions 88 | 89 | data Pos = Pos !Int{- Line -} !Int{- Column -} 90 | 91 | get_pos :: ParserM Pos 92 | get_pos = ParserM $ \i@(AlexInput p _) -> return (i, p) 93 | 94 | alexMove :: Pos -> Char -> Pos 95 | alexMove (Pos l _) '\n' = Pos (l+1) 1 96 | alexMove (Pos l c) '\t' = Pos l ((c+8) `div` 8 * 8) 97 | alexMove (Pos l c) _ = Pos l (c+1) 98 | 99 | init_pos :: Pos 100 | init_pos = Pos 1 1 101 | 102 | show_pos :: Pos -> String 103 | show_pos (Pos l c) = "line " ++ show l ++ ", column " ++ show c 104 | 105 | -- Input 106 | 107 | data AlexInput = AlexInput {position :: !Pos, input :: String} 108 | 109 | alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) 110 | alexGetByte (AlexInput p (x:xs)) = Just (fromIntegral (ord x), 111 | AlexInput (alexMove p x) xs) 112 | alexGetByte (AlexInput _ []) = Nothing 113 | 114 | alexInputPrevChar :: AlexInput -> Char 115 | alexInputPrevChar _ = error "Lexer doesn't implement alexInputPrevChar" 116 | 117 | happyError :: ParserM a 118 | happyError = do p <- get_pos 119 | fail $ "Parse error at " ++ show_pos p 120 | 121 | -------------------------------------------------------------------------------- /examples/igloo/README: -------------------------------------------------------------------------------- 1 | From: Ian Lynagh [igloo@earth.li] 2 | Subject: happy and line numbers 3 | Date: Thu 12/02/2004 18:48 4 | 5 | I think it would be nice to have an example of how to have a nice 6 | position tracking monadic parser calling a lexer per token in the 7 | examples directory. I've attached a cut-down parser of mine that does it 8 | well enough for me. The only slight niggle is that parse errors are 9 | reported at the end of the token rather than the start, but that hasn't 10 | bothered me enough to look into fixing it yet. 11 | 12 | The cut down parser doesn't use start codes, but I've left the machinery 13 | in to make it easier for people to see how to use them. 14 | 15 | Naturally any suggestions for improving it would be gladly received! 16 | 17 | -------------------------------------------------------------------------------- /hackage-upload.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -e 3 | TOP=$(readlink -f $(dirname $0)) 4 | 5 | # Some sanity checking for version 6 | CABAL_FILE=$(ls *.cabal) 7 | VERSION=$(grep -E '^version:' "$CABAL_FILE" | awk '{print $2}') 8 | if [ -z "$VERSION" ]; then 9 | echo "No version found in $CABAL_FILE." 10 | exit 1 11 | fi 12 | echo "Found version: $VERSION" 13 | 14 | # Ensure that we depend on the proper version of happy-lib 15 | if grep -Eq "(^| )happy-lib[[:space:]]*==[[:space:]]*$VERSION" "$CABAL_FILE"; then 16 | echo "happy-lib dependency is correctly listed with version $VERSION in $CABAL_FILE." 17 | else 18 | echo "happy-lib dependency with version $VERSION is NOT listed in $CABAL_FILE!" 19 | exit 1 20 | fi 21 | 22 | sdist=$(mktemp -d $TOP/dist.XXXXXX) 23 | trap 'rm -rf "$sdist"' EXIT 24 | 25 | cabal sdist --builddir=$sdist 26 | cabal upload $1 $sdist/sdist/*.tar.gz 27 | -------------------------------------------------------------------------------- /happy.cabal: -------------------------------------------------------------------------------- 1 | name: happy 2 | version: 2.1.5 3 | license: BSD2 4 | license-file: LICENSE 5 | copyright: (c) Andy Gill, Simon Marlow 6 | author: Andy Gill and Simon Marlow 7 | maintainer: https://github.com/haskell/happy 8 | bug-reports: https://github.com/haskell/happy/issues 9 | stability: stable 10 | homepage: https://www.haskell.org/happy/ 11 | synopsis: Happy is a parser generator for Haskell 12 | category: Development 13 | cabal-version: >= 1.10 14 | build-type: Simple 15 | 16 | Description: 17 | Happy is a parser generator for Haskell. Given a grammar 18 | specification in BNF, Happy generates Haskell code to parse the 19 | grammar. Happy works in a similar way to the @yacc@ tool for C. 20 | 21 | tested-with: 22 | GHC == 9.12.2 23 | GHC == 9.10.2 24 | GHC == 9.8.4 25 | GHC == 9.6.7 26 | GHC == 9.4.8 27 | GHC == 9.2.8 28 | GHC == 9.0.2 29 | GHC == 8.10.7 30 | GHC == 8.8.4 31 | GHC == 8.6.5 32 | GHC == 8.4.4 33 | GHC == 8.2.2 34 | GHC == 8.0.2 35 | 36 | extra-source-files: 37 | ChangeLog.md 38 | Makefile 39 | README.md 40 | examples/glr/nlp/Main.lhs 41 | examples/glr/nlp/Makefile 42 | examples/glr/nlp/README 43 | examples/glr/nlp/English.y 44 | examples/glr/nlp/Hugs.lhs 45 | examples/glr/Makefile 46 | examples/glr/Makefile.defs 47 | examples/glr/expr-eval/Main.lhs 48 | examples/glr/expr-eval/Makefile 49 | examples/glr/expr-eval/Expr.y 50 | examples/glr/expr-eval/README 51 | examples/glr/expr-eval/Hugs.lhs 52 | examples/glr/expr-tree/Main.lhs 53 | examples/glr/expr-tree/Makefile 54 | examples/glr/expr-tree/Expr.y 55 | examples/glr/expr-tree/README 56 | examples/glr/expr-tree/Tree.lhs 57 | examples/glr/expr-tree/Hugs.lhs 58 | examples/glr/highly-ambiguous/Main.lhs 59 | examples/glr/highly-ambiguous/Makefile 60 | examples/glr/highly-ambiguous/Expr.y 61 | examples/glr/highly-ambiguous/README 62 | examples/glr/highly-ambiguous/Hugs.lhs 63 | examples/glr/hidden-leftrec/Main.lhs 64 | examples/glr/hidden-leftrec/Makefile 65 | examples/glr/hidden-leftrec/Expr.y 66 | examples/glr/hidden-leftrec/README 67 | examples/glr/hidden-leftrec/Hugs.lhs 68 | examples/glr/expr-monad/Main.lhs 69 | examples/glr/expr-monad/Makefile 70 | examples/glr/expr-monad/Expr.y 71 | examples/glr/expr-monad/README 72 | examples/glr/expr-monad/Hugs.lhs 73 | examples/glr/bio-eg/Main.lhs 74 | examples/glr/bio-eg/Makefile 75 | examples/glr/bio-eg/Bio.y 76 | examples/glr/bio-eg/README 77 | examples/glr/bio-eg/1-1200.dna 78 | examples/glr/bio-eg/1-600.dna 79 | examples/glr/common/DV_lhs 80 | examples/glr/common/DaVinciTypes.hs 81 | examples/glr/packing/Main.lhs 82 | examples/glr/packing/Makefile 83 | examples/glr/packing/Expr.y 84 | examples/glr/packing/README 85 | examples/glr/packing/Hugs.lhs 86 | examples/PgnParser.ly 87 | examples/MonadTest.ly 88 | examples/igloo/ParserM.hs 89 | examples/igloo/Makefile 90 | examples/igloo/Parser.y 91 | examples/igloo/Foo.hs 92 | examples/igloo/README 93 | examples/igloo/Lexer.x 94 | examples/README 95 | examples/Calc.ly 96 | examples/DavesExample.ly 97 | examples/ErrorTest.ly 98 | examples/ErlParser.ly 99 | examples/SimonsExample.ly 100 | examples/LexerTest.ly 101 | tests/AttrGrammar001.y 102 | tests/AttrGrammar002.y 103 | tests/Makefile 104 | tests/Partial.ly 105 | tests/Test.ly 106 | tests/TestMulti.ly 107 | tests/TestPrecedence.ly 108 | tests/bogus-token.y 109 | tests/bug001.ly 110 | tests/bug002.y 111 | tests/error001.stderr 112 | tests/error001.stdout 113 | tests/error001.y 114 | tests/monad001.y 115 | tests/monad002.ly 116 | tests/monaderror.y 117 | tests/precedence001.ly 118 | tests/precedence002.y 119 | tests/test_rules.y 120 | tests/issue91.y 121 | tests/issue93.y 122 | tests/issue94.y 123 | tests/issue95.y 124 | tests/monaderror-explist.y 125 | tests/typeclass_monad001.y 126 | tests/typeclass_monad002.ly 127 | tests/typeclass_monad_lexer.y 128 | tests/rank2.y 129 | tests/shift01.y 130 | 131 | source-repository head 132 | type: git 133 | location: https://github.com/haskell/happy.git 134 | 135 | executable happy 136 | hs-source-dirs: app 137 | main-is: Main.lhs 138 | 139 | build-depends: base >= 4.9 && < 5, 140 | array, 141 | containers >= 0.4.2, 142 | mtl >= 2.2.1, 143 | happy-lib == 2.1.5 144 | 145 | default-language: Haskell98 146 | default-extensions: CPP, MagicHash, FlexibleContexts, NamedFieldPuns 147 | ghc-options: -Wall -Wno-incomplete-uni-patterns 148 | other-modules: 149 | Paths_happy 150 | 151 | test-suite tests 152 | type: exitcode-stdio-1.0 153 | main-is: test.hs 154 | -- This line is important as it ensures that the local `exe:happy` component declared above is built before the test-suite component is invoked, as well as making sure that `happy` is made available on $PATH and `$happy_datadir` is set accordingly before invoking `test.hs` 155 | build-tools: happy 156 | ghc-options: -threaded 157 | 158 | build-depends: base >= 4.9 && < 5, process < 1.7 159 | default-language: Haskell98 160 | -------------------------------------------------------------------------------- /lib/ChangeLog.md: -------------------------------------------------------------------------------- 1 | ../ChangeLog.md -------------------------------------------------------------------------------- /lib/README.md: -------------------------------------------------------------------------------- 1 | ../README.md -------------------------------------------------------------------------------- /lib/backend-glr/LICENSE: -------------------------------------------------------------------------------- 1 | ../../LICENSE -------------------------------------------------------------------------------- /lib/backend-glr/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /lib/backend-glr/src/Happy/Backend/GLR.hs: -------------------------------------------------------------------------------- 1 | module Happy.Backend.GLR where 2 | 3 | import Happy.Paths 4 | 5 | glrBackendDataDir :: IO String 6 | glrBackendDataDir = getDataDir 7 | -------------------------------------------------------------------------------- /lib/backend-lalr/LICENSE: -------------------------------------------------------------------------------- 1 | ../../LICENSE -------------------------------------------------------------------------------- /lib/backend-lalr/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /lib/backend-lalr/src/Happy/Backend/LALR.hs: -------------------------------------------------------------------------------- 1 | module Happy.Backend.LALR where 2 | 3 | import Happy.Paths 4 | import Data.Char 5 | 6 | lalrBackendDataDir :: IO String 7 | lalrBackendDataDir = getDataDir 8 | 9 | magicFilter :: Maybe String -> String -> String 10 | magicFilter magicName = case magicName of 11 | Nothing -> id 12 | Just name' -> let 13 | small_name = name' 14 | big_name = toUpper (head name') : tail name' 15 | filter_output ('h':'a':'p':'p':'y':rest) = small_name ++ filter_output rest 16 | filter_output ('H':'a':'p':'p':'y':rest) = big_name ++ filter_output rest 17 | filter_output (c:cs) = c : filter_output cs 18 | filter_output [] = [] 19 | in filter_output 20 | 21 | importsToInject :: Bool -> String 22 | importsToInject debug = concat ["\n", import_prelude, import_array, import_bits, import_glaexts, debug_imports, applicative_imports] 23 | where 24 | debug_imports | debug = import_debug 25 | | otherwise = "" 26 | applicative_imports = import_applicative 27 | 28 | import_glaexts = "import qualified GHC.Exts as Happy_GHC_Exts\n" 29 | _import_ghcstack = "import qualified GHC.Stack as Happy_GHC_Stack\n" 30 | import_array = "import qualified Data.Array as Happy_Data_Array\n" 31 | import_bits = "import qualified Data.Bits as Bits\n" 32 | import_debug = "import qualified System.IO as Happy_System_IO\n" ++ 33 | "import qualified System.IO.Unsafe as Happy_System_IO_Unsafe\n" ++ 34 | "import qualified Debug.Trace as Happy_Debug_Trace\n" 35 | import_applicative = "import Control.Applicative(Applicative(..))\n" ++ 36 | "import Control.Monad (ap)\n" 37 | import_prelude = unlines $ map (\ x -> unwords ["import qualified", x, "as Happy_Prelude"]) $ 38 | [ "Data.Function" 39 | , "Data.Bool" 40 | , "Data.Function" 41 | , "Data.Maybe" 42 | , "Data.Int" 43 | , "Data.String" 44 | , "Data.Tuple" 45 | , "Data.List" 46 | , "Control.Monad" 47 | , "Text.Show" 48 | , "GHC.Num" 49 | , "GHC.Err" 50 | ] 51 | 52 | langExtsToInject :: [String] 53 | langExtsToInject = ["MagicHash", "BangPatterns", "TypeSynonymInstances", "FlexibleInstances", "PatternGuards", "NoStrictData", "UnboxedTuples", "PartialTypeSignatures"] 54 | 55 | defines :: Bool -> Bool -> String 56 | defines debug coerce = unlines [ "#define " ++ d ++ " 1" | d <- vars_to_define ] 57 | where 58 | vars_to_define = concat 59 | [ [ "HAPPY_DEBUG" | debug ] 60 | , [ "HAPPY_COERCE" | coerce ] 61 | ] 62 | -------------------------------------------------------------------------------- /lib/data/GLR_Base.hs: -------------------------------------------------------------------------------- 1 | {- GLR_Base.lhs 2 | $Id: GLR_Base.lhs,v 1.4 2004/12/04 15:01:37 paulcc Exp $ 3 | -} 4 | 5 | -- Basic defs required for compiling the data portion of the parser 6 | 7 | -- We're creating Int-indexed graphs 8 | 9 | type ForestId = (Int,Int,GSymbol) 10 | 11 | 12 | -- Actions for the GLR machine 13 | 14 | data GLRAction = Shift Int [Reduction] 15 | | Reduce [Reduction] 16 | | Accept 17 | | Error 18 | 19 | --- 20 | -- A Reduction (s,n,f) removes the top n node-ids, creates a new branch from these 21 | -- and labels the branch with the given symbol s. Additionally, the branch may 22 | -- hold some semantic value. 23 | 24 | type Reduction = (GSymbol,Int, [ForestId] -> Branch) 25 | 26 | 27 | --- 28 | -- A Branch holds the semantic result plus node ids of children 29 | 30 | data Branch 31 | = Branch {b_sem :: GSem, b_nodes :: [ForestId]} 32 | deriving Show 33 | 34 | instance Eq Branch where 35 | b1 == b2 = b_nodes b1 == b_nodes b2 36 | 37 | 38 | 39 | ------------------------------------------------------------------------------- 40 | -- Utilities for decoding 41 | 42 | --- 43 | -- Tree decode unpacks the forest into a list of results 44 | -- - this is ok for small examples, but inefficient for very large examples 45 | -- - the data file contains further instances 46 | -- - see documentation for further information 47 | -- - "Decode_Result" is a synonym used to insert the monad type constr (or not) 48 | 49 | class TreeDecode a where 50 | decode_b :: (ForestId -> [Branch]) -> Branch -> [Decode_Result a] 51 | 52 | decode :: TreeDecode a => (ForestId -> [Branch]) -> ForestId -> [Decode_Result a] 53 | decode f i@(_,_,HappyTok t) 54 | = decode_b f (Branch (SemTok t) []) 55 | decode f i 56 | = [ d | b <- f i, d <- decode_b f b ] 57 | 58 | ---- generated by Happy, since it means expansion of synonym (not ok in H-98) 59 | --instance TreeDecode UserDefTok where 60 | -- decode_b f (Branch (SemTok t) []) = [happy_return t] 61 | 62 | --- 63 | -- this is used to multiply the ambiguous possibilities from children 64 | 65 | --cross_fn :: [a -> b] -> [a] -> [b] 66 | --actual type will depend on monad in use. 67 | --happy_ap defined by parser generator 68 | cross_fn fs as = [ f `happy_ap` a | f <- fs, a <- as] 69 | 70 | --- 71 | -- Label decoding unpacks from the Semantic wrapper type 72 | -- - this allows arbitrary values (within the limits of the compiler settings) 73 | -- to be recovered from nodes in the tree. 74 | -- - again, more instances are written in the data file 75 | -- - see documentation for further information 76 | 77 | class LabelDecode a where 78 | unpack :: GSem -> a 79 | 80 | ---- generated by Happy, since it means expansion of synonym (not ok in H-98) 81 | --instance LabelDecode UserDefTok where 82 | -- unpack (SemTok t) = t 83 | 84 | 85 | -------------------------------------------------------------------------------- /lib/frontend/LICENSE: -------------------------------------------------------------------------------- 1 | ../../LICENSE -------------------------------------------------------------------------------- /lib/frontend/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /lib/frontend/boot-src/AttrGrammarParser.ly: -------------------------------------------------------------------------------- 1 | This parser parses the contents of the attribute grammar 2 | into a list of rules. A rule can either be an assignment 3 | to an attribute of the LHS (synthesized attribute), and 4 | assignment to an attribute of the RHS (an inherited attribute), 5 | or a conditional statement. 6 | 7 | > { 8 | > {-# OPTIONS_GHC -w #-} 9 | > module Happy.Frontend.AttrGrammar.Parser (agParser) where 10 | > import Happy.Frontend.ParseMonad.Class 11 | > import Happy.Frontend.ParseMonad 12 | > import Happy.Frontend.AttrGrammar 13 | > } 14 | 15 | > %name agParser 16 | > %tokentype { AgToken } 17 | > %token 18 | > "{" { AgTok_LBrace } 19 | > "}" { AgTok_RBrace } 20 | > ";" { AgTok_Semicolon } 21 | > "=" { AgTok_Eq } 22 | > where { AgTok_Where } 23 | > selfRef { AgTok_SelfRef _ } 24 | > subRef { AgTok_SubRef _ } 25 | > rightRef { AgTok_RightmostRef _ } 26 | > unknown { AgTok_Unknown _ } 27 | > 28 | > %monad { P } 29 | > %lexer { lexTokenP } { AgTok_EOF } 30 | 31 | > %% 32 | 33 | > agParser :: { [AgRule] } 34 | > : rules { $1 } 35 | 36 | > rules :: { [AgRule] } 37 | > : rule ";" rules { $1 : $3 } 38 | > | rule { $1 : [] } 39 | > | { [] } 40 | 41 | > rule :: { AgRule } 42 | > : selfRef "=" code { SelfAssign $ MkAgSelfAssign (selfRefVal $1) $3 } 43 | > | subRef "=" code { SubAssign $ MkAgSubAssign (subRefVal $1) $3 } 44 | > | rightRef "=" code { RightmostAssign (rightRefVal $1) $3 } 45 | > | where code { Conditional $ MkAgConditional $2 } 46 | 47 | > code :: { [AgToken] } 48 | > : "{" code0 "}" code { [$1] ++ $2 ++ [$3] ++ $4 } 49 | > | "=" code { $1 : $2 } 50 | > | selfRef code { $1 : $2 } 51 | > | subRef code { $1 : $2 } 52 | > | rightRef code { $1 : $2 } 53 | > | unknown code { $1 : $2 } 54 | > | { [] } 55 | 56 | > code0 :: { [AgToken] } 57 | > : "{" code0 "}" code0 { [$1] ++ $2 ++ [$3] ++ $4 } 58 | > | "=" code0 { $1 : $2 } 59 | > | ";" code0 { $1 : $2 } 60 | > | selfRef code0 { $1 : $2 } 61 | > | subRef code0 { $1 : $2 } 62 | > | rightRef code { $1 : $2 } 63 | > | unknown code0 { $1 : $2 } 64 | > | { [] } 65 | 66 | > { 67 | > happyError :: P a 68 | > happyError = failP (\l -> show l ++ ": Parse error\n") 69 | > } 70 | -------------------------------------------------------------------------------- /lib/frontend/bootstrap.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | BASEDIR=$(dirname "$0") 4 | happy -agc "$BASEDIR/boot-src/Parser.ly" -o "$BASEDIR/src/Happy/Frontend/Parser.hs" 5 | happy -agc "$BASEDIR/boot-src/AttrGrammarParser.ly" -o "$BASEDIR/src/Happy/Frontend/AttrGrammar/Parser.hs" 6 | -------------------------------------------------------------------------------- /lib/frontend/src/Happy/Frontend.hs: -------------------------------------------------------------------------------- 1 | module Happy.Frontend where 2 | 3 | import Happy.Frontend.AbsSyn 4 | import Happy.Frontend.Parser 5 | import Happy.Frontend.ParseMonad.Class 6 | 7 | parseYFileContents :: String -> ParseResult BookendedAbsSyn 8 | parseYFileContents contents = runFromStartP ourParser contents 1 9 | 10 | data FileType = Y | LY 11 | 12 | fileNameAndType :: String -> Maybe (String, FileType) 13 | fileNameAndType = nameType . reverse where 14 | nameType ('y':'.':f) = Just (reverse f, Y) 15 | nameType ('y':'l':'.':f) = Just (reverse f, LY) 16 | nameType _ = Nothing 17 | 18 | -- Delit, converting an ly file into a y file. 19 | deLitify :: String -> String 20 | deLitify = deLit where 21 | deLit ('>':' ':r) = deLit1 r 22 | deLit ('>':'\t':r) = '\t' : deLit1 r 23 | deLit ('>':'\n':r) = deLit r 24 | deLit ('>':_) = error "Error when de-litify-ing" 25 | deLit ('\n':r) = '\n' : deLit r 26 | deLit r = deLit2 r 27 | deLit1 ('\n':r) = '\n' : deLit r 28 | deLit1 (c:r) = c : deLit1 r 29 | deLit1 [] = [] 30 | deLit2 ('\n':r) = '\n' : deLit r 31 | deLit2 (_:r) = deLit2 r 32 | deLit2 [] = [] 33 | -------------------------------------------------------------------------------- /lib/frontend/src/Happy/Frontend/AttrGrammar.lhs: -------------------------------------------------------------------------------- 1 | > module Happy.Frontend.AttrGrammar 2 | > ( AgToken (..) 3 | 4 | > , AgRule (..) 5 | 6 | > , AgSelfAssign(..) 7 | > , AgSubAssign(..) 8 | > , AgConditional(..) 9 | 10 | > , HasLexer (..) 11 | 12 | > , Index 13 | 14 | > , agLexAll 15 | > , subRefVal 16 | > , selfRefVal 17 | > , rightRefVal 18 | > ) where 19 | 20 | > import Data.Char 21 | > import Happy.Frontend.ParseMonad.Class 22 | 23 | > type Index = Int 24 | 25 | > data AgToken 26 | > = AgTok_LBrace 27 | > | AgTok_RBrace 28 | > | AgTok_Where 29 | > | AgTok_Semicolon 30 | > | AgTok_Eq 31 | > | AgTok_SelfRef String 32 | > | AgTok_SubRef (Index, String) 33 | > | AgTok_RightmostRef String 34 | > | AgTok_Unknown String 35 | > | AgTok_EOF 36 | > deriving (Show,Eq,Ord) 37 | 38 | > subRefVal :: AgToken -> (Index, String) 39 | > subRefVal (AgTok_SubRef x) = x 40 | > subRefVal _ = error "subRefVal: Bad value" 41 | > selfRefVal :: AgToken -> String 42 | > selfRefVal (AgTok_SelfRef x) = x 43 | > selfRefVal _ = error "selfRefVal: Bad value" 44 | > rightRefVal :: AgToken -> String 45 | > rightRefVal (AgTok_RightmostRef x) = x 46 | > rightRefVal _ = error "rightRefVal: Bad value" 47 | 48 | > data AgRule 49 | > = SelfAssign AgSelfAssign 50 | > | SubAssign AgSubAssign 51 | > | RightmostAssign String [AgToken] 52 | > -- ^ Syntactic sugar 53 | > | Conditional AgConditional 54 | > deriving (Show,Eq,Ord) 55 | 56 | We will partition the rule types and handle them separately, so we want 57 | a separate data type for each core rule type. We don't need one for 58 | `RightmostAssign` because it is syntactic sugar. 59 | 60 | > data AgSelfAssign = MkAgSelfAssign String [AgToken] 61 | > deriving (Show,Eq,Ord) 62 | 63 | > data AgSubAssign = MkAgSubAssign (Index, String) [AgToken] 64 | > deriving (Show,Eq,Ord) 65 | 66 | > data AgConditional = MkAgConditional [AgToken] 67 | > deriving (Show,Eq,Ord) 68 | 69 | ----------------------------------------------------------------- 70 | -- For the most part, the body of the attribute grammar rules 71 | -- is uninterpreted Haskell expressions. We only need to know about 72 | -- a) braces and semicolons to break the rules apart 73 | -- b) the equals sign to break the rules into LValues and the RHS 74 | -- c) attribute references, which are $$, $x (positive integer x) 75 | -- or $> (for the rightmost symbol) followed by an optional 76 | -- attribute specifier, which is a dot followed by a 77 | -- Haskell variable identifier 78 | -- Examples: 79 | -- $$ 80 | -- $1 81 | -- $> 82 | -- $$.pos 83 | -- $3.value 84 | -- $2.someAttribute0' 85 | -- 86 | -- Everything else can be treated as uninterpreted strings. Our munging 87 | -- will wreck column alignment so attribute grammar specifications must 88 | -- not rely on layout. 89 | 90 | > agLexAll :: String -> Int -> ParseResult [AgToken] 91 | > agLexAll = aux [] 92 | > where aux toks [] _ = Right (reverse toks) 93 | > aux toks s l = agLexer (\t -> aux (t:toks)) s l 94 | 95 | > instance HasLexer AgToken where 96 | > lexToken = agLexer 97 | 98 | > agLexer :: (AgToken -> Pfunc a) -> Pfunc a 99 | > agLexer cont [] = cont AgTok_EOF [] 100 | > agLexer cont ('{':rest) = cont AgTok_LBrace rest 101 | > agLexer cont ('}':rest) = cont AgTok_RBrace rest 102 | > agLexer cont (';':rest) = cont AgTok_Semicolon rest 103 | > agLexer cont ('=':rest) = cont AgTok_Eq rest 104 | > agLexer cont ('w':'h':'e':'r':'e':rest) = cont AgTok_Where rest 105 | > agLexer cont ('$':'$':rest) = agLexAttribute cont (\a -> AgTok_SelfRef a) rest 106 | > agLexer cont ('$':'>':rest) = agLexAttribute cont (\a -> AgTok_RightmostRef a) rest 107 | > agLexer cont s@('$':rest) = 108 | > let (n,rest') = span isDigit rest 109 | > in if null n 110 | > then agLexUnknown cont s 111 | > else agLexAttribute cont (\a -> AgTok_SubRef (read n,a)) rest' 112 | > agLexer cont s@(c:rest) 113 | > | isSpace c = agLexer cont (dropWhile isSpace rest) 114 | > | otherwise = agLexUnknown cont s 115 | 116 | > agLexUnknown :: (AgToken -> Pfunc a) -> Pfunc a 117 | > agLexUnknown cont s = let (u,rest) = aux [] s in cont (AgTok_Unknown u) rest 118 | > where aux t [] = (reverse t,[]) 119 | > aux t ('$':c:cs) 120 | > | c /= '$' && not (isDigit c) = aux ('$':t) (c:cs) 121 | > | otherwise = (reverse t,'$':c:cs) 122 | > aux t (c:cs) 123 | > | isSpace c || c `elem` "{};=" = (reverse t,c:cs) 124 | > | otherwise = aux (c:t) cs 125 | 126 | > agLexAttribute :: (AgToken -> Pfunc a) -> (String -> AgToken) -> Pfunc a 127 | > agLexAttribute cont k ('.':x:xs) 128 | > | isLower x = let (ident,rest) = span (\c -> isAlphaNum c || c == '\'') xs in cont (k (x:ident)) rest 129 | > | otherwise = \_ -> Left "bad attribute identifier" 130 | > agLexAttribute cont k rest = cont (k "") rest 131 | -------------------------------------------------------------------------------- /lib/frontend/src/Happy/Frontend/Mangler/Monad.lhs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | Monad for error handling for the mangler 3 | 4 | Pulled out so it can be shared with the attribute grammar part of the 5 | mangler too. 6 | 7 | (c) 1993-2001 Andy Gill, Simon Marlow 8 | ----------------------------------------------------------------------------- 9 | 10 | > module Happy.Frontend.Mangler.Monad 11 | > ( ErrMsg 12 | > , M 13 | > , addErr 14 | > ) where 15 | 16 | > import Control.Monad.Writer ( Writer, MonadWriter(..) ) 17 | 18 | > type ErrMsg = String 19 | > type M a = Writer [ErrMsg] a 20 | 21 | > addErr :: ErrMsg -> M () 22 | > addErr e = tell [e] 23 | -------------------------------------------------------------------------------- /lib/frontend/src/Happy/Frontend/ParamRules.hs: -------------------------------------------------------------------------------- 1 | module Happy.Frontend.ParamRules(expand_rules, Prod1(..), Rule1(..)) where 2 | 3 | import Happy.Frontend.AbsSyn 4 | import Control.Monad.Writer 5 | import Control.Monad.Except(throwError) 6 | import Control.Monad.Trans.Except 7 | import Data.List(partition,intersperse) 8 | import qualified Data.Set as S 9 | import qualified Data.Map as M -- XXX: Make it work with old GHC. 10 | 11 | -- | Desugar parameterized productions into non-parameterized ones 12 | -- 13 | -- This transformation is fairly straightforward: we walk through every rule 14 | -- and collect every possible instantiation of parameterized productions. Then, 15 | -- we generate a new non-parametrized rule for each of these. 16 | expand_rules :: [Rule e] -> Either String [Rule1 e] 17 | expand_rules rs = do let (funs,rs1) = split_rules rs 18 | (as,is) <- runM2 (mapM (`inst_rule` []) rs1) 19 | bs <- make_insts funs (S.toList is) S.empty 20 | return (as++bs) 21 | 22 | type RuleName = String 23 | 24 | data Inst = Inst RuleName [RuleName] deriving (Eq, Ord) 25 | newtype Funs e = Funs (M.Map RuleName (Rule e)) 26 | 27 | -- | Similar to 'Rule', but `Term`'s have been flattened into `RuleName`'s 28 | data Rule1 e = Rule1 RuleName [Prod1 e] (Maybe (String, Subst)) 29 | 30 | -- | Similar to 'Prod', but `Term`'s have been flattened into `RuleName`'s 31 | data Prod1 e = Prod1 [RuleName] e Int Prec 32 | 33 | inst_name :: Inst -> RuleName 34 | inst_name (Inst f []) = f 35 | --inst_name (Inst f xs) = f ++ "(" ++ concat (intersperse "," xs) ++ ")" 36 | inst_name (Inst f xs) = f ++ "__" ++ concat (intersperse "__" xs) ++ "__" 37 | 38 | 39 | -- | A renaming substitution used when we instantiate a parameterized rule. 40 | type Subst = [(RuleName,RuleName)] 41 | type M1 = Writer (S.Set Inst) 42 | type M2 = ExceptT String M1 43 | 44 | -- | Collects the instances arising from a term. 45 | from_term :: Subst -> Term -> M1 RuleName 46 | from_term s (App f []) = return $ case lookup f s of 47 | Just g -> g 48 | Nothing -> f 49 | 50 | from_term s (App f ts) = do xs <- from_terms s ts 51 | let i = Inst f xs 52 | tell (S.singleton i) 53 | return $ inst_name i 54 | 55 | -- | Collects the instances arising from a list of terms. 56 | from_terms :: Subst -> [Term] -> M1 [RuleName] 57 | from_terms s ts = mapM (from_term s) ts 58 | 59 | -- XXX: perhaps change the line to the line of the instance 60 | inst_prod :: Subst -> Prod e -> M1 (Prod1 e) 61 | inst_prod s (Prod ts c l p) = do xs <- from_terms s ts 62 | return (Prod1 xs c l p) 63 | 64 | inst_rule :: Rule e -> [RuleName] -> M2 (Rule1 e) 65 | inst_rule (Rule x xs ps t) ts = do s <- build xs ts [] 66 | ps1 <- lift $ mapM (inst_prod s) ps 67 | let y = inst_name (Inst x ts) 68 | return (Rule1 y ps1 (fmap (\x' -> (x',s)) t)) 69 | where build (x':xs') (t':ts') m = build xs' ts' ((x',t'):m) 70 | build [] [] m = return m 71 | build xs' [] _ = err ("Need " ++ show (length xs') ++ " more arguments") 72 | build _ ts' _ = err (show (length ts') ++ " arguments too many.") 73 | 74 | err m = throwError ("In " ++ inst_name (Inst x ts) ++ ": " ++ m) 75 | 76 | make_rule :: Funs e -> Inst -> M2 (Rule1 e) 77 | make_rule (Funs funs) (Inst f xs) = 78 | case M.lookup f funs of 79 | Just r -> inst_rule r xs 80 | Nothing -> throwError ("Undefined rule: " ++ f) 81 | 82 | runM2 :: ExceptT e (Writer w) a -> Either e (a, w) 83 | runM2 m = case runWriter (runExceptT m) of 84 | (Left e,_) -> Left e 85 | (Right a,xs) -> Right (a,xs) 86 | 87 | make_insts :: Funs e -> [Inst] -> S.Set Inst -> Either String [Rule1 e] 88 | make_insts _ [] _ = return [] 89 | make_insts funs is done = 90 | do (as,ws) <- runM2 (mapM (make_rule funs) is) 91 | let done1 = S.union (S.fromList is) done 92 | let is1 = filter (not . (`S.member` done1)) (S.toList ws) 93 | bs <- make_insts funs is1 done1 94 | return (as++bs) 95 | 96 | 97 | split_rules :: [Rule e] -> (Funs e,[Rule e]) 98 | split_rules rs = let (xs,ys) = partition has_args rs 99 | in (Funs (M.fromList [ (x,r) | r@(Rule x _ _ _) <- xs ]),ys) 100 | where has_args (Rule _ args _ _) = not (null args) 101 | -------------------------------------------------------------------------------- /lib/frontend/src/Happy/Frontend/ParseMonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | 5 | #if __GLASGOW_HASKELL__ >= 800 6 | {-# OPTIONS_GHC -Wno-orphans #-} 7 | #else 8 | {-# OPTIONS_GHC -fno-warn-orphans #-} 9 | #endif 10 | 11 | module Happy.Frontend.ParseMonad where 12 | 13 | import Control.Monad.Reader 14 | import Happy.Frontend.ParseMonad.Class 15 | 16 | type P = ReaderT (String, Int) ParseResult 17 | 18 | mkP :: (String -> Int -> ParseResult a) -> P a 19 | mkP = ReaderT . uncurry 20 | 21 | runP :: P a -> String -> Int -> ParseResult a 22 | runP f s l = runReaderT f (s, l) 23 | 24 | instance ParseMonad P where 25 | failP mkStr = ReaderT (\(_, l) -> Left $ mkStr l) 26 | lineP = asks snd 27 | runFromStartP m s l = runP m s l 28 | 29 | lexTokenP :: HasLexer token => (token -> P r) -> P r 30 | lexTokenP k = ReaderT $ uncurry $ lexToken (\t -> runP $ k t) 31 | -------------------------------------------------------------------------------- /lib/frontend/src/Happy/Frontend/ParseMonad/Class.hs: -------------------------------------------------------------------------------- 1 | module Happy.Frontend.ParseMonad.Class where 2 | 3 | type Pfunc a = String -> Int -> ParseResult a 4 | 5 | class HasLexer token where 6 | lexToken :: (token -> Pfunc r) -> Pfunc r 7 | 8 | type ParseResult = Either String 9 | 10 | class Monad p => ParseMonad p where 11 | failP :: (Int -> String) -> p a 12 | lineP :: p Int 13 | runFromStartP :: p a -> String -> Int -> ParseResult a 14 | -------------------------------------------------------------------------------- /lib/frontend/src/Happy/Frontend/PrettyGrammar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Happy.Frontend.PrettyGrammar where 3 | 4 | #if MIN_VERSION_base(4,11,0) 5 | import Prelude hiding ((<>)) 6 | #endif 7 | import Happy.Frontend.AbsSyn 8 | 9 | render :: Doc -> String 10 | render = maybe "" ($ "") 11 | 12 | ppAbsSyn :: AbsSyn String -> Doc 13 | ppAbsSyn (AbsSyn ds rs) = vsep (vcat (map ppDirective ds) : map ppRule rs) 14 | 15 | ppDirective :: Directive a -> Doc 16 | ppDirective dir = 17 | case dir of 18 | TokenNonassoc xs -> prec "%nonassoc" xs 19 | TokenRight xs -> prec "%right" xs 20 | TokenLeft xs -> prec "%left" xs 21 | _ -> empty 22 | where 23 | prec x xs = text x <+> hsep (map text xs) 24 | 25 | ppRule :: Rule String -> Doc 26 | ppRule (Rule name _ prods _) = text name 27 | $$ vcat (zipWith (<+>) starts (map ppProd prods)) 28 | where 29 | starts = text " :" : repeat (text " |") 30 | 31 | ppProd :: Prod String -> Doc 32 | ppProd (Prod ts _ _ p) = psDoc <+> ppPrec p 33 | where 34 | psDoc = if null ts then text "{- empty -}" else hsep (map ppTerm ts) 35 | 36 | ppPrec :: Prec -> Doc 37 | ppPrec PrecNone = empty 38 | ppPrec PrecShift = text "%shift" 39 | ppPrec (PrecId x) = text "%prec" <+> text x 40 | 41 | ppTerm :: Term -> Doc 42 | ppTerm (App x ts) = text x <> ppTuple (map ppTerm ts) 43 | 44 | ppTuple :: [Doc] -> Doc 45 | ppTuple [] = empty 46 | ppTuple xs = parens (hsep (punctuate comma xs)) 47 | 48 | -------------------------------------------------------------------------------- 49 | -- Pretty printing combinator 50 | 51 | type Doc = Maybe ShowS 52 | 53 | empty :: Doc 54 | empty = Nothing 55 | 56 | punctuate :: Doc -> [Doc] -> [Doc] 57 | punctuate _ [] = [] 58 | punctuate _ [x] = [x] 59 | punctuate sep (x : xs) = (x <> sep) : punctuate sep xs 60 | 61 | comma :: Doc 62 | comma = char ',' 63 | 64 | char :: Char -> Doc 65 | char x = Just (showChar x) 66 | 67 | text :: String -> Doc 68 | text x = if null x then Nothing else Just (showString x) 69 | 70 | (<+>) :: Doc -> Doc -> Doc 71 | Nothing <+> y = y 72 | x <+> Nothing = x 73 | x <+> y = x <> char ' ' <> y 74 | 75 | (<>) :: Doc -> Doc -> Doc 76 | Nothing <> y = y 77 | x <> Nothing = x 78 | Just x <> Just y = Just (x . y) 79 | 80 | ($$) :: Doc -> Doc -> Doc 81 | Nothing $$ y = y 82 | x $$ Nothing = x 83 | x $$ y = x <> char '\n' <> y 84 | 85 | hsep :: [Doc] -> Doc 86 | hsep = hcat . punctuate (char ' ') 87 | 88 | vcat :: [Doc] -> Doc 89 | vcat = foldr ($$) empty 90 | 91 | vsep :: [Doc] -> Doc 92 | vsep = vcat . punctuate (char '\n') 93 | 94 | parens :: Doc -> Doc 95 | parens x = char '(' <> x <> char ')' 96 | 97 | hcat :: [Doc] -> Doc 98 | hcat = foldr (<>) empty 99 | 100 | 101 | -------------------------------------------------------------------------------- /lib/grammar/LICENSE: -------------------------------------------------------------------------------- 1 | ../../LICENSE -------------------------------------------------------------------------------- /lib/grammar/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /lib/grammar/src/Happy/Grammar/ExpressionWithHole.hs: -------------------------------------------------------------------------------- 1 | module Happy.Grammar.ExpressionWithHole where 2 | 3 | -- | The overall expression is 4 | -- 'tokLeft ++ substitutedForHole ++ tokRight'. 5 | data ExpressionWithHole 6 | = ExpressionWithHole { 7 | exprLeft :: String, 8 | exprRight :: String 9 | } 10 | deriving (Eq, Show) 11 | 12 | substExpressionWithHole :: ExpressionWithHole -> String -> String 13 | substExpressionWithHole (ExpressionWithHole l r) = \repr -> l ++ repr ++ r 14 | -------------------------------------------------------------------------------- /lib/hackage-upload.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -e 3 | TOP=$(readlink -f $(dirname $0)) 4 | 5 | # Some sanity checking for version 6 | CABAL_FILE=$(ls *.cabal) 7 | VERSION=$(grep -E '^version:' "$CABAL_FILE" | awk '{print $2}') 8 | if [ -z "$VERSION" ]; then 9 | echo "No version found in $CABAL_FILE." 10 | exit 1 11 | fi 12 | echo "Found version: $VERSION" 13 | 14 | # Check if ChangeLog.md contains the version string 15 | if grep -q "$VERSION" ChangeLog.md; then 16 | echo "Version $VERSION is mentioned in ChangeLog.md." 17 | else 18 | echo "Version $VERSION is NOT mentioned in ChangeLog.md!" 19 | exit 1 20 | fi 21 | 22 | sdist=$(mktemp -d $TOP/dist.XXXXXX) 23 | trap 'rm -rf "$sdist"' EXIT 24 | 25 | cabal sdist --builddir=$sdist 26 | cabal upload $1 $sdist/sdist/*.tar.gz 27 | 28 | cabal haddock --builddir="$sdist" --haddock-for-hackage --enable-doc --haddock-options=--quickjump 29 | 30 | cabal upload -d $1 $sdist/*-docs.tar.gz 31 | -------------------------------------------------------------------------------- /lib/tabular/LICENSE: -------------------------------------------------------------------------------- 1 | ../../LICENSE -------------------------------------------------------------------------------- /lib/tabular/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /lib/tabular/src/Happy/Tabular.lhs: -------------------------------------------------------------------------------- 1 | > module Happy.Tabular ( 2 | > Tables(..), 3 | > genTables, 4 | > SelectReductions, 5 | > select_all_reductions, 6 | > select_first_reduction 7 | > ) where 8 | 9 | > import Happy.Grammar 10 | > import Happy.Tabular.First 11 | > import Happy.Tabular.LALR 12 | > import Happy.Tabular.NameSet (NameSet) 13 | 14 | > import Data.Array( Array, assocs, elems, (!) ) 15 | > import Data.List ( nub ) 16 | 17 | > data Tables = 18 | > Tables { 19 | > lr0items :: [ItemSetWithGotos], 20 | > la_spont :: [(Int, Lr0Item, NameSet)], 21 | > la_prop :: Array Int [(Lr0Item, Int, Lr0Item)], 22 | > lookaheads :: Array Int [(Lr0Item, NameSet)], 23 | > lr1items :: [ ([Lr1Item], [(Name,Int)]) ], 24 | > gotoTable :: GotoTable, 25 | > actionTable :: ActionTable, 26 | > conflicts :: (Array Int (Int,Int), (Int,Int)), 27 | > redundancies :: ([Int], [String]) 28 | > } 29 | 30 | > genTables :: 31 | > SelectReductions -> -- for computing used/unused 32 | > Grammar e -> 33 | > Tables 34 | > genTables select_reductions g = 35 | > let first = {-# SCC "First" #-} (mkFirst g) 36 | > closures = {-# SCC "Closures" #-} (precalcClosure0 g) 37 | > lr0items = {-# SCC "LR0_Sets" #-} (genLR0items g closures) 38 | > (la_spont, la_prop) 39 | > = {-# SCC "Prop" #-} (propLookaheads g lr0items first) 40 | > lookaheads = {-# SCC "Calc" #-} (calcLookaheads (length lr0items) la_spont la_prop) 41 | > lr1items = {-# SCC "Merge" #-} (mergeLookaheadInfo lookaheads lr0items) 42 | > gotoTable = {-# SCC "Goto" #-} (genGotoTable g lr0items) 43 | > actionTable = {-# SCC "Action" #-} (genActionTable g first lr1items) 44 | > conflicts = {-# SCC "Conflict" #-} (countConflicts actionTable) 45 | > redundancies = find_redundancies select_reductions g actionTable 46 | > in Tables { lr0items, la_spont, la_prop, lookaheads, lr1items, 47 | > gotoTable, actionTable, conflicts, redundancies } 48 | 49 | ----------------------------------------------------------------------------- 50 | Find unused rules and tokens 51 | 52 | > find_redundancies 53 | > :: SelectReductions -> Grammar e -> ActionTable -> ([Int], [String]) 54 | > find_redundancies extract_reductions g action_table = 55 | > (unused_rules, map (env !) unused_terminals) 56 | > where 57 | > Grammar { terminals = terms, 58 | > token_names = env, 59 | > eof_term = eof, 60 | > starts = starts', 61 | > productions = productions' 62 | > } = g 63 | > actions = concat (map assocs (elems action_table)) 64 | > start_rules = [ 0 .. (length starts' - 1) ] 65 | > used_rules = start_rules ++ 66 | > nub [ r | (_,a) <- actions, r <- extract_reductions a ] 67 | > used_tokens = errorTok : catchTok : eof : 68 | > nub [ t | (t,a) <- actions, is_shift a ] 69 | > n_prods = length productions' 70 | > unused_terminals = filter (`notElem` used_tokens) terms 71 | > unused_rules = filter (`notElem` used_rules ) [0..n_prods-1] 72 | 73 | > is_shift :: LRAction -> Bool 74 | > is_shift (LR'Shift _ _) = True 75 | > is_shift (LR'Multiple _ LR'Shift{}) = True 76 | > is_shift _ = False 77 | 78 | --- 79 | selects what counts as a reduction when calculating used/unused 80 | 81 | > type SelectReductions = LRAction -> [Int] 82 | 83 | > select_all_reductions :: SelectReductions 84 | > select_all_reductions = go 85 | > where go (LR'Reduce r _) = [r] 86 | > go (LR'Multiple as a) = concatMap go (a : as) 87 | > go _ = [] 88 | 89 | > select_first_reduction :: SelectReductions 90 | > select_first_reduction = go 91 | > where go (LR'Reduce r _) = [r] 92 | > go (LR'Multiple _ a) = go a -- eg R/R conflict 93 | > go _ = [] 94 | -------------------------------------------------------------------------------- /lib/tabular/src/Happy/Tabular/First.lhs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | Implementation of FIRST 3 | 4 | (c) 1993-2001 Andy Gill, Simon Marlow 5 | ----------------------------------------------------------------------------- 6 | 7 | > module Happy.Tabular.First ( mkFirst, mkClosure ) where 8 | 9 | > import Happy.Tabular.NameSet ( NameSet ) 10 | > import qualified Happy.Tabular.NameSet as Set 11 | > import Happy.Grammar 12 | > import Data.Maybe (fromMaybe) 13 | 14 | \subsection{Utilities} 15 | 16 | > joinSymSets :: (a -> NameSet) -> [a] -> NameSet 17 | > joinSymSets f = foldr go (Set.singleton epsilonTok) . map f 18 | > where 19 | > go h b 20 | > | Set.member epsilonTok h = Set.delete epsilonTok h `Set.union` b 21 | > | otherwise = h 22 | 23 | @mkClosure@ makes a closure, when given a comparison and iteration loop. 24 | It's a fixed point computation, we keep applying the function over the 25 | input until it does not change. 26 | Be careful, because if the functional always makes the object different, 27 | This will never terminate. 28 | 29 | > mkClosure :: (a -> a -> Bool) -> (a -> a) -> a -> a 30 | > mkClosure eq f = until (\x -> eq x (f x)) f 31 | 32 | \subsection{Implementation of FIRST} 33 | 34 | > mkFirst :: Grammar e -> [Name] -> NameSet 35 | > mkFirst (Grammar { first_term = fst_term 36 | > , lookupProdNo = prodNo 37 | > , lookupProdsOfName = prodsOfName 38 | > , non_terminals = nts 39 | > }) 40 | > = joinSymSets (\h -> fromMaybe (Set.singleton h) (lookup h env)) 41 | > where 42 | > env = mkClosure (==) (updateFirstSets fst_term prodNo prodsOfName) [(name,Set.empty) | name <- nts] 43 | 44 | > updateFirstSets :: Name -> (a -> Production e) -> (Name -> [a]) -> [(Name, NameSet)] 45 | > -> [(Name, NameSet)] 46 | > updateFirstSets fst_term prodNo prodsOfName env = [ (nm, nextFstSet nm) 47 | > | (nm,_) <- env ] 48 | > where 49 | > terminalP :: Name -> Bool 50 | > terminalP s = s >= fst_term 51 | 52 | > currFstSet :: Name -> NameSet 53 | > currFstSet s | s == errorTok || s == catchTok || terminalP s = Set.singleton s 54 | > | otherwise = maybe (error "attempted FIRST(e) :-(") 55 | > id (lookup s env) 56 | 57 | > nextFstSet :: Name -> NameSet 58 | > nextFstSet s | terminalP s = Set.singleton s 59 | > | otherwise = Set.unions [ joinSymSets currFstSet rhs 60 | > | rl <- prodsOfName s 61 | > , let Production _ rhs _ _ = prodNo rl ] 62 | -------------------------------------------------------------------------------- /lib/tabular/src/Happy/Tabular/NameSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Happy.Tabular.NameSet ( 4 | -- * Set type 5 | NameSet (..), 6 | -- * Construction 7 | empty, 8 | singleton, 9 | fromList, 10 | -- * Deletion 11 | delete, 12 | -- * Query 13 | member, 14 | null, 15 | -- * Combine 16 | union, 17 | unions, 18 | difference, 19 | (\\), 20 | -- * Folds 21 | foldr, 22 | -- * Conversion 23 | -- ** List 24 | toAscList 25 | ) where 26 | 27 | import Prelude hiding (foldr, null) 28 | 29 | import Data.Coerce 30 | import Data.IntSet (IntSet) 31 | import qualified Data.IntSet as IntSet 32 | 33 | import Happy.Grammar 34 | 35 | newtype NameSet = MkNameSet IntSet 36 | deriving (Read, Show, Eq, Ord) 37 | 38 | -- 39 | 40 | empty :: NameSet 41 | empty = coerce IntSet.empty 42 | 43 | singleton :: Name -> NameSet 44 | singleton = coerce IntSet.singleton 45 | 46 | fromList :: [Name] -> NameSet 47 | fromList = coerce IntSet.fromList 48 | 49 | -- 50 | 51 | delete :: Name -> NameSet -> NameSet 52 | delete = coerce IntSet.delete 53 | 54 | -- 55 | 56 | member :: Name -> NameSet -> Bool 57 | member = coerce IntSet.member 58 | 59 | null :: NameSet -> Bool 60 | null = coerce IntSet.null 61 | 62 | -- 63 | 64 | union :: NameSet -> NameSet -> NameSet 65 | union = coerce IntSet.union 66 | 67 | unions :: [NameSet] -> NameSet 68 | unions = coerce . IntSet.unions . fmap coerce 69 | 70 | difference :: NameSet -> NameSet -> NameSet 71 | difference = coerce IntSet.difference 72 | 73 | (\\) :: NameSet -> NameSet -> NameSet 74 | (\\) = coerce (IntSet.\\) 75 | 76 | -- 77 | 78 | foldr :: forall b. (Name -> b -> b) -> b -> NameSet -> b 79 | foldr = coerce (IntSet.foldr :: (Int -> b -> b) -> b -> IntSet -> b) 80 | 81 | -- 82 | 83 | toAscList :: NameSet -> [Name] 84 | toAscList = coerce IntSet.toAscList 85 | -------------------------------------------------------------------------------- /test.hs: -------------------------------------------------------------------------------- 1 | import Data.List (intercalate) 2 | import GHC.Conc (numCapabilities) 3 | import System.Process (system) 4 | import System.Exit (exitWith) 5 | 6 | main = do 7 | let jFlag = "-j" ++ show numCapabilities -- to run tests in parallel, run `cabal test --test-options="+RTS -N"` 8 | let cmd = ["make", jFlag, "-k", "-C", "tests", "clean", "all"] 9 | system (intercalate " " cmd) >>= exitWith 10 | -------------------------------------------------------------------------------- /tests/.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.o 3 | *.bin 4 | *.g.hs 5 | *.n.hs 6 | *.stderr 7 | *.stdout 8 | -------------------------------------------------------------------------------- /tests/AttrGrammar001.y: -------------------------------------------------------------------------------- 1 | { 2 | import Control.Monad (unless) 3 | } 4 | 5 | %tokentype { Char } 6 | 7 | %token a { 'a' } 8 | %token b { 'b' } 9 | %token c { 'c' } 10 | 11 | %attributetype { Attrs a } 12 | %attribute value { a } 13 | %attribute len { Int } 14 | 15 | %name parse abcstring 16 | 17 | %monad { Maybe } 18 | 19 | %% 20 | 21 | abcstring 22 | : alist blist clist 23 | { $$ = $1 ++ $2 ++ $3 24 | ; $2.len = $1.len 25 | ; $3.len = $1.len 26 | } 27 | 28 | alist 29 | : a alist 30 | { $$ = $1 : $> 31 | ; $$.len = $>.len + 1 32 | } 33 | | { $$ = []; $$.len = 0 } 34 | 35 | blist 36 | : b blist 37 | { $$ = $1 : $> 38 | ; $>.len = $$.len - 1 39 | } 40 | | { $$ = [] 41 | ; where failUnless ($$.len == 0) "blist wrong length" 42 | } 43 | 44 | clist 45 | : c clist 46 | { $$ = $1 : $> 47 | ; $>.len = $$.len - 1 48 | } 49 | | { $$ = [] 50 | ; where failUnless ($$.len == 0) "clist wrong length" 51 | } 52 | 53 | { 54 | happyError = error "parse error" 55 | failUnless b msg = unless b (fail msg) 56 | 57 | main = case parse "" of { Just _ -> 58 | case parse "abc" of { Just _ -> 59 | case parse "aaaabbbbcccc" of { Just _ -> 60 | case parse "abbcc" of { Nothing -> 61 | case parse "aabcc" of { Nothing -> 62 | case parse "aabbc" of { Nothing -> 63 | putStrLn "Test works"; 64 | _ -> quit } ; _ -> quit }; _ -> quit }; 65 | _ -> quit } ; _ -> quit }; _ -> quit } 66 | 67 | quit = putStrLn "Test failed" 68 | } 69 | -------------------------------------------------------------------------------- /tests/AttrGrammar002.y: -------------------------------------------------------------------------------- 1 | 2 | %tokentype { Char } 3 | 4 | %token minus { '-' } 5 | %token plus { '+' } 6 | %token one { '1' } 7 | %token zero { '0' } 8 | 9 | %attributetype { Attrs } 10 | %attribute value { Integer } 11 | %attribute pos { Int } 12 | 13 | %name parse start 14 | 15 | %monad { Maybe } 16 | 17 | %% 18 | 19 | start 20 | : num { $$ = $1 } 21 | 22 | num 23 | : bits { $$ = $1 ; $1.pos = 0 } 24 | | plus bits { $$ = $2 ; $2.pos = 0 } 25 | | minus bits { $$ = negate $2; $2.pos = 0 } 26 | 27 | bits 28 | : bit { $$ = $1 29 | ; $1.pos = $$.pos 30 | } 31 | 32 | | bits bit { $$ = $1 + $2 33 | ; $1.pos = $$.pos + 1 34 | ; $2.pos = $$.pos 35 | } 36 | 37 | bit 38 | : zero { $$ = 0 } 39 | | one { $$ = 2^($$.pos) } 40 | 41 | 42 | { 43 | happyError msg = fail $ "parse error: "++msg 44 | 45 | main = case parse "" of { Nothing -> 46 | case parse "abc" of { Nothing -> 47 | case parse "0" of { Just 0 -> 48 | case parse "1" of { Just 1 -> 49 | case parse "101" of { Just 5 -> 50 | case parse "111" of { Just 7 -> 51 | case parse "10001" of { Just 17 -> 52 | putStrLn "Test worked"; 53 | _ -> quit }; _ -> quit }; _ -> quit }; 54 | _ -> quit }; _ -> quit }; _ -> quit }; 55 | _ -> quit } 56 | 57 | quit = putStrLn "Test Failed" 58 | } 59 | -------------------------------------------------------------------------------- /tests/Makefile: -------------------------------------------------------------------------------- 1 | # NOTE: This assumes that a working `ghc` is on $PATH; this may not 2 | # necessarily be the same GHC used by `cabal` for building `happy`. 3 | # 4 | # Again, if HC has been set in the environment (e.g. by the CI), we keep this setting. 5 | # [2021-07-14, PR #196](https://github.com/haskell/happy/pull/196) 6 | # 7 | HC ?= ghc 8 | HC_OPTS=-package array -Wall -Werror -XHaskell98 9 | 10 | # NOTE: `cabal test` will take care to build the local `happy` 11 | # executable and place it into $PATH for us to pick up. 12 | # (This is ensured by setting build-tool-depends.) 13 | # 14 | # If it doesn't look like the alex binary in $PATH comes from the 15 | # build tree, then we'll fall back to pointing to 16 | # ../dist/build/alex/alex to support running tests via "runghc 17 | # Setup.hs test". 18 | # 19 | # If HAPPY has been set outside, e.g. in the environment, we trust this setting. 20 | # This way, we can pass in the correct Happy executable from a CI environment 21 | # without danger of it being "fixed" by the logic below. 22 | # [2021-07-14, PR #196](https://github.com/haskell/happy/pull/196) 23 | # 24 | HAPPY ?= happy 25 | 26 | .PRECIOUS: %.n.hs %.c.hs %.o %.exe %.bin 27 | 28 | ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32" 29 | HS_PROG_EXT = .exe 30 | else 31 | HS_PROG_EXT = .bin 32 | endif 33 | 34 | TESTS = Test.ly TestMulti.ly TestPrecedence.ly bug001.ly \ 35 | monad001.y monad002.ly precedence001.ly precedence002.y \ 36 | bogus-token.y bug002.y Partial.ly \ 37 | issue91.y issue93.y issue94.y issue95.y \ 38 | test_rules.y monaderror.y monaderror-explist.y \ 39 | typeclass_monad001.y typeclass_monad002.ly typeclass_monad_lexer.y \ 40 | rank2.y shift01.y \ 41 | AttrGrammar001.y AttrGrammar002.y 42 | 43 | ERROR_TESTS = error001.y 44 | 45 | # NOTE: `cabal` will set the `happy_datadir` env-var accordingly before invoking the test-suite 46 | #TEST_HAPPY_OPTS = --strict --template=.. 47 | TEST_HAPPY_OPTS = --strict -g 48 | 49 | %.n.hs : %.y 50 | $(HAPPY) $(TEST_HAPPY_OPTS) $< -o $@ 51 | 52 | %.n.hs : %.ly 53 | $(HAPPY) $(TEST_HAPPY_OPTS) $< -o $@ 54 | 55 | %.c.hs : %.y 56 | $(HAPPY) $(TEST_HAPPY_OPTS) -c $< -o $@ 57 | 58 | %.c.hs : %.ly 59 | $(HAPPY) $(TEST_HAPPY_OPTS) -c $< -o $@ 60 | 61 | %.d.hs : %.y 62 | $(HAPPY) $(TEST_HAPPY_OPTS) -d $< -o $@ 63 | 64 | %.d.hs : %.ly 65 | $(HAPPY) $(TEST_HAPPY_OPTS) -d $< -o $@ 66 | 67 | CLEAN_FILES += *.n.hs *.c.hs *.info *.hi *.bin *.exe *.o *.run.stdout *.run.stderr 68 | 69 | ALL_TEST_HS = $(shell echo $(TESTS) | sed -e 's/\([^\. ]*\)\.\(l\)\{0,1\}y/\1.n.hs \1.c.hs/g') 70 | 71 | ALL_TESTS = $(patsubst %.hs, %.run, $(ALL_TEST_HS)) 72 | 73 | DEBUG_TESTS = Test.d$(HS_PROG_EXT) # Compile a single file with -d to ensure that it works 74 | 75 | CHECK_ERROR_TESTS = $(patsubst %, check.%, $(ERROR_TESTS)) 76 | 77 | HC_OPTS += -fforce-recomp 78 | 79 | .PRECIOUS: %.hs %.o %.bin %.$(HS_PROG_EXT) 80 | 81 | %.run : %$(HS_PROG_EXT) 82 | @echo "--> Checking $<..." 83 | ./$< 84 | 85 | path.run : # simply a test to output the path of the built happy executable, useful in CI 86 | @echo "--> Printing happy path..." 87 | which $(HAPPY) 88 | 89 | check.%.y : %.y 90 | @echo "--> Checking $<..." 91 | $(HAPPY) $(TEST_HAPPY_OPTS) -g $< 1>$*.run.stdout 2>$*.run.stderr || true 92 | sed -i '/^Up to date$$/d' $*.run.stdout $*.run.stderr 93 | @diff -u --ignore-all-space $*.stdout $*.run.stdout 94 | @diff -u --ignore-all-space $*.stderr $*.run.stderr 95 | 96 | %$(HS_PROG_EXT) : %.hs 97 | $(HC) $(HC_OPTS) $($*_LD_OPTS) $< -o $@ 98 | 99 | all :: path.run $(CHECK_ERROR_TESTS) $(DEBUG_TESTS) $(ALL_TESTS) 100 | 101 | check-todo:: 102 | $(HAPPY) $(TEST_HAPPY_OPTS) -d Test.ly 103 | $(HC) Test.hs -o happy_test 104 | ./happy_test 105 | -rm -f ./happy_test 106 | $(HAPPY) $(TEST_HAPPY_OPTS) -cd Test.ly 107 | $(HC) Test.hs -o happy_test 108 | ./happy_test 109 | -rm -f ./happy_test 110 | 111 | .PHONY: clean all check-todo path.run 112 | 113 | clean: 114 | $(RM) $(CLEAN_FILES) 115 | -------------------------------------------------------------------------------- /tests/ParGF.y: -------------------------------------------------------------------------------- 1 | {- 2 | 3 | With Happy 1.17 this file produces "Internal Happy error" when run: 4 | 5 | $ happy ParGF.y && runghc ParGF.hs 6 | ParGF.hs: Internal Happy error 7 | 8 | The problem is that we always pass around the "current token". When not 9 | using %lexer and we've run out of tokens, the current token is notHappyAtAll, 10 | which gets passed to happyError when there's an error. 11 | 12 | -} 13 | 14 | { 15 | } 16 | 17 | %name pGrammar 18 | 19 | %tokentype { String } 20 | %error { parseError } 21 | 22 | %token 23 | 'a' { "a" } 24 | 25 | %% 26 | 27 | Grammar :: { () } 28 | Grammar : 'a' 'a' { () } 29 | 30 | { 31 | 32 | parseError :: [String] -> a 33 | -- commenting out the below line gets rid of the "Internal Happy Error" 34 | parseError ("":_) = error "bar" 35 | parseError _ = error "foo" 36 | 37 | main :: IO () 38 | main = print $ pGrammar ["a"] 39 | 40 | } 41 | -------------------------------------------------------------------------------- /tests/Partial.ly: -------------------------------------------------------------------------------- 1 | This is a simple test for happy. 2 | 3 | First thing to declare is the name of your parser, 4 | and the type of the tokens the parser reads. 5 | 6 | > { 7 | > import Data.Char 8 | > } 9 | 10 | > %name calc Exp 11 | > %partial term Term 12 | > %tokentype { Token } 13 | 14 | The parser will be of type [Token] -> ?, where ? is determined by the 15 | production rules. Now we declare all the possible tokens: 16 | 17 | > %token 18 | > let { TokenLet } 19 | > in { TokenIn } 20 | > int { TokenInt $$ } 21 | > var { TokenVar $$ } 22 | > '=' { TokenEq } 23 | > '+' { TokenPlus } 24 | > '-' { TokenMinus } 25 | > '*' { TokenTimes } 26 | > '/' { TokenDiv } 27 | > '(' { TokenOB } 28 | > ')' { TokenCB } 29 | 30 | The *new* system. 31 | 32 | %token 33 | let ( let ) 34 | in ( in ) 35 | int ( digit+ ) 36 | var ( {alpha}{alphanum}+ ) 37 | '=' ( = ) 38 | '+' ( + ) 39 | '-' ( - ) 40 | '*' ( * ) 41 | '/' ( / ) 42 | '(' ( \( ) 43 | ')' ( \) ) 44 | %whitespace ( {space}|{tab} ) 45 | %newline ( {newline} ) 46 | 47 | The left hand side are the names of the terminals or tokens, 48 | and the right hand side is how to pattern match them. 49 | 50 | Like yacc, we include %% here, for no real reason. 51 | 52 | > %% 53 | 54 | Now we have the production rules. 55 | 56 | > Exp :: { Exp } 57 | > Exp : let var '=' Exp in Exp { Let $2 $4 $6 } 58 | > | Exp1 { Exp1 $1 } 59 | > 60 | > Exp1 :: { Exp1 } 61 | > Exp1 : Exp1 '+' Term { Plus $1 $3 } 62 | > | Exp1 '-' Term { Minus $1 $3 } 63 | > | Term { Term $1 } 64 | > 65 | > Term :: { Term } 66 | > Term : Term '*' Factor { Times $1 $3 } 67 | > | Term '/' Factor { Div $1 $3 } 68 | > | Factor { Factor $1 } 69 | > 70 | > Factor :: { Factor } 71 | > Factor : int { Int $1 } 72 | > | var { Var $1 } 73 | > | '(' Exp ')' { Brack $2 } 74 | 75 | We are simply returning the parsed data structure ! 76 | Now we need some extra code, to support this parser, 77 | and make in complete: 78 | 79 | > { 80 | 81 | All parsers must declair this function, 82 | which is called when an error is detected. 83 | Note that currently we do no error recovery. 84 | 85 | > happyError tks = error "Parse error" 86 | 87 | Now we declare the datastructure that we are parsing. 88 | 89 | > data Exp = Let String Exp Exp | Exp1 Exp1 deriving Show 90 | > data Exp1 = Plus Exp1 Term | Minus Exp1 Term | Term Term deriving Show 91 | > data Term = Times Term Factor | Div Term Factor | Factor Factor deriving Show 92 | > data Factor = Int Int | Var String | Brack Exp deriving Show 93 | 94 | The datastructure for the tokens... 95 | 96 | > data Token 97 | > = TokenLet 98 | > | TokenIn 99 | > | TokenInt Int 100 | > | TokenVar String 101 | > | TokenEq 102 | > | TokenPlus 103 | > | TokenMinus 104 | > | TokenTimes 105 | > | TokenDiv 106 | > | TokenOB 107 | > | TokenCB 108 | 109 | .. and a simple lexer that returns this datastructure. 110 | 111 | > lexer :: String -> [Token] 112 | > lexer [] = [] 113 | > lexer (c:cs) 114 | > | isSpace c = lexer cs 115 | > | isAlpha c = lexVar (c:cs) 116 | > | isDigit c = lexNum (c:cs) 117 | > lexer ('=':cs) = TokenEq : lexer cs 118 | > lexer ('+':cs) = TokenPlus : lexer cs 119 | > lexer ('-':cs) = TokenMinus : lexer cs 120 | > lexer ('*':cs) = TokenTimes : lexer cs 121 | > lexer ('/':cs) = TokenDiv : lexer cs 122 | > lexer ('(':cs) = TokenOB : lexer cs 123 | > lexer (')':cs) = TokenCB : lexer cs 124 | 125 | > lexNum cs = TokenInt (read num) : lexer rest 126 | > where (num,rest) = span isDigit cs 127 | 128 | > lexVar cs = 129 | > case span isAlpha cs of 130 | > ("let",rest) -> TokenLet : lexer rest 131 | > ("in",rest) -> TokenIn : lexer rest 132 | > (var,rest) -> TokenVar var : lexer rest 133 | 134 | To run the program, call this in gofer, or use some code 135 | to print it. 136 | 137 | > runCalc :: String -> Exp 138 | > runCalc = calc . lexer 139 | 140 | > runTerm :: String -> Term 141 | > runTerm = term . lexer 142 | 143 | Here we test our parser. 144 | 145 | > main = case runCalc "1 + 2 + 3" of { 146 | > (Exp1 (Plus (Plus (Term (Factor (Int 1))) (Factor (Int 2))) (Factor (Int 3)))) -> 147 | > case runCalc "1 * 2 + 3" of { 148 | > (Exp1 (Plus (Term (Times (Factor (Int 1)) (Int 2))) (Factor (Int 3)))) -> 149 | > case runCalc "1 + 2 * 3" of { 150 | > (Exp1 (Plus (Term (Factor (Int 1))) (Times (Factor (Int 2)) (Int 3)))) -> 151 | > case runCalc "let x = 2 in x * (x - 2)" of { 152 | > (Let "x" (Exp1 (Term (Factor (Int 2)))) (Exp1 (Term (Times (Factor (Var "x")) (Brack (Exp1 (Minus (Term (Factor (Var "x"))) (Factor (Int 2))))))))) -> 153 | > case runTerm "1 + 2 * 3" of { 154 | > Factor (Int 1) -> 155 | > case runTerm "1*2+3" of { 156 | > Times (Factor (Int 1)) (Int 2) -> 157 | > case runTerm "1*2*3" of { 158 | > Times (Times (Factor (Int 1)) (Int 2)) (Int 3) -> 159 | > print "Test works\n"; 160 | > _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } 161 | > quit = print "Test failed\n" 162 | 163 | > } 164 | -------------------------------------------------------------------------------- /tests/Test.ly: -------------------------------------------------------------------------------- 1 | This is a simple test for happy. 2 | 3 | First thing to declare is the name of your parser, 4 | and the type of the tokens the parser reads. 5 | 6 | > { 7 | > import Data.Char 8 | > } 9 | 10 | > %name calc 11 | > %tokentype { Token } 12 | 13 | The parser will be of type [Token] -> ?, where ? is determined by the 14 | production rules. Now we declare all the possible tokens: 15 | 16 | > %token 17 | > let { TokenLet } 18 | > in { TokenIn } 19 | > int { TokenInt $$ } 20 | > var { TokenVar $$ } 21 | > '=' { TokenEq } 22 | > '+' { TokenPlus } 23 | > '-' { TokenMinus } 24 | > '*' { TokenTimes } 25 | > '/' { TokenDiv } 26 | > '(' { TokenOB } 27 | > ')' { TokenCB } 28 | 29 | The *new* system. 30 | 31 | %token 32 | let ( let ) 33 | in ( in ) 34 | int ( digit+ ) 35 | var ( {alpha}{alphanum}+ ) 36 | '=' ( = ) 37 | '+' ( + ) 38 | '-' ( - ) 39 | '*' ( * ) 40 | '/' ( / ) 41 | '(' ( \( ) 42 | ')' ( \) ) 43 | %whitespace ( {space}|{tab} ) 44 | %newline ( {newline} ) 45 | 46 | The left hand side are the names of the terminals or tokens, 47 | and the right hand side is how to pattern match them. 48 | 49 | Like yacc, we include %% here, for no real reason. 50 | 51 | > %% 52 | 53 | Now we have the production rules. 54 | 55 | > Exp :: { Exp } 56 | > Exp : let var '=' Exp in Exp { Let $2 $4 $6 } 57 | > | Exp1 { Exp1 $1 } 58 | > 59 | > Exp1 :: { Exp1 } 60 | > Exp1 : Exp1 '+' Term { Plus $1 $3 } 61 | > | Exp1 '-' Term { Minus $1 $3 } 62 | > | Term { Term $1 } 63 | > 64 | > Term :: { Term } 65 | > Term : Term '*' Factor { Times $1 $3 } 66 | > | Term '/' Factor { Div $1 $3 } 67 | > | Factor { Factor $1 } 68 | > 69 | > Factor :: { Factor } 70 | > Factor : int { Int $1 } 71 | > | var { Var $1 } 72 | > | '(' Exp ')' { Brack $2 } 73 | 74 | We are simply returning the parsed data structure ! 75 | Now we need some extra code, to support this parser, 76 | and make in complete: 77 | 78 | > { 79 | 80 | All parsers must declair this function, 81 | which is called when an error is detected. 82 | Note that currently we do no error recovery. 83 | 84 | > happyError tks = error "Parse error" 85 | 86 | Now we declare the datastructure that we are parsing. 87 | 88 | > data Exp = Let String Exp Exp | Exp1 Exp1 89 | > data Exp1 = Plus Exp1 Term | Minus Exp1 Term | Term Term 90 | > data Term = Times Term Factor | Div Term Factor | Factor Factor 91 | > data Factor = Int Int | Var String | Brack Exp 92 | 93 | The datastructure for the tokens... 94 | 95 | > data Token 96 | > = TokenLet 97 | > | TokenIn 98 | > | TokenInt Int 99 | > | TokenVar String 100 | > | TokenEq 101 | > | TokenPlus 102 | > | TokenMinus 103 | > | TokenTimes 104 | > | TokenDiv 105 | > | TokenOB 106 | > | TokenCB 107 | 108 | .. and a simple lexer that returns this datastructure. 109 | 110 | > lexer :: String -> [Token] 111 | > lexer [] = [] 112 | > lexer (c:cs) 113 | > | isSpace c = lexer cs 114 | > | isAlpha c = lexVar (c:cs) 115 | > | isDigit c = lexNum (c:cs) 116 | > lexer ('=':cs) = TokenEq : lexer cs 117 | > lexer ('+':cs) = TokenPlus : lexer cs 118 | > lexer ('-':cs) = TokenMinus : lexer cs 119 | > lexer ('*':cs) = TokenTimes : lexer cs 120 | > lexer ('/':cs) = TokenDiv : lexer cs 121 | > lexer ('(':cs) = TokenOB : lexer cs 122 | > lexer (')':cs) = TokenCB : lexer cs 123 | 124 | > lexNum cs = TokenInt (read num) : lexer rest 125 | > where (num,rest) = span isDigit cs 126 | 127 | > lexVar cs = 128 | > case span isAlpha cs of 129 | > ("let",rest) -> TokenLet : lexer rest 130 | > ("in",rest) -> TokenIn : lexer rest 131 | > (var,rest) -> TokenVar var : lexer rest 132 | 133 | To run the program, call this in gofer, or use some code 134 | to print it. 135 | 136 | > runCalc :: String -> Exp 137 | > runCalc = calc . lexer 138 | 139 | Here we test our parser. 140 | 141 | > main = case runCalc "1 + 2 + 3" of { 142 | > (Exp1 (Plus (Plus (Term (Factor (Int 1))) (Factor (Int 2))) (Factor (Int 3)))) -> 143 | > case runCalc "1 * 2 + 3" of { 144 | > (Exp1 (Plus (Term (Times (Factor (Int 1)) (Int 2))) (Factor (Int 3)))) -> 145 | > case runCalc "1 + 2 * 3" of { 146 | > (Exp1 (Plus (Term (Factor (Int 1))) (Times (Factor (Int 2)) (Int 3)))) -> 147 | > case runCalc "let x = 2 in x * (x - 2)" of { 148 | > (Let "x" (Exp1 (Term (Factor (Int 2)))) (Exp1 (Term (Times (Factor (Var "x")) (Brack (Exp1 (Minus (Term (Factor (Var "x"))) (Factor (Int 2))))))))) -> print "Test works\n"; 149 | > _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } 150 | > quit = print "Test failed\n" 151 | 152 | > } 153 | -------------------------------------------------------------------------------- /tests/TestMulti.ly: -------------------------------------------------------------------------------- 1 | This is a simple test for happy. 2 | 3 | First thing to declare is the name of your parser, 4 | and the type of the tokens the parser reads. 5 | 6 | > { 7 | > import Data.Char 8 | > } 9 | 10 | > %name calcExp Exp 11 | > %name calcTerm Term 12 | > %tokentype { Token } 13 | 14 | The parser will be of type [Token] -> ?, where ? is determined by the 15 | production rules. Now we declare all the possible tokens: 16 | 17 | > %token 18 | > let { TokenLet } 19 | > in { TokenIn } 20 | > int { TokenInt $$ } 21 | > var { TokenVar $$ } 22 | > '=' { TokenEq } 23 | > '+' { TokenPlus } 24 | > '-' { TokenMinus } 25 | > '*' { TokenTimes } 26 | > '/' { TokenDiv } 27 | > '(' { TokenOB } 28 | > ')' { TokenCB } 29 | 30 | The *new* system. 31 | 32 | %token 33 | let ( let ) 34 | in ( in ) 35 | int ( digit+ ) 36 | var ( {alpha}{alphanum}+ ) 37 | '=' ( = ) 38 | '+' ( + ) 39 | '-' ( - ) 40 | '*' ( * ) 41 | '/' ( / ) 42 | '(' ( \( ) 43 | ')' ( \) ) 44 | %whitespace ( {space}|{tab} ) 45 | %newline ( {newline} ) 46 | 47 | The left hand side are the names of the terminals or tokens, 48 | and the right hand side is how to pattern match them. 49 | 50 | Like yacc, we include %% here, for no real reason. 51 | 52 | > %% 53 | 54 | Now we have the production rules. 55 | 56 | > Exp :: { Exp } 57 | > Exp : let var '=' Exp in Exp { Let $2 $4 $6 } 58 | > | Exp1 { Exp1 $1 } 59 | > 60 | > Exp1 :: { Exp1 } 61 | > Exp1 : Exp1 '+' Term { Plus $1 $3 } 62 | > | Exp1 '-' Term { Minus $1 $3 } 63 | > | Term { Term $1 } 64 | > 65 | > Term :: { Term } 66 | > Term : Term '*' Factor { Times $1 $3 } 67 | > | Term '/' Factor { Div $1 $3 } 68 | > | Factor { Factor $1 } 69 | > 70 | > Factor :: { Factor } 71 | > Factor : int { Int $1 } 72 | > | var { Var $1 } 73 | > | '(' Exp ')' { Brack $2 } 74 | 75 | We are simply returning the parsed data structure ! 76 | Now we need some extra code, to support this parser, 77 | and make in complete: 78 | 79 | > { 80 | 81 | All parsers must declair this function, 82 | which is called when an error is detected. 83 | Note that currently we do no error recovery. 84 | 85 | > happyError tks = error "Parse error" 86 | 87 | Now we declare the datastructure that we are parsing. 88 | 89 | > data Exp = Let String Exp Exp | Exp1 Exp1 90 | > data Exp1 = Plus Exp1 Term | Minus Exp1 Term | Term Term 91 | > data Term = Times Term Factor | Div Term Factor | Factor Factor 92 | > data Factor = Int Int | Var String | Brack Exp 93 | 94 | The datastructure for the tokens... 95 | 96 | > data Token 97 | > = TokenLet 98 | > | TokenIn 99 | > | TokenInt Int 100 | > | TokenVar String 101 | > | TokenEq 102 | > | TokenPlus 103 | > | TokenMinus 104 | > | TokenTimes 105 | > | TokenDiv 106 | > | TokenOB 107 | > | TokenCB 108 | 109 | .. and a simple lexer that returns this datastructure. 110 | 111 | > lexer :: String -> [Token] 112 | > lexer [] = [] 113 | > lexer (c:cs) 114 | > | isSpace c = lexer cs 115 | > | isAlpha c = lexVar (c:cs) 116 | > | isDigit c = lexNum (c:cs) 117 | > lexer ('=':cs) = TokenEq : lexer cs 118 | > lexer ('+':cs) = TokenPlus : lexer cs 119 | > lexer ('-':cs) = TokenMinus : lexer cs 120 | > lexer ('*':cs) = TokenTimes : lexer cs 121 | > lexer ('/':cs) = TokenDiv : lexer cs 122 | > lexer ('(':cs) = TokenOB : lexer cs 123 | > lexer (')':cs) = TokenCB : lexer cs 124 | 125 | > lexNum cs = TokenInt (read num) : lexer rest 126 | > where (num,rest) = span isDigit cs 127 | 128 | > lexVar cs = 129 | > case span isAlpha cs of 130 | > ("let",rest) -> TokenLet : lexer rest 131 | > ("in",rest) -> TokenIn : lexer rest 132 | > (var,rest) -> TokenVar var : lexer rest 133 | 134 | To run the program, call this in gofer, or use some code 135 | to print it. 136 | 137 | > runCalcExp :: String -> Exp 138 | > runCalcExp = calcExp . lexer 139 | 140 | > runCalcTerm :: String -> Term 141 | > runCalcTerm = calcTerm . lexer 142 | 143 | Here we test our parser. 144 | 145 | > main = case runCalcExp "1 + 2 + 3" of { 146 | > (Exp1 (Plus (Plus (Term (Factor (Int 1))) (Factor (Int 2))) (Factor (Int 3)))) -> 147 | > case runCalcExp "1 * 2 + 3" of { 148 | > (Exp1 (Plus (Term (Times (Factor (Int 1)) (Int 2))) (Factor (Int 3)))) -> 149 | > case runCalcExp "1 + 2 * 3" of { 150 | > (Exp1 (Plus (Term (Factor (Int 1))) (Times (Factor (Int 2)) (Int 3)))) -> 151 | > case runCalcExp "let x = 2 in x * (x - 2)" of { 152 | > (Let "x" (Exp1 (Term (Factor (Int 2)))) (Exp1 (Term (Times (Factor (Var "x")) (Brack (Exp1 (Minus (Term (Factor (Var "x"))) (Factor (Int 2))))))))) -> 153 | > 154 | > case runCalcTerm "2 * (3 + 1)" of { 155 | > (Times (Factor (Int 2)) (Brack (Exp1 (Plus (Term (Factor (Int 3))) (Factor (Int 1)))))) -> print "Test works\n"; 156 | > _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } 157 | > quit = print "Test failed\n" 158 | 159 | > } 160 | -------------------------------------------------------------------------------- /tests/TestPrecedence.ly: -------------------------------------------------------------------------------- 1 | This is a simple test for happy using operator precedence. 2 | 3 | First thing to declare is the name of your parser, 4 | and the type of the tokens the parser reads. 5 | 6 | > { 7 | > import Data.Char 8 | > } 9 | 10 | > %name calc 11 | > %tokentype { Token } 12 | 13 | The parser will be of type [Token] -> ?, where ? is determined by the 14 | production rules. Now we declare all the possible tokens: 15 | 16 | > %token 17 | > let { TokenLet } 18 | > in { TokenIn } 19 | > int { TokenInt $$ } 20 | > var { TokenVar $$ } 21 | > '=' { TokenEq } 22 | > '>' { TokenGreater } 23 | > '<' { TokenLess } 24 | > '+' { TokenPlus } 25 | > '-' { TokenMinus } 26 | > '*' { TokenTimes } 27 | > '/' { TokenDiv } 28 | > '(' { TokenOB } 29 | > ')' { TokenCB } 30 | > UMINUS { TokenFoo } 31 | 32 | > %nonassoc '>' '<' 33 | > %left '+' '-' 34 | > %left '*' '/' 35 | > %left UMINUS 36 | 37 | > %% 38 | 39 | > Exp :: { Exp } 40 | > Exp : let var '=' Exp in Exp { Let $2 $4 $6 } 41 | > | Exp '>' Exp { Greater $1 $3 } 42 | > | Exp '<' Exp { Less $1 $3 } 43 | > | Exp '+' Exp { Plus $1 $3 } 44 | > | Exp '-' Exp { Minus $1 $3 } 45 | > | Exp '*' Exp { Times $1 $3 } 46 | > | Exp '/' Exp { Div $1 $3 } 47 | > | '-' Exp %prec UMINUS { Uminus $2 } 48 | > | '(' Exp ')' { Brack $2 } 49 | > | int { Int $1 } 50 | > | var { Var $1 } 51 | 52 | We are simply returning the parsed data structure ! 53 | Now we need some extra code, to support this parser, 54 | and make in complete: 55 | 56 | > { 57 | 58 | All parsers must declair this function, 59 | which is called when an error is detected. 60 | Note that currently we do no error recovery. 61 | 62 | > happyError tks = error "Parse error" 63 | 64 | Now we declare the datastructure that we are parsing. 65 | 66 | > data Exp 67 | > = Let String Exp Exp 68 | > | Greater Exp Exp 69 | > | Less Exp Exp 70 | > | Plus Exp Exp 71 | > | Minus Exp Exp 72 | > | Times Exp Exp 73 | > | Div Exp Exp 74 | > | Uminus Exp 75 | > | Brack Exp 76 | > | Int Int 77 | > | Var String 78 | > deriving Show 79 | 80 | The datastructure for the tokens... 81 | 82 | > data Token 83 | > = TokenLet 84 | > | TokenIn 85 | > | TokenInt Int 86 | > | TokenVar String 87 | > | TokenEq 88 | > | TokenGreater 89 | > | TokenLess 90 | > | TokenPlus 91 | > | TokenMinus 92 | > | TokenTimes 93 | > | TokenDiv 94 | > | TokenOB 95 | > | TokenCB 96 | > | TokenFoo 97 | 98 | .. and a simple lexer that returns this datastructure. 99 | 100 | > lexer :: String -> [Token] 101 | > lexer [] = [] 102 | > lexer (c:cs) 103 | > | isSpace c = lexer cs 104 | > | isAlpha c = lexVar (c:cs) 105 | > | isDigit c = lexNum (c:cs) 106 | > lexer ('=':cs) = TokenEq : lexer cs 107 | > lexer ('>':cs) = TokenGreater : lexer cs 108 | > lexer ('<':cs) = TokenLess : lexer cs 109 | > lexer ('+':cs) = TokenPlus : lexer cs 110 | > lexer ('-':cs) = TokenMinus : lexer cs 111 | > lexer ('*':cs) = TokenTimes : lexer cs 112 | > lexer ('/':cs) = TokenDiv : lexer cs 113 | > lexer ('(':cs) = TokenOB : lexer cs 114 | > lexer (')':cs) = TokenCB : lexer cs 115 | 116 | > lexNum cs = TokenInt (read num) : lexer rest 117 | > where (num,rest) = span isDigit cs 118 | 119 | > lexVar cs = 120 | > case span isAlpha cs of 121 | > ("let",rest) -> TokenLet : lexer rest 122 | > ("in",rest) -> TokenIn : lexer rest 123 | > (var,rest) -> TokenVar var : lexer rest 124 | 125 | To run the program, call this in gofer, or use some code 126 | to print it. 127 | 128 | > runCalc :: String -> Exp 129 | > runCalc = calc . lexer 130 | 131 | Here we test our parser. 132 | 133 | > main = case runCalc "let x = 1 in let y = 2 in x * y + x / y" of { 134 | > (Let "x" (Int 1) (Let "y" (Int 2) (Plus (Times (Var "x") (Var "y")) (Div (Var "x") (Var "y"))))) -> 135 | > case runCalc "- 1 * - 2 + 3" of { 136 | > (Plus (Times (Uminus (Int 1)) (Uminus (Int 2))) (Int 3)) -> 137 | > case runCalc "- - - 1 + 2 * 3 - 4" of { 138 | > (Minus (Plus (Uminus (Uminus (Uminus (Int 1)))) (Times (Int 2) (Int 3))) (Int 4)) -> 139 | > print "Test works\n"; 140 | > _ -> quit } ; _ -> quit } ; _ -> quit } 141 | > 142 | > quit = print "Test failed\n"; 143 | > 144 | > } 145 | -------------------------------------------------------------------------------- /tests/bogus-token.y: -------------------------------------------------------------------------------- 1 | { 2 | module Main where 3 | import Control.Exception as Exception 4 | } 5 | 6 | %tokentype { Token } 7 | %token A { A } 8 | 9 | %name parse 10 | 11 | %% 12 | 13 | parse : A { () } 14 | 15 | { 16 | data Token = A | B 17 | 18 | test1 = parse [B] 19 | main = do Exception.try (print test1 >> fail "Test failed.") :: IO (Either ErrorCall ()) 20 | putStrLn "Test worked" 21 | 22 | happyError = error "parse error" 23 | } 24 | -------------------------------------------------------------------------------- /tests/bug001.ly: -------------------------------------------------------------------------------- 1 | > %name parse 2 | > %tokentype { Token } 3 | > %token Int { TokenInt } 4 | > %% 5 | 6 | > Expr :: { Int } 7 | > Expr : Term { $1 } 8 | 9 | The constant in the next rule would be defaulted to Integer, but it is 10 | forced to Int by the type signature of Expr above. This test exposed 11 | a bug in the unsafeCoerce method. 12 | 13 | > Term : Int { 42 } 14 | 15 | > { 16 | > main = print (parse [TokenInt]) 17 | > 18 | > data Token = TokenInt 19 | > 20 | > happyError = error "" 21 | > } 22 | -------------------------------------------------------------------------------- /tests/bug002.y: -------------------------------------------------------------------------------- 1 | { 2 | module Main where 3 | } 4 | 5 | %name parser 6 | %token foo { 1 } 7 | %tokentype { Int } 8 | 9 | %% 10 | 11 | -- two productions for the same non-terminal should work 12 | Foo : {- empty -} { () } 13 | Foo : Foo foo { () } 14 | 15 | { 16 | main = return () 17 | happyError = undefined 18 | } 19 | -------------------------------------------------------------------------------- /tests/catch-shift-reduce.y: -------------------------------------------------------------------------------- 1 | { 2 | module Main where 3 | 4 | import Data.Char 5 | } 6 | 7 | %name parseExp Exp 8 | %tokentype { Token } 9 | %error { abort } { reportError } 10 | 11 | %monad { ParseM } { (>>=) } { return } 12 | 13 | %token 14 | '1' { TOne } 15 | '+' { TPlus } 16 | '(' { TOpen } 17 | ')' { TClose } 18 | 19 | %right '+' 20 | %expect 0 -- The point of this test: The List productions should expose a shift/reduce conflict because of catch 21 | 22 | %% 23 | 24 | Close :: { String } 25 | Close : ')' { ")" } 26 | | catch { "catch" } 27 | 28 | Exp :: { String } 29 | Exp : catch { "catch" } 30 | | '1' { "1"} 31 | | '(' List Close { "(" ++ $2 ++ $3 } 32 | 33 | List :: { String } 34 | : Exp '+' { $1 ++ "+" } 35 | | Exp '+' Exp { $1 ++ "+" ++ $3 } 36 | 37 | { 38 | data Token = TOne | TPlus | TComma | TOpen | TClose 39 | 40 | type ParseM = Maybe 41 | 42 | abort :: [Token] -> ParseM a 43 | abort = undefined 44 | 45 | reportError :: [Token] -> ([Token] -> ParseM a) -> ParseM a 46 | reportError = undefined 47 | 48 | main :: IO () 49 | main = return () 50 | } 51 | -------------------------------------------------------------------------------- /tests/error001.stderr: -------------------------------------------------------------------------------- 1 | error001.y: Multiple rules for 'foo' 2 | error001.y: 8: unknown identifier ''a'' 3 | error001.y: 10: unknown identifier ''a'' 4 | error001.y: 11: unknown identifier ''b'' 5 | 6 | -------------------------------------------------------------------------------- /tests/error001.stdout: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell/happy/6596a2a193dfbfa694d67a05e5dfa6012c21cabe/tests/error001.stdout -------------------------------------------------------------------------------- /tests/error001.y: -------------------------------------------------------------------------------- 1 | %name foo 2 | %tokentype { Token } 3 | 4 | %% 5 | 6 | foo : 'a' { } 7 | 8 | bar : 'a' { } 9 | 10 | foo : 'b' { } 11 | -------------------------------------------------------------------------------- /tests/issue131.y: -------------------------------------------------------------------------------- 1 | { 2 | module Main where 3 | import Prelude () 4 | import qualified Prelude as Pre 5 | } 6 | 7 | %name parser 8 | %token foo { 1 } 9 | %tokentype { Pre.Int } 10 | 11 | %% 12 | 13 | Foo : foo { () } 14 | 15 | { 16 | main = Pre.putStrLn "Test works" 17 | happyError = Pre.undefined 18 | } 19 | -------------------------------------------------------------------------------- /tests/issue265.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | -- For ancient GHC 7.0.4 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | module Main where 7 | 8 | import Control.Monad (when) 9 | import Data.Char 10 | import System.Exit 11 | } 12 | 13 | %name parseStmts 14 | %tokentype { Token } 15 | %errorhandlertype explist 16 | %error { handleError } 17 | 18 | %monad { ParseM } { (>>=) } { return } 19 | 20 | %token 21 | '1' { TOne } 22 | '+' { TPlus } 23 | ';' { TSemi } 24 | 25 | %% 26 | 27 | Stmts : {- empty -} { [] } 28 | | Stmt { [$1] } 29 | | Stmts ';' Stmt { $1 ++ [$3] } 30 | 31 | Stmt : Exp { ExpStmt $1 } 32 | 33 | Exp : '1' { One } 34 | | Exp '+' Exp %shift { Plus $1 $3 } 35 | 36 | { 37 | data Token = TOne | TPlus | TSemi 38 | deriving (Eq,Show) 39 | 40 | type Stmts = [Stmt] 41 | data Stmt = ExpStmt Exp 42 | deriving (Eq, Show) 43 | data Exp = One | Plus Exp Exp 44 | deriving (Eq, Show) 45 | 46 | type ParseM = Either ParseError 47 | 48 | data ParseError 49 | = ParseError [String] 50 | deriving Eq 51 | instance Show ParseError where 52 | show (ParseError exp) = "Parse error. Expected: " ++ show exp 53 | 54 | recordParseError :: [String] -> ParseM a 55 | recordParseError expected = Left (ParseError expected) 56 | 57 | handleError :: ([Token], [String]) -> ParseM a 58 | handleError (ts, expected) = recordParseError expected 59 | 60 | lexer :: String -> [Token] 61 | lexer [] = [] 62 | lexer (c:cs) 63 | | isSpace c = lexer cs 64 | | c == '1' = TOne:(lexer cs) 65 | | c == '+' = TPlus:(lexer cs) 66 | | c == ';' = TSemi:(lexer cs) 67 | | otherwise = error "lexer error" 68 | 69 | main :: IO () 70 | main = do 71 | test "11;1" $ \res -> res == Left (ParseError ["';'","'+'"]) 72 | where 73 | test inp p = do 74 | putStrLn $ "testing " ++ inp 75 | let tokens = lexer inp 76 | let res = parseStmts tokens 77 | when (not (p res)) $ do 78 | print res 79 | exitWith (ExitFailure 1) 80 | } 81 | -------------------------------------------------------------------------------- /tests/issue91.y: -------------------------------------------------------------------------------- 1 | -- See for more information 2 | %name parse prod 3 | 4 | %tokentype { Tok } 5 | 6 | %monad { P } { bindP } { returnP } 7 | %error { error "parse error" } 8 | %lexer { lexer } { EOF } 9 | 10 | %token 11 | IDENT { Identifier $$ } 12 | 13 | %% 14 | 15 | prod :: { () } 16 | : IDENT { () } 17 | 18 | { 19 | 20 | data Tok = EOF | Identifier String 21 | 22 | type P a = String -> (a, String) 23 | 24 | bindP :: P a -> (a -> P b) -> P b 25 | bindP p f s = let (x,s') = p s in f x s' 26 | 27 | returnP :: a -> P a 28 | returnP = (,) 29 | 30 | lexer :: (Tok -> P a) -> P a 31 | lexer cont s = cont (case s of { "" -> EOF; _ -> Identifier s }) "" 32 | 33 | main = pure () 34 | 35 | } 36 | -------------------------------------------------------------------------------- /tests/issue94.y: -------------------------------------------------------------------------------- 1 | -- See for more information 2 | %name parse prod 3 | 4 | %tokentype { Token } 5 | 6 | %monad { P } { bindP } { returnP } 7 | %error { error "parse error" } 8 | %lexer { lexer } { EOF } 9 | 10 | %token 11 | IDENT { Identifier $$ } 12 | 13 | %% 14 | 15 | prod 16 | : IDENT { () } 17 | 18 | { 19 | data Token = EOF | Identifier String 20 | 21 | type P a = String -> (a, String) 22 | 23 | bindP :: P a -> (a -> P b) -> P b 24 | bindP p f s = let (x,s') = p s in f x s' 25 | 26 | returnP :: a -> P a 27 | returnP = (,) 28 | 29 | lexer :: (Token -> P a) -> P a 30 | lexer cont s = cont (case s of { "" -> EOF; _ -> Identifier s }) "" 31 | 32 | main = return () 33 | } 34 | -------------------------------------------------------------------------------- /tests/issue95.y: -------------------------------------------------------------------------------- 1 | -- See for more information 2 | %name parse prod 3 | 4 | %tokentype { Token } 5 | 6 | %monad { P } { bindP } { returnP } 7 | %error { error "parse error" } 8 | %lexer { lexer } { EOF } 9 | 10 | %token 11 | IDENT { Identifier $$ } 12 | 13 | %% 14 | 15 | prod :: { () } 16 | : IDENT {%% \_ -> returnP () } 17 | 18 | { 19 | 20 | data Token = EOF | Identifier String 21 | 22 | type P a = String -> (a, String) 23 | 24 | bindP :: P a -> (a -> P b) -> P b 25 | bindP p f s = let (x,s') = p s in f x s' 26 | 27 | returnP :: a -> P a 28 | returnP = (,) 29 | 30 | lexer :: (Token -> P a) -> P a 31 | lexer cont s = cont (case s of { "" -> EOF; _ -> Identifier s }) "" 32 | 33 | main = pure () 34 | 35 | } 36 | -------------------------------------------------------------------------------- /tests/monad001.y: -------------------------------------------------------------------------------- 1 | -- Testing %monad without %lexer, using the IO monad. 2 | 3 | { 4 | module Main where 5 | 6 | import System.IO 7 | import Data.Char 8 | } 9 | 10 | %name calc 11 | %tokentype { Token } 12 | 13 | %token num { TokenNum $$ } 14 | '+' { TokenPlus } 15 | '-' { TokenMinus } 16 | '*' { TokenTimes } 17 | '/' { TokenDiv } 18 | '^' { TokenExp } 19 | '\n' { TokenEOL } 20 | '(' { TokenOB } 21 | ')' { TokenCB } 22 | 23 | %left '-' '+' 24 | %left '*' 25 | %nonassoc '/' 26 | %left NEG -- negation--unary minus 27 | %right '^' -- exponentiation 28 | 29 | %monad { IO } { (>>=) } { return } 30 | 31 | %% 32 | input : {- empty string -} { () } 33 | | input line { $1 } 34 | 35 | line : '\n' { () } 36 | | exp '\n' {% hPutStr stdout (show $1) } 37 | 38 | exp : num { $1 } 39 | | exp '+' exp { $1 + $3 } 40 | | exp '-' exp { $1 - $3 } 41 | | exp '*' exp { $1 * $3 } 42 | | exp '/' exp { $1 / $3 } 43 | | '-' exp %prec NEG { -$2 } 44 | -- | exp '^' exp { $1 ^ $3 } 45 | | '(' exp ')' { $2 } 46 | 47 | { 48 | main = do 49 | calc (lexer "1 + 2 * 3 / 4\n") 50 | 51 | {- 52 | -- check that non-associative operators can't be used together 53 | r <- try (calc (lexer "1 / 2 / 3")) 54 | case r of 55 | Left e -> return () 56 | Right _ -> ioError (userError "fail!") 57 | -} 58 | 59 | data Token 60 | = TokenExp 61 | | TokenEOL 62 | | TokenNum Double 63 | | TokenPlus 64 | | TokenMinus 65 | | TokenTimes 66 | | TokenDiv 67 | | TokenOB 68 | | TokenCB 69 | 70 | -- and a simple lexer that returns this datastructure. 71 | 72 | lexer :: String -> [Token] 73 | lexer [] = [] 74 | lexer ('\n':cs) = TokenEOL : lexer cs 75 | lexer (c:cs) 76 | | isSpace c = lexer cs 77 | | isDigit c = lexNum (c:cs) 78 | lexer ('+':cs) = TokenPlus : lexer cs 79 | lexer ('-':cs) = TokenMinus : lexer cs 80 | lexer ('*':cs) = TokenTimes : lexer cs 81 | lexer ('/':cs) = TokenDiv : lexer cs 82 | lexer ('^':cs) = TokenExp : lexer cs 83 | lexer ('(':cs) = TokenOB : lexer cs 84 | lexer (')':cs) = TokenCB : lexer cs 85 | 86 | lexNum cs = TokenNum (read num) : lexer rest 87 | where (num,rest) = span isNum cs 88 | isNum c = isDigit c || c == '.' 89 | 90 | 91 | happyError tokens = ioError (userError "parse error") 92 | } 93 | -------------------------------------------------------------------------------- /tests/monad002.ly: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | Test for monadic Happy Parsers, Simon Marlow 1996. 3 | 4 | > { 5 | > {-# OPTIONS_GHC -fglasgow-exts #-} 6 | > -- -fglasgow-exts required because P is a type synonym, and Happy uses it 7 | > -- unsaturated. 8 | > import Data.Char 9 | > } 10 | 11 | > %name calc 12 | > %tokentype { Token } 13 | 14 | > %monad { P } { thenP } { returnP } 15 | > %lexer { lexer } { TokenEOF } 16 | 17 | > %token 18 | > let { TokenLet } 19 | > in { TokenIn } 20 | > int { TokenInt $$ } 21 | > var { TokenVar $$ } 22 | > '=' { TokenEq } 23 | > '+' { TokenPlus } 24 | > '-' { TokenMinus } 25 | > '*' { TokenTimes } 26 | > '/' { TokenDiv } 27 | > '(' { TokenOB } 28 | > ')' { TokenCB } 29 | 30 | > %% 31 | 32 | > Exp :: {Exp} 33 | > : let var '=' Exp in Exp {% \s l -> ParseOk (Let l $2 $4 $6) } 34 | > | Exp1 { Exp1 $1 } 35 | > 36 | > Exp1 :: {Exp1} 37 | > : Exp1 '+' Term { Plus $1 $3 } 38 | > | Exp1 '-' Term { Minus $1 $3 } 39 | > | Term { Term $1 } 40 | > 41 | > Term :: {Term} 42 | > : Term '*' Factor { Times $1 $3 } 43 | > | Term '/' Factor { Div $1 $3 } 44 | > | Factor { Factor $1 } 45 | > 46 | 47 | > Factor :: {Factor} 48 | > : int { Int $1 } 49 | > | var { Var $1 } 50 | > | '(' Exp ')' { Brack $2 } 51 | 52 | > { 53 | 54 | ----------------------------------------------------------------------------- 55 | The monad serves three purposes: 56 | 57 | * it passes the input string around 58 | * it passes the current line number around 59 | * it deals with success/failure. 60 | 61 | > data ParseResult a 62 | > = ParseOk a 63 | > | ParseFail String 64 | 65 | > type P a = String -> Int -> ParseResult a 66 | 67 | > thenP :: P a -> (a -> P b) -> P b 68 | > m `thenP` k = \s l -> 69 | > case m s l of 70 | > ParseFail s -> ParseFail s 71 | > ParseOk a -> k a s l 72 | 73 | > returnP :: a -> P a 74 | > returnP a = \s l -> ParseOk a 75 | 76 | ----------------------------------------------------------------------------- 77 | 78 | Now we declare the datastructure that we are parsing. 79 | 80 | > data Exp = Let Int String Exp Exp | Exp1 Exp1 81 | > data Exp1 = Plus Exp1 Term | Minus Exp1 Term | Term Term 82 | > data Term = Times Term Factor | Div Term Factor | Factor Factor 83 | > data Factor = Int Int | Var String | Brack Exp 84 | 85 | The datastructure for the tokens... 86 | 87 | > data Token 88 | > = TokenLet 89 | > | TokenIn 90 | > | TokenInt Int 91 | > | TokenVar String 92 | > | TokenEq 93 | > | TokenPlus 94 | > | TokenMinus 95 | > | TokenTimes 96 | > | TokenDiv 97 | > | TokenOB 98 | > | TokenCB 99 | > | TokenEOF 100 | 101 | .. and a simple lexer that returns this datastructure. 102 | 103 | > -- lexer :: (Token -> Parse) -> Parse 104 | > lexer cont s = case s of 105 | > [] -> cont TokenEOF [] 106 | > ('\n':cs) -> \line -> lexer cont cs (line+1) 107 | > (c:cs) 108 | > | isSpace c -> lexer cont cs 109 | > | isAlpha c -> lexVar (c:cs) 110 | > | isDigit c -> lexNum (c:cs) 111 | > ('=':cs) -> cont TokenEq cs 112 | > ('+':cs) -> cont TokenPlus cs 113 | > ('-':cs) -> cont TokenMinus cs 114 | > ('*':cs) -> cont TokenTimes cs 115 | > ('/':cs) -> cont TokenDiv cs 116 | > ('(':cs) -> cont TokenOB cs 117 | > (')':cs) -> cont TokenCB cs 118 | > where 119 | > lexNum cs = cont (TokenInt (read num)) rest 120 | > where (num,rest) = span isDigit cs 121 | > lexVar cs = 122 | > case span isAlpha cs of 123 | > ("let",rest) -> cont TokenLet rest 124 | > ("in",rest) -> cont TokenIn rest 125 | > (var,rest) -> cont (TokenVar var) rest 126 | 127 | > runCalc :: String -> Exp 128 | > runCalc s = case calc s 1 of 129 | > ParseOk e -> e 130 | > ParseFail s -> error s 131 | 132 | ----------------------------------------------------------------------------- 133 | The following functions should be defined for all parsers. 134 | 135 | This is the overall type of the parser. 136 | 137 | > type Parse = P Exp 138 | > calc :: Parse 139 | 140 | The next function is called when a parse error is detected. It has 141 | the same type as the top-level parse function. 142 | 143 | > -- happyError :: Parse 144 | > happyError = \s i -> error ( 145 | > "Parse error in line " ++ show (i::Int) ++ "\n") 146 | 147 | ----------------------------------------------------------------------------- 148 | 149 | Here we test our parser. 150 | 151 | > main = case runCalc "1 + 2 + 3" of { 152 | > (Exp1 (Plus (Plus (Term (Factor (Int 1))) (Factor (Int 2))) (Factor (Int 3)))) -> 153 | > case runCalc "1 * 2 + 3" of { 154 | > (Exp1 (Plus (Term (Times (Factor (Int 1)) (Int 2))) (Factor (Int 3)))) -> 155 | > case runCalc "1 + 2 * 3" of { 156 | > (Exp1 (Plus (Term (Factor (Int 1))) (Times (Factor (Int 2)) (Int 3)))) -> 157 | > case runCalc "let x = 2 in x * (x - 2)" of { 158 | > (Let 1 "x" (Exp1 (Term (Factor (Int 2)))) (Exp1 (Term (Times (Factor (Var "x")) (Brack (Exp1 (Minus (Term (Factor (Var "x"))) (Factor (Int 2))))))))) -> print "Test works\n"; 159 | > _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } 160 | > quit = print "Test failed\n" 161 | > } 162 | -------------------------------------------------------------------------------- /tests/monaderror-explist.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | -- For ancient GHC 7.0.4 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | module Main where 7 | 8 | import Data.Char 9 | import Control.Monad (when) 10 | import System.Exit 11 | import System.Environment (getProgName) 12 | import Data.List (isPrefixOf) 13 | } 14 | 15 | %name parseFoo 16 | %tokentype { Token } 17 | %errorhandlertype explist 18 | %error { handleErrorExpList } 19 | 20 | %monad { ParseM } { (>>=) } { return } 21 | 22 | %token 23 | 'S' { TokenSucc } 24 | 'Z' { TokenZero } 25 | 'T' { TokenTest } 26 | 27 | %% 28 | 29 | Exp : 'Z' { 0 } 30 | | 'T' 'Z' Exp { $3 + 1 } 31 | | 'S' Exp { $2 + 1 } 32 | 33 | { 34 | 35 | type ParseM a = Either ParseError a 36 | data ParseError 37 | = ParseError (Maybe (Token, [String])) 38 | | StringError String 39 | deriving (Eq,Show) 40 | instance Error ParseError where 41 | strMsg = StringError 42 | 43 | data Token 44 | = TokenSucc 45 | | TokenZero 46 | | TokenTest 47 | deriving (Eq,Show) 48 | 49 | handleErrorExpList :: ([Token], [String]) -> ParseM a 50 | handleErrorExpList ([], _) = throwError $ ParseError Nothing 51 | handleErrorExpList (ts, explist) = throwError $ ParseError $ Just $ (head ts, explist) 52 | 53 | lexer :: String -> [Token] 54 | lexer [] = [] 55 | lexer (c:cs) 56 | | isSpace c = lexer cs 57 | | c == 'S' = TokenSucc:(lexer cs) 58 | | c == 'Z' = TokenZero:(lexer cs) 59 | | c == 'T' = TokenTest:(lexer cs) 60 | | otherwise = error "lexer error" 61 | 62 | main :: IO () 63 | main = do 64 | test "Z Z" $ Left (ParseError (Just (TokenZero,[]))) 65 | test "T S" $ Left (ParseError (Just (TokenSucc,["'Z'"]))) 66 | 67 | where 68 | test inp exp = do 69 | putStrLn $ "testing " ++ inp 70 | let tokens = lexer inp 71 | when (parseFoo tokens /= exp) $ do 72 | print (parseFoo tokens) 73 | exitWith (ExitFailure 1) 74 | 75 | --- 76 | class Error a where 77 | noMsg :: a 78 | noMsg = strMsg "" 79 | strMsg :: String -> a 80 | class Monad m => MonadError e m | m -> e where 81 | throwError :: e -> m a 82 | instance MonadError e (Either e) where 83 | throwError = Left 84 | } 85 | -------------------------------------------------------------------------------- /tests/monaderror-lexer-explist.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiWayIf #-} 5 | -- For ancient GHC 7.0.4 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | module Main where 8 | 9 | import Data.Char 10 | import Control.Monad (when) 11 | import System.Exit 12 | import System.Environment (getProgName) 13 | import Data.List (isPrefixOf) 14 | import Control.Monad.Trans.State 15 | import Control.Monad.Trans.Except 16 | import Control.Monad.Trans.Class 17 | } 18 | 19 | %name parseFoo 20 | %tokentype { Token } 21 | %errorhandlertype explist 22 | %error { handleErrorExpList } 23 | %lexer { lexer } { TokenEOF } 24 | 25 | %monad { ParseM } { (>>=) } { return } 26 | 27 | %token 28 | 'S' { TokenSucc } 29 | 'Z' { TokenZero } 30 | 'T' { TokenTest } 31 | 32 | %% 33 | 34 | Exp : 'Z' { 0 } 35 | | 'T' 'Z' Exp { $3 + 1 } 36 | | 'S' Exp { $2 + 1 } 37 | 38 | { 39 | 40 | type ParseM a = ExceptT ParseError (State String) a 41 | data ParseError = ParseError (Maybe (Token, [String])) 42 | deriving (Eq,Show) 43 | 44 | data Token 45 | = TokenSucc 46 | | TokenZero 47 | | TokenTest 48 | | TokenEOF 49 | deriving (Eq,Show) 50 | 51 | handleErrorExpList :: (Token, [String]) -> ParseM a 52 | handleErrorExpList (t, explist) = throwE $ ParseError $ Just $ (t, explist) 53 | 54 | lexer :: (Token -> ParseM a) -> ParseM a 55 | lexer cont = do 56 | toks <- lift get 57 | case toks of 58 | [] -> cont TokenEOF 59 | c : rest -> do 60 | lift $ put rest 61 | if | isSpace c -> lexer cont 62 | | c == 'S' -> cont TokenSucc 63 | | c == 'Z' -> cont TokenZero 64 | | c == 'T' -> cont TokenTest 65 | | otherwise -> error "lexer error" 66 | 67 | main :: IO () 68 | main = do 69 | test "Z Z" $ Left (ParseError (Just (TokenZero,[]))) 70 | test "T S" $ Left (ParseError (Just (TokenSucc,["'Z'"]))) 71 | 72 | where 73 | test inp exp = do 74 | putStrLn $ "testing " ++ inp 75 | let act = evalState (runExceptT parseFoo) inp 76 | when (act /= exp) $ do 77 | print act 78 | exitWith (ExitFailure 1) 79 | } 80 | -------------------------------------------------------------------------------- /tests/monaderror-newexplist.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | -- For ancient GHC 7.0.4 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | module Main where 7 | 8 | import Data.Char 9 | import Control.Monad (when) 10 | import System.Exit 11 | import System.Environment (getProgName) 12 | import Data.List (isPrefixOf) 13 | } 14 | 15 | %name parseFoo 16 | %tokentype { Token } 17 | %error { handleErrorExpList } 18 | %error.expected 19 | 20 | %monad { ParseM } { (>>=) } { return } 21 | 22 | %token 23 | 'S' { TokenSucc } 24 | 'Z' { TokenZero } 25 | 'T' { TokenTest } 26 | 27 | %% 28 | 29 | Exp : 'Z' { 0 } 30 | | 'T' 'Z' Exp { $3 + 1 } 31 | | 'S' Exp { $2 + 1 } 32 | 33 | { 34 | 35 | type ParseM a = Either ParseError a 36 | data ParseError 37 | = ParseError (Maybe (Token, [String])) 38 | | StringError String 39 | deriving (Eq,Show) 40 | instance Error ParseError where 41 | strMsg = StringError 42 | 43 | data Token 44 | = TokenSucc 45 | | TokenZero 46 | | TokenTest 47 | deriving (Eq,Show) 48 | 49 | handleErrorExpList :: [Token] -> [String] -> ParseM a 50 | handleErrorExpList [] _ = throwError $ ParseError Nothing 51 | handleErrorExpList ts explist = throwError $ ParseError $ Just $ (head ts, explist) 52 | 53 | lexer :: String -> [Token] 54 | lexer [] = [] 55 | lexer (c:cs) 56 | | isSpace c = lexer cs 57 | | c == 'S' = TokenSucc:(lexer cs) 58 | | c == 'Z' = TokenZero:(lexer cs) 59 | | c == 'T' = TokenTest:(lexer cs) 60 | | otherwise = error "lexer error" 61 | 62 | main :: IO () 63 | main = do 64 | test "Z Z" $ Left (ParseError (Just (TokenZero,[]))) 65 | test "T S" $ Left (ParseError (Just (TokenSucc,["'Z'"]))) 66 | 67 | where 68 | test inp exp = do 69 | putStrLn $ "testing " ++ inp 70 | let tokens = lexer inp 71 | when (parseFoo tokens /= exp) $ do 72 | print (parseFoo tokens) 73 | exitWith (ExitFailure 1) 74 | 75 | --- 76 | class Error a where 77 | noMsg :: a 78 | noMsg = strMsg "" 79 | strMsg :: String -> a 80 | class Monad m => MonadError e m | m -> e where 81 | throwError :: e -> m a 82 | instance MonadError e (Either e) where 83 | throwError = Left 84 | } 85 | -------------------------------------------------------------------------------- /tests/monaderror-resume.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | -- For ancient GHC 7.0.4 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | module Main where 7 | 8 | import Control.Monad (when) 9 | import Data.IORef 10 | import Data.Char 11 | import System.Exit 12 | } 13 | 14 | %name parseStmts Stmts 15 | %name parseExp Exp 16 | %tokentype { LToken } 17 | %error { abort } { reportError } -- the entire point of this test 18 | %error.expected -- as in monaderror-explist.y 19 | 20 | %monad { ParseM } { (>>=) } { return } 21 | 22 | %token 23 | '1' { (_, TOne) } 24 | '+' { (_, TPlus) } 25 | ';' { (_, TSemi) } 26 | '(' { (_, TOpen) } 27 | ')' { (_, TClose) } 28 | 29 | %right '+' 30 | 31 | %% 32 | 33 | Stmts :: { [String] } 34 | Stmts : {- empty -} { [] } 35 | | Exp { [$1] } 36 | | Stmts ';' Exp { $1 ++ [$3] } 37 | 38 | Exp :: { String } 39 | Exp : '1' { "1" } 40 | | catch { "catch" } 41 | | Exp '+' Exp { $1 ++ " + " ++ $3 } 42 | | '(' Exp ')' { "(" ++ $2 ++ ")" } 43 | 44 | { 45 | data Token = TOne | TPlus | TSemi | TOpen | TClose 46 | deriving (Eq,Show) 47 | 48 | ----------- Validation monad 49 | data Validate e a = V e (Maybe a) 50 | deriving Functor 51 | instance Monoid e => Applicative (Validate e) where 52 | pure a = V mempty (Just a) 53 | V e1 f <*> V e2 a = V (e1 <> e2) (f <*> a) 54 | instance Monoid e => Monad (Validate e) where 55 | V e Nothing >>= _ = V e Nothing -- fatal 56 | V e1 (Just a) >>= k | V e2 b <- k a = V (e1 <> e2) b -- non-fatal 57 | 58 | abort :: Monoid e => [LToken] -> Validate e a -- this would be mzero from MonadPlus 59 | abort _ = V mempty Nothing 60 | 61 | recordError :: e -> Validate e () -- this would be tell from MonadWriter 62 | recordError e = V e (Just ()) 63 | 64 | runValidate (V e mb_a) = (e, mb_a) 65 | ----------- 66 | 67 | type ParseM = Validate [ParseError] 68 | 69 | data ParseError 70 | = ParseError Int [String] 71 | deriving Eq 72 | instance Show ParseError where 73 | show (ParseError loc exp) = "Parse error at " ++ locS ++ ". Expected: " ++ commaSep exp ++ "." 74 | where 75 | locS | loc < 0 = "EOF" 76 | | otherwise = "column " ++ show loc 77 | commaSep [] = "" 78 | commaSep [s] = s 79 | commaSep (s:ss) = s ++ "," ++ commaSep ss 80 | 81 | recordParseError :: Int -> [String] -> ParseM () 82 | recordParseError loc expected = recordError [ParseError loc expected] 83 | 84 | eofLoc :: Int 85 | eofLoc = -1 86 | reportError :: [LToken] -> [String] -> ([LToken] -> ParseM a) -> ParseM a 87 | reportError ts expected resume = do 88 | let loc | (l,_):_ <- ts = l 89 | | otherwise = eofLoc 90 | recordParseError loc expected 91 | resume ts 92 | 93 | type LToken = (Int, Token) -- Token with location 94 | 95 | lexer :: Int -> String -> [LToken] 96 | lexer _ [] = [] 97 | lexer n (c:cs) 98 | | isSpace c = lexer (n+1) cs 99 | | c == '1' = (n,TOne):(lexer (n+1) cs) 100 | | c == '+' = (n,TPlus):(lexer (n+1) cs) 101 | | c == ';' = (n,TSemi):(lexer (n+1) cs) 102 | | c == '(' = (n,TOpen):(lexer (n+1) cs) 103 | | c == ')' = (n,TClose):(lexer (n+1) cs) 104 | | otherwise = error "lexer error" 105 | 106 | main :: IO () 107 | main = do 108 | exit_code_ref <- newIORef ExitSuccess 109 | let exp_err loc = ParseError loc ["'1'","'('"] 110 | testStmts exit_code_ref "1+1;1" $ \(_,mb_ast) -> mb_ast == Just ["1 + 1", "1"] 111 | testStmts exit_code_ref "1++1;1" $ \(errs,_) -> errs == [exp_err 2] 112 | testStmts exit_code_ref "1++1;1;+" $ \(errs,_) -> errs == [exp_err 2, exp_err 7, exp_err eofLoc] 113 | testStmts exit_code_ref "11;1" $ \(errs,_) -> errs == [ParseError 1 ["';'"]] 114 | testStmts exit_code_ref "11;1;++" $ \(errs,_) -> errs == [ParseError 1 ["';'"], exp_err 5, exp_err 6, exp_err eofLoc] 115 | testStmts exit_code_ref "11;1;1++" $ \(errs,_) -> errs == [ParseError 1 ["';'"], exp_err 7, exp_err eofLoc] 116 | testExp exit_code_ref "11" $ \(errs,_) -> errs == [ParseError 1 ["'+'"]] 117 | 118 | testStmts exit_code_ref "(;1)" $ \(errs,mb_ast) -> errs == [exp_err 1, ParseError 3 ["';'"]] 119 | testStmts exit_code_ref "1+;" $ \(errs,mb_ast) -> errs == [exp_err 2, exp_err eofLoc] 120 | 121 | -- The main point of the following 2 tests: rather than discarding tokens until 122 | -- the EOF is reached upon the first error because of a missing ')', resume 123 | -- after ';'. In the first case, we error again at EOF, in the second case we error again on '+' 124 | testStmts exit_code_ref "(;" $ \(errs,mb_ast) -> 125 | errs == [exp_err 1, exp_err eofLoc] && 126 | mb_ast == Just ["catch","catch"] 127 | testStmts exit_code_ref "(;+1" $ \(errs,mb_ast) -> 128 | errs == [exp_err 1, exp_err 2] && 129 | mb_ast == Just ["catch","catch + 1"] 130 | 131 | -- Example from the user's guide: 132 | testStmts exit_code_ref "1+;+1;(+1;1" $ \(_,mb_ast) -> mb_ast == Just ["1 + catch","catch + 1","catch","1"] 133 | 134 | readIORef exit_code_ref >>= exitWith 135 | where 136 | testStmts ref inp p = do 137 | putStrLn $ "testing Stmts " ++ inp 138 | let tokens = lexer 0 inp 139 | let res@(_,mb_ast) = runValidate $ parseStmts tokens 140 | when (not (p res) || mb_ast == Nothing) $ do -- mb_ast == Nothing: Ensure that we *never* fail to resume! 141 | print res 142 | writeIORef ref (ExitFailure 1) 143 | testExp ref inp p = do 144 | putStrLn $ "testing Exp " ++ inp 145 | let tokens = lexer 0 inp 146 | let res = runValidate $ parseExp tokens 147 | when (not (p res)) $ do 148 | print res 149 | writeIORef ref (ExitFailure 1) 150 | } 151 | -------------------------------------------------------------------------------- /tests/monaderror.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | -- For ancient GHC 7.0.4 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | module Main where 7 | 8 | import Control.Monad (when) 9 | import Data.Char 10 | import System.Exit 11 | } 12 | 13 | %name parseFoo 14 | %tokentype { Token } 15 | %error { handleError } 16 | 17 | %monad { ParseM } { (>>=) } { return } 18 | 19 | %token 20 | 'S' { TokenSucc } 21 | 'Z' { TokenZero } 22 | 23 | %% 24 | 25 | Exp : 'Z' { 0 } 26 | | 'S' Exp { $2 + 1 } 27 | 28 | { 29 | 30 | type ParseM a = Either ParseError a 31 | data ParseError 32 | = ParseError (Maybe Token) 33 | | StringError String 34 | deriving (Eq,Show) 35 | instance Error ParseError where 36 | strMsg = StringError 37 | 38 | data Token 39 | = TokenSucc 40 | | TokenZero 41 | deriving (Eq,Show) 42 | 43 | handleError :: [Token] -> ParseM a 44 | handleError [] = throwError $ ParseError Nothing 45 | handleError ts = throwError $ ParseError $ Just $ head ts 46 | 47 | lexer :: String -> [Token] 48 | lexer [] = [] 49 | lexer (c:cs) 50 | | isSpace c = lexer cs 51 | | c == 'S' = TokenSucc:(lexer cs) 52 | | c == 'Z' = TokenZero:(lexer cs) 53 | | otherwise = error "lexer error" 54 | 55 | main :: IO () 56 | main = do 57 | let tokens = lexer "S S" 58 | when (parseFoo tokens /= Left (ParseError Nothing)) $ do 59 | print (parseFoo tokens) 60 | exitWith (ExitFailure 1) 61 | 62 | --- 63 | class Error a where 64 | noMsg :: a 65 | noMsg = strMsg "" 66 | strMsg :: String -> a 67 | class Monad m => MonadError e m | m -> e where 68 | throwError :: e -> m a 69 | instance MonadError e (Either e) where 70 | throwError = Left 71 | } 72 | -------------------------------------------------------------------------------- /tests/precedence001.ly: -------------------------------------------------------------------------------- 1 | This module demonstrates a Happy bug (in version <= 1.10). 2 | 3 | > { 4 | > module Main where 5 | > import System.IO 6 | > import Control.Exception as Exception 7 | > } 8 | > 9 | > %name parse 10 | > 11 | > %tokentype { Tok } 12 | > %token 13 | > '+' { Plus } 14 | > '-' { Minus } 15 | > int { Num $$ } 16 | > 17 | > %nonassoc '+' '-' 18 | > 19 | > %% 20 | 21 | Ambiguous grammar. 22 | 23 | > E : E '+' E { Plus' $1 $3 } 24 | > | E '-' E { Minus' $1 $3 } 25 | > | int { Num' $1 } 26 | 27 | > { 28 | > happyError :: [Tok] -> a 29 | > happyError s = error (concatMap show s) 30 | > 31 | > data Tok = Plus | Minus | Num Int deriving Show 32 | > 33 | > data Syn = Plus' Syn Syn | Minus' Syn Syn | Num' Int deriving Show 34 | 35 | All the examples below should fail. None of them does so 36 | under Happy v1.8, and only the first one under Happy v1.9 37 | and v1.10. 38 | 39 | > test1 = parse tokens1 40 | > test2 = parse tokens2 41 | > test3 = parse tokens3 42 | > 43 | > tokens1 = [Num 6, Plus, Num 7, Plus, Num 8] 44 | > tokens2 = [Num 6, Plus, Num 7, Minus, Num 8] 45 | > tokens3 = [Num 6, Minus, Num 7, Minus, Num 8] 46 | 47 | The generated info files seem correct, so there is probably 48 | something wrong with the table generation. 49 | 50 | These errors only show up when one uses Happy with the -a 51 | flag (and only that flag). I know that it's no point in 52 | using just that flag, but I happened to be doing so while 53 | trying the code out with Hugs. (Hugs didn't like the code 54 | generated with GHC extensions, -gac.) 55 | 56 | > main = do 57 | > Exception.try (print test1 >> fail "Test failed.") :: IO (Either ErrorCall ()) 58 | > Exception.try (print test2 >> fail "Test failed.") :: IO (Either ErrorCall ()) 59 | > Exception.try (print test3 >> fail "Test failed.") :: IO (Either ErrorCall ()) 60 | 61 | > } 62 | -------------------------------------------------------------------------------- /tests/precedence002.y: -------------------------------------------------------------------------------- 1 | -- This module demonstrates a bug in the original 1.11 release of Happy. 2 | 3 | { 4 | module Main where 5 | import System.IO 6 | import Control.Exception as Exception 7 | } 8 | 9 | %name parse 10 | 11 | %tokentype { Tok } 12 | %token 13 | '+' { Plus } 14 | '/' { Divide } 15 | int { Num $$ } 16 | 17 | %left '+' 18 | %left '*' 19 | %nonassoc '/' 20 | 21 | %% 22 | E : E '+' E { Plus' $1 $3 } 23 | | E '/' E { Divide' $1 $3 } 24 | | int { Num' $1 } 25 | 26 | { 27 | happyError :: [Tok] -> a 28 | happyError s = error (concatMap show s) 29 | 30 | data Tok = Plus | Divide | Num Int deriving Show 31 | 32 | data Syn = Plus' Syn Syn | Divide' Syn Syn | Num' Int deriving Show 33 | 34 | -- due to a bug in conflict resolution, this caused a parse error: 35 | tokens1 = [Num 6, Divide, Num 7, Plus, Num 8] 36 | 37 | main = print (parse tokens1) 38 | } 39 | -------------------------------------------------------------------------------- /tests/rank2.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE GADTs #-} 4 | module Main where 5 | 6 | import System.IO 7 | import Data.Char 8 | } 9 | 10 | %name calc 11 | %tokentype { Token } 12 | 13 | %token tok { Token } 14 | 15 | %monad { IO } { (>>=) } { return } 16 | 17 | %% 18 | 19 | ib :: { (Int, Double, Bool) } 20 | : f n { ($1 $2, $1 $2, $1 True) } 21 | 22 | f :: { forall a. a -> a } 23 | : { id } 24 | 25 | n :: { forall a. Num a => a } 26 | : { 5 } 27 | 28 | { 29 | main = calc [] >>= print 30 | 31 | data Token = Token 32 | 33 | lexer :: String -> [Token] 34 | lexer _ = [] 35 | 36 | happyError tokens = ioError (userError "parse error") 37 | } 38 | -------------------------------------------------------------------------------- /tests/shift01.y: -------------------------------------------------------------------------------- 1 | -- Testing the %shift directive 2 | 3 | { 4 | module Main where 5 | 6 | import System.IO 7 | import Data.Char 8 | } 9 | 10 | %expect 0 -- We must resolve the conflicts with %shift 11 | %name group_a 12 | %tokentype { Token } 13 | 14 | %token 'A' { A } 15 | 16 | %% 17 | exp : exp 'A' %shift { $1 ++ ",A" } 18 | | exp 'A' 'A' { $1 ++ ",2A" } 19 | | { "S" } 20 | 21 | { 22 | main = 23 | if group_a [A, A, A] == "S,2A,A" 24 | then return () 25 | else error "bad parse" 26 | 27 | data Token = A 28 | 29 | happyError _ = error "parse error" 30 | } 31 | -------------------------------------------------------------------------------- /tests/test_rules.y: -------------------------------------------------------------------------------- 1 | { 2 | import Control.Monad(when) 3 | import System.Exit 4 | } 5 | 6 | %monad { Maybe } { (>>=) } { return } 7 | %tokentype { Char } 8 | %token 9 | 'a' { 'a' } 10 | 'b' { 'b' } 11 | 12 | %name test1 test1 13 | %name test2 test2 14 | 15 | %% 16 | 17 | test1 18 | : sepBy('a','b') { $1 } 19 | 20 | test2 21 | : endBy('a','b') { $1 } 22 | 23 | many_rev1(p) 24 | : p { [$1] } 25 | | many_rev1(p) p { $2 : $1 } 26 | 27 | many1(p) 28 | : many_rev1(p) { reverse $1 } 29 | 30 | many(p) 31 | : many1(p) { $1 } 32 | | { [] } 33 | 34 | optional(p) 35 | : p { Just $1 } 36 | | { Nothing } 37 | 38 | sepR(p,q) 39 | : p q { $2 } 40 | 41 | sepL(p,q) 42 | : p q { $1 } 43 | 44 | sepBy1(p,q) 45 | : p many(sepR(q,p)) { $1 : $2 } 46 | 47 | sepBy(p,q) 48 | : sepBy1(p,q) { $1 } 49 | | { [] } 50 | 51 | endBy(p,q) 52 | : many (sepL(p,q)) { $1 } 53 | 54 | endBy1(p,q) 55 | : many1 (sepL(p,q)) { $1 } 56 | 57 | { 58 | happyError _ = Nothing 59 | 60 | tests = [ test1 "" == Just "" 61 | , test1 "a" == Just "a" 62 | , test1 "ab" == Nothing 63 | , test1 "aba" == Just "aa" 64 | , test1 "abab" == Nothing 65 | 66 | , test2 "" == Just "" 67 | , test2 "a" == Nothing 68 | , test2 "ab" == Just "a" 69 | , test2 "aba" == Nothing 70 | , test2 "abab" == Just "aa" 71 | ] 72 | 73 | main = do let failed = filter (not . snd) (zip [0..] tests) 74 | when (not (null failed)) $ 75 | do putStrLn ("Failed tests: " ++ show (map fst failed)) 76 | exitFailure 77 | putStrLn "Tests passed." 78 | 79 | } 80 | -------------------------------------------------------------------------------- /tests/typeclass_monad001.y: -------------------------------------------------------------------------------- 1 | -- Testing %monad without %lexer, using the IO monad. 2 | 3 | { 4 | module Main where 5 | 6 | import System.IO 7 | import Data.Char 8 | } 9 | 10 | %name calc 11 | %tokentype { Token } 12 | 13 | %token num { TokenNum $$ } 14 | '+' { TokenPlus } 15 | '-' { TokenMinus } 16 | '*' { TokenTimes } 17 | '/' { TokenDiv } 18 | '^' { TokenExp } 19 | '\n' { TokenEOL } 20 | '(' { TokenOB } 21 | ')' { TokenCB } 22 | 23 | %left '-' '+' 24 | %left '*' 25 | %nonassoc '/' 26 | %left NEG -- negation--unary minus 27 | %right '^' -- exponentiation 28 | 29 | %monad { (MonadIO m) } { m } { (>>=) } { return } 30 | 31 | %% 32 | input : {- empty string -} { () } 33 | | input line { $1 } 34 | 35 | line : '\n' { () } 36 | | exp '\n' {% hPutStr stdout (show $1) } 37 | 38 | exp : num { $1 } 39 | | exp '+' exp { $1 + $3 } 40 | | exp '-' exp { $1 - $3 } 41 | | exp '*' exp { $1 * $3 } 42 | | exp '/' exp { $1 / $3 } 43 | | '-' exp %prec NEG { -$2 } 44 | -- | exp '^' exp { $1 ^ $3 } 45 | | '(' exp ')' { $2 } 46 | 47 | { 48 | main = do 49 | calc (lexer "1 + 2 * 3 / 4\n") 50 | 51 | {- 52 | -- check that non-associative operators can't be used together 53 | r <- try (calc (lexer "1 / 2 / 3")) 54 | case r of 55 | Left e -> return () 56 | Right _ -> ioError (userError "fail!") 57 | -} 58 | 59 | data Token 60 | = TokenExp 61 | | TokenEOL 62 | | TokenNum Double 63 | | TokenPlus 64 | | TokenMinus 65 | | TokenTimes 66 | | TokenDiv 67 | | TokenOB 68 | | TokenCB 69 | 70 | -- and a simple lexer that returns this datastructure. 71 | 72 | lexer :: String -> [Token] 73 | lexer [] = [] 74 | lexer ('\n':cs) = TokenEOL : lexer cs 75 | lexer (c:cs) 76 | | isSpace c = lexer cs 77 | | isDigit c = lexNum (c:cs) 78 | lexer ('+':cs) = TokenPlus : lexer cs 79 | lexer ('-':cs) = TokenMinus : lexer cs 80 | lexer ('*':cs) = TokenTimes : lexer cs 81 | lexer ('/':cs) = TokenDiv : lexer cs 82 | lexer ('^':cs) = TokenExp : lexer cs 83 | lexer ('(':cs) = TokenOB : lexer cs 84 | lexer (')':cs) = TokenCB : lexer cs 85 | 86 | lexNum cs = TokenNum (read num) : lexer rest 87 | where (num,rest) = span isNum cs 88 | isNum c = isDigit c || c == '.' 89 | 90 | 91 | happyError tokens = liftIO (ioError (userError "parse error")) 92 | 93 | -- vendored in parts of mtl 94 | 95 | class Monad m => MonadIO m where liftIO :: IO a -> m a 96 | instance MonadIO IO where liftIO = id 97 | } 98 | -------------------------------------------------------------------------------- /tests/typeclass_monad002.ly: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | Test for monadic Happy Parsers, Simon Marlow 1996. 3 | 4 | > { 5 | > {-# OPTIONS_GHC -fglasgow-exts #-} 6 | > -- -fglasgow-exts required because P is a type synonym, and Happy uses it 7 | > -- unsaturated. 8 | > import Data.Char 9 | > } 10 | 11 | > %name calc 12 | > %tokentype { Token } 13 | 14 | > %monad { (Monad m) } { P m } { thenP } { returnP } 15 | > %lexer { lexer } { TokenEOF } 16 | 17 | > %token 18 | > let { TokenLet } 19 | > in { TokenIn } 20 | > int { TokenInt $$ } 21 | > var { TokenVar $$ } 22 | > '=' { TokenEq } 23 | > '+' { TokenPlus } 24 | > '-' { TokenMinus } 25 | > '*' { TokenTimes } 26 | > '/' { TokenDiv } 27 | > '(' { TokenOB } 28 | > ')' { TokenCB } 29 | 30 | > %% 31 | 32 | > Exp :: {Exp} 33 | > : let var '=' Exp in Exp {% \s l -> return (ParseOk (Let l $2 $4 $6)) } 34 | > | Exp1 { Exp1 $1 } 35 | > 36 | > Exp1 :: {Exp1} 37 | > : Exp1 '+' Term { Plus $1 $3 } 38 | > | Exp1 '-' Term { Minus $1 $3 } 39 | > | Term { Term $1 } 40 | > 41 | > Term :: {Term} 42 | > : Term '*' Factor { Times $1 $3 } 43 | > | Term '/' Factor { Div $1 $3 } 44 | > | Factor { Factor $1 } 45 | > 46 | 47 | > Factor :: {Factor} 48 | > : int { Int $1 } 49 | > | var { Var $1 } 50 | > | '(' Exp ')' { Brack $2 } 51 | 52 | > { 53 | 54 | ----------------------------------------------------------------------------- 55 | The monad serves three purposes: 56 | 57 | * it passes the input string around 58 | * it passes the current line number around 59 | * it deals with success/failure. 60 | 61 | > data ParseResult a 62 | > = ParseOk a 63 | > | ParseFail String 64 | 65 | > type P m a = String -> Int -> m (ParseResult a) 66 | 67 | > thenP :: Monad m => P m a -> (a -> P m b) -> P m b 68 | > m `thenP` k = \s l -> 69 | > do 70 | > res <- m s l 71 | > case res of 72 | > ParseFail s -> return (ParseFail s) 73 | > ParseOk a -> k a s l 74 | 75 | > returnP :: Monad m => a -> P m a 76 | > returnP a = \s l -> return (ParseOk a) 77 | 78 | ----------------------------------------------------------------------------- 79 | 80 | Now we declare the datastructure that we are parsing. 81 | 82 | > data Exp = Let Int String Exp Exp | Exp1 Exp1 83 | > data Exp1 = Plus Exp1 Term | Minus Exp1 Term | Term Term 84 | > data Term = Times Term Factor | Div Term Factor | Factor Factor 85 | > data Factor = Int Int | Var String | Brack Exp 86 | 87 | The datastructure for the tokens... 88 | 89 | > data Token 90 | > = TokenLet 91 | > | TokenIn 92 | > | TokenInt Int 93 | > | TokenVar String 94 | > | TokenEq 95 | > | TokenPlus 96 | > | TokenMinus 97 | > | TokenTimes 98 | > | TokenDiv 99 | > | TokenOB 100 | > | TokenCB 101 | > | TokenEOF 102 | 103 | .. and a simple lexer that returns this datastructure. 104 | 105 | > lexer :: Monad m => (Token -> P m a) -> P m a 106 | > lexer cont s = case s of 107 | > [] -> cont TokenEOF [] 108 | > ('\n':cs) -> \line -> lexer cont cs (line+1) 109 | > (c:cs) 110 | > | isSpace c -> lexer cont cs 111 | > | isAlpha c -> lexVar (c:cs) 112 | > | isDigit c -> lexNum (c:cs) 113 | > ('=':cs) -> cont TokenEq cs 114 | > ('+':cs) -> cont TokenPlus cs 115 | > ('-':cs) -> cont TokenMinus cs 116 | > ('*':cs) -> cont TokenTimes cs 117 | > ('/':cs) -> cont TokenDiv cs 118 | > ('(':cs) -> cont TokenOB cs 119 | > (')':cs) -> cont TokenCB cs 120 | > where 121 | > lexNum cs = cont (TokenInt (read num)) rest 122 | > where (num,rest) = span isDigit cs 123 | > lexVar cs = 124 | > case span isAlpha cs of 125 | > ("let",rest) -> cont TokenLet rest 126 | > ("in",rest) -> cont TokenIn rest 127 | > (var,rest) -> cont (TokenVar var) rest 128 | 129 | > runCalc :: Monad m => String -> m Exp 130 | > runCalc s = 131 | > do 132 | > res <- calc s 1 133 | > case res of 134 | > ParseOk e -> return e 135 | > ParseFail s -> error s 136 | 137 | ----------------------------------------------------------------------------- 138 | The following functions should be defined for all parsers. 139 | 140 | This is the overall type of the parser. 141 | 142 | > type Parse m = P m Exp 143 | > calc :: Monad m => Parse m 144 | 145 | The next function is called when a parse error is detected. It has 146 | the same type as the top-level parse function. 147 | 148 | > happyError :: P m a 149 | > happyError = \s i -> error ( 150 | > "Parse error in line " ++ show (i::Int) ++ "\n") 151 | 152 | ----------------------------------------------------------------------------- 153 | 154 | Here we test our parser. 155 | 156 | > main = 157 | > do 158 | > res <- runCalc "1 + 2 + 3" 159 | > case res of 160 | > (Exp1 (Plus (Plus (Term (Factor (Int 1))) 161 | > (Factor (Int 2))) (Factor (Int 3)))) -> 162 | > do 163 | > res <- runCalc "1 * 2 + 3" 164 | > case res of 165 | > (Exp1 (Plus (Term (Times (Factor (Int 1)) (Int 2))) 166 | > (Factor (Int 3)))) -> 167 | > do 168 | > res <- runCalc "1 + 2 * 3" 169 | > case res of 170 | > (Exp1 (Plus (Term (Factor (Int 1))) 171 | > (Times (Factor (Int 2)) (Int 3)))) -> 172 | > do 173 | > res <- runCalc "let x = 2 in x * (x - 2)" 174 | > case res of 175 | > (Let 1 "x" (Exp1 (Term (Factor (Int 2)))) 176 | > (Exp1 (Term (Times (Factor (Var "x")) 177 | > (Brack (Exp1 (Minus (Term (Factor (Var "x"))) 178 | > (Factor (Int 2))))))))) -> 179 | > print "Test works\n" 180 | > _ -> quit 181 | > _ -> quit 182 | > _ -> quit 183 | > _ -> quit 184 | > quit = print "Test failed\n" 185 | > } 186 | -------------------------------------------------------------------------------- /tests/typeclass_monad_lexer.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | -- For ancient GHC 7.0.4 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | import Control.Monad (liftM, ap) 8 | import Control.Applicative as A 9 | } 10 | 11 | %name parse exp 12 | %tokentype { Token } 13 | %error { parseError } 14 | %monad { (MonadIO m) } { Parser m } 15 | %lexer { lexer } { EOF } 16 | %token ID { Id _ } 17 | NUM { Num _ } 18 | PLUS { Plus } 19 | MINUS { Minus } 20 | TIMES { Times } 21 | LPAREN { LParen } 22 | RPAREN { RParen } 23 | 24 | %% 25 | 26 | exp :: { AST } 27 | : exp PLUS prod 28 | { Sum $1 $3 } 29 | | prod 30 | { $1 } 31 | 32 | prod :: { AST } 33 | : prod TIMES neg 34 | { Prod $1 $3 } 35 | | neg 36 | { $1 } 37 | 38 | neg :: { AST } 39 | : MINUS neg 40 | { Neg $2 } 41 | | atom 42 | { $1 } 43 | 44 | atom :: { AST } 45 | : ID 46 | { let Id str = $1 in Var str } 47 | | NUM 48 | { let Num n = $1 in Lit n } 49 | | LPAREN exp RPAREN 50 | { $2 } 51 | 52 | { 53 | 54 | data Token = 55 | Plus 56 | | Minus 57 | | Times 58 | | LParen 59 | | RParen 60 | | Id String 61 | | Num Int 62 | | EOF 63 | deriving (Eq, Ord, Show) 64 | 65 | data AST = 66 | Sum AST AST 67 | | Prod AST AST 68 | | Neg AST 69 | | Var String 70 | | Lit Int 71 | deriving (Eq, Ord) 72 | 73 | type Parser m = ExceptT () (Lexer m) 74 | 75 | type Lexer m = StateT [Token] m 76 | 77 | parseError :: MonadIO m => Token -> Parser m a 78 | parseError tok = 79 | do 80 | liftIO (putStrLn ("Parse error at " ++ show tok)) 81 | throwError () 82 | 83 | lexer :: MonadIO m => (Token -> Parser m a) -> Parser m a 84 | lexer cont = 85 | do 86 | toks <- get 87 | case toks of 88 | [] -> cont EOF 89 | first : rest -> 90 | do 91 | put rest 92 | cont first 93 | 94 | parse :: (MonadIO m) => Parser m AST 95 | 96 | parser :: (MonadIO m) => 97 | [Token] 98 | -> m (Maybe AST) 99 | parser input = 100 | let 101 | run :: (MonadIO m) => 102 | Lexer m (Maybe AST) 103 | run = 104 | do 105 | res <- runExceptT parse 106 | case res of 107 | Left () -> return Nothing 108 | Right ast -> return (Just ast) 109 | in do 110 | (out, _) <- runStateT run input 111 | return out 112 | 113 | main :: IO () 114 | main = 115 | let 116 | input = [Id "x", Plus, 117 | Minus, Num 1, Times, 118 | LParen, Num 2, Plus, Id "y", RParen] 119 | expected = Sum (Var "x") (Prod (Neg (Lit 1)) (Sum (Lit 2) (Var "y"))) 120 | in do 121 | res <- parser input 122 | case res of 123 | Nothing -> print "Test failed\n" 124 | Just actual 125 | | expected == actual -> print "Test works\n" 126 | | otherwise -> print "Test failed\n" 127 | 128 | -- vendored in parts of mtl 129 | 130 | class Monad m => MonadIO m where liftIO :: IO a -> m a 131 | instance MonadIO IO where liftIO = id 132 | 133 | class Monad m => MonadState s m | m -> s where 134 | put :: s -> m () 135 | get :: m s 136 | 137 | newtype StateT s m a = StateT { runStateT :: s -> m (a, s) } 138 | 139 | instance Monad m => Functor (StateT s m) where 140 | fmap = liftM 141 | 142 | instance Monad m => A.Applicative (StateT s m) where 143 | pure = return 144 | (<*>) = ap 145 | 146 | instance Monad m => Monad (StateT s m) where 147 | return x = StateT $ \s -> return (x, s) 148 | m >>= k = StateT $ \s0 -> do 149 | (x, s1) <- runStateT m s0 150 | runStateT (k x) s1 151 | 152 | instance Monad m => MonadState s (StateT s m) where 153 | put s = StateT $ \_ -> return ((), s) 154 | get = StateT $ \s -> return (s, s) 155 | 156 | instance MonadIO m => MonadIO (StateT e m) where 157 | liftIO m = StateT $ \s -> liftM (\x -> (x, s)) (liftIO m) 158 | 159 | class Monad m => MonadError e m | m -> e where 160 | throwError :: e -> m a 161 | 162 | newtype ExceptT e m a = ExceptT { runExceptT :: m (Either e a) } 163 | 164 | instance Monad m => Functor (ExceptT e m) where 165 | fmap = liftM 166 | 167 | instance Monad m => A.Applicative (ExceptT e m) where 168 | pure = return 169 | (<*>) = ap 170 | 171 | instance Monad m => Monad (ExceptT e m) where 172 | return = ExceptT . return . Right 173 | m >>= k = ExceptT $ do 174 | x <- runExceptT m 175 | case x of 176 | Left e -> return (Left e) 177 | Right y -> runExceptT (k y) 178 | 179 | instance MonadState s m => MonadState s (ExceptT e m) where 180 | put s = ExceptT (liftM Right (put s)) 181 | get = ExceptT (liftM Right get) 182 | 183 | instance MonadIO m => MonadIO (ExceptT e m) where 184 | liftIO = ExceptT . liftM Right . liftIO 185 | 186 | instance Monad m => MonadError e (ExceptT e m) where 187 | throwError = ExceptT . return . Left 188 | 189 | } 190 | --------------------------------------------------------------------------------