diff --git a/ANNOUNCE b/ANNOUNCE new file mode 100644 --- /dev/null +++ b/ANNOUNCE @@ -0,0 +1,21 @@ +I am pleased to announce version 2.1.0 of Alex, the lexical analyser +generator for Haskell. + +Changes in Alex 2.1.0 vs. 2.0.1: + + * Switch to a Cabal build system: you need a recent version of Cabal + (1.1.6 or later). If you have GHC 6.4.2, then you need to upgrade + Cabal before building Alex. GHC 6.6 is fine. + + * Slight change in the error semantics: the input returned on error + is before the erroneous character was read, not after. This helps + to give better error messages. + +Distributions can be obtained from Alex's home page: + + http://www.haskell.org/alex/ + +Alex is distributed under a BSD-style license. + +Cheers, + Simon diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 1995-2003, Chris Dornan and Simon Marlow +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holders, nor the names of the + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,31 @@ + Alex: A Lexical Analyser Generator + + Version 2.0 + + 8 August 2003 + + +Alex is a Lex-like tool for generating Haskell scanners. For complete +documentation, see the doc directory. + +Alex version 2.0 has changed fairly considerably since version 1.x, +and the syntax is almost completely different. For a detailed list of +changes, see the CHANGES file. + +Alex is now covered by a BSD-Style licence; see the licence file in +the `doc' directory for details. + +The sources are in the the `src' directory and the documentation in the `doc' +directory; various examples are in the 'examples' subdirectory. + +The source code in the 'src' and 'examples' directories is intended +for a Haskell 98 compiler with hierarchical modules. It should work +with an version of GHC >= 5.04. + +Please report any bugs or comments to the email addresses given below. + +Share and enjoy, + +Chris Dornan: cdornan@arm.com +Isaac Jones: ijones@syntaxpolice.org +Simon Marlow: simonmar@microsoft.com diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,117 @@ +#!/usr/bin/runhaskell + +\begin{code} +module Main where + +import Control.Exception ( finally ) +import Distribution.PackageDescription ( PackageDescription ) +import Distribution.Setup ( BuildFlags, CleanFlags, CopyDest(..), CopyFlags(..), InstallFlags ) +import Distribution.Simple ( defaultMainWithHooks, defaultUserHooks, UserHooks(..), Args, compilerPath ) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), mkDataDir ) +import System.Directory +import System.Exit ( ExitCode(..) ) +import System.IO +import System.IO.Error +import System.Process +import System.Cmd +import Text.Printf ( printf ) + +main :: IO () +main = defaultMainWithHooks defaultUserHooks{ postBuild = myPostBuild, + postClean = myPostClean, + postCopy = myPostCopy, + postInst = myPostInstall } + +myPostBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode +myPostBuild _ _ _ lbi = + excursion "templates" $ do + let cpp_template src dst opts = do + let dst_pp = dst ++ ".hspp" + ghc = compilerPath (compiler lbi) + ghc_args = ["-o", dst_pp, "-E", "-cpp", src] ++ opts + -- hack to turn cpp-style '# 27 "GenericTemplate.hs"' into + -- '{-# LINE 27 "GenericTemplate.hs" #-}'. + perl_args = ["-pe", "s/^#\\s+(\\d+)\\s+(\"[^\"]*\")/{-# LINE \\1 \\2 #-}/g;s/\\$(Id:.*)\\$/\\1/g", dst_pp] + mb_perl <- findExecutable "perl" + perl <- case mb_perl of + Nothing -> ioError (userError "You need \"perl\" installed and on your PATH to complete the build") + Just path -> return path + do_cmd ghc ghc_args `cmd_seq` do_cmd_out perl perl_args dst + + cmd_seqs ([ cpp_template "GenericTemplate.hs" dst opts | (dst,opts) <- templates ] ++ + [ cpp_template "wrappers.hs" dst opts | (dst,opts) <- wrappers ]) + +myPostClean :: Args -> CleanFlags -> PackageDescription -> Maybe LocalBuildInfo -> IO ExitCode +myPostClean _ _ _ _ = + excursion "templates" $ do + sequence [ try (removeFile f) >> try (removeFile (f ++ ".hspp")) + | (f,_) <- all_templates] + return ExitSuccess + +myPostInstall :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode +myPostInstall _ _ pkg_descr lbi = + install pkg_descr lbi NoCopyDest + +myPostCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode +myPostCopy _ copy_flags pkg_descr lbi = + install pkg_descr lbi (copyDest copy_flags) + +install :: PackageDescription -> LocalBuildInfo -> CopyDest -> IO ExitCode +install pkg_descr lbi copy_dest = + excursion "templates" $ do + let dataDir = mkDataDir pkg_descr lbi copy_dest + createDirectoryIfMissing True dataDir + sequence [ copyFile f (dataDir ++ '/':f) | (f,_) <- all_templates ] + -- XXX: joinFileName + return ExitSuccess + +all_templates :: [(FilePath,[String])] +all_templates = templates ++ wrappers + +templates :: [(FilePath,[String])] +templates = [ + ("AlexTemplate", []), + ("AlexTemplate-ghc", ["-DALEX_GHC"]), + ("AlexTemplate-ghc-debug", ["-DALEX_GHC","-DALEX_DEBUG"]), + ("AlexTemplate-debug", ["-DALEX_DEBUG"]) + ] + +wrappers :: [(FilePath,[String])] +wrappers = [ + ("AlexWrapper-basic", ["-DALEX_BASIC"]), + ("AlexWrapper-posn", ["-DALEX_POSN"]), + ("AlexWrapper-monad", ["-DALEX_MONAD"]), + ("AlexWrapper-gscan", ["-DALEX_GSCAN"]) + ] + +-- ----------------------------------------------------------------------------- +-- Utils + +do_cmd :: FilePath -> [String] -> IO ExitCode +do_cmd cmd args = do + putStrLn (unwords (cmd:args)) + ph <- runProcess cmd args Nothing Nothing Nothing Nothing Nothing + waitForProcess ph + +do_cmd_out :: FilePath -> [String] -> FilePath -> IO ExitCode +do_cmd_out cmd args outfile = do + putStrLn (unwords (cmd:args)) + outh <- openFile outfile WriteMode + ph <- runProcess cmd args Nothing Nothing Nothing (Just outh) Nothing + waitForProcess ph + +cmd_seq :: IO ExitCode -> IO ExitCode -> IO ExitCode +cmd_seq c1 c2 = do + e <- c1 + case e of + ExitSuccess -> c2 + _ -> return e + +cmd_seqs :: [IO ExitCode] -> IO ExitCode +cmd_seqs = foldr cmd_seq (return ExitSuccess) + +excursion :: FilePath -> IO a -> IO a +excursion d io = do + cwd <- getCurrentDirectory + (do setCurrentDirectory d; io) `finally` setCurrentDirectory cwd +\end{code} diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,31 @@ +- Option for pure Haskell 98 output? + +- Extend to Unicode (32-bit Char) + +- Put in {-# LINE #-} pragmas for token actions + +- bug: we throw away the first character of code + +- Prune states that aren't reachable? + +- Issues a warning for tokens that can't be generated? + +- Info file? + - start codes + - accepting states + +- More compact lexer table encoding: + - equivalence classes? + +- Improve performance of Alex itself + +- AlexEOF doesn't provide a way to get at the text position of the EOF. + +- AlexState should include some user state - would make this monad + more useful in general. + +- Allow user-defined wrappers? Wrappers in files relative to the + current directory, for example? + +- case-insensitivity option (like flex's -i). + diff --git a/alex.cabal b/alex.cabal new file mode 100644 --- /dev/null +++ b/alex.cabal @@ -0,0 +1,71 @@ +name: alex +version: 2.1.0 +license: BSD3 +license-file: LICENSE +copyright: (c) Chis Dornan, Simon Marlow +author: Chris Dornan and Simon Marlow +maintainer: Simon Marlow +stability: stable +homepage: http://www.haskell.org/alex/ +synopsis: Alex is a tool for generating lexical analysers in Haskell +build-depends: base>=1.0, haskell98>=1.0 +extra-source-files: + ANNOUNCE + README + TODO + alex.spec + doc/Makefile + doc/aclocal.m4 + doc/alex.1.in + doc/alex.xml + doc/config.mk.in + doc/configure.ac + doc/docbook-xml.mk + doc/fptools.css + examples/Makefile + examples/Tokens.x + examples/Tokens_gscan.x + examples/Tokens_posn.x + examples/examples.x + examples/haskell.x + examples/lit.x + examples/pp.x + examples/state.x + examples/tiny.y + examples/tkns.hs + examples/words.x + examples/words_monad.x + examples/words_posn.x + src/Parser.y + src/Scan.hs + src/ghc_hooks.c + templates/GenericTemplate.hs + templates/Makefile + templates/wrappers.hs + tests/Makefile + tests/simple.x + tests/tokens.x + tests/tokens_gscan.x + tests/tokens_posn.x + +executable: alex +hs-source-dirs: src +main-is: Main.hs +extensions: CPP +other-modules: + AbsSyn + CharSet + DFA + DFS + Info + Main + Map + NFA + Output + Parser + ParseMonad + Scan + Set + Sort + Util +ghc-options: -O diff --git a/alex.spec b/alex.spec new file mode 100644 --- /dev/null +++ b/alex.spec @@ -0,0 +1,49 @@ +%define name alex +%define version 2.1.0 +%define release 1 + +Name: %{name} +Version: %{version} +Release: %{release} +License: BSD-like +Group: Development/Languages/Haskell +URL: http://haskell.org/alex/ +Source: http://haskell.org/alex/dist/%{version}/alex-%{version}.tar.gz +Packager: Sven Panne +BuildRoot: %{_tmppath}/%{name}-%{version}-build +Prefix: %{_prefix} +BuildRequires: happy, ghc, docbook-dtd, docbook-xsl-stylesheets, libxslt, libxml2, fop, xmltex, dvips +Summary: The lexer generator for Haskell + +%description +Alex is a tool for generating lexical analysers in Haskell, given a +description of the tokens to be recognised in the form of regular +expressions. It is similar to the tool lex or flex for C/C++. + +%prep +%setup -n alex-%{version} + +%build +runhaskell Setup.lhs configure --prefix=%{prefix} +runhaskell Setup.lhs build +cd doc +test -f configure || autoreconf +./configure +make html + +%install +runhaskell Setup.lhs copy --destdir=${RPM_BUILD_ROOT} + +%clean +rm -rf ${RPM_BUILD_ROOT} + +%files +%defattr(-,root,root) +%doc ANNOUNCE +%doc LICENSE +%doc README +%doc TODO +%doc doc/alex +%doc examples +%{prefix}/bin/alex +%{prefix}/share/alex-%{version} diff --git a/doc/Makefile b/doc/Makefile new file mode 100644 --- /dev/null +++ b/doc/Makefile @@ -0,0 +1,6 @@ +include config.mk + +XML_DOC = alex +INSTALL_XML_DOC = alex + +include docbook-xml.mk diff --git a/doc/aclocal.m4 b/doc/aclocal.m4 new file mode 100644 --- /dev/null +++ b/doc/aclocal.m4 @@ -0,0 +1,174 @@ +# FP_GEN_DOCBOOK_XML +# ------------------ +# Generates a DocBook XML V4.2 document in conftest.xml. +AC_DEFUN([FP_GEN_DOCBOOK_XML], +[rm -f conftest.xml +cat > conftest.xml << EOF + + + + A DocBook Test Document + + A Chapter Title + This is a paragraph, referencing . + + + Another Chapter Title + This is another paragraph, referencing . + + +EOF +]) # FP_GEN_DOCBOOK_XML + + +# FP_PROG_XSLTPROC +# ---------------- +# Sets the output variable XsltprocCmd to the full path of the XSLT processor +# xsltproc. XsltprocCmd is empty if xsltproc could not be found. +AC_DEFUN([FP_PROG_XSLTPROC], +[AC_PATH_PROG([XsltprocCmd], [xsltproc]) +if test -z "$XsltprocCmd"; then + AC_MSG_WARN([cannot find xsltproc in your PATH, you will not be able to build the documentation]) +fi +])# FP_PROG_XSLTPROC + + +# FP_DIR_DOCBOOK_XSL(XSL-DIRS) +# ---------------------------- +# Check which of the directories XSL-DIRS contains DocBook XSL stylesheets. The +# output variable DIR_DOCBOOK_XSL will contain the first usable directory or +# will be empty if none could be found. +AC_DEFUN([FP_DIR_DOCBOOK_XSL], +[AC_REQUIRE([FP_PROG_XSLTPROC])dnl +if test -n "$XsltprocCmd"; then + AC_CACHE_CHECK([for DocBook XSL stylesheet directory], fp_cv_dir_docbook_xsl, + [FP_GEN_DOCBOOK_XML + fp_cv_dir_docbook_xsl=no + for fp_var in $1; do + if $XsltprocCmd ${fp_var}/html/docbook.xsl conftest.xml > /dev/null 2>&1; then + fp_cv_dir_docbook_xsl=$fp_var + break + fi + done + rm -rf conftest*]) +fi +if test x"$fp_cv_dir_docbook_xsl" = xno; then + AC_MSG_WARN([cannot find DocBook XSL stylesheets, you will not be able to build the documentation]) + DIR_DOCBOOK_XSL= +else + DIR_DOCBOOK_XSL=$fp_cv_dir_docbook_xsl +fi +AC_SUBST([DIR_DOCBOOK_XSL]) +])# FP_DIR_DOCBOOK_XSL + + +# FP_PROG_XMLLINT +# ---------------- +# Sets the output variable XmllintCmd to the full path of the XSLT processor +# xmllint. XmllintCmd is empty if xmllint could not be found. +AC_DEFUN([FP_PROG_XMLLINT], +[AC_PATH_PROG([XmllintCmd], [xmllint]) +if test -z "$XmllintCmd"; then + AC_MSG_WARN([cannot find xmllint in your PATH, you will not be able to validate your documentation]) +fi +])# FP_PROG_XMLLINT + + +# FP_CHECK_DOCBOOK_DTD +# -------------------- +AC_DEFUN([FP_CHECK_DOCBOOK_DTD], +[AC_REQUIRE([FP_PROG_XMLLINT])dnl +if test -n "$XmllintCmd"; then + AC_MSG_CHECKING([for DocBook DTD]) + FP_GEN_DOCBOOK_XML + if $XmllintCmd --valid --noout conftest.xml > /dev/null 2>&1; then + AC_MSG_RESULT([ok]) + else + AC_MSG_RESULT([failed]) + AC_MSG_WARN([cannot find a DTD for DocBook XML V4.2, you will not be able to validate your documentation]) + AC_MSG_WARN([check your XML_CATALOG_FILES environment variable and/or /etc/xml/catalog]) + fi + rm -rf conftest* +fi +])# FP_CHECK_DOCBOOK_DTD + + +# FP_GEN_FO +# ------------------ +# Generates a formatting objects document in conftest.fo. +AC_DEFUN([FP_GEN_FO], +[rm -f conftest.fo +cat > conftest.fo << EOF + + + + + + + + + + + Test! + + + + +EOF +]) # FP_GEN_FO + + +# FP_PROG_FOP +# ----------- +# Set the output variable 'FopCmd' to the first working 'fop' in the current +# 'PATH'. Note that /usr/bin/fop is broken in SuSE 9.1 (unpatched), so try +# /usr/share/fop/fop.sh in that case (or no 'fop'), too. +AC_DEFUN([FP_PROG_FOP], +[AC_PATH_PROGS([FopCmd1], [fop]) +if test -n "$FopCmd1"; then + AC_CACHE_CHECK([for $FopCmd1 usability], [fp_cv_fop_usability], + [FP_GEN_FO + if "$FopCmd1" -fo conftest.fo -ps conftest.ps > /dev/null 2>&1; then + fp_cv_fop_usability=yes + else + fp_cv_fop_usability=no + fi + rm -rf conftest*]) + if test x"$fp_cv_fop_usability" = xyes; then + FopCmd=$FopCmd1 + fi +fi +if test -z "$FopCmd"; then + AC_PATH_PROGS([FopCmd2], [fop.sh], , [/usr/share/fop]) + FopCmd=$FopCmd2 +fi +AC_SUBST([FopCmd]) +])# FP_PROG_FOP + + +# FP_PROG_FO_PROCESSOR +# -------------------- +# Try to find an FO processor. PassiveTeX output is sometimes a bit strange, so +# try FOP first. Sets the output variables FopCmd, XmltexCmd, DvipsCmd, and +# PdfxmltexCmd. +AC_DEFUN([FP_PROG_FO_PROCESSOR], +[AC_REQUIRE([FP_PROG_FOP]) +AC_PATH_PROG([XmltexCmd], [xmltex]) +AC_PATH_PROG([DvipsCmd], [dvips]) +if test -z "$FopCmd"; then + if test -z "$XmltexCmd"; then + AC_MSG_WARN([cannot find an FO => DVI converter, you will not be able to build DVI or PostScript documentation]) + else + if test -z "$DvipsCmd"; then + AC_MSG_WARN([cannot find a DVI => PS converter, you will not be able to build PostScript documentation]) + fi + fi + AC_PATH_PROG([PdfxmltexCmd], [pdfxmltex]) + if test -z "$PdfxmltexCmd"; then + AC_MSG_WARN([cannot find an FO => PDF converter, you will not be able to build PDF documentation]) + fi +elif test -z "$XmltexCmd"; then + AC_MSG_WARN([cannot find an FO => DVI converter, you will not be able to build DVI documentation]) +fi +])# FP_PROG_FO_PROCESSOR diff --git a/doc/alex.1.in b/doc/alex.1.in new file mode 100644 --- /dev/null +++ b/doc/alex.1.in @@ -0,0 +1,111 @@ +.TH ALEX 1 "2003-09-09" "Glasgow FP Suite" "Alex Lexical Analyser Generator" +.SH NAME +alex \- the lexical analyser generator for Haskell + +.SH SYNOPSIS +.B alex +[\fIOPTION\fR]... \fIfile\fR [\fIOPTION\fR]... + +.SH DESCRIPTION +This manual page documents briefly the +.BR alex +command. + +.PP +This manual page was written for the Debian GNU/Linux distribution +because the original program does not have a manual page. Instead, it +has documentation in various other formats, including DVI, Info and +HTML; see below. + +.PP +.B Alex +is a lexical analyser generator system for Haskell. It is similar to the +tool lex or flex for C/C++. + +.PP +Input files are expected to be of the form +.I file.x +and +.B alex +will produce output in +.I file.y + +.PP +Caveat: When using +.I hbc +(Chalmers Haskell) the command argument structure is slightly +different. This is because the hbc run time system takes some flags +as its own (for setting things like the heap size, etc). This problem +can be circumvented by adding a single dash (`-') to your command +line. So when using a hbc generated version of Alex, the argument +structure is: + +.B alex \- +[\fIOPTION\fR]... \fIfile\fR [\fIOPTION\fR]... + +.SH OPTIONS +The programs follow the usual GNU command line syntax, with long +options starting with two dashes (`--'). A summary of options is +included below. For a complete description, see the other +documentation. + +.TP +.BR \-d ", " \-\-debug +Instructs Alex to generate a lexer which will output debugging messsages +as it runs. + +.TP +.BR \-g ", " \-\-ghc +Instructs Alex to generate a lexer which is optimised for compiling with +GHC. The lexer will be significantly more efficient, both in terms of +the size of the compiled lexer and its runtime. + +.TP +\fB\-o\fR \fIFILE\fR, \fB\-\-outfile=\fIFILE +Specifies the filename in which the output is to be placed. By default, +this is the name of the input file with the +.I .x +suffix replaced by +.I .hs + +.TP +\fB\-i\fR [\fIFILE\fR], \fB\-\-info\fR[=\fIFILE\fR] +Produces a human-readable rendition of the state machine (DFA) that +Alex derives from the lexer, in +.I FILE +(default: +.I file.info +where the input file is +.I file.x +). + +The format of the info file is currently a bit basic, and not +particularly informative. + +.TP +.BR \-v ", " \-\-version +Print version information on standard output then exit successfully. + +.SH FILES +.I @LIBDIR@ + +.SH "SEE ALSO" +.BR @DOCDIR@ , +the Alex homepage +.UR http://haskell.org/alex/ +(http://haskell.org/alex/) +.UE + +.SH COPYRIGHT +Alex Version @VERSION@ + +Copyright (c) 1995-2003, Chris Dornan and Simon Marlow + +.SH AUTHOR +This manual page was written by Ian Lynagh +, based on the happy manpage, for the Debian GNU/Linux +system (but may be used by others). + +.\" Local variables: +.\" mode: nroff +.\" End: diff --git a/doc/alex.xml b/doc/alex.xml new file mode 100644 --- /dev/null +++ b/doc/alex.xml @@ -0,0 +1,1394 @@ + + + + + + + 2003-8-11 + Alex User Guide + + Chris + Dornan + + + Isaac + Jones + + + Simon + Marlow + +
ijones@syntaxpolice.org
+ + + + + + + Alex is a tool for generating lexical analysers in + Haskell, given a description of the tokens to be recognised in + the form of regular expressions. It is similar to the tool + lex or flex for C/C++. + + + + + + + + About Alex + + Alex can always be obtained from its home page. The latest + source code lives in the fptools CVS + repository; instructions on accessing that repository are here. + +
+ Release Notes for version 2.1.0 + + + + Switch to a Cabal build system: you need a recent + version of Cabal (1.1.6 or later). If you have GHC 6.4.2, + then you need to upgrade Cabal before building Alex. GHC + 6.6 is fine. + + + + Slight change in the error semantics: the input + returned on error is before the erroneous character was + read, not after. This helps to give better error + messages. + + +
+ +
+ Release Notes for version 2.0 + + Alex has changed a lot between + versions 1.x and 2.0. The following is supposed to be an + exhaustive list of the changes: + +
+ Syntax changes + + + + Code blocks are now surrounded by + {...} rather than + %{...%}. + + + + Character-set macros now begin with + ‘$’ instead of + ‘^’ and have + multi-character names. + + + + Regular expression macros now begin with + ‘@’ instead of + ‘%’ and have + multi-character names. + + + + Macro definitions are no longer surrounded by + { ... }. + + + + Rules are now of the form +<c1,c2,...> regex { code } + where c1, c2 are + startcodes, and code is an arbitrary + Haskell expression. + + + + Regular expression syntax changes: + + + + () is the empty regular + expression (used to be + ‘$’) + + + + set complement can now be expressed as + [^sets] (for similarity with lex + regular expressions). + + + + The 'abc' form is no longer + available, use [abc] + instead. + + + + ‘^’ and + ‘$’ have the usual + meanings: ‘^’ matches + just after a ‘\n’, and + ‘$’ matches just before + a ‘\n’. + + + + ‘\n’ is now the + escape character, not + ‘^’. + + + + The form "..." means the same + as the sequence of characters inside the quotes, the + difference being that special characters do not need + to be escaped inside "...". + + + + + + Rules can have arbitrary predicates attached to + them. This subsumes the previous left-context and + right-context facilities (although these are still allowed + as syntactic sugar). + + +
+ +
+ Changes in the form of an Alex file + + + + Each file can now only define a single grammar. + This change was made to simplify code generation. + Multiple grammars can be simulated using startcodes, or + split into separate modules. + + + + The programmer experience has been simplified, and + at the same time made more flexible. See the for details. + + + + You no longer need to import the + Alex module. + + +
+ +
+ Usage changes + + The command-line syntax is quite different. See . +
+ +
+ Implementation changes + + + + A more efficient table representation, coupled with + standard table-compression techniques, are used to keep + the size of the generated code down. + + + + When compiling a grammar with GHC, the -g switch + causes an even faster and smaller grammar to be + generated. + + + + Startcodes are implemented in a different way: each + state corresponds to a different initial state in the DFA, + so the scanner doesn't have to check the startcode when it + gets to an accept state. This results in a larger, but + quicker, scanner. + + +
+
+ +
+ Reporting bugs in Alex + + Please report bugs in Alex to + simonmar@microsoft.com. There are no specific + mailing lists for the discussion of Alex-related matters, but + such topics should be fine on the Haskell + and Haskell + Cafe mailing lists. +
+ +
+ License + + Copyright (c) 1995-2003, Chris Dornan and Simon Marlow. + All rights reserved. + + Redistribution and use in source and binary forms, with or + without modification, are permitted provided that the following + conditions are met: + + + + Redistributions of source code must retain the above + copyright notice, this list of conditions and the following + disclaimer. + + + + Redistributions in binary form must reproduce the + above copyright notice, this list of conditions and the + following disclaimer in the documentation and/or other + materials provided with the distribution. + + + + Neither the name of the copyright holders, nor the + names of the contributors may be used to endorse or promote + products derived from this software without specific prior + written permission. + + + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND + CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR + CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF + USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING + IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +
+ + + + Introduction + + Alex is a tool for generating lexical analysers in Haskell, + given a description of the tokens to be recognised in the form of + regular expressions. It is similar to the tools + lex and flex for C/C++. + + Alex takes a description of tokens based on regular + expressions and generates a Haskell module containing code for + scanning text efficiently. Alex is designed to be familiar to + exisiting lex users, although it does depart from lex in a number + of ways. + +
A simple Alex specification. +{ +module Main (main) where +} + +%wrapper "basic" + +$digit = 0-9 -- digits +$alpha = [a-zA-Z] -- alphabetic characters + +tokens :- + + $white+ ; + "--".* ; + let { \s -> Let } + in { \s -> In } + $digit+ { \s -> Int (read s) } + [\=\+\-\*\/\(\)] { \s -> Sym (head s) } + $alpha [$alpha $digit \_ \']* { \s -> Var s } + +{ +-- Each action has type :: String -> Token + +-- The token type: +data Token = + Let | + In | + Sym Char | + Var String | + Int Int + deriving (Eq,Show) + +main = do + s <- getContents + print (alexScanTokens s) +}
+ + A sample specification is given in . The first few lines between the + { and } provide a code scrap + (some inlined Haskell code) to be placed directly in the output, + the scrap at the top of the module is normally used to declare the + module name for the generated Haskell module, in this case + Main. + + The next line, %wrapper "basic" controls + what kind of support code Alex should produce along with the basic + scanner. The basic wrapper selects a scanner + that tokenises a String and returns a list of + tokens. Wrappers are described fully in . + + The next two lines define the $digit and + $alpha macros for use in the token + definitions. + + The ‘tokens :-’ line ends the + macro definitions and starts the definition of the scanner. + + The scanner is specified as a series of token definitions + where each token specification takes the form of + +regexp { code } + + The meaming of a this rule is "if the input matches + regexp, then return + code". The code part along with the + braces can be replaced by simply + ‘;’, meaning that this token should + be ignored in the input stream. As you can see, we've used this + to ignore whitespace in our example. + + Our scanner is set up so that the actions are all functions + with type String->Token. When the token is + matched, the portion of the input stream that it matched is passed + to the appropriate action function as a + String. + + At the bottom of the file we have another code fragment, + surrounded by braces { ... }. In this + fragment, we declare the type of the tokens, and give a + main function that we can use for testing it; + the main function just tokenises the input and + prints the results to standard output. + + Alex has kindly provided the following function which we can + use to invoke the scanner: + +alexScanTokens :: String -> [Token] + + Alex arranges for the input stream to be tokenised, each of + the action functions to be passed the appriate + String, and a list of Tokens + returned as the result. If the input stream is lazy, the output + stream will also be produced lazilythat is, unless you + have any patterns that require a long lookahead. + . + + We have demonstrated the simplest form of scanner here, + which was selected by the %wrapper "basic" line + near the top of the file. In general, actions do not have to have + type String->Token, and there's no requirement + for the scanner to return a list of tokens. + + With this specification in the file + Tokens.x, Alex can be used to generate + Tokens.hs: + +$ alex Tokens.x + + If the module needed to be placed in different file, + Main.hs for example, then the output filename + can be specified using the option: + +$ alex Tokens.x -o Main.hs + + The resulting module is Haskell 98 compatible. It can also + be readily used with a Happy parser. + + + + Alex Files + + In this section we describe the layout of an Alex lexical + specification. We begin with the lexical syntax; elements of the + lexical syntax are referred to throughout the rest of this + documentation, so you may need to refer back to the following + section several times. + +
+ Lexical syntax + + Alex's lexical syntax is given below. It is written as a + set of macro definitions using Alex's own syntax. These macros + are used in the BNF specification of the syntax later on. + +$digit = [0-9] +$octdig = [0-7] +$hexdig = [0-9A-Fa-f] +$special = [\.\;\,\$\|\*\+\?\#\~\-\{\}\(\)\[\]\^\/] +$graphic = $printable # $white + +@string = \" ($graphic # \")* \" +@id = [A-Za-z][A-Za-z'_]* +@smac = '$' id +@rmac = '@' id +@char = ($graphic # $special) | @escape +@escape = '\\' ($printable | 'x' $hexdig+ | 'o' $octdig+ | $digit+) +@code = -- curly braces surrounding a Haskell code fragment +
+ +
+ Syntax of Alex files + + In the following description of the Alex syntax, we use an + extended form of BNF, where optional phrases are enclosed in + square brackets ([ ... ]), and phrases which + may be repeated zero or more times are enclosed in braces + ({ ... }). Literal text is enclosed in + single quotes. + + An Alex lexical specification is normally placed in a file + with a .x extension. The overall layout of + an Alex file is: + +alex := [ @code ] [ wrapper ] { macrodef } @id ':-' { rule } [ @code ] + + The file begins and ends with optional code fragments. + These code fragments are copied verbatim into the generated + source file. + + At the top of the file, the code fragment is normally used + to declare the module name and some imports, and that is all it + should do: don't declare any functions or types in the top code + fragment, because Alex may need to inject some imports of its + own into the generated lexer code, and it does this by adding + them directly after this code fragment in the output + file. + + Next comes an optional wrapper specification: + +wrapper := '%wrapper' @string + + wrappers are described in . + +
+ Macro definitions + + Next, the lexer specification can contain a series of + macro definitions. There are two kinds of macros, + character set macros, which begin with + a $, and regular expression + macros, which begin with a @. + A character set macro can be used wherever a character set is + valid (see ), and a regular + expression macro can be used wherever a regular expression is + valid (see ). + +macrodef := @smac '=' set + | @rmac '=' regexp +
+ +
+ Rules + + The rules are heralded by the sequence + ‘id :-’ + in the file. It doesn't matter what you use for the + identifer, it is just there for documentation purposes. In + fact, it can be omitted, but the :- must be + left in. + + The syntax of rules is as follows: + +rule := [ startcodes ] token + | startcodes '{' { token } '}' + +token := [ left_ctx ] regexp [ right_ctx ] rhs + +rhs := @code | ';' + + Each rule defines one token in the lexical + specification. When the input stream matches the regular + expression in a rule, the Alex lexer will return the value of + the expression on the right hand side, which we call the + action. The action can be any Haskell + expression. Alex only places one restriction on actions: all + the actions must have the same type. They can be values in a + token type, for example, or possibly operations in a monad. + More about how this all works is in . + + The action may be missing, indicated by replacing it + with ‘;’, in which case the + token will be skipped in the input stream. + + Alex will always find the longest match. For example, + if we have a rule that matches whitespace: + +$white+ ; + + Then this rule will match as much whitespace at the + beginning of the input stream as it can. Be careful: if we + had instead written this rule as + +$white* ; + + then it would also match the empty string, which would + mean that Alex could never fail to match a rule! + + When the input stream matches more than one rule, the + rule which matches the longest prefix of the input stream + wins. If there are still several rules which match an equal + number of characters, then the rule which appears earliest in + the file wins. + +
+ Contexts + + Alex allows a left and right context to be placed on + any rule: + + +left_ctx := '^' + | set '^' + +right_ctx := '$' + | '/' regexp + | '/' @code + + + The left context matches the character which + immediately precedes the token in the input stream. The + character immediately preceding the beginning of the stream + is assumed to be ‘\n’. The + special left-context ‘^’ is + shorthand for ‘\n^’. + + Right context is rather more general. There are three + forms: + + + + + / regexp + + + This right-context causes the rule to match if + and only if it is followed in the input stream by text + which matches + regexp. + + NOTE: this should be used sparingly, because it + can have a serious impact on performance. Any time + this rule could match, its + right-context will be checked against the current + input stream. + + + + + $ + + Equivalent to + ‘/\n’. + + + + + / { ... } + + This form is called a + predicate on the rule. The + Haskell expression inside the curly braces should have + type: +{ ... } :: user -- predicate state + -> AlexInput -- input stream before the token + -> Int -- length of the token + -> AlexInput -- input stream after the token + -> Bool -- True <=> accept the token + Alex will only accept the token as matching if + the predicate returns True. + + See for the meaning of the + AlexInput type. The + user argument is available for + passing into the lexer a special state which is used + by predicates; to give this argument a value, the + alexScanUser entry point to the + lexer must be used (see ). + + + +
+ +
+ Start codes + + Start codes are a way of adding state to a lexical + specification, such that only certain rules will match for a + given state. + + A startcode is simply an identifer, or the special + start code ‘0’. Each rule + may be given a list of startcodes under which it + applies: + +startcode := @id | '0' +startcodes := '<' startcode { ',' startcode } '>' + + When the lexer is invoked to scan the next token from + the input stream, the start code to use is also specified + (see ). Only rules that mention this + start code are then enabled. Rules which do not have a list + of startcodes are available all the time. + + Each distinct start code mentioned in the lexical + specification causes a definition of the same name to be + inserted in the generated source file, whose value is of + type Int. For example, if we mentioned + startcodes foo and bar + in the lexical spec, then Alex will create definitions such + as: +foo = 1 +bar = 2 + in the output file. + + Another way to think of start codes is as a way to + define several different (but possibly overlapping) lexical + specifications in a single file, since each start code + corresponds to a different set of rules. In concrete terms, + each start code corresponds to a distinct initial state in + the state machine that Alex derives from the lexical + specification. + + Here is an example of using startcodes as states, for + collecting the characters inside a string: + +<0> ([^\"] | \n)* ; +<0> \" { begin string } +<string> [^\"] { stringchar } +<string> \" { begin 0 } + + When it sees a quotation mark, the lexer switches into + the string state and each character + thereafter causes a stringchar action, + until the next quotation mark is found, when we switch back + into the 0 state again. + + From the lexer's point of view, the startcode is just + an integer passed in, which tells it which state to start + in. In order to actually use it as a state, you must have + some way for the token actions to specify new start codes - + describes some ways this can be done. + In some applications, it might be necessary to keep a + stack of start codes, where at the end + of a state we pop the stack and resume parsing in the + previous state. If you want this functionality, you have to + program it yourself. +
+ +
+
+ + + + Regular Expression + + Regular expressions are the patterns that Alex uses to match + tokens in the input stream. + +
+ Syntax of regular expressions + +regexp := rexp2 { '|' rexp2 } + +rexp2 := rexp1 { rexp1 } + +rexp1 := rexp0 [ '*' | '+' | '?' | repeat ] + +rexp0 := set + | @rmac + | @string + | '(' [ regexp ] ')' + +repeat := '{' $digit '}' + | '{' $digit ',' '}' + | '{' $digit ',' $digit '}' + + The syntax of regular expressions is fairly standard, the + only difference from normal lex-style regular expressions being + that we allow the sequence () to denote the + regular expression that matches the empty string. + + Spaces are ignored in a regular expression, so feel free + to space out your regular expression as much as you like, even + split it over multiple lines and include comments. Literal + whitespace can be included by surrounding it with quotes + "   ", or by escaping each whitespace character + with \. + + + + set + + Matches any of the characters in + set. See for the syntax of sets. + + + + + @foo + + Expands to the definition of the appropriate + regular expression macro. + + + + + "..." + + Matches the sequence of characters in the string, in + that order. + + + + + r* + + Matches zero or more occurences of + r. + + + + + r+ + + Matches one or more occurences of + r. + + + + + r? + + Matches zero or one occurences of + r. + + + + + r{n} + + Matches n occurrences of + r. + + + + + r{n,} + + Matches n or more occurrences of + r. + + + + + r{n,m} + + Matches between n and + m (inclusive) occurrences of + r. + + + +
+ +
+ Syntax of character sets + + Character sets are the fundamental elements in a regular + expression. A character set is a pattern that matches a single + character. The syntax of character sets is as follows: + +set := set ['#' set0] + +set0 := @char [ '-' @char ] + | '.' + | @smac + | '[' [^] { set } ']' + | '~' set0 + + The various character set constructions are: + + + + char + + The simplest character set is a single character. + Note that special characters such as [ + and . must be escaped by prefixing them + with \ (see the lexical syntax, , for the list of special + characters). + + Certain non-printable characters have special escape + sequences. These are: \a, + \b, \f, + \n, \r, + \t, and \v. Other + characters can be represented by using their numerical + character values (although this may be non-portable): + \x0A is equivalent to + \n, for example. + + Whitespace characters are ignored; to represent a + literal space, escape it with \. + + + + + char-char + + A range of characters can be expressed by separating + the characters with a ‘-’, + all the characters with codes in the given range are + included in the set. Character ranges can also be + non-portable. + + + + + . + + The built-in set ‘.’ + matches all characters except newline + (\n). + + Equivalent to the set + [\x00-\xff] # \n. + + + + + set0 # set1 + + Matches all the characters in + set0 that are not in + set1. + + + + + [sets] + + The union of sets. + + + + + [^sets] + + The complement of the union of the + sets. Equivalent to + ‘. # [sets]’. + + + + + ~set + + The complement of set. + Equivalent to ‘. # set’ + + + + + A set macro is written as $ followed by + an identifier. There are some builtin character set + macros: + + + + $white + + Matches all whitespace characters, including + newline. + + Equivalent to the set + [\t\n\f\v\r]. + + + + + $printable + + Matches all printable characters (characters 32 to + 126 in ASCII). Equivalent to the set + [\32-\126]. + + + + + Character set macros can be defined at the top of the file + at the same time as regular expression macros (see ). Here are some example character set + macros: + +$lls = a-z -- little letters +$not_lls = ~a-z -- anything but little letters +$ls_ds = [a-zA-Z0-9] -- letters and digits +$sym = [ \! \@ \# \$ ] -- the symbols !, @, #, and $ +$sym_q_nl = [ \' \! \@ \# \$ \n ] -- the above symbols with ' and newline +$quotable = $printable # \' -- any graphic character except ' +$del = \127 -- ASCII DEL +
+ + + + + The Interface to an Alex-generated lexer + + This section answers the question: "How do I include an + Alex lexer in my program? + + Alex provides for a great deal of flexibility in how the + lexer is exposed to the rest of the program. For instance, + there's no need to parse a String directly if + you have some special character-buffer operations that avoid the + overheads of ordinary Haskell Strings. You + might want Alex to keep track of the line and column number in the + input text, or you might wish to do it yourself (perhaps you use a + different tab width from the standard 8-columns, for + example). + + The general story is this: Alex provides a basic interface + to the generated lexer (described in the next section), which you + can use to parse tokens given an abstract input type with + operations over it. You also have the option of including a + wrapper, which provides a higher-level + abstraction over the basic interface; Alex comes with several + wrappers. + +
+ Basic interface + + If you compile your Alex file without a + %wrapper declaration, then you get access to + the lowest-level API to the lexer. You must provide definitions + for the following, either in the same module or imported from + another module: + +type AlexInput +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexInputPrevChar :: AlexInput -> Char + + The generated lexer is independent of the input type, + which is why you have to provide a definition for the input type + yourself. Note that the input type needs to keep track of the + previous character in the input stream; + this is used for implementing patterns with a left-context + (those that begin with ^ or + set^). If you + don't ever use patterns with a left-context in your lexical + specification, then you can safely forget about the previous + character in the input stream, and have + alexInputPrevChar return + undefined. + + Alex will provide the following function: + +alexScan :: AlexInput -- The current input + -> Int -- The "start code" + -> AlexReturn action -- The return value + +data AlexReturn action + = AlexEOF + + | AlexError + !AlexInput -- Remaining input + + | AlexSkip + !AlexInput -- Remaining input + !Int -- Token length + + | AlexToken + !AlexInput -- Remaining input + !Int -- Token length + action -- action value + + Calling alexScan will scan a single + token from the input stream, and return a value of type + AlexReturn. The value returned is either: + + + + AlexEOF + + The end-of-file was reached. + + + + + AlexError + + A valid token could not be recognised. + + + + + AlexSkip + + The matched token did not have an action associated + with it. + + + + + AlexToken + + A token was matched, and the action associated with + it is returned. + + + + + The action is simply the value of the + expression inside {...} on the + right-hand-side of the appropriate rule in the Alex file. + Alex doesn't specify what type these expressions should have, it + simply requires that they all have the same type, or else you'll + get a type error when you try to compile the generated + lexer. + + Once you have the action, it is up to + you what to do with it. The type of action + could be a function which takes the String + representation of the token and returns a value in some token + type, or it could be a continuation that takes the new input and + calls alexScan again, building a list of + tokens as it goes. + + This is pretty low-level stuff; you have complete + flexibility about how you use the lexer, but there might be a + fair amount of support code to write before you can actually use + it. For this reason, we also provide a selection of wrappers + that add some common functionality to this basic scheme. + Wrappers are described in the next section. + + There is another entry point, which is useful if your + grammar contains any predicates (see ): + +alexScanUser + :: user -- predicate state + -> AlexInput -- The current input + -> Int -- The "start code" + -> Maybe ( -- Nothing on error or EOF + AlexInput, -- The remaining input + Int, -- Length of this token + action -- The action (an unknown type) + ) + + The extra argument, of some type user, + is passed to each predicate. +
+ +
+ Wrappers + + To use one of the provided wrappers, include the following + declaration in your file: + +%wrapper "name" + + where name is the name of the + wrapper, eg. basic. The following sections + describe each of the wrappers that come with Alex. + +
+ The "basic" wrapper + + The basic wrapper is a good way to obtain a function of + type String -> [token] from a lexer + specification, with little fuss. + + It provides definitions for + AlexInput, alexGetChar + and alexInputPrevChar that are suitable for + lexing a String input. It also provides a + function alexScanTokens which takes a + String input and returns a list of the + tokens it contains. + + The basic wrapper provides no support + for using startcodes; the initial startcode is always set to + zero. + + Here is the actual code included in the lexer when the + basic wrapper is selected: + +type AlexInput = (Char, -- previous char + String) -- current input string + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (_, []) = Nothing +alexGetChar (_, c:cs) = Just (c, (c,cs)) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (c,_) = c + +-- alexScanTokens :: String -> [token] +alexScanTokens str = go ('\n',str) + where go inp@(_,str) = + case alexScan inp 0 of + AlexEOF -> [] + AlexError _ -> error "lexical error" + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act (take len str) : go inp' + + The type signature for alexScanTokens + is commented out, because the token type is + unkonwn. All of the actions in your lexical specification + should have type: + +{ ... } :: String -> token + + for some type token. + + For an example of the use of the basic wrapper, see the + file examples/Tokens_basic.x in the Alex + distribution. +
+ +
+ The "posn" wrapper + + The posn wrapper provides slightly more functionality + than the basic wrapper: it keeps track of line and column + numbers of tokens in the input text. + + The posn wrapper provides the following, in addition to + the straightforward definitions of + alexGetChar and + alexInputPrevChar: + +data AlexPosn = AlexPn !Int -- absolute character offset + !Int -- line number + !Int -- column number + +type AlexInput = (AlexPosn, -- current position, + Char, -- previous char + String) -- current input string + +--alexScanTokens :: String -> [token] +alexScanTokens str = go (alexStartPos,'\n',str) + where go inp@(pos,_,str) = + case alexScan inp 0 of + AlexEOF -> [] + AlexError _ -> error "lexical error" + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act pos (take len str) : go inp' + + The types of the token actions should be: + +{ ... } :: AlexPosn -> String -> token + + For an example using the posn + wrapper, see the file + examples/Tokens_posn.x in the Alex + distribution. +
+ +
+ The "monad" wrapper + + The monad wrapper is the most + flexible of the wrappers provided with Alex. It includes a + state monad which keeps track of the current input and text + position, and the startcode. It is intended to be a template + for building your own monads - feel free to copy the code and + modify it to build a monad with the facilities you + need. + +data AlexState = AlexState { + alex_pos :: !AlexPosn, -- position at current input location + alex_inp :: String, -- the current input + alex_chr :: !Char, -- the character before the input + alex_scd :: !Int -- the current startcode + } + +newtype Alex a = Alex { unAlex :: AlexState + -> Either String (AlexState, a) } + +runAlex :: String -> Alex a -> Either String a + +alexGetInput :: Alex AlexInput +alexSetInput :: AlexInput -> Alex () + +alexError :: String -> Alex a + +alexGetStartCode :: Alex Int +alexSetStartCode :: Int -> Alex () + + To invoke a scanner under the monad + wrapper, use alexMonadScan: + +alexMonadScan :: Alex result + + The token actions should have the following type: + +type AlexAction result = AlexInput -> Int -> Alex result +{ ... } :: AlexAction result + + The monad wrapper also provides some + useful combinators for constructing token actions: + +-- skip :: AlexAction result +skip input len = alexMonadScan + +-- andBegin :: AlexAction result -> Int -> AlexAction result +(act `andBegin` code) input len = do alexSetStartCode code; act input len + +-- begin :: Int -> AlexAction result +begin code = skip `andBegin` code + +-- token :: (String -> Int -> token) -> AlexAction token +token t input len = return (t input len) +
+ +
+ The "gscan" wrapper + + The gscan wrapper is provided mainly + for historical reasons: it exposes an interface which is very + similar to that provided by Alex version 1.x. The interface + is intended to be very general, allowing actions to modify the + startcode, and pass around an arbitrary state value. + +alexGScan :: StopAction state result -> state -> String -> result + +type StopAction state result + = AlexPosn -> Char -> String -> (Int,state) -> result + + The token actions should all have this type: + +{ ... } :: AlexPosn -- token position + -> Char -- previous character + -> String -- input string at token + -> Int -- length of token + -> ((Int,state) -> result) -- continuation + -> (Int,state) -- current (startcode,state) + -> result +
+
+ + + + Invoking Alex + + The command line syntax for Alex is entirely + standard: + +$ alex { option } file.x { option } + + Alex expects a single + file.x to be named + on the command line. By default, Alex will create + file.hs containing + the Haskell source for the lexer. + + The options that Alex accepts are listed below: + + + + file + =file + + Specifies the filename in which the output is to be + placed. By default, this is the name of the input file with + the .x suffix replaced by + .hs. + + + + + file + =file + + Produces a human-readable rendition of the state + machine (DFA) that Alex derives from the lexer, in + file (default: + file.info + where the input file is + file.x). + + The format of the info file is currently a bit basic, + and not particularly informative. + + + + + dir + =dir + + Look in dir for template files. + + + + + + + + Causes Alex to produce a lexer which is optimised for + compiling with GHC. The lexer will be significantly more + efficient, both in terms of the size of the compiled + lexer and its runtime. + + + + + + + + Causes Alex to produce a lexer which will output + debugging messsages as it runs. + + + + + + + + Display help and exit. + + + + + + + + Output version information and exit. Note that for legacy + reasons is supported, too, but the use of it + is deprecated. will be used for verbose mode + when it is actually implemented. + + + + + + diff --git a/doc/config.mk.in b/doc/config.mk.in new file mode 100644 --- /dev/null +++ b/doc/config.mk.in @@ -0,0 +1,15 @@ +#----------------------------------------------------------------------------- +# DocBook XML stuff + +XSLTPROC = @XsltprocCmd@ +XMLLINT = @XmllintCmd@ +FOP = @FopCmd@ +XMLTEX = @XmltexCmd@ +PDFXMLTEX = @PdfxmltexCmd@ +DVIPS = @DvipsCmd@ + +DIR_DOCBOOK_XSL = @DIR_DOCBOOK_XSL@ + +XSLTPROC_LABEL_OPTS = --stringparam toc.section.depth 3 \ + --stringparam section.autolabel 1 \ + --stringparam section.label.includes.component.label 1 diff --git a/doc/configure.ac b/doc/configure.ac new file mode 100644 --- /dev/null +++ b/doc/configure.ac @@ -0,0 +1,12 @@ + +AC_INIT([Haddock docs], [1.0], [simonmar@microsoft.com], []) + +AC_CONFIG_SRCDIR([Makefile]) + +dnl ** check for DocBook toolchain +FP_CHECK_DOCBOOK_DTD +FP_DIR_DOCBOOK_XSL([/usr/share/xml/docbook/stylesheet/nwalsh/current /usr/share/xml/docbook/stylesheet/nwalsh /usr/share/sgml/docbook/docbook-xsl-stylesheets* /usr/share/sgml/docbook/xsl-stylesheets* /opt/kde?/share/apps/ksgmltools2/docbook/xsl /usr/share/docbook-xsl /usr/share/sgml/docbkxsl /usr/local/share/xsl/docbook /sw/share/xml/xsl/docbook-xsl]) +FP_PROG_FO_PROCESSOR + +AC_CONFIG_FILES([config.mk]) +AC_OUTPUT diff --git a/doc/docbook-xml.mk b/doc/docbook-xml.mk new file mode 100644 --- /dev/null +++ b/doc/docbook-xml.mk @@ -0,0 +1,130 @@ +#----------------------------------------------------------------------------- +# DocBook XML + +.PHONY: html html-no-chunks chm HxS fo dvi ps pdf + +ifneq "$(XML_DOC)" "" + +all :: html + +# multi-file XML document: main document name is specified in $(XML_DOC), +# sub-documents (.xml files) listed in $(XML_SRCS). + +ifeq "$(XML_SRCS)" "" +XML_SRCS = $(wildcard *.xml) +endif + +XML_HTML = $(addsuffix /index.html,$(basename $(XML_DOC))) +XML_HTML_NO_CHUNKS = $(addsuffix .html,$(XML_DOC)) +XML_CHM = $(addsuffix .chm,$(XML_DOC)) +XML_HxS = $(addsuffix .HxS,$(XML_DOC)) +XML_FO = $(addsuffix .fo,$(XML_DOC)) +XML_DVI = $(addsuffix .dvi,$(XML_DOC)) +XML_PS = $(addsuffix .ps,$(XML_DOC)) +XML_PDF = $(addsuffix .pdf,$(XML_DOC)) + +$(XML_HTML) $(XML_NO_CHUNKS_HTML) $(XML_FO) $(XML_DVI) $(XML_PS) $(XML_PDF) :: $(XML_SRCS) + +html :: $(XML_HTML) +html-no-chunks :: $(XML_HTML_NO_CHUNKS) +chm :: $(XML_CHM) +HxS :: $(XML_HxS) +fo :: $(XML_FO) +dvi :: $(XML_DVI) +ps :: $(XML_PS) +pdf :: $(XML_PDF) + +CLEAN_FILES += $(XML_HTML_NO_CHUNKS) $(XML_FO) $(XML_DVI) $(XML_PS) $(XML_PDF) + +FPTOOLS_CSS = fptools.css + +clean :: + $(RM) -rf $(XML_DOC).out $(basename $(XML_DOC)) $(basename $(XML_DOC))-htmlhelp + +validate :: + $(XMLLINT) --valid --noout $(XMLLINT_OPTS) $(XML_DOC).xml +endif + +#----------------------------------------------------------------------------- +# DocBook XML suffix rules +# + +%.html : %.xml + $(XSLTPROC) --output $@ \ + --stringparam html.stylesheet $(FPTOOLS_CSS) \ + $(XSLTPROC_LABEL_OPTS) $(XSLTPROC_OPTS) \ + $(DIR_DOCBOOK_XSL)/html/docbook.xsl $< + +%/index.html : %.xml + $(RM) -rf $(dir $@) + $(XSLTPROC) --stringparam base.dir $(dir $@) \ + --stringparam use.id.as.filename 1 \ + --stringparam html.stylesheet $(FPTOOLS_CSS) \ + $(XSLTPROC_LABEL_OPTS) $(XSLTPROC_OPTS) \ + $(DIR_DOCBOOK_XSL)/html/chunk.xsl $< + cp $(FPTOOLS_CSS) $(dir $@) + +# Note: Numeric labeling seems to be uncommon for HTML Help +%-htmlhelp/index.html : %.xml + $(RM) -rf $(dir $@) + $(XSLTPROC) --stringparam base.dir $(dir $@) \ + --stringparam manifest.in.base.dir 1 \ + --stringparam htmlhelp.chm "..\\"$(basename $<).chm \ + $(XSLTPROC_OPTS) \ + $(DIR_DOCBOOK_XSL)/htmlhelp/htmlhelp.xsl $< + +%-htmlhelp2/collection.HxC : %.xml + $(RM) -rf $(dir $@) + $(XSLTPROC) --stringparam base.dir $(dir $@) \ + --stringparam use.id.as.filename 1 \ + --stringparam manifest.in.base.dir 1 \ + $(XSLTPROC_OPTS) \ + $(DIR_DOCBOOK_XSL)/htmlhelp2/htmlhelp2.xsl $< + +# TODO: Detect hhc & Hxcomp via autoconf +# +# Two obstacles here: +# +# * The reason for the strange "if" below is that hhc returns 0 on error and 1 +# on success, the opposite of what shells and make expect. +# +# * There seems to be some trouble with DocBook indices, but the *.chm looks OK, +# anyway, therefore we pacify make by "|| true". Ugly... +# +%.chm : %-htmlhelp/index.html + ( cd $(dir $<) && if hhc htmlhelp.hhp ; then false ; else true ; fi ) || true + +%.HxS : %-htmlhelp2/collection.HxC + ( cd $(dir $<) && if Hxcomp -p collection.HxC -o ../$@ ; then false ; else true ; fi ) + +%.fo : %.xml + $(XSLTPROC) --output $@ \ + --stringparam draft.mode no \ + $(XSLTPROC_LABEL_OPTS) $(XSLTPROC_OPTS) \ + $(DIR_DOCBOOK_XSL)/fo/docbook.xsl $< + +ifeq "$(FOP)" "" +ifneq "$(PDFXMLTEX)" "" +%.pdf : %.fo + $(PDFXMLTEX) $< + if grep "LaTeX Warning: Label(s) may have changed.Rerun to get cross-references right." $(basename $@).log > /dev/null ; then \ + $(PDFXMLTEX) $< ; \ + $(PDFXMLTEX) $< ; \ + fi +endif +else +%.ps : %.fo + $(FOP) $(FOP_OPTS) -fo $< -ps $@ + +%.pdf : %.fo + $(FOP) $(FOP_OPTS) -fo $< -pdf $@ +endif + +ifneq "$(XMLTEX)" "" +%.dvi : %.fo + $(XMLTEX) $< + if grep "LaTeX Warning: Label(s) may have changed.Rerun to get cross-references right." $(basename $@).log > /dev/null ; then \ + $(XMLTEX) $< ; \ + $(XMLTEX) $< ; \ + fi +endif diff --git a/doc/fptools.css b/doc/fptools.css new file mode 100644 --- /dev/null +++ b/doc/fptools.css @@ -0,0 +1,36 @@ +div { + font-family: sans-serif; + color: black; + background: white +} + +h1, h2, h3, h4, h5, h6, p.title { color: #005A9C } + +h1 { font: 170% sans-serif } +h2 { font: 140% sans-serif } +h3 { font: 120% sans-serif } +h4 { font: bold 100% sans-serif } +h5 { font: italic 100% sans-serif } +h6 { font: small-caps 100% sans-serif } + +pre { + font-family: monospace; + border-width: 1px; + border-style: solid; + padding: 0.3em +} + +pre.screen { color: #006400 } +pre.programlisting { color: maroon } + +div.example { + background-color: #fffcf5; + margin: 1ex 0em; + border: solid #412e25 1px; + padding: 0ex 0.4em +} + +a:link { color: #0000C8 } +a:hover { background: #FFFFA8 } +a:active { color: #D00000 } +a:visited { color: #680098 } diff --git a/examples/Makefile b/examples/Makefile new file mode 100644 --- /dev/null +++ b/examples/Makefile @@ -0,0 +1,31 @@ +TOP = .. +include $(TOP)/mk/boilerplate.mk + +PROGS = lit Tokens Tokens_posn Tokens_gscan words words_posn words_monad \ + tiny haskell + +lit : lit.hs + $(HC) $(HC_OPTS) -o $@ $< + +tiny : Tokens_posn.o tiny.o + $(HC) $(HC_OPTS) -o $@ Tokens_posn.o tiny.o + +Tokens_posn : Tokens_posn.hs + $(HC) $(HC_OPTS) -o $@ $< + +Tokens_gscan : Tokens_gscan.hs + $(HC) $(HC_OPTS) -o $@ $< + +words : words.hs + $(HC) $(HC_OPTS) -o $@ $< + +words_posn : words_posn.hs + $(HC) $(HC_OPTS) -o $@ $< + +words_monad : words_monad.hs + $(HC) $(HC_OPTS) -o $@ $< + +haskell : haskell.hs + $(HC) $(HC_OPTS) -o $@ $< + +include $(TOP)/mk/target.mk diff --git a/examples/Tokens.x b/examples/Tokens.x new file mode 100644 --- /dev/null +++ b/examples/Tokens.x @@ -0,0 +1,34 @@ +{ +module Tokens (Token(..), alexScanTokens) where +} + +%wrapper "basic" + +$digit = 0-9 -- digits +$alpha = [a-zA-Z] -- alphabetic characters + +tokens :- + + $white+ { \s -> White } + "--".* { \s -> Comment } + let { \s -> Let } + in { \s -> In } + $digit+ { \s -> Int (read s) } + [\=\+\-\*\/\(\)] { \s -> Sym (head s) } + $alpha [$alpha $digit \_ \']* { \s -> Var s } + +{ +-- Each right-hand side has type :: String -> Token + +-- The token type: +data Token = + White | + Comment | + Let | + In | + Sym Char | + Var String | + Int Int | + Err + deriving (Eq,Show) +} diff --git a/examples/Tokens_gscan.x b/examples/Tokens_gscan.x new file mode 100644 --- /dev/null +++ b/examples/Tokens_gscan.x @@ -0,0 +1,40 @@ +{ +module Main (main) where +} + +%wrapper "gscan" + +$digit = 0-9 -- digits +$alpha = [a-zA-Z] -- alphabetic characters + +tokens :- + + $white+ ; + "--".* ; + let { tok (\p s -> Let p) } + in { tok (\p s -> In p) } + $digit+ { tok (\p s -> Int p (read s)) } + [\=\+\-\*\/\(\)] { tok (\p s -> Sym p (head s)) } + $alpha [$alpha $digit \_ \']* { tok (\p s -> Var p s) } + +{ +-- Some action helpers: +tok f p c str len cont (sc,state) = f p (take len str) : cont (sc,state) + +-- The token type: +data Token = + Let AlexPosn | + In AlexPosn | + Sym AlexPosn Char | + Var AlexPosn String | + Int AlexPosn Int | + Err AlexPosn + deriving (Eq,Show) + +main = do + s <- getContents + print (alexGScan stop undefined s) + where + stop p c "" (sc,s) = [] + stop p c _ (sc,s) = error "lexical error" +} diff --git a/examples/Tokens_posn.x b/examples/Tokens_posn.x new file mode 100644 --- /dev/null +++ b/examples/Tokens_posn.x @@ -0,0 +1,40 @@ +{ +module Tokens_posn (Token(..), AlexPosn(..), alexScanTokens, token_posn) where +} + +%wrapper "posn" + +$digit = 0-9 -- digits +$alpha = [a-zA-Z] -- alphabetic characters + +tokens :- + + $white+ ; + "--".* ; + let { tok (\p s -> Let p) } + in { tok (\p s -> In p) } + $digit+ { tok (\p s -> Int p (read s)) } + [\=\+\-\*\/\(\)] { tok (\p s -> Sym p (head s)) } + $alpha [$alpha $digit \_ \']* { tok (\p s -> Var p s) } + +{ +-- Each right-hand side has type :: AlexPosn -> String -> Token + +-- Some action helpers: +tok f p s = f p s + +-- The token type: +data Token = + Let AlexPosn | + In AlexPosn | + Sym AlexPosn Char | + Var AlexPosn String | + Int AlexPosn Int + deriving (Eq,Show) + +token_posn (Let p) = p +token_posn (In p) = p +token_posn (Sym p _) = p +token_posn (Var p _) = p +token_posn (Int p _) = p +} diff --git a/examples/examples.x b/examples/examples.x new file mode 100644 --- /dev/null +++ b/examples/examples.x @@ -0,0 +1,19 @@ +"example_rexps":- + + ::= $ | a+ -- = a*, zero or more as + ::= aa* -- = a+, one or more as + ::= $ | a -- = a?, zero or one as + ::= a{3} -- = aaa, three as + ::= a{3,5} -- = a{3}a?a? + ::= a{3,} -- = a{3}a* + + +"example_sets":- + + ::= a-z -- little letters + ::= ~a-z -- anything but little letters + ::= [a-zA-Z0-9] -- letters and digits + ::= `!@@#$' -- the symbols !, @@, # and $ + ::= [`!#@@$'^'^n] -- the above symbols with ' and newline + ::= ^p#^' -- any graphic character except ' + ::= ^127 -- ASCII DEL diff --git a/examples/haskell.x b/examples/haskell.x new file mode 100644 --- /dev/null +++ b/examples/haskell.x @@ -0,0 +1,172 @@ +-- +-- Lexical syntax for Haskell 98. +-- +-- (c) Simon Marlow 2003, with the caveat that much of this is +-- translated directly from the syntax in the Haskell 98 report. +-- +-- This isn't a complete Haskell 98 lexer - it doesn't handle layout +-- for one thing. However, it could be adapted with a small +-- amount of effort. +-- + +{ +module Main (main) where +} + +%wrapper "monad" + +$whitechar = [ \t\n\r\f\v] +$special = [\(\)\,\;\[\]\`\{\}] + +$ascdigit = 0-9 +$unidigit = [] -- TODO +$digit = [$ascdigit $unidigit] + +$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~] +$unisymbol = [] -- TODO +$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\'] + +$large = [A-Z \xc0-\xd6 \xd8-\xde] +$small = [a-z \xdf-\xf6 \xf8-\xff \_] +$alpha = [$small $large] + +$graphic = [$small $large $symbol $digit $special \:\"\'] + +$octit = 0-7 +$hexit = [0-9 A-F a-f] +$idchar = [$alpha $digit \'] +$symchar = [$symbol \:] +$nl = [\n\r] + +@reservedid = + as|case|class|data|default|deriving|do|else|hiding|if| + import|in|infix|infixl|infixr|instance|let|module|newtype| + of|qualified|then|type|where + +@reservedop = + ".." | ":" | "::" | "=" | \\ | "|" | "<-" | "->" | "@" | "~" | "=>" + +@varid = $small $idchar* +@conid = $large $idchar* +@varsym = $symbol $symchar* +@consym = \: $symchar* + +@decimal = $digit+ +@octal = $octit+ +@hexadecimal = $hexit+ +@exponent = [eE] [\-\+] @decimal + +$cntrl = [$large \@\[\\\]\^\_] +@ascii = \^ $cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK + | BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE + | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM + | SUB | ESC | FS | GS | RS | US | SP | DEL +$charesc = [abfnrtv\\\"\'\&] +@escape = \\ ($charesc | @ascii | @decimal | o @octal | x @hexadecimal) +@gap = \\ $whitechar+ \\ +@string = $graphic # [\"\\] | " " | @escape | @gap + +haskell :- + +<0> $white+ { skip } +<0> "--"\-*[^$symbol].* { skip } + +"{-" { nested_comment } + +<0> $special { mkL LSpecial } + +<0> @reservedid { mkL LReservedId } +<0> @conid \. @varid { mkL LQVarId } +<0> @conid \. @conid { mkL LQConId } +<0> @varid { mkL LVarId } +<0> @conid { mkL LConId } + +<0> @reservedop { mkL LReservedOp } +<0> @conid \. @varsym { mkL LVarSym } +<0> @conid \. @consym { mkL LConSym } +<0> @varsym { mkL LVarSym } +<0> @consym { mkL LConSym } + +<0> @decimal + | 0[oO] @octal + | 0[xX] @hexadecimal { mkL LInteger } + +<0> @decimal \. @decimal @exponent? + | @decimal @exponent { mkL LFloat } + +<0> \' ($graphic # [\'\\] | " " | @escape) \' + { mkL LChar } + +<0> \" @string* \" { mkL LString } + +{ +data Lexeme = L AlexPosn LexemeClass String + +data LexemeClass + = LInteger + | LFloat + | LChar + | LString + | LSpecial + | LReservedId + | LReservedOp + | LVarId + | LQVarId + | LConId + | LQConId + | LVarSym + | LQVarSym + | LConSym + | LQConSym + | LEOF + deriving Eq + +mkL :: LexemeClass -> AlexInput -> Int -> Alex Lexeme +mkL c (p,_,str) len = return (L p c (take len str)) + +nested_comment :: AlexInput -> Int -> Alex Lexeme +nested_comment _ _ = do + input <- alexGetInput + go 1 input + where go 0 input = do alexSetInput input; alexMonadScan + go n input = do + case alexGetChar input of + Nothing -> err input + Just (c,input) -> do + case c of + '-' -> do + case alexGetChar input of + Nothing -> err input + Just ('\125',input) -> go (n-1) input + Just (c,input) -> go n input + '\123' -> do + case alexGetChar input of + Nothing -> err input + Just ('-',input) -> go (n+1) input + Just (c,input) -> go n input + c -> go n input + + err input = do alexSetInput input; lexError "error in nested comment" + +lexError s = do + (p,c,input) <- alexGetInput + alexError (showPosn p ++ ": " ++ s ++ + (if (not (null input)) + then " before " ++ show (head input) + else " at end of file")) + +scanner str = runAlex str $ do + let loop i = do tok@(L _ cl _) <- alexMonadScan; + if cl == LEOF + then return i + else do loop $! (i+1) + loop 0 + +alexEOF = return (L undefined LEOF "") + +showPosn (AlexPn _ line col) = show line ++ ':': show col + +main = do + s <- getContents + print (scanner s) +} diff --git a/examples/lit.x b/examples/lit.x new file mode 100644 --- /dev/null +++ b/examples/lit.x @@ -0,0 +1,47 @@ +{ +module Main (main) where +} + +%wrapper "gscan" + +$space = $white # \n +@blank = \n $space* +@scrap = \n \> .* +@comment = \n ( [^ \> $white] | $space+ ~$white ) .* + +lit :- + + @blank @scrap+ { scrap } + @blank @comment* { comment } + +{ +scrap _ _ inp len cont st = strip len inp + where + strip 0 _ = cont st + strip (n+1) (c:rst) = + if c=='\n' + then '\n':strip_nl n rst + else c:strip n rst + + strip_nl (n+1) ('>':rst) = ' ':strip n rst + strip_nl n rst = strip n rst + +comment _ _ inp len cont st = strip len inp + where + strip 0 _ = cont st + strip (n+1) (c:rst) = if c=='\n' then c:strip n rst else strip n rst + + +main:: IO () +main = interact literate + +literate:: String -> String +literate inp = drop 2 (alexGScan stop_act () ('\n':'\n':inp)) + +stop_act p _ "" st = [] +stop_act p _ _ _ = error (msg ++ loc p ++ "\n") + +msg = "literate preprocessing error at " + +loc (AlexPn _ l c) = "line " ++ show(l-2) ++ ", column " ++ show c +} diff --git a/examples/pp.x b/examples/pp.x new file mode 100644 --- /dev/null +++ b/examples/pp.x @@ -0,0 +1,38 @@ +%{ +import System +import Char +import Alex +%} + + +"pp_lx"/"pp_acts":- + +{ ^s = ^w#^n } -- spaces and tabs, etc. +{ ^f = [A-Za-z0-9`~%-_.,/'] } -- file name character + + ::= ^#include^s+^"^f+^"^s*^n + ::= .*^n + + +%{ +inc p c inp len cont st = pp fn >> cont st + where + fn = (takeWhile ('"'/=) . tail . dropWhile isSpace . drop 8) inp + +txt p c inp len cont st = putStr (take len inp) >> cont st + + +main:: IO () +main = getArgs >>= \args -> + case args of + [fn] -> pp fn + _ -> error "usage: pp file\n" + +pp:: String -> IO () +pp fn = readFile fn >>= \cts -> gscan pp_scan () cts + +pp_scan:: GScan () (IO ()) +pp_scan = load_gscan (pp_acts,stop_act) pp_lx + where + stop_act _ _ _ _ = return () +%} diff --git a/examples/state.x b/examples/state.x new file mode 100644 --- /dev/null +++ b/examples/state.x @@ -0,0 +1,32 @@ +{ +module Main (main) where +} + +%wrapper "gscan" + +state :- + + $white+ { skip } + \{ [^\}]* \} { code } + [A-Za-z]+ { ide } + +{ +code _ _ inp len cont (sc,frags) = cont (sc,frag:frags) + where + frag = take (len-4) (drop 2 inp) + +ide _ _ inp len cont st = Ide (take len inp):cont st + +skip _ _ inp len cont st = cont st + +data Token = Ide String | Eof String | Err deriving Show + +stop_act _ _ "" (_,frags) = [Eof (unlines(reverse frags))] +stop_act _ _ _ _ = [Err] + +tokens:: String -> [Token] +tokens inp = alexGScan stop_act [] inp + +main:: IO () +main = interact (show.tokens) +} diff --git a/examples/tiny.y b/examples/tiny.y new file mode 100644 --- /dev/null +++ b/examples/tiny.y @@ -0,0 +1,69 @@ +-- An example demonstrating how to connect a Happy parser to an Alex lexer. +{ +import Tokens_posn +} + +%name calc +%tokentype { Token } + +%token let { Let _ } + in { In _ } + int { Int _ $$ } + var { Var _ $$ } + '=' { Sym _ '=' } + '+' { Sym _ '+' } + '-' { Sym _ '-' } + '*' { Sym _ '*' } + '/' { Sym _ '/' } + '(' { Sym _ '(' } + ')' { Sym _ ')' } + +%% + +Exp :: { Exp } +Exp : let var '=' Exp in Exp { LetE $2 $4 $6 } + | Exp1 { $1 } + +Exp1 : Exp1 '+' Term { PlusE $1 $3 } + | Exp1 '-' Term { MinusE $1 $3 } + | Term { $1 } + +Term : Term '*' Factor { TimesE $1 $3 } + | Term '/' Factor { DivE $1 $3 } + | Factor { $1 } + +Factor : '-' Atom { NegE $2 } + | Atom { $1 } + +Atom : int { IntE $1 } + | var { VarE $1 } + | '(' Exp ')' { $2 } + +{ +data Exp = + LetE String Exp Exp | + PlusE Exp Exp | + MinusE Exp Exp | + TimesE Exp Exp | + DivE Exp Exp | + NegE Exp | + IntE Int | + VarE String + deriving Show + + +main:: IO () +main = interact (show.runCalc) + +runCalc :: String -> Exp +runCalc = calc . alexScanTokens + +happyError :: [Token] -> a +happyError tks = error ("Parse error at " ++ lcn ++ "\n") + where + lcn = case tks of + [] -> "end of file" + tk:_ -> "line " ++ show l ++ ", column " ++ show c + where + AlexPn _ l c = token_posn tk +} diff --git a/examples/tkns.hs b/examples/tkns.hs new file mode 100644 --- /dev/null +++ b/examples/tkns.hs @@ -0,0 +1,5 @@ +import Alex +import Tokens + +main:: IO () +main = interact (show.tokens) diff --git a/examples/words.x b/examples/words.x new file mode 100644 --- /dev/null +++ b/examples/words.x @@ -0,0 +1,17 @@ +-- Performance test; run with input /usr/dict/words, for example +{ +module Main (main) where +} + +%wrapper "basic" + +words :- + +$white+ ; +[A-Za-z0-9\'\-]+ { \s -> () } + +{ +main = do + s <- getContents + print (length (alexScanTokens s)) +} diff --git a/examples/words_monad.x b/examples/words_monad.x new file mode 100644 --- /dev/null +++ b/examples/words_monad.x @@ -0,0 +1,28 @@ +-- Performance test; run with input /usr/dict/words, for example +{ +module Main (main) where +} + +%wrapper "monad" + +words :- + +$white+ { skip } +[A-Za-z0-9\'\-]+ { word } + +{ +word (_,_,input) len = return (take len input) + +scanner str = runAlex str $ do + let loop i = do tok <- alexMonadScan; + if tok == "stopped." || tok == "error." + then return i + else do let i' = i+1 in i' `seq` loop i' + loop 0 + +alexEOF = return "stopped." + +main = do + s <- getContents + print (scanner s) +} diff --git a/examples/words_posn.x b/examples/words_posn.x new file mode 100644 --- /dev/null +++ b/examples/words_posn.x @@ -0,0 +1,17 @@ +-- Performance test; run with input /usr/dict/words, for example +{ +module Main (main) where +} + +%wrapper "posn" + +words :- + +$white+ ; +[A-Za-z0-9\'\-]+ { \p s -> () } + +{ +main = do + s <- getContents + print (length (alexScanTokens s)) +} diff --git a/src/AbsSyn.hs b/src/AbsSyn.hs new file mode 100644 --- /dev/null +++ b/src/AbsSyn.hs @@ -0,0 +1,263 @@ +-- ----------------------------------------------------------------------------- +-- +-- AbsSyn.hs, part of Alex +-- +-- (c) Chris Dornan 1995-2000, Simon Marlow 2003 +-- +-- This module provides a concrete representation for regular expressions and +-- scanners. Scanners are used for tokenising files in preparation for parsing. +-- +-- ----------------------------------------------------------------------------} + +module AbsSyn ( + Code, Directive(..), + Scanner(..), + RECtx(..), + RExp(..), + DFA(..), State(..), SNum, StartCode, Accept(..), + RightContext(..), + encodeStartCodes, extractActions, + Target(..) + ) where + +import CharSet ( CharSet ) +import Map ( Map ) +import qualified Map hiding ( Map ) +import Sort ( nub' ) +import Util ( str, nl ) + +import Data.Maybe ( fromJust ) + +infixl 4 :| +infixl 5 :%% + +-- ----------------------------------------------------------------------------- +-- Abstract Syntax for Alex scripts + +type Code = String + +data Directive + = WrapperDirective String -- use this wrapper + +-- TODO: update this comment +-- +-- A `Scanner' consists of an association list associating token names with +-- regular expressions with context. The context may include a list of start +-- codes, some leading context to test the character immediately preceding the +-- token and trailing context to test the residual input after the token. +-- +-- The start codes consist of the names and numbers of the start codes; +-- initially the names only will be generated by the parser, the numbers being +-- allocated at a later stage. Start codes become meaningful when scanners are +-- converted to DFAs; see the DFA section of the Scan module for details. + +data Scanner = Scanner { scannerName :: String, + scannerTokens :: [RECtx] } + deriving Show + +data RECtx = RECtx { reCtxStartCodes :: [(String,StartCode)], + reCtxPreCtx :: Maybe CharSet, + reCtxRE :: RExp, + reCtxPostCtx :: RightContext RExp, + reCtxCode :: Maybe Code + } + +data RightContext r + = NoRightContext + | RightContextRExp r + | RightContextCode Code + +instance Show RECtx where + showsPrec _ (RECtx scs _ r rctx code) = + showStarts scs . shows r . showRCtx rctx . showMaybeCode code + +showMaybeCode Nothing = id +showMaybeCode (Just code) = showCode code + +showCode code = showString " { " . showString code . showString " }" + +showStarts [] = id +showStarts scs = shows scs + +showRCtx NoRightContext = id +showRCtx (RightContextRExp r) = ('\\':) . shows r +showRCtx (RightContextCode code) = showString "\\ " . showCode code + +-- ----------------------------------------------------------------------------- +-- DFAs + +data DFA s a = DFA + { dfa_start_states :: [s], + dfa_states :: Map s (State s a) + } + +data State s a = State [Accept a] (Map Char s) + +type SNum = Int + +data Accept a + = Acc { accPrio :: Int, + accAction :: Maybe a, + accLeftCtx :: Maybe CharSet, + accRightCtx :: RightContext SNum + } + +type StartCode = Int + +-- ----------------------------------------------------------------------------- +-- Regular expressions + +-- `RExp' provides an abstract syntax for regular expressions. `Eps' will +-- match empty strings; `Ch p' matches strings containinng a single character +-- `c' if `p c' is true; `re1 :%% re2' matches a string if `re1' matches one of +-- its prefixes and `re2' matches the rest; `re1 :| re2' matches a string if +-- `re1' or `re2' matches it; `Star re', `Plus re' and `Ques re' can be +-- expressed in terms of the other operators. See the definitions of `ARexp' +-- for a formal definition of the semantics of these operators. + +data RExp + = Eps + | Ch CharSet + | RExp :%% RExp + | RExp :| RExp + | Star RExp + | Plus RExp + | Ques RExp + +instance Show RExp where + showsPrec _ Eps = showString "()" + showsPrec _ (Ch set) = showString "[..]" + showsPrec _ (l :%% r) = shows l . shows r + showsPrec _ (l :| r) = shows l . ('|':) . shows r + showsPrec _ (Star r) = shows r . ('*':) + showsPrec _ (Plus r) = shows r . ('+':) + showsPrec _ (Ques r) = shows r . ('?':) + +{------------------------------------------------------------------------------ + Abstract Regular Expression +------------------------------------------------------------------------------} + + +-- This section contains demonstrations; it is not part of Alex. + +{- +-- This function illustrates `ARexp'. It returns true if the string in its +-- argument is matched by the regular expression. + +recognise:: RExp -> String -> Bool +recognise re inp = any (==len) (ap_ar (arexp re) inp) + where + len = length inp + + +-- `ARexp' provides an regular expressions in abstract format. Here regular +-- expressions are represented by a function that takes the string to be +-- matched and returns the sizes of all the prefixes matched by the regular +-- expression (the list may contain duplicates). Each of the `RExp' operators +-- are represented by similarly named functions over ARexp. The `ap' function +-- takes an `ARExp', a string and returns the sizes of all the prefixes +-- matching that regular expression. `arexp' converts an `RExp' to an `ARexp'. + + +arexp:: RExp -> ARexp +arexp Eps = eps_ar +arexp (Ch p) = ch_ar p +arexp (re :%% re') = arexp re `seq_ar` arexp re' +arexp (re :| re') = arexp re `bar_ar` arexp re' +arexp (Star re) = star_ar (arexp re) +arexp (Plus re) = plus_ar (arexp re) +arexp (Ques re) = ques_ar (arexp re) + + +star_ar:: ARexp -> ARexp +star_ar sc = eps_ar `bar_ar` plus_ar sc + +plus_ar:: ARexp -> ARexp +plus_ar sc = sc `seq_ar` star_ar sc + +ques_ar:: ARexp -> ARexp +ques_ar sc = eps_ar `bar_ar` sc + + +-- Hugs abstract type definition -- not for GHC. + +type ARexp = String -> [Int] +-- in ap_ar, eps_ar, ch_ar, seq_ar, bar_ar + +ap_ar:: ARexp -> String -> [Int] +ap_ar sc = sc + +eps_ar:: ARexp +eps_ar inp = [0] + +ch_ar:: (Char->Bool) -> ARexp +ch_ar p "" = [] +ch_ar p (c:rst) = if p c then [1] else [] + +seq_ar:: ARexp -> ARexp -> ARexp +seq_ar sc sc' inp = [n+m| n<-sc inp, m<-sc' (drop n inp)] + +bar_ar:: ARexp -> ARexp -> ARexp +bar_ar sc sc' inp = sc inp ++ sc' inp +-} + +-- ----------------------------------------------------------------------------- +-- Utils + +-- Map the available start codes onto [1..] + +encodeStartCodes:: Scanner -> (Scanner,[StartCode],ShowS) +encodeStartCodes scan = (scan', 0 : map snd name_code_pairs, sc_hdr) + where + scan' = scan{ scannerTokens = map mk_re_ctx (scannerTokens scan) } + + mk_re_ctx (RECtx scs lc re rc code) + = RECtx (map mk_sc scs) lc re rc code + + mk_sc (nm,_) = (nm, if nm=="0" then 0 + else fromJust (Map.lookup nm code_map)) + + sc_hdr tl = + case name_code_pairs of + [] -> tl + (nm,_):rst -> "\n" ++ nm ++ foldr f t rst + where + f (nm, _) t = "," ++ nm ++ t + t = " :: Int\n" ++ foldr fmt_sc tl name_code_pairs + where + fmt_sc (nm,sc) t = nm ++ " = " ++ show sc ++ "\n" ++ t + + code_map = Map.fromList name_code_pairs + + name_code_pairs = zip (nub' (<=) nms) [1..] + + nms = [nm | RECtx{reCtxStartCodes = scs} <- scannerTokens scan, + (nm,_) <- scs, nm /= "0"] + + +-- Grab the code fragments for the token actions, and replace them +-- with function names of the form alex_action_$n$. We do this +-- because the actual action fragments might be duplicated in the +-- generated file. + +extractActions :: Scanner -> (Scanner,ShowS) +extractActions scanner = (scanner{scannerTokens = new_tokens}, decl_str) + where + (new_tokens, decls) = unzip (zipWith f (scannerTokens scanner) act_names) + + f r@RECtx{ reCtxCode = Just code } name + = (r{reCtxCode = Just name}, Just (mkDecl name code)) + f r@RECtx{ reCtxCode = Nothing } name + = (r{reCtxCode = Nothing}, Nothing) + + mkDecl fun code = str fun . str " = " . str code . nl + + act_names = map (\n -> "alex_action_" ++ show n) [0..] + + decl_str = foldr (.) id [ decl | Just decl <- decls ] + +-- ----------------------------------------------------------------------------- +-- Code generation targets + +data Target = GhcTarget | HaskellTarget + diff --git a/src/CharSet.hs b/src/CharSet.hs new file mode 100644 --- /dev/null +++ b/src/CharSet.hs @@ -0,0 +1,56 @@ +-- ----------------------------------------------------------------------------- +-- +-- CharSet.hs, part of Alex +-- +-- (c) Chris Dornan 1995-2000, Simon Marlow 2003 +-- +-- An abstract CharSet type for Alex. To begin with we'll use Alex's +-- original definition of sets as functions, then later will +-- transition to something that will work better with Unicode. +-- +-- ----------------------------------------------------------------------------} + +module CharSet ( + CharSet, -- abstract + emptyCharSet, + charSetSingleton, + charSet, + charSetMinus, + charSetComplement, + charSetRange, + charSetUnion, + charSetToArray, + charSetElems + ) where + +import Data.Array ( Array, array ) + +-- Implementation as functions +type CharSet = Char -> Bool + +emptyCharSet = const False + +charSetSingleton :: Char -> CharSet +charSetSingleton c = \x -> x == c + +charSet :: [Char] -> CharSet +charSet s x = x `elem` s + +charSetMinus :: CharSet -> CharSet -> CharSet +charSetMinus s1 s2 x = s1 x && not (s2 x) + +charSetUnion :: CharSet -> CharSet -> CharSet +charSetUnion s1 s2 x = s1 x || s2 x + +charSetComplement :: CharSet -> CharSet +charSetComplement s1 = not . s1 + +charSetRange :: Char -> Char -> CharSet +charSetRange c1 c2 x = x >= c1 && x <= c2 + +charSetToArray :: CharSet -> Array Char Bool +charSetToArray set = array (fst (head ass), fst (last ass)) ass + where ass = [(c,set c) | c <- ['\0'..'\xff']] + +charSetElems :: CharSet -> [Char] +charSetElems set = [c | c <- ['\0'..'\xff'], set c] diff --git a/src/DFA.hs b/src/DFA.hs new file mode 100644 --- /dev/null +++ b/src/DFA.hs @@ -0,0 +1,245 @@ +-- ----------------------------------------------------------------------------- +-- +-- DFA.hs, part of Alex +-- +-- (c) Chris Dornan 1995-2000, Simon Marlow 2003 +-- +-- This module generates a DFA from a scanner by first converting it +-- to an NFA and then converting the NFA with the subset construction. +-- +-- See the chapter on `Finite Automata and Lexical Analysis' in the +-- dragon book for an excellent overview of the algorithms in this +-- module. +-- +-- ----------------------------------------------------------------------------} + +module DFA(scanner2dfa) where + +import AbsSyn +import qualified Map +import NFA +import Sort ( msort, nub' ) + +import Data.Array ( (!) ) +import Data.Maybe ( fromJust ) + +{- Defined in the Scan Module + +-- (This section should logically belong to the DFA module but it has been +-- placed here to make this module self-contained.) +-- +-- `DFA' provides an alternative to `Scanner' (described in the RExp module); +-- it can be used directly to scan text efficiently. Additionally it has an +-- extra place holder for holding action functions for generating +-- application-specific tokens. When this place holder is not being used, the +-- unit type will be used. +-- +-- Each state in the automaton consist of a list of `Accept' values, descending +-- in priority, and an array mapping characters to new states. As the array +-- may only cover a sub-range of the characters, a default state number is +-- given in the third field. By convention, all transitions to the -1 state +-- represent invalid transitions. +-- +-- A list of accept states is provided for as the original specification may +-- have been ambiguous, in which case the highest priority token should be +-- taken (the one appearing earliest in the specification); this can not be +-- calculated when the DFA is generated in all cases as some of the tokens may +-- be associated with leading or trailing context or start codes. +-- +-- `scan_token' (see above) can deal with unconditional accept states more +-- efficiently than those associated with context; to save it testing each time +-- whether the list of accept states contains an unconditional state, the flag +-- in the first field of `St' is set to true whenever the list contains an +-- unconditional state. +-- +-- The `Accept' structure contains the priority of the token being accepted +-- (lower numbers => higher priorities), the name of the token, a place holder +-- that can be used for storing the `action' function for constructing the +-- token from the input text and thge scanner's state, a list of start codes +-- (listing the start codes that the scanner must be in for the token to be +-- accepted; empty => no restriction), the leading and trailing context (both +-- `Nothing' if there is none). +-- +-- The leading context consists simply of a character predicate that will +-- return true if the last character read is acceptable. The trailing context +-- consists of an alternative starting state within the DFA; if this `sub-dfa' +-- turns up any accepting state when applied to the residual input then the +-- trailing context is acceptable (see `scan_token' above). + +type DFA a = Array SNum (State a) + +type SNum = Int + +data State a = St Bool [Accept a] SNum (Array Char SNum) + +data Accept a = Acc Int String a [StartCode] (MB(Char->Bool)) (MB SNum) + +type StartCode = Int +-} + + +-- Scanners are converted to DFAs by converting them to NFAs first. Converting +-- an NFA to a DFA works by identifying the states of the DFA with subsets of +-- the NFA. The PartDFA is used to construct the DFA; it is essentially a DFA +-- in which the states are represented directly by state sets of the NFA. +-- `nfa2pdfa' constructs the partial DFA from the NFA by searching for all the +-- transitions from a given list of state sets, initially containing the start +-- state of the partial DFA, until all possible state sets have been considered +-- The final DFA is then constructed with a `mk_dfa'. + +scanner2dfa:: Scanner -> [StartCode] -> DFA SNum Code +scanner2dfa scanner scs = nfa2dfa scs (scanner2nfa scanner scs) + +nfa2dfa:: [StartCode] -> NFA -> DFA SNum Code +nfa2dfa scs nfa = mk_int_dfa nfa (nfa2pdfa nfa pdfa (dfa_start_states pdfa)) + where + pdfa = new_pdfa n_starts nfa + n_starts = length scs -- number of start states + +-- `nfa2pdfa' works by taking the next outstanding state set to be considered +-- and and ignoring it if the state is already in the partial DFA, otherwise +-- generating all possible transitions from it, adding the new state to the +-- partial DFA and continuing the closure with the extra states. Note the way +-- it incorporates the trailing context references into the search (by +-- including `rctx_ss' in the search). + +nfa2pdfa:: NFA -> DFA StateSet Code -> [StateSet] -> DFA StateSet Code +nfa2pdfa nfa pdfa [] = pdfa +nfa2pdfa nfa pdfa (ss:umkd) + | ss `in_pdfa` pdfa = nfa2pdfa nfa pdfa umkd + | otherwise = nfa2pdfa nfa pdfa' umkd' + where + pdfa' = add_pdfa ss (State accs (Map.fromList ss_outs)) pdfa + + umkd' = rctx_sss ++ map snd ss_outs ++ umkd + + ss_outs = [ (ch, mk_ss nfa ss') + | ch <- dfa_alphabet, + let ss' = [ s' | (p,s') <- outs, p ch ], + not (null ss') + ] + + rctx_sss = [ mk_ss nfa [s] + | s <- ss, + Acc _ _ _ (RightContextRExp s) <- accs ] + + outs = [ out | s <- ss, out <- nst_outs (nfa!s) ] + accs = sort_accs [acc| s<-ss, acc<-nst_accs (nfa!s)] + +dfa_alphabet:: [Char] +dfa_alphabet = ['\0'..'\255'] + +-- `sort_accs' sorts a list of accept values into decending order of priority, +-- eliminating any elements that follow an unconditional accept value. + +sort_accs:: [Accept a] -> [Accept a] +sort_accs accs = foldr chk [] (msort le accs) + where + chk acc@(Acc _ _ Nothing NoRightContext) rst = [acc] + chk acc rst = acc:rst + + le (Acc{accPrio = n}) (Acc{accPrio=n'}) = n<=n' + + + +{------------------------------------------------------------------------------ + State Sets and Partial DFAs +------------------------------------------------------------------------------} + + + +-- A `PartDFA' is a partially constructed DFA in which the states are +-- represented by sets of states of the original NFA. It is represented by a +-- triple consisting of the start state of the partial DFA, the NFA from which +-- it is derived and a map from state sets to states of the partial DFA. The +-- state set for a given list of NFA states is calculated by taking the epsilon +-- closure of all the states, sorting the result with duplicates eliminated. + +type StateSet = [SNum] + +new_pdfa:: Int -> NFA -> DFA StateSet a +new_pdfa starts nfa + = DFA { dfa_start_states = start_ss, + dfa_states = Map.empty + } + where + start_ss = [ msort (<=) (nst_cl(nfa!n)) | n <- [0..starts]] + + -- starts is the number of start states + +-- constructs the epsilon-closure of a set of NFA states +mk_ss:: NFA -> [SNum] -> StateSet +mk_ss nfa l = nub' (<=) [s'| s<-l, s'<-nst_cl(nfa!s)] + +add_pdfa:: StateSet -> State StateSet a -> DFA StateSet a -> DFA StateSet a +add_pdfa ss pst (DFA st mp) = DFA st (Map.insert ss pst mp) + +in_pdfa:: StateSet -> DFA StateSet a -> Bool +in_pdfa ss (DFA _ mp) = ss `Map.member` mp + +-- Construct a DFA with numbered states, from a DFA whose states are +-- sets of states from the original NFA. + +mk_int_dfa:: NFA -> DFA StateSet a -> DFA SNum a +mk_int_dfa nfa pdfa@(DFA start_states mp) + = DFA [0 .. length start_states-1] + (Map.fromList [ (lookup st, cnv pds) | (st, pds) <- Map.toAscList mp ]) + where + mp' = Map.fromList (zip (start_states ++ + (map fst . Map.toAscList) (foldr Map.delete mp start_states)) [0..]) + + lookup = fromJust . flip Map.lookup mp' + + cnv :: State StateSet a -> State SNum a + cnv (State accs as) = State accs' as' + where + as' = Map.mapWithKey (\ch s -> lookup s) as + + accs' = map cnv_acc accs + cnv_acc (Acc p a lctx rctx) = Acc p a lctx rctx' + where rctx' = + case rctx of + RightContextRExp s -> + RightContextRExp (lookup (mk_ss nfa [s])) + other -> other + +{- + +-- `mk_st' constructs a state node from the list of accept values and a list of +-- transitions. The transitions list all the valid transitions out of the +-- node; all invalid transitions should be represented in the array by state +-- -1. `mk_st' has to work out whether the accept states contain an +-- unconditional entry, in which case the first field of `St' should be true, +-- and which default state to use in constructing the array (the array may span +-- a sub-range of the character set, the state number given the third argument +-- of `St' being taken as the default if an input character lies outside the +-- range). The default values is chosen to minimise the bounds of the array +-- and so there are two candidates: the value that 0 maps to (in which case +-- some initial segment of the array may be omitted) or the value that 255 maps +-- to (in which case a final segment of the array may be omitted), hence the +-- calculation of `(df,bds)'. +-- +-- Note that empty arrays are avoided as they can cause severe problems for +-- some popular Haskell compilers. + +mk_st:: [Accept Code] -> [(Char,Int)] -> State Code +mk_st accs as = + if null as + then St accs (-1) (listArray ('0','0') [-1]) + else St accs df (listArray bds [arr!c| c<-range bds]) + where + bds = if sz==0 then ('0','0') else bds0 + + (sz,df,bds0) | sz1 < sz2 = (sz1,df1,bds1) + | otherwise = (sz2,df2,bds2) + + (sz1,df1,bds1) = mk_bds(arr!chr 0) + (sz2,df2,bds2) = mk_bds(arr!chr 255) + + mk_bds df = (t-b, df, (chr b, chr (255-t))) + where + b = length (takeWhile id [arr!c==df| c<-['\0'..'\xff']]) + t = length (takeWhile id [arr!c==df| c<-['\xff','\xfe'..'\0']]) + + arr = listArray ('\0','\xff') (take 256 (repeat (-1))) // as +-} diff --git a/src/DFS.hs b/src/DFS.hs new file mode 100644 --- /dev/null +++ b/src/DFS.hs @@ -0,0 +1,136 @@ +{------------------------------------------------------------------------------ + DFS + +This module is a portable version of the ghc-specific `DFS.g.hs', which is +itself a straightforward encoding of the Launchbury/King paper on linear graph +algorithms. This module uses balanced binary trees instead of mutable arrays +to implement the depth-first search so the complexity of the algorithms is +n.log(n) instead of linear. + +The vertices of the graphs manipulated by these modules are labelled with the +integers from 0 to n-1 where n is the number of vertices in the graph. + +The module's principle products are `mk_graph' for constructing a graph from an +edge list, `t_close' for taking the transitive closure of a graph and `scc' +for generating a list of strongly connected components; the components are +listed in dependency order and each component takes the form of a `dfs tree' +(see Launchberry and King). Thus if each edge (fid,fid') encodes the fact that +function `fid' references function `fid'' in a program then `scc' performs a +dependency analysis. + +Chris Dornan, 23-Jun-94, 2-Jul-96, 29-Aug-96, 29-Sep-97 +------------------------------------------------------------------------------} + +module DFS where + +import Set ( Set ) +import qualified Set hiding ( Set ) + +import Data.Array ( (!), accumArray, listArray ) + +-- The result of a depth-first search of a graph is a list of trees, +-- `GForrest'. `post_order' provides a post-order traversal of a forrest. + +type GForrest = [GTree] +data GTree = GNode Int GForrest + +postorder:: GForrest -> [Int] +postorder ts = po ts [] + where + po ts l = foldr po_tree l ts + + po_tree (GNode a ts) l = po ts (a:l) + +list_tree:: GTree -> [Int] +list_tree t = l_t t [] + where + l_t (GNode x ts) l = foldr l_t (x:l) ts + + +-- Graphs are represented by a pair of an integer, giving the number of nodes +-- in the graph, and function mapping each vertex (0..n-1, n=size of graph) to +-- its neighbouring nodes. `mk_graph' takes a size and an edge list and +-- constructs a graph. + +type Graph = (Int,Int->[Int]) +type Edge = (Int,Int) + +mk_graph:: Int -> [Edge] -> Graph +mk_graph sz es = (sz,\v->ar!v) + where + ar = accumArray (flip (:)) [] (0,sz-1) [(v,v')| (v,v')<-es] + +vertices:: Graph -> [Int] +vertices (sz,_) = [0..sz-1] + +out:: Graph -> Int -> [Int] +out (_,f) = f + +edges:: Graph -> [Edge] +edges g = [(v,v')| v<-vertices g, v'<-out g v] + +rev_edges:: Graph -> [Edge] +rev_edges g = [(v',v)| v<-vertices g, v'<-out g v] + +reverse_graph:: Graph -> Graph +reverse_graph g@(sz,_) = mk_graph sz (rev_edges g) + + +-- `t_close' takes the transitive closure of a graph; `scc' returns the stronly +-- connected components of the graph and `top_sort' topologically sorts the +-- graph. Note that the array is given one more element in order to avoid +-- problems with empty arrays. + +t_close:: Graph -> Graph +t_close g@(sz,_) = (sz,\v->ar!v) + where + ar = listArray (0,sz) ([postorder(dff' [v] g)| v<-vertices g]++[und]) + und = error "t_close" + +scc:: Graph -> GForrest +scc g = dff' (reverse (top_sort (reverse_graph g))) g + +top_sort:: Graph -> [Int] +top_sort = postorder . dff + + +-- `dff' computes the depth-first forrest. It works by unrolling the +-- potentially infinite tree from each of the vertices with `generate_g' and +-- then pruning out the duplicates. + +dff:: Graph -> GForrest +dff g = dff' (vertices g) g + +dff':: [Int] -> Graph -> GForrest +dff' vs (bs,f) = prune (map (generate_g f) vs) + +generate_g:: (Int->[Int]) -> Int -> GTree +generate_g f v = GNode v (map (generate_g f) (f v)) + +prune:: GForrest -> GForrest +prune ts = snd(chop(empty_int,ts)) + where + empty_int:: Set Int + empty_int = Set.empty + +chop:: (Set Int,GForrest) -> (Set Int,GForrest) +chop p@(vstd,[]) = p +chop (vstd,GNode v ts:us) = + if v `Set.member` vstd + then chop (vstd,us) + else let vstd1 = Set.insert v vstd + (vstd2,ts') = chop (vstd1,ts) + (vstd3,us') = chop (vstd2,us) + in + (vstd3,GNode v ts' : us') + + +{-- Some simple test functions + +test:: Graph Char +test = mk_graph (char_bds ('a','h')) (mk_pairs "eefggfgegdhfhged") + where + mk_pairs [] = [] + mk_pairs (a:b:l) = (a,b):mk_pairs l + +-} diff --git a/src/Info.hs b/src/Info.hs new file mode 100644 --- /dev/null +++ b/src/Info.hs @@ -0,0 +1,64 @@ +-- ----------------------------------------------------------------------------- +-- +-- Info.hs, part of Alex +-- +-- (c) Simon Marlow 2003 +-- +-- Generate a human-readable rendition of the state machine. +-- +-- ----------------------------------------------------------------------------} + +module Info (infoDFA) where + +import AbsSyn +import qualified Map +import Util ( str, nl, interleave_shows, char, ljustify ) + +-- ----------------------------------------------------------------------------- +-- Generate a human readable dump of the state machine + +infoDFA :: Int -> String -> DFA SNum Code -> ShowS +infoDFA n func_nm dfa + = str "Scanner : " . str func_nm . nl + . str "States : " . shows (length dfa_list) . nl + . nl . infoDFA dfa + where + dfa_list = Map.toAscList (dfa_states dfa) + + infoDFA dfa = interleave_shows nl (map infoStateN dfa_list) + + infoStateN (i,s) = str "State " . shows i . nl . infoState s . nl + + infoState :: State SNum Code -> ShowS + infoState (State accs out) + = infoArr out . nl + -- . str ("\tDefault -> ") . shows df + + infoArr out + = char '\t' . interleave_shows (str "\n\t") + (map infoTransition (Map.toAscList out)) + + infoTransition (char,state) + = str (ljustify 8 (show char)) + . str " -> " + . shows state + +-- outputAccs :: [Accept Code] -> ShowS +-- outputAccs accs +-- = brack (interleave_shows (char ',') (map (paren.outputAcc) accs)) +-- +-- outputAcc (Acc prio act scs lctx rctx) +-- = str "Acc " . shows prio . space +-- . paren (str act) . space +-- . shows scs . space +-- . outputLCtx lctx . space +-- . shows rctx +-- +-- outputLCtx Nothing +-- = str "Nothing" +-- outputLCtx (Just set) +-- = str "Just " . paren (outputArr (charSetToArray set)) +-- +-- outputArr arr +-- = str "Array.array " . shows (bounds arr) . space +-- . shows (assocs arr) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,318 @@ +-- ----------------------------------------------------------------------------- +-- +-- Main.hs, part of Alex +-- +-- (c) Chris Dornan 1995-2000, Simon Marlow 2003 +-- +-- ----------------------------------------------------------------------------} + +module Main (main) where + +import AbsSyn +import CharSet +import DFA +import Info +import Map ( Map ) +import qualified Map hiding ( Map ) +import Output +import ParseMonad ( runP ) +import Parser +import Scan +import Util ( hline ) +import Paths_alex ( version, getDataDir ) + +import Control.Exception as Exception ( block, unblock, catch, throw ) +import Control.Monad ( when, liftM ) +import Data.Char ( chr ) +import Data.List ( isSuffixOf ) +import Data.Maybe ( isJust, fromJust ) +import Data.Version ( showVersion ) +import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(..), OptDescr(..), ArgDescr(..) ) +import System.Directory ( removeFile ) +import System.Environment ( getProgName, getArgs ) +import System.Exit ( ExitCode(..), exitWith ) +import System.IO ( stderr, Handle, IOMode(..), openFile, hClose, hPutStr, hPutStrLn ) + +-- `main' decodes the command line arguments and calls `alex'. + +main:: IO () +main = do + args <- getArgs + case getOpt Permute argInfo args of + (cli,_,[]) | DumpHelp `elem` cli -> do + prog <- getProgramName + bye (usageInfo (usageHeader prog) argInfo) + (cli,_,[]) | DumpVersion `elem` cli -> + bye copyright + (cli,[file],[]) -> + runAlex cli file + (_,_,errors) -> do + prog <- getProgramName + die (concat errors ++ usageInfo (usageHeader prog) argInfo) + +projectVersion :: String +projectVersion = showVersion version + +copyright :: String +copyright = "Alex version " ++ projectVersion ++ ", (c) 2003 Chris Dornan and Simon Marlow\n" + +usageHeader :: String -> String +usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file\n" + +runAlex :: [CLIFlags] -> FilePath -> IO () +runAlex cli file = do + basename <- case (reverse file) of + 'x':'.':r -> return (reverse r) + _ -> die (file ++ ": filename must end in \'.x\'\n") + + prg <- readFile file + script <- parseScript file prg + alex cli file basename script + +parseScript :: FilePath -> String + -> IO (Maybe (AlexPosn,Code), [Directive], Scanner, Maybe (AlexPosn,Code)) +parseScript file prg = + case runP prg initialParserEnv parse of + Left (Just (AlexPn _ line col),err) -> + die (file ++ ":" ++ show line ++ ":" ++ show col + ++ ": " ++ err ++ "\n") + Left (Nothing, err) -> + die (file ++ ": " ++ err ++ "\n") + + Right script -> return script + +alex :: [CLIFlags] -> FilePath -> FilePath + -> (Maybe (AlexPosn, Code), [Directive], Scanner, Maybe (AlexPosn, Code)) + -> IO () +alex cli file basename script = do + (put_info, finish_info) <- + case [ f | OptInfoFile f <- cli ] of + [] -> return (\_ -> return (), return ()) + [Nothing] -> infoStart file (basename ++ ".info") + [Just f] -> infoStart file f + _ -> dieAlex "multiple -i/--info options" + + o_file <- case [ f | OptOutputFile f <- cli ] of + [] -> return (basename ++ ".hs") + [f] -> return f + _ -> dieAlex "multiple -o/--outfile options" + + let target + | OptGhcTarget `elem` cli = GhcTarget + | otherwise = HaskellTarget + + template_dir <- templateDir getDataDir cli + let template_name = templateFile template_dir target cli + + -- open the output file; remove it if we encounter an error + bracketOnError + (openFile o_file WriteMode) + (\h -> do hClose h; removeFile o_file) + $ \out_h -> do + + let + (maybe_header, directives, scanner1, maybe_footer) = script + (scanner2, scs, sc_hdr) = encodeStartCodes scanner1 + (scanner_final, actions) = extractActions scanner2 + + wrapper_name <- wrapperFile template_dir directives + + hPutStr out_h (optsToInject target cli) + injectCode maybe_header file out_h + + hPutStr out_h (importsToInject target cli) + + let dfa = scanner2dfa scanner_final scs + nm = scannerName scanner_final + + put_info (infoDFA 1 nm dfa "") + hPutStr out_h (outputDFA target 1 nm dfa "") + + injectCode maybe_footer file out_h + + hPutStr out_h (sc_hdr "") + hPutStr out_h (actions "") + + -- add the template + tmplt <- readFile template_name + hPutStr out_h tmplt + + -- add the wrapper, if necessary + when (isJust wrapper_name) $ + do str <- readFile (fromJust wrapper_name) + hPutStr out_h str + + hClose out_h + finish_info + +-- inject some code, and add a {-# LINE #-} pragma at the top +injectCode :: Maybe (AlexPosn,Code) -> FilePath -> Handle -> IO () +injectCode Nothing _ _ = return () +injectCode (Just (AlexPn _ ln _,code)) filename hdl = do + hPutStrLn hdl ("{-# LINE " ++ show ln ++ " \"" ++ filename ++ "\" #-}") + hPutStrLn hdl code + +optsToInject :: Target -> [CLIFlags] -> String +optsToInject GhcTarget _ = "{-# OPTIONS -fglasgow-exts -cpp #-}\n" +optsToInject _ _ = "{-# OPTIONS -cpp #-}\n" + +importsToInject :: Target -> [CLIFlags] -> String +importsToInject _ cli = always_imports ++ debug_imports ++ glaexts_import + where + glaexts_import | OptGhcTarget `elem` cli = import_glaexts + | otherwise = "" + + debug_imports | OptDebugParser `elem` cli = import_debug + | otherwise = "" + +-- CPP is turned on for -fglasogw-exts, so we can use conditional +-- compilation. We need to #include "config.h" to get hold of +-- WORDS_BIGENDIAN (see GenericTemplate.hs). + +always_imports :: String +always_imports = "#if __GLASGOW_HASKELL__ >= 603\n" ++ + "#include \"ghcconfig.h\"\n" ++ + "#else\n" ++ + "#include \"config.h\"\n" ++ + "#endif\n" ++ + "#if __GLASGOW_HASKELL__ >= 503\n" ++ + "import Data.Array\n" ++ + "import Data.Char (ord)\n" ++ + "import Data.Array.Base (unsafeAt)\n" ++ + "#else\n" ++ + "import Array\n" ++ + "import Char (ord)\n" ++ + "#endif\n" + +import_glaexts :: String +import_glaexts = "#if __GLASGOW_HASKELL__ >= 503\n" ++ + "import GHC.Exts\n" ++ + "#else\n" ++ + "import GlaExts\n" ++ + "#endif\n" + +import_debug :: String +import_debug = "#if __GLASGOW_HASKELL__ >= 503\n" ++ + "import System.IO\n" ++ + "import System.IO.Unsafe\n" ++ + "import Debug.Trace\n" ++ + "#else\n" ++ + "import IO\n" ++ + "import IOExts\n" ++ + "#endif\n" + +templateDir :: IO FilePath -> [CLIFlags] -> IO FilePath +templateDir def cli + = case [ d | OptTemplateDir d <- cli ] of + [] -> def + ds -> return (last ds) + +templateFile :: FilePath -> Target -> [CLIFlags] -> FilePath +templateFile dir target cli + = dir ++ "/AlexTemplate" ++ maybe_ghc ++ maybe_debug + where + maybe_ghc = case target of + GhcTarget -> "-ghc" + _ -> "" + + maybe_debug + | OptDebugParser `elem` cli = "-debug" + | otherwise = "" + +wrapperFile :: FilePath -> [Directive] -> IO (Maybe FilePath) +wrapperFile dir directives = + case [ f | WrapperDirective f <- directives ] of + [] -> return Nothing + [f] -> return (Just (dir ++ "/AlexWrapper-" ++ f)) + _many -> dieAlex "multiple %wrapper directives" + +infoStart :: FilePath -> FilePath -> IO (String -> IO (), IO ()) +infoStart x_file info_file = do + bracketOnError + (openFile info_file WriteMode) + (\h -> do hClose h; removeFile info_file) + (\h -> do infoHeader h x_file + return (hPutStr h, hClose h) + ) + +infoHeader :: Handle -> FilePath -> IO () +infoHeader h file = do + hPutStrLn h ("Info file produced by Alex version " ++ projectVersion ++ + ", from " ++ file) + hPutStrLn h hline + hPutStr h "\n" + +initialParserEnv :: (Map String CharSet, Map String RExp) +initialParserEnv = (initSetEnv, initREEnv) + +initSetEnv :: Map String CharSet +initSetEnv = Map.fromList [("white", charSet " \t\n\v\f\r"), + ("printable", charSet [chr 32 .. chr 126]), + (".", charSetComplement emptyCharSet + `charSetMinus` charSetSingleton '\n')] + +initREEnv :: Map String RExp +initREEnv = Map.empty + +-- ----------------------------------------------------------------------------- +-- Command-line flags + +data CLIFlags + = OptDebugParser + | OptGhcTarget + | OptOutputFile FilePath + | OptInfoFile (Maybe FilePath) + | OptTemplateDir FilePath + | DumpHelp + | DumpVersion + deriving Eq + +argInfo :: [OptDescr CLIFlags] +argInfo = [ + Option ['o'] ["outfile"] (ReqArg OptOutputFile "FILE") + "write the output to FILE (default: file.hs)", + Option ['i'] ["info"] (OptArg OptInfoFile "FILE") + "put detailed state-machine info in FILE (or file.info)", + Option ['t'] ["template"] (ReqArg OptTemplateDir "DIR") + "look in DIR for template files", + Option ['g'] ["ghc"] (NoArg OptGhcTarget) + "use GHC extensions", + Option ['d'] ["debug"] (NoArg OptDebugParser) + "produce a debugging scanner", + Option ['?'] ["help"] (NoArg DumpHelp) + "display this help and exit", + Option ['V','v'] ["version"] (NoArg DumpVersion) -- ToDo: -v is deprecated! + "output version information and exit" + ] + +-- ----------------------------------------------------------------------------- +-- Utils + +getProgramName :: IO String +getProgramName = liftM (`withoutSuffix` ".bin") getProgName + where str `withoutSuffix` suff + | suff `isSuffixOf` str = take (length str - length suff) str + | otherwise = str + +bye :: String -> IO a +bye s = putStr s >> exitWith ExitSuccess + +die :: String -> IO a +die s = hPutStr stderr s >> exitWith (ExitFailure 1) + +dieAlex :: String -> IO a +dieAlex s = getProgramName >>= \prog -> die (prog ++ ": " ++ s) + +bracketOnError + :: IO a -- ^ computation to run first (\"acquire resource\") + -> (a -> IO b) -- ^ computation to run last (\"release resource\") + -> (a -> IO c) -- ^ computation to run in-between + -> IO c -- returns the value from the in-between computation +bracketOnError before after thing = + block (do + a <- before + r <- Exception.catch + (unblock (thing a)) + (\e -> do { after a; throw e }) + return r + ) diff --git a/src/Map.hs b/src/Map.hs new file mode 100644 --- /dev/null +++ b/src/Map.hs @@ -0,0 +1,67 @@ +module Map ( + Map, + member, lookup, findWithDefault, + empty, + insert, insertWith, + delete, + union, unionWith, unions, + mapWithKey, + elems, + fromList, fromListWith, + toAscList +) where + +import Prelude hiding ( lookup ) + +#if __GLASGOW_HASKELL__ >= 603 +import Data.Map +#else +import Data.FiniteMap + +type Map k a = FiniteMap k a + +member :: Ord k => k -> Map k a -> Bool +member = elemFM + +lookup :: Ord k => k -> Map k a -> Maybe a +lookup = flip lookupFM + +findWithDefault :: Ord k => a -> k -> Map k a -> a +findWithDefault a k m = lookupWithDefaultFM m a k + +empty :: Map k a +empty = emptyFM + +insert :: Ord k => k -> a -> Map k a -> Map k a +insert k a m = addToFM m k a + +insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a +insertWith c k a m = addToFM_C c m k a + +delete :: Ord k => k -> Map k a -> Map k a +delete = flip delFromFM + +union :: Ord k => Map k a -> Map k a -> Map k a +union = flip plusFM + +unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a +unionWith c l r = plusFM_C c r l + +unions :: Ord k => [Map k a] -> Map k a +unions = foldl (flip plusFM) emptyFM + +mapWithKey :: (k -> a -> b) -> Map k a -> Map k b +mapWithKey = mapFM + +elems :: Map k a -> [a] +elems = eltsFM + +fromList :: Ord k => [(k,a)] -> Map k a +fromList = listToFM + +fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a +fromListWith c = addListToFM_C (flip c) emptyFM + +toAscList :: Map k a -> [(k,a)] +toAscList = fmToList +#endif diff --git a/src/NFA.hs b/src/NFA.hs new file mode 100644 --- /dev/null +++ b/src/NFA.hs @@ -0,0 +1,223 @@ +-- ----------------------------------------------------------------------------- +-- +-- NFA.hs, part of Alex +-- +-- (c) Chris Dornan 1995-2000, Simon Marlow 2003 +-- +-- The `scanner2nfa' takes a `Scanner' (see the `RExp' module) and +-- generates its equivelent nondeterministic finite automaton. NFAs +-- are turned into DFAs in the DFA module. +-- +-- See the chapter on `Finite Automata and Lexical Analysis' in the +-- dragon book for an excellent overview of the algorithms in this +-- module. +-- +-- ----------------------------------------------------------------------------} + +module NFA where + +import AbsSyn +import CharSet ( CharSet, charSetToArray ) +import DFS ( t_close, out ) +import Map ( Map ) +import qualified Map hiding ( Map ) +import Util ( str, space ) + +import Control.Monad ( zipWithM, zipWithM_ ) +import Data.Array ( Array, (!), array, listArray, assocs, bounds ) +--import Debug.Trace + +-- Each state of a nondeterministic automaton contains a list of `Accept' +-- values, a list of epsilon transitions (an epsilon transition represents a +-- transition to another state that can be made without reading a character) +-- and a list of transitions qualified with a character predicate (the +-- transition can only be made to the given state on input of a character +-- permitted by the predicate). Although a list of `Accept' values is provided +-- for, in actual fact each state will have zero or one of them (the `Maybe' +-- type is not used because the flexibility offered by the list representation +-- is useful). + +type NFA = Array SNum NState + +data NState = NSt { + nst_accs :: [Accept Code], + nst_cl :: [SNum], + nst_outs :: [(CharSet,SNum)] + } + +-- Debug stuff +instance Show (Accept a) where + showsPrec _ (Acc p act lctx rctx) = shows p --TODO + +instance Show NState where + showsPrec _ (NSt accs cl outs) = + str "NSt " . shows accs . space . shows cl . space . + shows [ (charSetToArray c, s) | (c,s) <- outs ] + +{- From the Scan Module + +-- The `Accept' structure contains the priority of the token being accepted +-- (lower numbers => higher priorities), the name of the token, a place holder +-- that can be used for storing the `action' function, a list of start codes +-- (listing the start codes that the scanner must be in for the token to be +-- accepted; empty => no restriction), the leading and trailing context (both +-- `Nothing' if there is none). +-- +-- The leading context consists simply of a character predicate that will +-- return true if the last character read is acceptable. The trailing context +-- consists of an alternative starting state within the DFA; if this `sub-dfa' +-- turns up any accepting state when applied to the residual input then the +-- trailing context is acceptable. +-} + + +-- `scanner2nfa' takes a scanner (see the AbsSyn module) and converts it to an +-- NFA, using the NFA creation monad (see below). +-- +-- We generate a start state for each startcode, with the same number +-- as that startcode, and epsilon transitions from this state to each +-- of the sub-NFAs for each of the tokens acceptable in that startcode. + +scanner2nfa:: Scanner -> [StartCode] -> NFA +scanner2nfa Scanner{scannerTokens = toks} startcodes + = runNFA $ + do + -- make a start state for each start code (these will be + -- numbered from zero). + start_states <- sequence (replicate (length startcodes) newState) + + -- construct the NFA for each token + tok_states <- zipWithM do_token toks [0..] + + -- make an epsilon edge from each state state to each + -- token that is acceptable in that state + zipWithM_ (tok_transitions (zip toks tok_states)) + startcodes start_states + + where + do_token (RECtx scs lctx re rctx code) prio = do + b <- newState + e <- newState + rexp2nfa b e re + + rctx_e <- case rctx of + NoRightContext -> + return NoRightContext + RightContextCode code -> + return (RightContextCode code) + RightContextRExp re -> do + r_b <- newState + r_e <- newState + rexp2nfa r_b r_e re + accept r_e rctxt_accept + return (RightContextRExp r_b) + + + let lctx' = case lctx of + Nothing -> Nothing + Just st -> Just st + + accept e (Acc prio code lctx' rctx_e) + return b + + tok_transitions toks_with_states start_code start_state = do + let states = [ s | (RECtx scs _ _ _ _, s) <- toks_with_states, + null scs || start_code `elem` map snd scs ] + mapM_ (epsilonEdge start_state) states + +-- ----------------------------------------------------------------------------- +-- NFA creation from a regular expression + +-- rexp2nfa B E R generates an NFA that begins in state B, recognises +-- R, and ends in state E only if R has been recognised. + +rexp2nfa :: SNum -> SNum -> RExp -> NFAM () +rexp2nfa b e Eps = epsilonEdge b e +rexp2nfa b e (Ch p) = charEdge b p e +rexp2nfa b e (re1 :%% re2) = do + s <- newState + rexp2nfa b s re1 + rexp2nfa s e re2 +rexp2nfa b e (re1 :| re2) = do + rexp2nfa b e re1 + rexp2nfa b e re2 +rexp2nfa b e (Star re) = do + s <- newState + epsilonEdge b s + rexp2nfa s s re + epsilonEdge s e +rexp2nfa b e (Plus re) = do + s1 <- newState + s2 <- newState + rexp2nfa s1 s2 re + epsilonEdge b s1 + epsilonEdge s2 s1 + epsilonEdge s2 e +rexp2nfa b e (Ques re) = do + rexp2nfa b e re + epsilonEdge b e + +-- ----------------------------------------------------------------------------- +-- NFA creation monad. + +-- Partial credit to Thomas Hallgren for this code, as I adapted it from +-- his "Lexing Haskell in Haskell" lexer generator. + +type MapNFA = Map SNum NState + +newtype NFAM a = N {unN :: SNum -> MapNFA -> (SNum, MapNFA, a)} + +instance Monad NFAM where + return a = N $ \s n -> (s,n,a) + + m >>= k = N $ \s n -> case unN m s n of + (s,n,a) -> unN (k a) s n + +runNFA :: NFAM () -> NFA +runNFA m = case unN m 0 Map.empty of + (s, nfa_map, ()) -> -- trace (show (Map.toAscList nfa_map)) $ + e_close (array (0,s-1) (Map.toAscList nfa_map)) + +e_close:: Array Int NState -> NFA +e_close ar = listArray bds + [NSt accs (out gr v) outs|(v,NSt accs _ outs)<-assocs ar] + where + gr = t_close (hi+1,\v->nst_cl (ar!v)) + bds@(_,hi) = bounds ar + +newState :: NFAM SNum +newState = N $ \s n -> (s+1,n,s) + +charEdge :: SNum -> CharSet -> SNum -> NFAM () +charEdge from charset to = N $ \s n -> (s, addEdge n from charset to, ()) + where + addEdge n from charset to = + case Map.lookup from n of + Nothing -> + Map.insert from (NSt [] [] [(charset,to)]) n + Just (NSt acc eps trans) -> + Map.insert from (NSt acc eps ((charset,to):trans)) n + +epsilonEdge :: SNum -> SNum -> NFAM () +epsilonEdge from to + | from == to = return () + | otherwise = N $ \s n -> (s, addEdge n from to, ()) + where + addEdge n from to = + case Map.lookup from n of + Nothing -> Map.insert from (NSt [] [to] []) n + Just (NSt acc eps trans) -> Map.insert from (NSt acc (to:eps) trans) n + +accept :: SNum -> Accept Code -> NFAM () +accept state new_acc = N $ \s n -> (s, addAccept n state, ()) + where + addAccept n state = + case Map.lookup state n of + Nothing -> + Map.insert state (NSt [new_acc] [] []) n + Just (NSt acc eps trans) -> + Map.insert state (NSt (new_acc:acc) eps trans) n + + +rctxt_accept :: Accept Code +rctxt_accept = Acc 0 Nothing Nothing NoRightContext diff --git a/src/Output.hs b/src/Output.hs new file mode 100644 --- /dev/null +++ b/src/Output.hs @@ -0,0 +1,336 @@ +-- ----------------------------------------------------------------------------- +-- +-- Output.hs, part of Alex +-- +-- (c) Simon Marlow 2003 +-- +-- Code-outputing and table-generation routines +-- +-- ----------------------------------------------------------------------------} + +module Output (outputDFA) where + +import AbsSyn +import CharSet +import Util +import qualified Map + +import Control.Monad.ST ( ST, runST ) +import Data.Array ( Array ) +import Data.Array.Base ( unsafeRead ) +import Data.Array.ST ( STUArray, newArray, readArray, writeArray, freeze ) +import Data.Array.Unboxed ( UArray, bounds, assocs, elems, (!), array, listArray ) +import Data.Bits +import Data.Char ( ord, chr ) +-- import Debug.Trace +import Data.List ( maximumBy, sortBy, groupBy ) + +-- ----------------------------------------------------------------------------- +-- Printing the output + +outputDFA :: Target -> Int -> String -> DFA SNum Code -> ShowS +outputDFA target n func_nm dfa + = interleave_shows nl + [outputBase, outputTable, outputCheck, outputDefault, outputAccept] + where + (base, table, check, deflt, accept) = mkTables dfa + + table_size = length table - 1 + n_states = length base - 1 + + base_nm = "alex_base" + table_nm = "alex_table" + check_nm = "alex_check" + deflt_nm = "alex_deflt" + accept_nm = "alex_accept" + + outputBase = do_array hexChars32 base_nm n_states base + outputTable = do_array hexChars16 table_nm table_size table + outputCheck = do_array hexChars16 check_nm table_size check + outputDefault = do_array hexChars16 deflt_nm n_states deflt + + do_array hex_chars nm upper_bound ints = case target of + GhcTarget -> + str nm . str " :: AlexAddr\n" + . str nm . str " = AlexA# \"" + . str (hex_chars ints) + . str "\"#\n" + + _ -> + str nm . str " :: Array Int Int\n" + . str nm . str " = listArray (0," . shows upper_bound + . str ") [" . interleave_shows (char ',') (map shows ints) + . str "]\n" + + outputAccept + = -- No type signature: we don't know what the type of the actions is. + -- str accept_nm . str " :: Array Int (Accept Code)\n" + str accept_nm . str " = listArray (0::Int," . shows n_states + . str ") [" . interleave_shows (char ',') (map outputAccs accept) + . str "]\n" + + outputAccs :: [Accept Code] -> ShowS + outputAccs accs + = brack (interleave_shows (char ',') (map (paren.outputAcc) accs)) + + outputAcc (Acc prio Nothing Nothing NoRightContext) + = str "AlexAccSkip" + outputAcc (Acc prio (Just act) Nothing NoRightContext) + = str "AlexAcc " . paren (str act) + outputAcc (Acc prio Nothing lctx rctx) + = str "AlexAccSkipPred " . space + . paren (outputPred lctx rctx) + outputAcc (Acc prio (Just act) lctx rctx) + = str "AlexAccPred " . space + . paren (str act) . space + . paren (outputPred lctx rctx) + + outputPred (Just set) NoRightContext + = outputLCtx set + outputPred Nothing rctx + = outputRCtx rctx + outputPred (Just set) rctx + = outputLCtx set + . str " `alexAndPred` " + . outputRCtx rctx + + outputLCtx set + = case charSetElems set of + [] -> error "outputLCtx" + [c] -> str "alexPrevCharIs " . shows c + _other -> str "alexPrevCharIsOneOf " + . paren (outputArr (charSetToArray set)) + + outputRCtx NoRightContext = id + outputRCtx (RightContextRExp sn) + = str "alexRightContext " . shows sn + outputRCtx (RightContextCode code) + = str code + + outputArr arr + = str "array " . shows (bounds arr) . space + . shows (assocs arr) + +-- ----------------------------------------------------------------------------- +-- Generating arrays. + +-- Here we use the table-compression algorithm described in section +-- 3.9 of the dragon book, which is a common technique used by lexical +-- analyser generators. + +-- We want to generate: +-- +-- base :: Array SNum Int +-- maps the current state to an offset in the main table +-- +-- table :: Array Int SNum +-- maps (base!state + char) to the next state +-- +-- check :: Array Int SNum +-- maps (base!state + char) to state if table entry is valid, +-- otherwise we use the default for this state +-- +-- default :: Array SNum SNum +-- default production for this state +-- +-- accept :: Array SNum [Accept Code] +-- maps state to list of accept codes for this state +-- +-- For each state, we decide what will be the default symbol (pick the +-- most common). We now have a mapping Char -> SNum, with one special +-- state reserved as the default. + + +mkTables :: DFA SNum Code + -> ( + [Int], -- base + [Int], -- table + [Int], -- check + [Int], -- default + [[Accept Code]] -- accept + ) +mkTables dfa + = ( elems base_offs, + take max_off (elems table), + take max_off (elems check), + elems defaults, + accept + ) + where + accept = [ as | State as _ <- elems dfa_arr ] + + state_assocs = Map.toAscList (dfa_states dfa) + n_states = length state_assocs + top_state = n_states - 1 + + dfa_arr :: Array SNum (State SNum Code) + dfa_arr = array (0,top_state) state_assocs + + -- fill in all the error productions + expand_states = + [ expand (dfa_arr!state) | state <- [0..top_state] ] + + expand (State _ out) = + [(i, lookup out i) | i <- ['\0'..'\255']] + where lookup out i = case Map.lookup i out of + Nothing -> -1 + Just s -> s + + defaults :: UArray SNum SNum + defaults = listArray (0,top_state) (map best_default expand_states) + + -- find the most common destination state in a given state, and + -- make it the default. + best_default :: [(Char,SNum)] -> SNum + best_default prod_list + | null sorted = -1 + | otherwise = snd (head (maximumBy lengths eq)) + where sorted = sortBy compareSnds prod_list + compareSnds (_,a) (_,b) = compare a b + eq = groupBy (\(_,a) (_,b) -> a == b) sorted + lengths a b = length a `compare` length b + + -- remove all the default productions from the DFA + dfa_no_defaults = + [ (s, prods_without_defaults s out) + | (s, out) <- zip [0..] expand_states + ] + + prods_without_defaults s out + = [ (ord c, dest) | (c,dest) <- out, dest /= defaults!s ] + + (base_offs, table, check, max_off) + = runST (genTables n_states 255 dfa_no_defaults) + + +genTables + :: Int -- number of states + -> Int -- maximum token no. + -> [(SNum,[(Int,SNum)])] -- entries for the table + -> ST s (UArray Int Int, -- base + UArray Int Int, -- table + UArray Int Int, -- check + Int -- highest offset in table + ) + +genTables n_states max_token entries = do + + base <- newArray (0, n_states-1) 0 + table <- newArray (0, mAX_TABLE_SIZE) 0 + check <- newArray (0, mAX_TABLE_SIZE) (-1) + off_arr <- newArray (-max_token, mAX_TABLE_SIZE) 0 + + max_off <- genTables' base table check off_arr entries max_token + + base' <- freeze base + table' <- freeze table + check' <- freeze check + return (base', table',check',max_off+1) + + where mAX_TABLE_SIZE = n_states * (max_token + 1) + + +genTables' + :: STUArray s Int Int -- base + -> STUArray s Int Int -- table + -> STUArray s Int Int -- check + -> STUArray s Int Int -- offset array + -> [(SNum,[(Int,SNum)])] -- entries for the table + -> Int -- maximum token no. + -> ST s Int -- highest offset in table + +genTables' base table check off_arr entries max_token + = fit_all entries 0 1 + where + + fit_all [] max_off fst_zero = return max_off + fit_all (s:ss) max_off fst_zero = do + (off, new_max_off, new_fst_zero) <- fit s max_off fst_zero + writeArray off_arr off 1 + fit_all ss new_max_off new_fst_zero + + -- fit a vector into the table. Return the offset of the vector, + -- the maximum offset used in the table, and the offset of the first + -- entry in the table (used to speed up the lookups a bit). + fit (_,[]) max_off fst_zero = return (0,max_off,fst_zero) + + fit (state_no, state@((t,_):_)) max_off fst_zero = do + -- start at offset 1 in the table: all the empty states + -- (states with just a default reduction) are mapped to + -- offset zero. + off <- findFreeOffset (-t + fst_zero) check off_arr state + let new_max_off | furthest_right > max_off = furthest_right + | otherwise = max_off + furthest_right = off + max_token + + --trace ("fit: state " ++ show state_no ++ ", off " ++ show off ++ ", elems " ++ show state) $ do + + writeArray base state_no off + addState off table check state + new_fst_zero <- findFstFreeSlot check fst_zero + return (off, new_max_off, new_fst_zero) + + +-- Find a valid offset in the table for this state. +findFreeOffset off check off_arr state = do + -- offset 0 isn't allowed + if off == 0 then try_next else do + + -- don't use an offset we've used before + b <- readArray off_arr off + if b /= 0 then try_next else do + + -- check whether the actions for this state fit in the table + ok <- fits off state check + if ok then return off else try_next + where + try_next = findFreeOffset (off+1) check off_arr state + +-- This is an inner loop, so we use some strictness hacks, and avoid +-- array bounds checks (unsafeRead instead of readArray) to speed +-- things up a bit. +fits :: Int -> [(Int,Int)] -> STUArray s Int Int -> ST s Bool +fits off [] check = off `seq` check `seq` return True -- strictness hacks +fits off ((t,_):rest) check = do + i <- unsafeRead check (off+t) + if i /= -1 then return False + else fits off rest check + +addState off table check [] = return () +addState off table check ((t,val):state) = do + writeArray table (off+t) val + writeArray check (off+t) t + addState off table check state + +findFstFreeSlot :: STUArray s Int Int -> Int -> ST s Int +findFstFreeSlot table n = do + i <- readArray table n + if i == -1 then return n + else findFstFreeSlot table (n+1) + +----------------------------------------------------------------------------- +-- Convert an integer to a 16-bit number encoded in \xNN\xNN format suitable +-- for placing in a string (copied from Happy's ProduceCode.lhs) + +hexChars16 :: [Int] -> String +hexChars16 acts = concat (map conv16 acts) + where + conv16 i | i > 0x7fff || i < -0x8000 + = error ("Internal error: hexChars16: out of range: " ++ show i) + | otherwise + = hexChar16 i + +hexChars32 :: [Int] -> String +hexChars32 acts = concat (map conv32 acts) + where + conv32 i = hexChar16 (i .&. 0xffff) ++ + hexChar16 ((i `shiftR` 16) .&. 0xffff) + +hexChar16 :: Int -> String +hexChar16 i = toHex (i .&. 0xff) + ++ toHex ((i `shiftR` 8) .&. 0xff) -- force little-endian + +toHex i = ['\\','x', hexDig (i `div` 16), hexDig (i `mod` 16)] + +hexDig i | i <= 9 = chr (i + ord '0') + | otherwise = chr (i - 10 + ord 'a') diff --git a/src/ParseMonad.hs b/src/ParseMonad.hs new file mode 100644 --- /dev/null +++ b/src/ParseMonad.hs @@ -0,0 +1,127 @@ +-- ----------------------------------------------------------------------------- +-- +-- ParseMonad.hs, part of Alex +-- +-- (c) Simon Marlow 2003 +-- +-- ----------------------------------------------------------------------------} + +module ParseMonad ( + AlexInput, alexInputPrevChar, alexGetChar, + AlexPosn(..), alexStartPos, + + P, runP, StartCode, failP, lookupSMac, lookupRMac, newSMac, newRMac, + setStartCode, getStartCode, getInput, setInput, + ) where + +import AbsSyn hiding ( StartCode ) +import CharSet ( CharSet ) +import Map ( Map ) +import qualified Map hiding ( Map ) + +-- ----------------------------------------------------------------------------- +-- The input type + +type AlexInput = (AlexPosn, -- current position, + Char, -- previous char + String) -- current input string + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p,c,s) = c + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (p,c,[]) = Nothing +alexGetChar (p,_,(c:s)) = let p' = alexMove p c in p' `seq` + Just (c, (p', c, s)) + +-- ----------------------------------------------------------------------------- +-- Token positions + +-- `Posn' records the location of a token in the input text. It has three +-- fields: the address (number of chacaters preceding the token), line number +-- and column of a token within the file. `start_pos' gives the position of the +-- start of the file and `eof_pos' a standard encoding for the end of file. +-- `move_pos' calculates the new position after traversing a given character, +-- assuming the usual eight character tab stops. + +data AlexPosn = AlexPn !Int !Int !Int + deriving (Eq,Show) + +alexStartPos :: AlexPosn +alexStartPos = AlexPn 0 1 1 + +alexMove :: AlexPosn -> Char -> AlexPosn +alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+7) `div` 8)*8+1) +alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1) 1 +alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) + +-- ----------------------------------------------------------------------------- +-- Alex lexing/parsing monad + +type ParseError = (Maybe AlexPosn, String) +type StartCode = Int + +data PState = PState { + smac_env :: Map String CharSet, + rmac_env :: Map String RExp, + startcode :: Int, + input :: AlexInput + } + +newtype P a = P { unP :: PState -> Either ParseError (PState,a) } + +instance Monad P where + (P m) >>= k = P $ \env -> case m env of + Left err -> Left err + Right (env',ok) -> unP (k ok) env' + return a = P $ \env -> Right (env,a) + +runP :: String -> (Map String CharSet, Map String RExp) + -> P a -> Either ParseError a +runP str (senv,renv) (P p) + = case p initial_state of + Left err -> Left err + Right (_,a) -> Right a + where initial_state = + PState{ smac_env=senv, rmac_env=renv, + startcode = 0, input=(alexStartPos,'\n',str) } + +failP str = P $ \PState{ input = (p,_,_) } -> Left (Just p,str) + +-- Macros are expanded during parsing, to simplify the abstract +-- syntax. The parsing monad passes around two environments mapping +-- macro names to sets and regexps respectively. + +lookupSMac :: (AlexPosn,String) -> P CharSet +lookupSMac (posn,smac) + = P $ \s@PState{ smac_env = senv } -> + case Map.lookup smac senv of + Just ok -> Right (s,ok) + Nothing -> Left (Just posn, "unknown set macro: $" ++ smac) + +lookupRMac :: String -> P RExp +lookupRMac rmac + = P $ \s@PState{ rmac_env = renv } -> + case Map.lookup rmac renv of + Just ok -> Right (s,ok) + Nothing -> Left (Nothing, "unknown regex macro: %" ++ rmac) + +newSMac :: String -> CharSet -> P () +newSMac smac set + = P $ \s -> Right (s{smac_env = Map.insert smac set (smac_env s)}, ()) + +newRMac :: String -> RExp -> P () +newRMac rmac rexp + = P $ \s -> Right (s{rmac_env = Map.insert rmac rexp (rmac_env s)}, ()) + +setStartCode :: StartCode -> P () +setStartCode sc = P $ \s -> Right (s{ startcode = sc }, ()) + +getStartCode :: P StartCode +getStartCode = P $ \s -> Right (s, startcode s) + +getInput :: P AlexInput +getInput = P $ \s -> Right (s, input s) + +setInput :: AlexInput -> P () +setInput inp = P $ \s -> Right (s{ input = inp }, ()) diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -0,0 +1,1130 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +-- ----------------------------------------------------------------------------- +-- +-- Parser.y, part of Alex +-- +-- (c) Simon Marlow 2003 +-- +-- ----------------------------------------------------------------------------- + +module Parser ( parse, P ) where +import AbsSyn +import Scan +import CharSet +import ParseMonad hiding ( StartCode ) + +import Data.Char +--import Debug.Trace +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +#else +import Array +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif + +-- parser produced by Happy Version 1.16 + +newtype HappyAbsSyn = HappyAbsSyn (() -> ()) +happyIn4 :: ((Maybe (AlexPosn,Code), [Directive], Scanner, Maybe (AlexPosn,Code))) -> (HappyAbsSyn ) +happyIn4 x = unsafeCoerce# x +{-# INLINE happyIn4 #-} +happyOut4 :: (HappyAbsSyn ) -> ((Maybe (AlexPosn,Code), [Directive], Scanner, Maybe (AlexPosn,Code))) +happyOut4 x = unsafeCoerce# x +{-# INLINE happyOut4 #-} +happyIn5 :: (Maybe (AlexPosn,Code)) -> (HappyAbsSyn ) +happyIn5 x = unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> (Maybe (AlexPosn,Code)) +happyOut5 x = unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: ([Directive]) -> (HappyAbsSyn ) +happyIn6 x = unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> ([Directive]) +happyOut6 x = unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: (Directive) -> (HappyAbsSyn ) +happyIn7 x = unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> (Directive) +happyOut7 x = unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: (()) -> (HappyAbsSyn ) +happyIn8 x = unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> (()) +happyOut8 x = unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: (()) -> (HappyAbsSyn ) +happyIn9 x = unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> (()) +happyOut9 x = unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: (Scanner) -> (HappyAbsSyn ) +happyIn10 x = unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> (Scanner) +happyOut10 x = unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: ([RECtx]) -> (HappyAbsSyn ) +happyIn11 x = unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> ([RECtx]) +happyOut11 x = unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: ([RECtx]) -> (HappyAbsSyn ) +happyIn12 x = unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> ([RECtx]) +happyOut12 x = unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyIn13 :: (RECtx) -> (HappyAbsSyn ) +happyIn13 x = unsafeCoerce# x +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn ) -> (RECtx) +happyOut13 x = unsafeCoerce# x +{-# INLINE happyOut13 #-} +happyIn14 :: ([RECtx]) -> (HappyAbsSyn ) +happyIn14 x = unsafeCoerce# x +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn ) -> ([RECtx]) +happyOut14 x = unsafeCoerce# x +{-# INLINE happyOut14 #-} +happyIn15 :: ([(String,StartCode)]) -> (HappyAbsSyn ) +happyIn15 x = unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> ([(String,StartCode)]) +happyOut15 x = unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyIn16 :: ([(String,StartCode)]) -> (HappyAbsSyn ) +happyIn16 x = unsafeCoerce# x +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> ([(String,StartCode)]) +happyOut16 x = unsafeCoerce# x +{-# INLINE happyOut16 #-} +happyIn17 :: (String) -> (HappyAbsSyn ) +happyIn17 x = unsafeCoerce# x +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> (String) +happyOut17 x = unsafeCoerce# x +{-# INLINE happyOut17 #-} +happyIn18 :: (Maybe Code) -> (HappyAbsSyn ) +happyIn18 x = unsafeCoerce# x +{-# INLINE happyIn18 #-} +happyOut18 :: (HappyAbsSyn ) -> (Maybe Code) +happyOut18 x = unsafeCoerce# x +{-# INLINE happyOut18 #-} +happyIn19 :: (Maybe CharSet, RExp, RightContext RExp) -> (HappyAbsSyn ) +happyIn19 x = unsafeCoerce# x +{-# INLINE happyIn19 #-} +happyOut19 :: (HappyAbsSyn ) -> (Maybe CharSet, RExp, RightContext RExp) +happyOut19 x = unsafeCoerce# x +{-# INLINE happyOut19 #-} +happyIn20 :: (CharSet) -> (HappyAbsSyn ) +happyIn20 x = unsafeCoerce# x +{-# INLINE happyIn20 #-} +happyOut20 :: (HappyAbsSyn ) -> (CharSet) +happyOut20 x = unsafeCoerce# x +{-# INLINE happyOut20 #-} +happyIn21 :: (RightContext RExp) -> (HappyAbsSyn ) +happyIn21 x = unsafeCoerce# x +{-# INLINE happyIn21 #-} +happyOut21 :: (HappyAbsSyn ) -> (RightContext RExp) +happyOut21 x = unsafeCoerce# x +{-# INLINE happyOut21 #-} +happyIn22 :: (RExp) -> (HappyAbsSyn ) +happyIn22 x = unsafeCoerce# x +{-# INLINE happyIn22 #-} +happyOut22 :: (HappyAbsSyn ) -> (RExp) +happyOut22 x = unsafeCoerce# x +{-# INLINE happyOut22 #-} +happyIn23 :: (RExp) -> (HappyAbsSyn ) +happyIn23 x = unsafeCoerce# x +{-# INLINE happyIn23 #-} +happyOut23 :: (HappyAbsSyn ) -> (RExp) +happyOut23 x = unsafeCoerce# x +{-# INLINE happyOut23 #-} +happyIn24 :: (RExp) -> (HappyAbsSyn ) +happyIn24 x = unsafeCoerce# x +{-# INLINE happyIn24 #-} +happyOut24 :: (HappyAbsSyn ) -> (RExp) +happyOut24 x = unsafeCoerce# x +{-# INLINE happyOut24 #-} +happyIn25 :: (RExp -> RExp) -> (HappyAbsSyn ) +happyIn25 x = unsafeCoerce# x +{-# INLINE happyIn25 #-} +happyOut25 :: (HappyAbsSyn ) -> (RExp -> RExp) +happyOut25 x = unsafeCoerce# x +{-# INLINE happyOut25 #-} +happyIn26 :: (RExp) -> (HappyAbsSyn ) +happyIn26 x = unsafeCoerce# x +{-# INLINE happyIn26 #-} +happyOut26 :: (HappyAbsSyn ) -> (RExp) +happyOut26 x = unsafeCoerce# x +{-# INLINE happyOut26 #-} +happyIn27 :: (CharSet) -> (HappyAbsSyn ) +happyIn27 x = unsafeCoerce# x +{-# INLINE happyIn27 #-} +happyOut27 :: (HappyAbsSyn ) -> (CharSet) +happyOut27 x = unsafeCoerce# x +{-# INLINE happyOut27 #-} +happyIn28 :: (CharSet) -> (HappyAbsSyn ) +happyIn28 x = unsafeCoerce# x +{-# INLINE happyIn28 #-} +happyOut28 :: (HappyAbsSyn ) -> (CharSet) +happyOut28 x = unsafeCoerce# x +{-# INLINE happyOut28 #-} +happyIn29 :: ([CharSet]) -> (HappyAbsSyn ) +happyIn29 x = unsafeCoerce# x +{-# INLINE happyIn29 #-} +happyOut29 :: (HappyAbsSyn ) -> ([CharSet]) +happyOut29 x = unsafeCoerce# x +{-# INLINE happyOut29 #-} +happyIn30 :: ((AlexPosn,String)) -> (HappyAbsSyn ) +happyIn30 x = unsafeCoerce# x +{-# INLINE happyIn30 #-} +happyOut30 :: (HappyAbsSyn ) -> ((AlexPosn,String)) +happyOut30 x = unsafeCoerce# x +{-# INLINE happyOut30 #-} +happyInTok :: Token -> (HappyAbsSyn ) +happyInTok x = unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> Token +happyOutTok x = unsafeCoerce# x +{-# INLINE happyOutTok #-} + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x72\x00\x72\x00\x66\x00\x00\x00\x52\x00\x51\x00\x60\x00\x67\x00\x00\x00\x00\x00\x63\x00\x51\x00\x7b\x00\x6d\x00\x00\x00\x5b\x00\x00\x00\x1a\x01\x6a\x00\x00\x00\x00\x00\x00\x00\x49\x00\x7b\x00\x80\x00\x00\x00\x64\x00\x00\x00\x00\x00\x62\x00\x00\x00\x4d\x00\x13\x00\x00\x00\x13\x00\x00\x00\x01\x00\xff\xff\x6d\x00\x02\x00\x10\x00\x1b\x00\x00\x00\x00\x00\x7b\x00\x48\x00\x73\x00\x59\x00\x7b\x00\x00\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x6d\x00\x00\x00\x15\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x25\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\xf7\xff\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x69\x00\x39\x00\x5c\x00\x00\x00\x00\x00\x4b\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x30\x00\x3a\x00\x11\x00\xfe\x00\x00\x00\x03\x01\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x00\x2b\x00\x07\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\xaa\x00\x00\x00\x96\x00\x00\x00\xda\x00\xf6\xff\xec\x00\x22\x00\x00\x00\x20\x00\x00\x00\x00\x00\x23\x00\x00\x00\xc2\x00\x00\x00\xb0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\xff\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xfc\xff\x00\x00\xfa\xff\xfd\xff\x00\x00\xf7\xff\xfa\xff\x00\x00\xf9\xff\xfb\xff\x00\x00\xf7\xff\x00\x00\x00\x00\xf5\xff\xdb\xff\xd9\xff\xd7\xff\xcd\xff\xca\xff\xc7\xff\xc1\xff\x00\x00\x00\x00\xc2\xff\xcf\xff\xc9\xff\xc0\xff\xce\xff\xf6\xff\xf8\xff\xfc\xff\xf2\xff\xf4\xff\xf2\xff\xef\xff\x00\x00\x00\x00\x00\x00\xdd\xff\xcd\xff\x00\x00\xe2\xff\xfe\xff\x00\x00\x00\x00\xc2\xff\x00\x00\xc2\xff\xc4\xff\x00\x00\xd0\xff\xd8\xff\xd6\xff\xd5\xff\xd4\xff\x00\x00\xda\xff\x00\x00\xdc\xff\x00\x00\xcc\xff\x00\x00\xc6\xff\xc3\xff\xc8\xff\xcb\xff\x00\x00\xe9\xff\xe8\xff\xe7\xff\xe1\xff\xe3\xff\xe0\xff\x00\x00\xdd\xff\xee\xff\xe5\xff\xe6\xff\xf1\xff\xec\xff\xf3\xff\xec\xff\x00\x00\xe4\xff\xdf\xff\xde\xff\x00\x00\xeb\xff\xc5\xff\x00\x00\xd3\xff\xd2\xff\x00\x00\xea\xff\xf0\xff\xed\xff\xd1\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x02\x00\x01\x00\x0c\x00\x0e\x00\x12\x00\x13\x00\x14\x00\x06\x00\x16\x00\x17\x00\x18\x00\x0b\x00\x1a\x00\x0d\x00\x0c\x00\x0d\x00\x10\x00\x1b\x00\x12\x00\x01\x00\x14\x00\x03\x00\x15\x00\x17\x00\x1a\x00\x05\x00\x11\x00\x1b\x00\x1c\x00\x1d\x00\x0f\x00\x0d\x00\x0c\x00\x01\x00\x10\x00\x14\x00\x12\x00\x01\x00\x14\x00\x17\x00\x18\x00\x17\x00\x1a\x00\x0c\x00\x0d\x00\x1b\x00\x1c\x00\x1d\x00\x16\x00\x0d\x00\x11\x00\x19\x00\x10\x00\x06\x00\x12\x00\x01\x00\x14\x00\x01\x00\x18\x00\x17\x00\x1a\x00\x04\x00\x05\x00\x1b\x00\x1c\x00\x1d\x00\x18\x00\x0d\x00\x1a\x00\x15\x00\x10\x00\x0c\x00\x12\x00\x01\x00\x0c\x00\x02\x00\x03\x00\x17\x00\x04\x00\x05\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x05\x00\x0d\x00\x0e\x00\x04\x00\x10\x00\x13\x00\x12\x00\x01\x00\x1b\x00\x02\x00\x03\x00\x17\x00\x0e\x00\x07\x00\x1b\x00\x1b\x00\x1c\x00\x1d\x00\x1a\x00\x0d\x00\x00\x00\x01\x00\x10\x00\x13\x00\x12\x00\x01\x00\x1e\x00\x1f\x00\x0f\x00\x17\x00\x21\x00\x01\x00\x11\x00\x1b\x00\x1c\x00\x1d\x00\x0f\x00\x0d\x00\x18\x00\x01\x00\x10\x00\x17\x00\x12\x00\x20\x00\x01\x00\x0f\x00\x10\x00\x17\x00\x12\x00\x20\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x10\x00\x1a\x00\x12\x00\x1b\x00\x1c\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\xff\xff\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x07\x00\x08\x00\x09\x00\xff\xff\x0b\x00\xff\xff\xff\xff\xff\xff\x0f\x00\x10\x00\xff\xff\x12\x00\x13\x00\x14\x00\xff\xff\x16\x00\x17\x00\x18\x00\xff\xff\x1a\x00\x07\x00\x08\x00\x09\x00\xff\xff\x0b\x00\xff\xff\xff\xff\xff\xff\x0f\x00\x10\x00\xff\xff\x12\x00\x13\x00\x14\x00\xff\xff\x16\x00\x17\x00\x18\x00\xff\xff\x1a\x00\x09\x00\x0a\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x0f\x00\x10\x00\xff\xff\x12\x00\x13\x00\x14\x00\xff\xff\x16\x00\x17\x00\x18\x00\xff\xff\x1a\x00\x09\x00\x0a\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x0f\x00\x10\x00\xff\xff\x12\x00\x13\x00\x14\x00\x09\x00\x16\x00\x17\x00\x18\x00\xff\xff\x1a\x00\x0f\x00\x10\x00\xff\xff\x12\x00\x13\x00\x14\x00\xff\xff\x16\x00\x17\x00\x18\x00\xff\xff\x1a\x00\x12\x00\x13\x00\x14\x00\xff\xff\x16\x00\x17\x00\x18\x00\xff\xff\x1a\x00\x12\x00\x13\x00\x14\x00\xff\xff\x16\x00\x17\x00\x18\x00\xff\xff\x1a\x00\x12\x00\x13\x00\x14\x00\xff\xff\x16\x00\x17\x00\x18\x00\xff\xff\x1a\x00\x12\x00\x13\x00\x14\x00\xff\xff\x16\x00\x17\x00\x18\x00\x14\x00\x1a\x00\x16\x00\x17\x00\x18\x00\xff\xff\x1a\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x4e\x00\x16\x00\x5d\x00\x4c\x00\x55\x00\x0f\x00\x10\x00\x4a\x00\x11\x00\x12\x00\x13\x00\x51\x00\x14\x00\x17\x00\x5e\x00\x44\x00\x18\x00\x5e\x00\x19\x00\x16\x00\x2b\x00\x2a\x00\x4b\x00\x1a\x00\x4f\x00\x5b\x00\x54\x00\x1b\x00\x1c\x00\x1d\x00\x2d\x00\x17\x00\x5c\x00\x2b\x00\x18\x00\x48\x00\x19\x00\x16\x00\x2b\x00\x1d\x00\x13\x00\x1a\x00\x14\x00\x43\x00\x44\x00\x1b\x00\x1c\x00\x1d\x00\x46\x00\x17\x00\x48\x00\x47\x00\x18\x00\x1f\x00\x19\x00\x16\x00\x2b\x00\x02\x00\x42\x00\x1a\x00\x14\x00\x1e\x00\x0b\x00\x1b\x00\x1c\x00\x1d\x00\x31\x00\x17\x00\x14\x00\x34\x00\x18\x00\x62\x00\x19\x00\x16\x00\x60\x00\x09\x00\x06\x00\x1a\x00\x0a\x00\x0b\x00\x57\x00\x1b\x00\x1c\x00\x1d\x00\x58\x00\x17\x00\x34\x00\x59\x00\x18\x00\x5a\x00\x19\x00\x16\x00\x3d\x00\x05\x00\x06\x00\x1a\x00\x3e\x00\x3b\x00\x42\x00\x1b\x00\x1c\x00\x1d\x00\x04\x00\x17\x00\x04\x00\x02\x00\x18\x00\x40\x00\x19\x00\x16\x00\x0d\x00\x0e\x00\x2d\x00\x1a\x00\xff\xff\x16\x00\x2e\x00\x1b\x00\x1c\x00\x1d\x00\x2d\x00\x17\x00\x21\x00\x16\x00\x18\x00\x09\x00\x19\x00\x08\x00\x16\x00\x2d\x00\x18\x00\x1a\x00\x19\x00\x08\x00\x00\x00\x1b\x00\x1c\x00\x1d\x00\x18\x00\x04\x00\x19\x00\x1b\x00\x1c\x00\x18\x00\x00\x00\x19\x00\x00\x00\x31\x00\x00\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x1c\x00\x51\x00\x22\x00\x23\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x00\x00\x27\x00\x0f\x00\x10\x00\x00\x00\x11\x00\x28\x00\x13\x00\x00\x00\x14\x00\x21\x00\x22\x00\x23\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x00\x00\x27\x00\x0f\x00\x10\x00\x00\x00\x11\x00\x28\x00\x13\x00\x00\x00\x14\x00\x52\x00\x60\x00\x2e\x00\x13\x00\x3e\x00\x14\x00\x25\x00\x26\x00\x00\x00\x27\x00\x0f\x00\x10\x00\x00\x00\x11\x00\x28\x00\x13\x00\x00\x00\x14\x00\x52\x00\x53\x00\x2e\x00\x13\x00\x40\x00\x14\x00\x25\x00\x26\x00\x00\x00\x27\x00\x0f\x00\x10\x00\x4f\x00\x11\x00\x28\x00\x13\x00\x00\x00\x14\x00\x25\x00\x26\x00\x00\x00\x27\x00\x0f\x00\x10\x00\x00\x00\x11\x00\x28\x00\x13\x00\x00\x00\x14\x00\x3b\x00\x0f\x00\x10\x00\x00\x00\x11\x00\x12\x00\x13\x00\x00\x00\x14\x00\x4b\x00\x0f\x00\x10\x00\x00\x00\x11\x00\x12\x00\x13\x00\x00\x00\x14\x00\x32\x00\x0f\x00\x10\x00\x00\x00\x11\x00\x12\x00\x13\x00\x00\x00\x14\x00\x0e\x00\x0f\x00\x10\x00\x00\x00\x11\x00\x12\x00\x13\x00\x39\x00\x14\x00\x11\x00\x12\x00\x13\x00\x00\x00\x14\x00\x2e\x00\x13\x00\x2f\x00\x14\x00\x36\x00\x37\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = array (1, 63) [ + (1 , happyReduce_1), + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35), + (36 , happyReduce_36), + (37 , happyReduce_37), + (38 , happyReduce_38), + (39 , happyReduce_39), + (40 , happyReduce_40), + (41 , happyReduce_41), + (42 , happyReduce_42), + (43 , happyReduce_43), + (44 , happyReduce_44), + (45 , happyReduce_45), + (46 , happyReduce_46), + (47 , happyReduce_47), + (48 , happyReduce_48), + (49 , happyReduce_49), + (50 , happyReduce_50), + (51 , happyReduce_51), + (52 , happyReduce_52), + (53 , happyReduce_53), + (54 , happyReduce_54), + (55 , happyReduce_55), + (56 , happyReduce_56), + (57 , happyReduce_57), + (58 , happyReduce_58), + (59 , happyReduce_59), + (60 , happyReduce_60), + (61 , happyReduce_61), + (62 , happyReduce_62), + (63 , happyReduce_63) + ] + +happy_n_terms = 34 :: Int +happy_n_nonterms = 27 :: Int + +happyReduce_1 = happyReduce 5# 0# happyReduction_1 +happyReduction_1 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_1 of { happy_var_1 -> + case happyOut6 happy_x_2 of { happy_var_2 -> + case happyOut10 happy_x_4 of { happy_var_4 -> + case happyOut5 happy_x_5 of { happy_var_5 -> + happyIn4 + ((happy_var_1,happy_var_2,happy_var_4,happy_var_5) + ) `HappyStk` happyRest}}}} + +happyReduce_2 = happySpecReduce_1 1# happyReduction_2 +happyReduction_2 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn5 + (case happy_var_1 of T pos (CodeT code) -> + Just (pos,code) + )} + +happyReduce_3 = happySpecReduce_0 1# happyReduction_3 +happyReduction_3 = happyIn5 + (Nothing + ) + +happyReduce_4 = happySpecReduce_2 2# happyReduction_4 +happyReduction_4 happy_x_2 + happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn6 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_5 = happySpecReduce_0 2# happyReduction_5 +happyReduction_5 = happyIn6 + ([] + ) + +happyReduce_6 = happySpecReduce_2 3# happyReduction_6 +happyReduction_6 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (T _ (StringT happy_var_2)) -> + happyIn7 + (WrapperDirective happy_var_2 + )} + +happyReduce_7 = happySpecReduce_2 4# happyReduction_7 +happyReduction_7 happy_x_2 + happy_x_1 + = happyIn8 + (() + ) + +happyReduce_8 = happySpecReduce_0 4# happyReduction_8 +happyReduction_8 = happyIn8 + (() + ) + +happyReduce_9 = happyMonadReduce 2# 5# happyReduction_9 +happyReduction_9 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (T _ (SMacDefT happy_var_1)) -> + case happyOut27 happy_x_2 of { happy_var_2 -> + ( newSMac happy_var_1 happy_var_2)}} + ) (\r -> happyReturn (happyIn9 r)) + +happyReduce_10 = happyMonadReduce 2# 5# happyReduction_10 +happyReduction_10 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (T _ (RMacDefT happy_var_1)) -> + case happyOut22 happy_x_2 of { happy_var_2 -> + ( newRMac happy_var_1 happy_var_2)}} + ) (\r -> happyReturn (happyIn9 r)) + +happyReduce_11 = happySpecReduce_2 6# happyReduction_11 +happyReduction_11 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (T _ (BindT happy_var_1)) -> + case happyOut11 happy_x_2 of { happy_var_2 -> + happyIn10 + (Scanner happy_var_1 happy_var_2 + )}} + +happyReduce_12 = happySpecReduce_2 7# happyReduction_12 +happyReduction_12 happy_x_2 + happy_x_1 + = case happyOut12 happy_x_1 of { happy_var_1 -> + case happyOut11 happy_x_2 of { happy_var_2 -> + happyIn11 + (happy_var_1 ++ happy_var_2 + )}} + +happyReduce_13 = happySpecReduce_0 7# happyReduction_13 +happyReduction_13 = happyIn11 + ([] + ) + +happyReduce_14 = happySpecReduce_2 8# happyReduction_14 +happyReduction_14 happy_x_2 + happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + case happyOut13 happy_x_2 of { happy_var_2 -> + happyIn12 + ([ replaceCodes happy_var_1 happy_var_2 ] + )}} + +happyReduce_15 = happyReduce 4# 8# happyReduction_15 +happyReduction_15 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut15 happy_x_1 of { happy_var_1 -> + case happyOut14 happy_x_3 of { happy_var_3 -> + happyIn12 + (map (replaceCodes happy_var_1) happy_var_3 + ) `HappyStk` happyRest}} + +happyReduce_16 = happySpecReduce_1 8# happyReduction_16 +happyReduction_16 happy_x_1 + = case happyOut13 happy_x_1 of { happy_var_1 -> + happyIn12 + ([ happy_var_1 ] + )} + +happyReduce_17 = happySpecReduce_2 9# happyReduction_17 +happyReduction_17 happy_x_2 + happy_x_1 + = case happyOut19 happy_x_1 of { happy_var_1 -> + case happyOut18 happy_x_2 of { happy_var_2 -> + happyIn13 + (let (l,e,r) = happy_var_1 in + RECtx [] l e r happy_var_2 + )}} + +happyReduce_18 = happySpecReduce_2 10# happyReduction_18 +happyReduction_18 happy_x_2 + happy_x_1 + = case happyOut13 happy_x_1 of { happy_var_1 -> + case happyOut14 happy_x_2 of { happy_var_2 -> + happyIn14 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_19 = happySpecReduce_0 10# happyReduction_19 +happyReduction_19 = happyIn14 + ([] + ) + +happyReduce_20 = happySpecReduce_3 11# happyReduction_20 +happyReduction_20 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut16 happy_x_2 of { happy_var_2 -> + happyIn15 + (happy_var_2 + )} + +happyReduce_21 = happySpecReduce_3 12# happyReduction_21 +happyReduction_21 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut17 happy_x_1 of { happy_var_1 -> + case happyOut16 happy_x_3 of { happy_var_3 -> + happyIn16 + ((happy_var_1,0) : happy_var_3 + )}} + +happyReduce_22 = happySpecReduce_1 12# happyReduction_22 +happyReduction_22 happy_x_1 + = case happyOut17 happy_x_1 of { happy_var_1 -> + happyIn16 + ([(happy_var_1,0)] + )} + +happyReduce_23 = happySpecReduce_1 13# happyReduction_23 +happyReduction_23 happy_x_1 + = happyIn17 + ("0" + ) + +happyReduce_24 = happySpecReduce_1 13# happyReduction_24 +happyReduction_24 happy_x_1 + = case happyOutTok happy_x_1 of { (T _ (IdT happy_var_1)) -> + happyIn17 + (happy_var_1 + )} + +happyReduce_25 = happySpecReduce_1 14# happyReduction_25 +happyReduction_25 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn18 + (case happy_var_1 of T _ (CodeT code) -> Just code + )} + +happyReduce_26 = happySpecReduce_1 14# happyReduction_26 +happyReduction_26 happy_x_1 + = happyIn18 + (Nothing + ) + +happyReduce_27 = happySpecReduce_3 15# happyReduction_27 +happyReduction_27 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut20 happy_x_1 of { happy_var_1 -> + case happyOut22 happy_x_2 of { happy_var_2 -> + case happyOut21 happy_x_3 of { happy_var_3 -> + happyIn19 + ((Just happy_var_1,happy_var_2,happy_var_3) + )}}} + +happyReduce_28 = happySpecReduce_2 15# happyReduction_28 +happyReduction_28 happy_x_2 + happy_x_1 + = case happyOut22 happy_x_1 of { happy_var_1 -> + case happyOut21 happy_x_2 of { happy_var_2 -> + happyIn19 + ((Nothing,happy_var_1,happy_var_2) + )}} + +happyReduce_29 = happySpecReduce_1 16# happyReduction_29 +happyReduction_29 happy_x_1 + = happyIn20 + (charSetSingleton '\n' + ) + +happyReduce_30 = happySpecReduce_2 16# happyReduction_30 +happyReduction_30 happy_x_2 + happy_x_1 + = case happyOut27 happy_x_1 of { happy_var_1 -> + happyIn20 + (happy_var_1 + )} + +happyReduce_31 = happySpecReduce_1 17# happyReduction_31 +happyReduction_31 happy_x_1 + = happyIn21 + (RightContextRExp (Ch (charSetSingleton '\n')) + ) + +happyReduce_32 = happySpecReduce_2 17# happyReduction_32 +happyReduction_32 happy_x_2 + happy_x_1 + = case happyOut22 happy_x_2 of { happy_var_2 -> + happyIn21 + (RightContextRExp happy_var_2 + )} + +happyReduce_33 = happySpecReduce_2 17# happyReduction_33 +happyReduction_33 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn21 + (RightContextCode (case happy_var_2 of + T _ (CodeT code) -> code) + )} + +happyReduce_34 = happySpecReduce_0 17# happyReduction_34 +happyReduction_34 = happyIn21 + (NoRightContext + ) + +happyReduce_35 = happySpecReduce_3 18# happyReduction_35 +happyReduction_35 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut22 happy_x_3 of { happy_var_3 -> + happyIn22 + (happy_var_1 :| happy_var_3 + )}} + +happyReduce_36 = happySpecReduce_1 18# happyReduction_36 +happyReduction_36 happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + happyIn22 + (happy_var_1 + )} + +happyReduce_37 = happySpecReduce_2 19# happyReduction_37 +happyReduction_37 happy_x_2 + happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut24 happy_x_2 of { happy_var_2 -> + happyIn23 + (happy_var_1 :%% happy_var_2 + )}} + +happyReduce_38 = happySpecReduce_1 19# happyReduction_38 +happyReduction_38 happy_x_1 + = case happyOut24 happy_x_1 of { happy_var_1 -> + happyIn23 + (happy_var_1 + )} + +happyReduce_39 = happySpecReduce_2 20# happyReduction_39 +happyReduction_39 happy_x_2 + happy_x_1 + = case happyOut26 happy_x_1 of { happy_var_1 -> + case happyOut25 happy_x_2 of { happy_var_2 -> + happyIn24 + (happy_var_2 happy_var_1 + )}} + +happyReduce_40 = happySpecReduce_1 20# happyReduction_40 +happyReduction_40 happy_x_1 + = case happyOut26 happy_x_1 of { happy_var_1 -> + happyIn24 + (happy_var_1 + )} + +happyReduce_41 = happySpecReduce_1 21# happyReduction_41 +happyReduction_41 happy_x_1 + = happyIn25 + (Star + ) + +happyReduce_42 = happySpecReduce_1 21# happyReduction_42 +happyReduction_42 happy_x_1 + = happyIn25 + (Plus + ) + +happyReduce_43 = happySpecReduce_1 21# happyReduction_43 +happyReduction_43 happy_x_1 + = happyIn25 + (Ques + ) + +happyReduce_44 = happySpecReduce_3 21# happyReduction_44 +happyReduction_44 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (T _ (CharT happy_var_2)) -> + happyIn25 + (repeat_rng (digit happy_var_2) Nothing + )} + +happyReduce_45 = happyReduce 4# 21# happyReduction_45 +happyReduction_45 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (T _ (CharT happy_var_2)) -> + happyIn25 + (repeat_rng (digit happy_var_2) (Just Nothing) + ) `HappyStk` happyRest} + +happyReduce_46 = happyReduce 5# 21# happyReduction_46 +happyReduction_46 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (T _ (CharT happy_var_2)) -> + case happyOutTok happy_x_4 of { (T _ (CharT happy_var_4)) -> + happyIn25 + (repeat_rng (digit happy_var_2) (Just (Just (digit happy_var_4))) + ) `HappyStk` happyRest}} + +happyReduce_47 = happySpecReduce_2 22# happyReduction_47 +happyReduction_47 happy_x_2 + happy_x_1 + = happyIn26 + (Eps + ) + +happyReduce_48 = happySpecReduce_1 22# happyReduction_48 +happyReduction_48 happy_x_1 + = case happyOutTok happy_x_1 of { (T _ (StringT happy_var_1)) -> + happyIn26 + (foldr (:%%) Eps + (map (Ch . charSetSingleton) happy_var_1) + )} + +happyReduce_49 = happyMonadReduce 1# 22# happyReduction_49 +happyReduction_49 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (T _ (RMacT happy_var_1)) -> + ( lookupRMac happy_var_1)} + ) (\r -> happyReturn (happyIn26 r)) + +happyReduce_50 = happySpecReduce_1 22# happyReduction_50 +happyReduction_50 happy_x_1 + = case happyOut27 happy_x_1 of { happy_var_1 -> + happyIn26 + (Ch happy_var_1 + )} + +happyReduce_51 = happySpecReduce_3 22# happyReduction_51 +happyReduction_51 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut22 happy_x_2 of { happy_var_2 -> + happyIn26 + (happy_var_2 + )} + +happyReduce_52 = happySpecReduce_3 23# happyReduction_52 +happyReduction_52 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut27 happy_x_1 of { happy_var_1 -> + case happyOut28 happy_x_3 of { happy_var_3 -> + happyIn27 + (happy_var_1 `charSetMinus` happy_var_3 + )}} + +happyReduce_53 = happySpecReduce_1 23# happyReduction_53 +happyReduction_53 happy_x_1 + = case happyOut28 happy_x_1 of { happy_var_1 -> + happyIn27 + (happy_var_1 + )} + +happyReduce_54 = happySpecReduce_1 24# happyReduction_54 +happyReduction_54 happy_x_1 + = case happyOutTok happy_x_1 of { (T _ (CharT happy_var_1)) -> + happyIn28 + (charSetSingleton happy_var_1 + )} + +happyReduce_55 = happySpecReduce_3 24# happyReduction_55 +happyReduction_55 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (T _ (CharT happy_var_1)) -> + case happyOutTok happy_x_3 of { (T _ (CharT happy_var_3)) -> + happyIn28 + (charSetRange happy_var_1 happy_var_3 + )}} + +happyReduce_56 = happyMonadReduce 1# 24# happyReduction_56 +happyReduction_56 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut30 happy_x_1 of { happy_var_1 -> + ( lookupSMac happy_var_1)} + ) (\r -> happyReturn (happyIn28 r)) + +happyReduce_57 = happySpecReduce_3 24# happyReduction_57 +happyReduction_57 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut29 happy_x_2 of { happy_var_2 -> + happyIn28 + (foldr charSetUnion emptyCharSet happy_var_2 + )} + +happyReduce_58 = happyMonadReduce 4# 24# happyReduction_58 +happyReduction_58 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut29 happy_x_3 of { happy_var_3 -> + ( do { dot <- lookupSMac (tokPosn happy_var_1, "."); + return (dot `charSetMinus` + foldr charSetUnion emptyCharSet happy_var_3) })}} + ) (\r -> happyReturn (happyIn28 r)) + +happyReduce_59 = happyMonadReduce 2# 24# happyReduction_59 +happyReduction_59 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut28 happy_x_2 of { happy_var_2 -> + ( do { dot <- lookupSMac (tokPosn happy_var_1, "."); + return (dot `charSetMinus` happy_var_2) })}} + ) (\r -> happyReturn (happyIn28 r)) + +happyReduce_60 = happySpecReduce_2 25# happyReduction_60 +happyReduction_60 happy_x_2 + happy_x_1 + = case happyOut27 happy_x_1 of { happy_var_1 -> + case happyOut29 happy_x_2 of { happy_var_2 -> + happyIn29 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_61 = happySpecReduce_0 25# happyReduction_61 +happyReduction_61 = happyIn29 + ([] + ) + +happyReduce_62 = happySpecReduce_1 26# happyReduction_62 +happyReduction_62 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn30 + ((tokPosn happy_var_1, ".") + )} + +happyReduce_63 = happySpecReduce_1 26# happyReduction_63 +happyReduction_63 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn30 + (case happy_var_1 of T p (SMacT s) -> (p, s) + )} + +happyNewToken action sts stk + = lexer(\tk -> + let cont i = happyDoAction i tk action sts stk in + case tk of { + T _ EOFT -> happyDoAction 33# tk action sts stk; + T _ (SpecialT '.') -> cont 1#; + T _ (SpecialT ';') -> cont 2#; + T _ (SpecialT '<') -> cont 3#; + T _ (SpecialT '>') -> cont 4#; + T _ (SpecialT ',') -> cont 5#; + T _ (SpecialT '$') -> cont 6#; + T _ (SpecialT '|') -> cont 7#; + T _ (SpecialT '*') -> cont 8#; + T _ (SpecialT '+') -> cont 9#; + T _ (SpecialT '?') -> cont 10#; + T _ (SpecialT '{') -> cont 11#; + T _ (SpecialT '}') -> cont 12#; + T _ (SpecialT '(') -> cont 13#; + T _ (SpecialT ')') -> cont 14#; + T _ (SpecialT '#') -> cont 15#; + T _ (SpecialT '~') -> cont 16#; + T _ (SpecialT '-') -> cont 17#; + T _ (SpecialT '[') -> cont 18#; + T _ (SpecialT ']') -> cont 19#; + T _ (SpecialT '^') -> cont 20#; + T _ (SpecialT '/') -> cont 21#; + T _ ZeroT -> cont 22#; + T _ (StringT happy_dollar_dollar) -> cont 23#; + T _ (BindT happy_dollar_dollar) -> cont 24#; + T _ (IdT happy_dollar_dollar) -> cont 25#; + T _ (CodeT _) -> cont 26#; + T _ (CharT happy_dollar_dollar) -> cont 27#; + T _ (SMacT _) -> cont 28#; + T _ (RMacT happy_dollar_dollar) -> cont 29#; + T _ (SMacDefT happy_dollar_dollar) -> cont 30#; + T _ (RMacDefT happy_dollar_dollar) -> cont 31#; + T _ WrapperT -> cont 32#; + _ -> happyError' tk + }) + +happyError_ tk = happyError' tk + +happyThen :: () => P a -> (a -> P b) -> P b +happyThen = ((>>=)) +happyReturn :: () => a -> P a +happyReturn = (return) +happyThen1 = happyThen +happyReturn1 :: () => a -> P a +happyReturn1 = happyReturn +happyError' :: () => Token -> P a +happyError' tk = (\token -> happyError) tk + +parse = happySomeParser where + happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (happyOut4 x)) + +happySeq = happyDontSeq + + +happyError :: P a +happyError = failP "parse error" + +-- ----------------------------------------------------------------------------- +-- Utils + +digit c = ord c - ord '0' + +repeat_rng :: Int -> Maybe (Maybe Int) -> (RExp->RExp) +repeat_rng n (Nothing) re = foldr (:%%) Eps (replicate n re) +repeat_rng n (Just Nothing) re = foldr (:%%) (Star re) (replicate n re) +repeat_rng n (Just (Just m)) re = intl :%% rst + where + intl = repeat_rng n Nothing re + rst = foldr (\re re'->Ques(re :%% re')) Eps (replicate (m-n) re) + +replaceCodes codes rectx = rectx{ reCtxStartCodes = codes } +{-# LINE 1 "GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "GenericTemplate.hs" #-} +-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + +{-# LINE 28 "GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Int# Happy_IntList + + + + + +{-# LINE 49 "GenericTemplate.hs" #-} + +{-# LINE 59 "GenericTemplate.hs" #-} + +{-# LINE 68 "GenericTemplate.hs" #-} + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n <# (0# :: Int#)) -> {- nothing -} + + (happyReduceArr ! rule) i tk st + where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n -# (1# :: Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off +# i) + check = if (off_i >=# (0# :: Int#)) + then (indexShortOffAddr happyCheck off_i ==# i) + else False + action | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + +{-# LINE 127 "GenericTemplate.hs" #-} + + +indexShortOffAddr (HappyA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + + +data HappyAddr = HappyA# Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 170 "GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k -# (1# :: Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyMonad2Reduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + + off = indexShortOffAddr happyGotoOffsets st1 + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk = +-- trace "failing" $ + happyError_ tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/src/Parser.y b/src/Parser.y new file mode 100644 --- /dev/null +++ b/src/Parser.y @@ -0,0 +1,218 @@ +{ +-- ----------------------------------------------------------------------------- +-- +-- Parser.y, part of Alex +-- +-- (c) Simon Marlow 2003 +-- +-- ----------------------------------------------------------------------------- + +module Parser ( parse, P ) where +import AbsSyn +import Scan +import CharSet +import ParseMonad hiding ( StartCode ) + +import Data.Char +--import Debug.Trace +} + +%tokentype { Token } + +%name parse + +%monad { P } { (>>=) } { return } +%lexer { lexer } { T _ EOFT } + +%token + '.' { T _ (SpecialT '.') } + ';' { T _ (SpecialT ';') } + '<' { T _ (SpecialT '<') } + '>' { T _ (SpecialT '>') } + ',' { T _ (SpecialT ',') } + '$' { T _ (SpecialT '$') } + '|' { T _ (SpecialT '|') } + '*' { T _ (SpecialT '*') } + '+' { T _ (SpecialT '+') } + '?' { T _ (SpecialT '?') } + '{' { T _ (SpecialT '{') } + '}' { T _ (SpecialT '}') } + '(' { T _ (SpecialT '(') } + ')' { T _ (SpecialT ')') } + '#' { T _ (SpecialT '#') } + '~' { T _ (SpecialT '~') } + '-' { T _ (SpecialT '-') } + '[' { T _ (SpecialT '[') } + ']' { T _ (SpecialT ']') } + '^' { T _ (SpecialT '^') } + '/' { T _ (SpecialT '/') } + ZERO { T _ ZeroT } + STRING { T _ (StringT $$) } + BIND { T _ (BindT $$) } + ID { T _ (IdT $$) } + CODE { T _ (CodeT _) } + CHAR { T _ (CharT $$) } + SMAC { T _ (SMacT _) } + RMAC { T _ (RMacT $$) } + SMAC_DEF { T _ (SMacDefT $$) } + RMAC_DEF { T _ (RMacDefT $$) } + WRAPPER { T _ WrapperT } +%% + +alex :: { (Maybe (AlexPosn,Code), [Directive], Scanner, Maybe (AlexPosn,Code)) } + : maybe_code directives macdefs scanner maybe_code { ($1,$2,$4,$5) } + +maybe_code :: { Maybe (AlexPosn,Code) } + : CODE { case $1 of T pos (CodeT code) -> + Just (pos,code) } + | {- empty -} { Nothing } + +directives :: { [Directive] } + : directive directives { $1 : $2 } + | {- empty -} { [] } + +directive :: { Directive } + : WRAPPER STRING { WrapperDirective $2 } + +macdefs :: { () } + : macdef macdefs { () } + | {- empty -} { () } + +-- hack: the lexer looks for the '=' in a macro definition, because there +-- doesn't seem to be a way to formulate the grammar here to avoid a +-- conflict (it needs LR(2) rather than LR(1) to find the '=' and distinguish +-- an SMAC/RMAC at the beginning of a definition from an SMAC/RMAC that is +-- part of a regexp in the previous definition). +macdef :: { () } + : SMAC_DEF set {% newSMac $1 $2 } + | RMAC_DEF rexp {% newRMac $1 $2 } + +scanner :: { Scanner } + : BIND tokendefs { Scanner $1 $2 } + +tokendefs :: { [RECtx] } + : tokendef tokendefs { $1 ++ $2 } + | {- empty -} { [] } + +tokendef :: { [RECtx] } + : startcodes rule { [ replaceCodes $1 $2 ] } + | startcodes '{' rules '}' { map (replaceCodes $1) $3 } + | rule { [ $1 ] } + +rule :: { RECtx } + : context rhs { let (l,e,r) = $1 in + RECtx [] l e r $2 } + +rules :: { [RECtx] } + : rule rules { $1 : $2 } + | {- empty -} { [] } + +startcodes :: { [(String,StartCode)] } + : '<' startcodes0 '>' { $2 } + +startcodes0 :: { [(String,StartCode)] } + : startcode ',' startcodes0 { ($1,0) : $3 } + | startcode { [($1,0)] } + +startcode :: { String } + : ZERO { "0" } + | ID { $1 } + +rhs :: { Maybe Code } + : CODE { case $1 of T _ (CodeT code) -> Just code } + | ';' { Nothing } + +context :: { Maybe CharSet, RExp, RightContext RExp } + : left_ctx rexp right_ctx { (Just $1,$2,$3) } + | rexp right_ctx { (Nothing,$1,$2) } + +left_ctx :: { CharSet } + : '^' { charSetSingleton '\n' } + | set '^' { $1 } + +right_ctx :: { RightContext RExp } + : '$' { RightContextRExp (Ch (charSetSingleton '\n')) } + | '/' rexp { RightContextRExp $2 } + | '/' CODE { RightContextCode (case $2 of + T _ (CodeT code) -> code) } + | {- empty -} { NoRightContext } + +rexp :: { RExp } + : alt '|' rexp { $1 :| $3 } + | alt { $1 } + +alt :: { RExp } + : alt term { $1 :%% $2 } + | term { $1 } + +term :: { RExp } + : rexp0 rep { $2 $1 } + | rexp0 { $1 } + +rep :: { RExp -> RExp } + : '*' { Star } + | '+' { Plus } + | '?' { Ques } + -- TODO: these don't check for digits + -- properly. + | '{' CHAR '}' { repeat_rng (digit $2) Nothing } + | '{' CHAR ',' '}' { repeat_rng (digit $2) (Just Nothing) } + | '{' CHAR ',' CHAR '}' { repeat_rng (digit $2) (Just (Just (digit $4))) } + +rexp0 :: { RExp } + : '(' ')' { Eps } + | STRING { foldr (:%%) Eps + (map (Ch . charSetSingleton) $1) } + | RMAC {% lookupRMac $1 } + | set { Ch $1 } + | '(' rexp ')' { $2 } + +set :: { CharSet } + : set '#' set0 { $1 `charSetMinus` $3 } + | set0 { $1 } + +set0 :: { CharSet } + : CHAR { charSetSingleton $1 } + | CHAR '-' CHAR { charSetRange $1 $3 } + | smac {% lookupSMac $1 } + | '[' sets ']' { foldr charSetUnion emptyCharSet $2 } + + -- [^sets] is the same as '. # [sets]' + -- The upshot is that [^set] does *not* match a newline character, + -- which seems much more useful than just taking the complement. + | '[' '^' sets ']' + {% do { dot <- lookupSMac (tokPosn $1, "."); + return (dot `charSetMinus` + foldr charSetUnion emptyCharSet $3) }} + + -- ~set is the same as '. # set' + | '~' set0 {% do { dot <- lookupSMac (tokPosn $1, "."); + return (dot `charSetMinus` $2) } } + +sets :: { [CharSet] } + : set sets { $1 : $2 } + | {- empty -} { [] } + +smac :: { (AlexPosn,String) } + : '.' { (tokPosn $1, ".") } + | SMAC { case $1 of T p (SMacT s) -> (p, s) } + +{ +happyError :: P a +happyError = failP "parse error" + +-- ----------------------------------------------------------------------------- +-- Utils + +digit c = ord c - ord '0' + +repeat_rng :: Int -> Maybe (Maybe Int) -> (RExp->RExp) +repeat_rng n (Nothing) re = foldr (:%%) Eps (replicate n re) +repeat_rng n (Just Nothing) re = foldr (:%%) (Star re) (replicate n re) +repeat_rng n (Just (Just m)) re = intl :%% rst + where + intl = repeat_rng n Nothing re + rst = foldr (\re re'->Ques(re :%% re')) Eps (replicate (m-n) re) + +replaceCodes codes rectx = rectx{ reCtxStartCodes = codes } +} diff --git a/src/Scan.hs b/src/Scan.hs new file mode 100644 --- /dev/null +++ b/src/Scan.hs @@ -0,0 +1,354 @@ +{-# OPTIONS -cpp #-} +{-# LINE 13 "Scan.x" #-} +module Scan(lexer, AlexPosn(..), Token(..), Tkn(..), tokPosn) where + +import Data.Char +import ParseMonad +--import Debug.Trace + +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#else +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +import Data.Char (ord) +import Data.Array.Base (unsafeAt) +#else +import Array +import Char (ord) +#endif +alex_base :: Array Int Int +alex_base = listArray (0,76) [-8,110,137,119,124,-4,-3,-37,-36,0,128,129,0,114,-35,115,-34,251,365,256,116,117,-33,0,138,0,423,0,-106,-100,-82,-96,-95,-83,-94,222,331,515,594,617,341,649,0,0,655,770,884,644,968,1052,1113,1227,1341,1455,1453,1537,1598,0,135,396,167,168,-26,0,169,801,170,281,-24,0,0,1682,1766,0,0,0,736] + +alex_table :: Array Int Int +alex_table = listArray (0,2021) [0,4,4,4,4,4,-1,-1,5,5,12,12,20,29,30,31,32,33,34,60,27,66,0,0,4,43,10,25,26,28,43,43,25,25,25,25,25,8,25,25,43,43,43,43,43,43,43,43,43,43,16,25,69,43,43,25,44,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,25,37,25,25,43,43,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,24,25,25,25,4,4,4,4,4,-1,-1,-1,-1,4,4,4,4,4,4,4,4,4,4,-1,-1,0,0,4,0,0,-1,4,4,4,4,4,4,0,0,0,7,4,0,0,0,13,0,9,9,7,0,0,0,0,4,0,0,15,15,15,15,0,-1,-1,-1,-1,73,7,0,0,70,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,58,0,0,74,0,0,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,58,58,64,64,0,76,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,71,19,19,19,19,19,19,19,19,19,19,35,35,35,35,35,35,35,35,35,35,0,0,0,19,0,0,0,0,19,0,18,-1,0,0,0,0,22,0,0,18,18,18,18,18,18,18,18,18,18,14,0,0,0,0,14,0,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,64,0,0,0,18,0,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,19,19,19,19,19,35,35,35,35,35,35,35,35,35,35,40,40,40,40,40,40,40,40,19,0,0,0,0,0,0,18,59,59,59,59,59,22,0,0,18,18,18,18,18,18,18,18,18,18,14,0,0,0,0,59,0,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,0,57,0,0,18,0,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,0,0,0,0,0,0,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,50,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,36,36,36,36,36,36,36,36,36,36,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,41,42,42,42,42,42,42,42,42,39,42,42,42,42,42,42,38,38,38,38,38,38,38,38,38,38,0,59,59,59,59,59,0,38,38,38,38,38,38,38,38,38,38,38,38,38,38,38,38,0,59,0,0,0,0,0,38,38,38,38,38,38,0,62,0,38,38,38,38,38,38,40,40,40,40,40,40,40,40,57,0,0,0,0,0,0,0,0,38,38,38,38,38,38,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,0,0,0,0,0,0,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,51,56,59,59,59,59,59,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,0,0,0,0,0,0,0,0,59,0,0,0,0,0,0,46,65,65,65,65,65,62,0,0,46,46,46,46,46,46,46,46,46,46,0,0,0,57,0,65,0,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,0,63,0,0,46,0,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,59,59,59,59,59,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,59,0,0,0,0,0,0,46,0,0,0,0,0,62,0,0,46,46,46,46,46,46,46,46,46,46,0,0,0,57,0,0,0,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,0,0,0,0,46,0,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,49,0,0,0,0,0,0,0,0,49,49,49,49,49,49,49,49,49,49,0,0,0,0,0,0,0,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,0,0,0,0,49,0,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,0,47,0,0,0,0,0,0,49,49,49,49,49,49,49,49,49,49,0,0,0,0,0,0,0,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,0,0,0,0,49,0,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,49,0,0,47,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,0,0,0,0,0,0,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,65,65,65,65,65,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,65,0,0,0,0,0,0,52,0,0,0,0,0,68,0,0,52,52,52,52,52,52,52,52,52,52,0,0,0,63,0,0,0,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,0,0,0,0,52,0,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,65,65,65,65,65,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,65,0,0,0,0,0,0,52,0,0,0,0,0,68,0,0,52,52,52,52,52,52,52,52,52,52,0,0,0,63,0,0,0,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,0,0,0,0,52,0,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,52,65,65,65,65,65,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,65,0,0,0,0,55,0,0,0,0,0,0,0,68,55,55,55,55,55,55,55,55,55,55,0,0,0,0,0,63,0,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,0,0,0,0,55,0,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,0,53,0,0,0,0,0,0,55,55,55,55,55,55,55,55,55,55,0,0,0,0,0,0,0,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,0,0,0,0,55,0,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,55,0,0,53,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,0,0,0,0,0,0,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,72,0,0,0,0,0,0,0,0,72,72,72,72,72,72,72,72,72,72,0,0,0,0,0,0,0,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,0,0,0,0,72,0,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,0,0,0,0,0,0,0,0,72,72,72,72,72,72,72,72,72,72,0,0,0,0,0,0,0,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,0,0,0,0,72,0,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] + +alex_check :: Array Int Int +alex_check = listArray (0,2021) [-1,9,10,11,12,13,10,10,45,45,45,45,45,119,114,97,112,112,101,45,114,45,-1,-1,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,9,10,11,12,13,10,10,10,10,9,10,11,12,13,9,10,11,12,13,10,10,-1,-1,32,-1,-1,10,9,10,11,12,13,32,-1,-1,-1,45,32,-1,-1,-1,45,-1,34,34,45,-1,-1,-1,-1,32,-1,-1,58,58,58,58,-1,10,10,10,10,44,45,-1,-1,48,48,49,50,51,52,53,54,55,56,57,61,-1,-1,62,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,61,61,61,61,-1,123,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,9,10,11,12,13,9,10,11,12,13,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,32,-1,-1,-1,-1,32,-1,39,10,-1,-1,-1,-1,45,-1,-1,48,49,50,51,52,53,54,55,56,57,58,-1,-1,-1,-1,58,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,61,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,9,10,11,12,13,48,49,50,51,52,53,54,55,56,57,48,49,50,51,52,53,54,55,32,-1,-1,-1,-1,-1,-1,39,9,10,11,12,13,45,-1,-1,48,49,50,51,52,53,54,55,56,57,58,-1,-1,-1,-1,32,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,61,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,-1,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,48,49,50,51,52,53,54,55,56,57,-1,9,10,11,12,13,-1,65,66,67,68,69,70,48,49,50,51,52,53,54,55,56,57,-1,32,-1,-1,-1,-1,-1,65,66,67,68,69,70,-1,45,-1,97,98,99,100,101,102,48,49,50,51,52,53,54,55,61,-1,-1,-1,-1,-1,-1,-1,-1,97,98,99,100,101,102,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,-1,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,9,10,11,12,13,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,-1,32,-1,-1,-1,-1,-1,-1,39,9,10,11,12,13,45,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,61,-1,32,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,61,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,9,10,11,12,13,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,32,-1,-1,-1,-1,-1,-1,39,-1,-1,-1,-1,-1,45,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,61,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,125,-1,-1,-1,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,-1,-1,125,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,-1,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,9,10,11,12,13,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,32,-1,-1,-1,-1,-1,-1,39,-1,-1,-1,-1,-1,45,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,61,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,9,10,11,12,13,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,32,-1,-1,-1,-1,-1,-1,39,-1,-1,-1,-1,-1,45,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,61,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,9,10,11,12,13,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,32,-1,-1,-1,-1,39,-1,-1,-1,-1,-1,-1,-1,45,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,61,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,125,-1,-1,-1,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,-1,-1,125,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,-1,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1] + +alex_deflt :: Array Int Int +alex_deflt = listArray (0,76) [-1,-1,-1,-1,-1,6,6,-1,-1,-1,11,11,-1,21,-1,21,-1,-1,-1,-1,21,21,-1,-1,23,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,61,-1,61,61,-1,-1,67,-1,67,67,-1,-1,-1,-1,-1,-1,-1,-1,75] + +alex_accept = listArray (0::Int,76) [[],[(AlexAcc (alex_action_21))],[],[],[(AlexAcc (alex_action_0))],[(AlexAcc (alex_action_0))],[(AlexAcc (alex_action_0))],[],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_10))],[],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[],[],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_10))],[],[],[],[],[],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[],[],[],[],[],[],[],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_11))],[],[],[],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_12))],[],[],[],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_13))],[],[],[],[],[(AlexAcc (alex_action_14))],[(AlexAcc (alex_action_14))],[],[],[],[],[(AlexAcc (alex_action_15))],[(AlexAcc (alex_action_16))],[(AlexAcc (alex_action_17))],[(AlexAcc (alex_action_17))],[(AlexAcc (alex_action_18))],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_20))],[]] +{-# LINE 73 "Scan.x" #-} + +-- ----------------------------------------------------------------------------- +-- Token type + +data Token = T AlexPosn Tkn + deriving Show + +tokPosn (T p _) = p + +data Tkn + = SpecialT Char + | CodeT String + | ZeroT + | IdT String + | StringT String + | BindT String + | CharT Char + | SMacT String + | RMacT String + | SMacDefT String + | RMacDefT String + | NumT Int + | WrapperT + | EOFT + deriving Show + +-- ----------------------------------------------------------------------------- +-- Token functions + +special (p,_,str) ln = return $ T p (SpecialT (head str)) +zero (p,_,str) ln = return $ T p ZeroT +string (p,_,str) ln = return $ T p (StringT (extract ln str)) +bind (p,_,str) ln = return $ T p (BindT (takeWhile isIdChar str)) +escape (p,_,str) ln = return $ T p (CharT (esc str)) +decch (p,_,str) ln = return $ T p (CharT (do_ech 10 ln (take (ln-1) (tail str)))) +hexch (p,_,str) ln = return $ T p (CharT (do_ech 16 ln (take (ln-2) (drop 2 str)))) +octch (p,_,str) ln = return $ T p (CharT (do_ech 8 ln (take (ln-2) (drop 2 str)))) +char (p,_,str) ln = return $ T p (CharT (head str)) +smac (p,_,str) ln = return $ T p (SMacT (mac ln str)) +rmac (p,_,str) ln = return $ T p (RMacT (mac ln str)) +smacdef (p,_,str) ln = return $ T p (SMacDefT (macdef ln str)) +rmacdef (p,_,str) ln = return $ T p (RMacDefT (macdef ln str)) +startcode (p,_,str) ln = return $ T p (IdT (take ln str)) +wrapper (p,_,str) ln = return $ T p WrapperT + +isIdChar c = isAlphaNum c || c `elem` "_'" + +extract ln str = take (ln-2) (tail str) + +do_ech radix ln str = chr (parseInt radix str) + +mac ln (_ : str) = take (ln-1) str + +macdef ln (_ : str) = takeWhile (not.isSpace) str + +esc (_ : x : _) = + case x of + 'a' -> '\a' + 'b' -> '\b' + 'f' -> '\f' + 'n' -> '\n' + 'r' -> '\r' + 't' -> '\t' + 'v' -> '\v' + c -> c + +parseInt :: Int -> String -> Int +parseInt radix ds = foldl1 (\n d -> n * radix + d) (map digitToInt ds) + +-- In brace-delimited code, we have to be careful to match braces +-- within the code, but ignore braces inside strings and character +-- literals. We do an approximate job (doing it properly requires +-- implementing a large chunk of the Haskell lexical syntax). + +code (p,_,inp) len = do + inp <- getInput + go inp 1 "" + where + go inp 0 cs = do + setInput inp + return (T p (CodeT (reverse (tail cs)))) + go inp n cs = do + case alexGetChar inp of + Nothing -> err inp + Just (c,inp) -> + case c of + '{' -> go inp (n+1) (c:cs) + '}' -> go inp (n-1) (c:cs) + '\'' -> go_char inp n (c:cs) + '\"' -> go_str inp n (c:cs) '\"' + c -> go inp n (c:cs) + + -- try to catch occurrences of ' within an identifier + go_char inp n (c1:c2:cs) | isAlphaNum c2 = go inp n (c1:c2:cs) + go_char inp n cs = go_str inp n cs '\'' + + go_str inp n cs end = do + case alexGetChar inp of + Nothing -> err inp + Just (c,inp) + | c == end -> go inp n (c:cs) + | otherwise -> + case c of + '\\' -> case alexGetChar inp of + Nothing -> err inp + Just (d,inp) -> go_str inp n (d:c:cs) end + c -> go_str inp n (c:cs) end + + err inp = do setInput inp; lexError "lexical error in code fragment" + + + +lexError s = do + (p,_,input) <- getInput + failP (s ++ (if (not (null input)) + then " at " ++ show (head input) + else " at end of file")) + +lexer :: (Token -> P a) -> P a +lexer cont = lexToken >>= cont + +lexToken :: P Token +lexToken = do + inp@(p,_,_) <- getInput + sc <- getStartCode + case alexScan inp sc of + AlexEOF -> return (T p EOFT) + AlexError _ -> lexError "lexical error" + AlexSkip inp1 len -> do + setInput inp1 + lexToken + AlexToken inp1 len t -> do + setInput inp1 + t inp len + +type Action = AlexInput -> Int -> P Token + +skip :: Action +skip _ _ = lexToken + +andBegin :: Action -> StartCode -> Action +andBegin act sc inp len = setStartCode sc >> act inp len + + +afterstartcodes,startcodes :: Int +afterstartcodes = 1 +startcodes = 2 +alex_action_0 = skip +alex_action_1 = string +alex_action_2 = bind +alex_action_3 = code +alex_action_4 = special +alex_action_5 = wrapper +alex_action_6 = decch +alex_action_7 = hexch +alex_action_8 = octch +alex_action_9 = escape +alex_action_10 = char +alex_action_11 = smac +alex_action_12 = rmac +alex_action_13 = smacdef +alex_action_14 = rmacdef +alex_action_15 = special `andBegin` startcodes +alex_action_16 = zero +alex_action_17 = startcode +alex_action_18 = special +alex_action_19 = special `andBegin` afterstartcodes +alex_action_20 = special `andBegin` 0 +alex_action_21 = skip `andBegin` 0 +{-# LINE 1 "GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +{-# LINE 35 "GenericTemplate.hs" #-} + +{-# LINE 45 "GenericTemplate.hs" #-} + +{-# LINE 66 "GenericTemplate.hs" #-} +alexIndexInt16OffAddr arr off = arr ! off + + +{-# LINE 87 "GenericTemplate.hs" #-} +alexIndexInt32OffAddr arr off = arr ! off + + +{-# LINE 98 "GenericTemplate.hs" #-} +quickIndex arr i = arr ! i + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input (sc) + = alexScanUser undefined input (sc) + +alexScanUser user input (sc) + = case alex_scan_tkn user input (0) input sc AlexNone of + (AlexNone, input') -> + case alexGetChar input of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input' + + (AlexLastSkip input len, _) -> + + + + AlexSkip input len + + (AlexLastAcc k input len, _) -> + + + + AlexToken input len k + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user orig_input len input s last_acc = + input `seq` -- strict in the input + let + new_acc = check_accs (alex_accept `quickIndex` (s)) + in + new_acc `seq` + case alexGetChar input of + Nothing -> (new_acc, input) + Just (c, new_input) -> + + + + let + base = alexIndexInt32OffAddr alex_base s + (ord_c) = ord c + offset = (base + ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if (offset >= (0)) && (check == ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + (-1) -> (new_acc, input) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user orig_input (len + (1)) + new_input new_s new_acc + + where + check_accs [] = last_acc + check_accs (AlexAcc a : _) = AlexLastAcc a input (len) + check_accs (AlexAccSkip : _) = AlexLastSkip input (len) + check_accs (AlexAccPred a pred : rest) + | pred user orig_input (len) input + = AlexLastAcc a input (len) + check_accs (AlexAccSkipPred pred : rest) + | pred user orig_input (len) input + = AlexLastSkip input (len) + check_accs (_ : rest) = check_accs rest + +data AlexLastAcc a + = AlexNone + | AlexLastAcc a !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc a user + = AlexAcc a + | AlexAccSkip + | AlexAccPred a (AlexAccPred user) + | AlexAccSkipPred (AlexAccPred user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user in1 len in2 + = p1 user in1 len in2 && p2 user in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (sc) user _ _ input = + case alex_scan_tkn user input (0) input sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + +-- used by wrappers +iUnbox (i) = i diff --git a/src/Scan.x b/src/Scan.x new file mode 100644 --- /dev/null +++ b/src/Scan.x @@ -0,0 +1,216 @@ +------------------------------------------------------------------------------- +-- ALEX SCANNER AND LITERATE PREPROCESSOR +-- +-- This Script defines the grammar used to generate the Alex scanner and a +-- preprocessing scanner for dealing with literate scripts. The actions for +-- the Alex scanner are given separately in the Alex module. +-- +-- See the Alex manual for a discussion of the scanners defined here. +-- +-- Chris Dornan, Aug-95, 4-Jun-96, 10-Jul-96, 29-Sep-97 +------------------------------------------------------------------------------- + +{ +module Scan(lexer, AlexPosn(..), Token(..), Tkn(..), tokPosn) where + +import Data.Char +import ParseMonad +--import Debug.Trace +} + +$digit = 0-9 +$hexdig = [0-9 A-F a-f] +$octal = 0-7 +$lower = a-z +$upper = A-Z +$alpha = [$upper $lower] +$alphanum = [$alpha $digit] +$idchar = [$alphanum \_ \'] + +$special = [\.\;\,\$\|\*\+\?\#\~\-\{\}\(\)\[\]\^\/] +$graphic = $printable # $white +$nonspecial = $graphic # [$special \%] + +@id = $alpha $idchar* +@smac = \$ @id | \$ \{ @id \} +@rmac = \@ @id | \@ \{ @id \} + +@comment = "--".* +@ws = $white+ | @comment + +alex :- + +@ws { skip } -- white space; ignore + +<0> \" [^\"]* \" { string } +<0> (@id @ws?)? \:\- { bind } +<0> \{ (\n | [^$digit]) { code } +<0> $special { special } -- note: matches { +<0> \% "wrapper" { wrapper } + +<0> \\ $digit+ { decch } +<0> \\ x $hexdig+ { hexch } +<0> \\ o $octal+ { octch } +<0> \\ $printable { escape } +<0> $nonspecial # [\<] { char } +<0> @smac { smac } +<0> @rmac { rmac } + +<0> @smac @ws? \= { smacdef } +<0> @rmac @ws? \= { rmacdef } + +-- identifiers are allowed to be unquoted in startcode lists +<0> \< { special `andBegin` startcodes } + 0 { zero } + @id { startcode } + \, { special } + \> { special `andBegin` afterstartcodes } + +-- After a <..> startcode sequence, we can have a {...} grouping of rules, +-- so don't try to interpret the opening { as a code block. + \{ (\n | [^$digit ]) { special `andBegin` 0 } + () { skip `andBegin` 0 } -- note: empty pattern +{ + +-- ----------------------------------------------------------------------------- +-- Token type + +data Token = T AlexPosn Tkn + deriving Show + +tokPosn (T p _) = p + +data Tkn + = SpecialT Char + | CodeT String + | ZeroT + | IdT String + | StringT String + | BindT String + | CharT Char + | SMacT String + | RMacT String + | SMacDefT String + | RMacDefT String + | NumT Int + | WrapperT + | EOFT + deriving Show + +-- ----------------------------------------------------------------------------- +-- Token functions + +special (p,_,str) ln = return $ T p (SpecialT (head str)) +zero (p,_,str) ln = return $ T p ZeroT +string (p,_,str) ln = return $ T p (StringT (extract ln str)) +bind (p,_,str) ln = return $ T p (BindT (takeWhile isIdChar str)) +escape (p,_,str) ln = return $ T p (CharT (esc str)) +decch (p,_,str) ln = return $ T p (CharT (do_ech 10 ln (take (ln-1) (tail str)))) +hexch (p,_,str) ln = return $ T p (CharT (do_ech 16 ln (take (ln-2) (drop 2 str)))) +octch (p,_,str) ln = return $ T p (CharT (do_ech 8 ln (take (ln-2) (drop 2 str)))) +char (p,_,str) ln = return $ T p (CharT (head str)) +smac (p,_,str) ln = return $ T p (SMacT (mac ln str)) +rmac (p,_,str) ln = return $ T p (RMacT (mac ln str)) +smacdef (p,_,str) ln = return $ T p (SMacDefT (macdef ln str)) +rmacdef (p,_,str) ln = return $ T p (RMacDefT (macdef ln str)) +startcode (p,_,str) ln = return $ T p (IdT (take ln str)) +wrapper (p,_,str) ln = return $ T p WrapperT + +isIdChar c = isAlphaNum c || c `elem` "_'" + +extract ln str = take (ln-2) (tail str) + +do_ech radix ln str = chr (parseInt radix str) + +mac ln (_ : str) = take (ln-1) str + +macdef ln (_ : str) = takeWhile (not.isSpace) str + +esc (_ : x : _) = + case x of + 'a' -> '\a' + 'b' -> '\b' + 'f' -> '\f' + 'n' -> '\n' + 'r' -> '\r' + 't' -> '\t' + 'v' -> '\v' + c -> c + +parseInt :: Int -> String -> Int +parseInt radix ds = foldl1 (\n d -> n * radix + d) (map digitToInt ds) + +-- In brace-delimited code, we have to be careful to match braces +-- within the code, but ignore braces inside strings and character +-- literals. We do an approximate job (doing it properly requires +-- implementing a large chunk of the Haskell lexical syntax). + +code (p,_,inp) len = do + inp <- getInput + go inp 1 "" + where + go inp 0 cs = do + setInput inp + return (T p (CodeT (reverse (tail cs)))) + go inp n cs = do + case alexGetChar inp of + Nothing -> err inp + Just (c,inp) -> + case c of + '{' -> go inp (n+1) (c:cs) + '}' -> go inp (n-1) (c:cs) + '\'' -> go_char inp n (c:cs) + '\"' -> go_str inp n (c:cs) '\"' + c -> go inp n (c:cs) + + -- try to catch occurrences of ' within an identifier + go_char inp n (c1:c2:cs) | isAlphaNum c2 = go inp n (c1:c2:cs) + go_char inp n cs = go_str inp n cs '\'' + + go_str inp n cs end = do + case alexGetChar inp of + Nothing -> err inp + Just (c,inp) + | c == end -> go inp n (c:cs) + | otherwise -> + case c of + '\\' -> case alexGetChar inp of + Nothing -> err inp + Just (d,inp) -> go_str inp n (d:c:cs) end + c -> go_str inp n (c:cs) end + + err inp = do setInput inp; lexError "lexical error in code fragment" + + + +lexError s = do + (p,_,input) <- getInput + failP (s ++ (if (not (null input)) + then " at " ++ show (head input) + else " at end of file")) + +lexer :: (Token -> P a) -> P a +lexer cont = lexToken >>= cont + +lexToken :: P Token +lexToken = do + inp@(p,_,_) <- getInput + sc <- getStartCode + case alexScan inp sc of + AlexEOF -> return (T p EOFT) + AlexError _ -> lexError "lexical error" + AlexSkip inp1 len -> do + setInput inp1 + lexToken + AlexToken inp1 len t -> do + setInput inp1 + t inp len + +type Action = AlexInput -> Int -> P Token + +skip :: Action +skip _ _ = lexToken + +andBegin :: Action -> StartCode -> Action +andBegin act sc inp len = setStartCode sc >> act inp len +} diff --git a/src/Set.hs b/src/Set.hs new file mode 100644 --- /dev/null +++ b/src/Set.hs @@ -0,0 +1,14 @@ +module Set ( Set, member, empty, insert ) where + +import Data.Set + +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603 +member :: Ord a => a -> Set a -> Bool +member = elementOf + +empty :: Set a +empty = emptySet + +insert :: Ord a => a -> Set a -> Set a +insert = flip addToSet +#endif diff --git a/src/Sort.hs b/src/Sort.hs new file mode 100644 --- /dev/null +++ b/src/Sort.hs @@ -0,0 +1,69 @@ +{------------------------------------------------------------------------------ + SORTING LISTS + +This module provides properly parameterised insertion and merge sort functions, +complete with associated functions for inserting and merging. `isort' is the +standard lazy version and can be used to the minimum k elements of a list in +linear time. The merge sort is based on a Bob Buckley's (Bob Buckley +18-AUG-95) coding of Knuth's natural merge sort (see Vol. 2). It seems to be +fast in the average case; it makes use of natural runs in the data becomming +linear on ordered data; and it completes in worst time O(n.log(n)). It is +divinely elegant. + +`nub'' is an n.log(n) version of `nub' and `group_sort' sorts a list into +strictly ascending order, using a combining function in its arguments to +amalgamate duplicates. + +Chris Dornan, 14-Aug-93, 17-Nov-94, 29-Dec-95 +------------------------------------------------------------------------------} + +module Sort where + + +-- `isort' is an insertion sort and is here for historical reasons; msort is +-- better in almost every situation. + +isort:: (a->a->Bool) -> [a] -> [a] +isort (<=) = foldr (insrt (<=)) [] + +insrt:: (a->a->Bool) -> a -> [a] -> [a] +insrt (<=) e [] = [e] +insrt (<=) e l@(h:t) = if e<=h then e:l else h:insrt (<=) e t + + +msort :: (a->a->Bool) -> [a] -> [a] +msort (<=) [] = [] -- (foldb f []) is undefined +msort (<=) xs = foldb (mrg (<=)) (runs (<=) xs) + +runs :: (a->a->Bool) -> [a] -> [[a]] +runs (<=) xs = foldr op [] xs + where + op z xss@(xs@(x:_):xss') | z<=x = (z:xs):xss' + | otherwise = [z]:xss + op z xss = [z]:xss + +foldb :: (a->a->a) -> [a] -> a +foldb _ [x] = x +foldb f xs = foldb f (fold xs) + where + fold (x1:x2:xs) = f x1 x2 : fold xs + fold xs = xs + +mrg:: (a->a->Bool) -> [a] -> [a] -> [a] +mrg (<=) [] l = l +mrg (<=) l@(_:_) [] = l +mrg (<=) l1@(h1:t1) l2@(h2:t2) = + if h1<=h2 + then h1:mrg (<=) t1 l2 + else h2:mrg (<=) l1 t2 + + +nub':: (a->a->Bool) -> [a] -> [a] +nub' (<=) l = group_sort (<=) const l + + +group_sort:: (a->a->Bool) -> (a->[a]->b) -> [a] -> [b] +group_sort le cmb l = s_m (msort le l) + where + s_m [] = [] + s_m (h:t) = cmb h (takeWhile (`le` h) t):s_m (dropWhile (`le` h) t) diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -0,0 +1,38 @@ +-- ----------------------------------------------------------------------------- +-- +-- Util.hs, part of Alex +-- +-- (c) Simon Marlow 2003 +-- +-- General utilities used in various parts of Alex +-- +-- ----------------------------------------------------------------------------} + +module Util where + +-- Pretty-printing utilities + +str = showString +char c = (c :) + +nl = char '\n' + +paren s = char '(' . s . char ')' +brack s = char '[' . s . char ']' + +interleave_shows s [] = id +interleave_shows s xs = foldr1 (\a b -> a . s . b) xs + +space = char ' ' + +cjustify, ljustify, rjustify :: Int -> String -> String +cjustify n s = spaces halfm ++ s ++ spaces (m - halfm) + where m = n - length s + halfm = m `div` 2 +ljustify n s = s ++ spaces (max 0 (n - length s)) +rjustify n s = spaces (n - length s) ++ s + +spaces :: Int -> String +spaces n = replicate n ' ' + +hline = replicate 77 '-' diff --git a/src/ghc_hooks.c b/src/ghc_hooks.c new file mode 100644 --- /dev/null +++ b/src/ghc_hooks.c @@ -0,0 +1,5 @@ +#include + +void ErrorHdrHook(chan) + FILE *chan; +{} diff --git a/templates/GenericTemplate.hs b/templates/GenericTemplate.hs new file mode 100644 --- /dev/null +++ b/templates/GenericTemplate.hs @@ -0,0 +1,221 @@ +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +#ifdef ALEX_GHC +#define ILIT(n) n# +#define IBOX(n) (I# (n)) +#define FAST_INT Int# +#define LT(n,m) (n <# m) +#define GTE(n,m) (n >=# m) +#define EQ(n,m) (n ==# m) +#define PLUS(n,m) (n +# m) +#define MINUS(n,m) (n -# m) +#define TIMES(n,m) (n *# m) +#define NEGATE(n) (negateInt# (n)) +#define IF_GHC(x) (x) +#else +#define ILIT(n) (n) +#define IBOX(n) (n) +#define FAST_INT Int +#define LT(n,m) (n < m) +#define GTE(n,m) (n >= m) +#define EQ(n,m) (n == m) +#define PLUS(n,m) (n + m) +#define MINUS(n,m) (n - m) +#define TIMES(n,m) (n * m) +#define NEGATE(n) (negate (n)) +#define IF_GHC(x) +#endif + +#ifdef ALEX_GHC +#undef __GLASGOW_HASKELL__ +#define ALEX_IF_GHC_GT_500 #if __GLASGOW_HASKELL__ > 500 +#define ALEX_IF_GHC_LT_503 #if __GLASGOW_HASKELL__ < 503 +#define ALEX_ELIF_GHC_500 #elif __GLASGOW_HASKELL__ == 500 +#define ALEX_IF_BIGENDIAN #ifdef WORDS_BIGENDIAN +#define ALEX_ELSE #else +#define ALEX_ENDIF #endif +#endif + +#ifdef ALEX_GHC +data AlexAddr = AlexA# Addr# + +ALEX_IF_GHC_LT_503 +uncheckedShiftL# = shiftL# +ALEX_ENDIF + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr (AlexA# arr) off = +ALEX_IF_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +ALEX_ELSE + indexInt16OffAddr# arr off +ALEX_ENDIF +#else +alexIndexInt16OffAddr arr off = arr ! off +#endif + +#ifdef ALEX_GHC +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr (AlexA# arr) off = +ALEX_IF_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +ALEX_ELSE + indexInt32OffAddr# arr off +ALEX_ENDIF +#else +alexIndexInt32OffAddr arr off = arr ! off +#endif + +#ifdef ALEX_GHC +ALEX_IF_GHC_LT_503 +quickIndex arr i = arr ! i +ALEX_ELSE +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +ALEX_ENDIF +#else +quickIndex arr i = arr ! i +#endif + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input IBOX(sc) + = alexScanUser undefined input IBOX(sc) + +alexScanUser user input IBOX(sc) + = case alex_scan_tkn user input ILIT(0) input sc AlexNone of + (AlexNone, input') -> + case alexGetChar input of + Nothing -> +#ifdef ALEX_DEBUG + trace ("End of input.") $ +#endif + AlexEOF + Just _ -> +#ifdef ALEX_DEBUG + trace ("Error.") $ +#endif + AlexError input' + + (AlexLastSkip input len, _) -> +#ifdef ALEX_DEBUG + trace ("Skipping.") $ +#endif + AlexSkip input len + + (AlexLastAcc k input len, _) -> +#ifdef ALEX_DEBUG + trace ("Accept.") $ +#endif + AlexToken input len k + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user orig_input len input s last_acc = + input `seq` -- strict in the input + let + new_acc = check_accs (alex_accept `quickIndex` IBOX(s)) + in + new_acc `seq` + case alexGetChar input of + Nothing -> (new_acc, input) + Just (c, new_input) -> +#ifdef ALEX_DEBUG + trace ("State: " ++ show IBOX(s) ++ ", char: " ++ show c) $ +#endif + let + base = alexIndexInt32OffAddr alex_base s + IBOX(ord_c) = ord c + offset = PLUS(base,ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if GTE(offset,ILIT(0)) && EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + ILIT(-1) -> (new_acc, input) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user orig_input PLUS(len,ILIT(1)) + new_input new_s new_acc + + where + check_accs [] = last_acc + check_accs (AlexAcc a : _) = AlexLastAcc a input IBOX(len) + check_accs (AlexAccSkip : _) = AlexLastSkip input IBOX(len) + check_accs (AlexAccPred a pred : rest) + | pred user orig_input IBOX(len) input + = AlexLastAcc a input IBOX(len) + check_accs (AlexAccSkipPred pred : rest) + | pred user orig_input IBOX(len) input + = AlexLastSkip input IBOX(len) + check_accs (_ : rest) = check_accs rest + +data AlexLastAcc a + = AlexNone + | AlexLastAcc a !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc a user + = AlexAcc a + | AlexAccSkip + | AlexAccPred a (AlexAccPred user) + | AlexAccSkipPred (AlexAccPred user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user in1 len in2 + = p1 user in1 len in2 && p2 user in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext IBOX(sc) user _ _ input = + case alex_scan_tkn user input ILIT(0) input sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + +-- used by wrappers +iUnbox IBOX(i) = i diff --git a/templates/Makefile b/templates/Makefile new file mode 100644 --- /dev/null +++ b/templates/Makefile @@ -0,0 +1,67 @@ +TOP = .. +include $(TOP)/mk/boilerplate.mk + +TEMPLATES = \ + AlexTemplate \ + AlexTemplate-ghc \ + AlexTemplate-ghc-debug \ + AlexTemplate-debug \ + AlexWrapper-basic \ + AlexWrapper-posn \ + AlexWrapper-monad \ + AlexWrapper-gscan + +GENERIC_TEMPLATE = GenericTemplate.hs +EXCLUDED_SRCS = $(GENERIC_TEMPLATE) wrappers.hs + +INSTALL_DATAS = $(TEMPLATES) + +all :: $(TEMPLATES) + +override datadir = $(libdir) + +ghc_411_at_least = $(shell expr "$(GhcMajVersion)" = 4 \& \ + "$(GhcMinVersion)" \>= 11 \| \ + "$(GhcMajVersion)" \> 4) + +ifeq "$(ghc_411_at_least)" "1" +CPP_IT = $(GHC) -E -cpp -o +else +CPP_IT = $(GHC) -E -cpp > +endif + +AlexTemplate.hspp : $(GENERIC_TEMPLATE) + $(CPP_IT) $@ $(GENERIC_TEMPLATE) + +AlexTemplate-ghc.hspp : $(GENERIC_TEMPLATE) + $(CPP_IT) $@ -DALEX_GHC $(GENERIC_TEMPLATE) + +AlexTemplate-ghc-debug.hspp : $(GENERIC_TEMPLATE) + $(CPP_IT) $@ -DALEX_GHC -DALEX_DEBUG $(GENERIC_TEMPLATE) + +AlexTemplate-debug.hspp : $(GENERIC_TEMPLATE) + $(CPP_IT) $@ -DALEX_DEBUG $(GENERIC_TEMPLATE) + +AlexTemplate-monad.hspp : $(GENERIC_TEMPLATE) + $(CPP_IT) $@ -DALEX_MONAD $(GENERIC_TEMPLATE) + +AlexWrapper-basic.hspp : wrappers.hs + $(CPP_IT) $@ -DALEX_BASIC $< + +AlexWrapper-posn.hspp : wrappers.hs + $(CPP_IT) $@ -DALEX_POSN $< + +AlexWrapper-monad.hspp : wrappers.hs + $(CPP_IT) $@ -DALEX_MONAD $< + +AlexWrapper-gscan.hspp : wrappers.hs + $(CPP_IT) $@ -DALEX_GSCAN $< + +# hack to turn cpp-style '# 27 "GenericTemplate.hs"' into +# '{-# LINE 27 "GenericTemplate.hs" #-}'. +% : %.hspp + perl -pe 's/^#\s+(\d+)\s+(\"[^\"]*\")/{-# LINE \1 \2 #-}/g;s/\$$(Id:.*)\$$/\1/g' < $< > $@ + +CLEAN_FILES += $(TEMPLATES) $(patsubst %, %.hspp, $(TEMPLATES)) + +include $(TOP)/mk/target.mk diff --git a/templates/wrappers.hs b/templates/wrappers.hs new file mode 100644 --- /dev/null +++ b/templates/wrappers.hs @@ -0,0 +1,180 @@ +-- ----------------------------------------------------------------------------- +-- Alex wrapper code. +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- The input type + +#if defined(ALEX_POSN) || defined(ALEX_MONAD) || defined(ALEX_GSCAN) +type AlexInput = (AlexPosn, -- current position, + Char, -- previous char + String) -- current input string + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p,c,s) = c + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (p,c,[]) = Nothing +alexGetChar (p,_,(c:s)) = let p' = alexMove p c in p' `seq` + Just (c, (p', c, s)) + +-- ----------------------------------------------------------------------------- +-- Token positions + +-- `Posn' records the location of a token in the input text. It has three +-- fields: the address (number of chacaters preceding the token), line number +-- and column of a token within the file. `start_pos' gives the position of the +-- start of the file and `eof_pos' a standard encoding for the end of file. +-- `move_pos' calculates the new position after traversing a given character, +-- assuming the usual eight character tab stops. + +data AlexPosn = AlexPn !Int !Int !Int + deriving (Eq,Show) + +alexStartPos :: AlexPosn +alexStartPos = AlexPn 0 1 1 + +alexMove :: AlexPosn -> Char -> AlexPosn +alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+7) `div` 8)*8+1) +alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1) 1 +alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) +#endif + +-- ----------------------------------------------------------------------------- +-- Default monad + +#ifdef ALEX_MONAD +data AlexState = AlexState { + alex_pos :: !AlexPosn, -- position at current input location + alex_inp :: String, -- the current input + alex_chr :: !Char, -- the character before the input + alex_scd :: !Int -- the current startcode + } + +-- Compile with -funbox-strict-fields for best results! + +runAlex :: String -> Alex a -> Either String a +runAlex input (Alex f) + = case f (AlexState {alex_pos = alexStartPos, + alex_inp = input, + alex_chr = '\n', + alex_scd = 0}) of Left msg -> Left msg + Right ( _, a ) -> Right a + +newtype Alex a = Alex { unAlex :: AlexState -> Either String (AlexState, a) } + +instance Monad Alex where + m >>= k = Alex $ \s -> case unAlex m s of + Left msg -> Left msg + Right (s',a) -> unAlex (k a) s' + return a = Alex $ \s -> Right (s,a) + +alexGetInput :: Alex AlexInput +alexGetInput + = Alex $ \s@AlexState{alex_pos=pos,alex_chr=c,alex_inp=inp} -> + Right (s, (pos,c,inp)) + +alexSetInput :: AlexInput -> Alex () +alexSetInput (pos,c,inp) + = Alex $ \s -> case s{alex_pos=pos,alex_chr=c,alex_inp=inp} of + s@(AlexState{}) -> Right (s, ()) + +alexError :: String -> Alex a +alexError message = Alex $ \s -> Left message + +alexGetStartCode :: Alex Int +alexGetStartCode = Alex $ \s@AlexState{alex_scd=sc} -> Right (s, sc) + +alexSetStartCode :: Int -> Alex () +alexSetStartCode sc = Alex $ \s -> Right (s{alex_scd=sc}, ()) + +alexMonadScan = do + inp <- alexGetInput + sc <- alexGetStartCode + case alexScan inp sc of + AlexEOF -> alexEOF + AlexError inp' -> alexError "lexical error" + AlexSkip inp' len -> do + alexSetInput inp' + alexMonadScan + AlexToken inp' len action -> do + alexSetInput inp' + action inp len + +-- ----------------------------------------------------------------------------- +-- Useful token actions + +type AlexAction result = AlexInput -> Int -> result + +-- just ignore this token and scan another one +-- skip :: AlexAction result +skip input len = alexMonadScan + +-- ignore this token, but set the start code to a new value +-- begin :: Int -> AlexAction result +begin code input len = do alexSetStartCode code; alexMonadScan + +-- perform an action for this token, and set the start code to a new value +-- andBegin :: AlexAction result -> Int -> AlexAction result +(action `andBegin` code) input len = do alexSetStartCode code; action input len + +-- token :: (String -> Int -> token) -> AlexAction token +token t input len = return (t input len) +#endif /* ALEX_MONAD */ + +-- ----------------------------------------------------------------------------- +-- Basic wrapper + +#ifdef ALEX_BASIC +type AlexInput = (Char,String) + +alexGetChar (_, []) = Nothing +alexGetChar (_, c:cs) = Just (c, (c,cs)) + +alexInputPrevChar (c,_) = c + +-- alexScanTokens :: String -> [token] +alexScanTokens str = go ('\n',str) + where go inp@(_,str) = + case alexScan inp 0 of + AlexEOF -> [] + AlexError _ -> error "lexical error" + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act (take len str) : go inp' +#endif + +-- ----------------------------------------------------------------------------- +-- Posn wrapper + +-- Adds text positions to the basic model. + +#ifdef ALEX_POSN +--alexScanTokens :: String -> [token] +alexScanTokens str = go (alexStartPos,'\n',str) + where go inp@(pos,_,str) = + case alexScan inp 0 of + AlexEOF -> [] + AlexError _ -> error "lexical error" + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act pos (take len str) : go inp' +#endif + +-- ----------------------------------------------------------------------------- +-- GScan wrapper + +-- For compatibility with previous versions of Alex, and because we can. + +#ifdef ALEX_GSCAN +alexGScan stop state inp = alex_gscan stop alexStartPos '\n' inp (0,state) + +alex_gscan stop p c inp (sc,state) = + case alexScan (p,c,inp) sc of + AlexEOF -> stop p c inp (sc,state) + AlexError _ -> stop p c inp (sc,state) + AlexSkip (p',c',inp') len -> alex_gscan stop p' c' inp' (sc,state) + AlexToken (p',c',inp') len k -> + k p c inp len (\scs -> alex_gscan stop p' c' inp' scs) + (sc,state) +#endif diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 --- /dev/null +++ b/tests/Makefile @@ -0,0 +1,39 @@ +TOP = .. +include $(TOP)/mk/boilerplate.mk + +.PRECIOUS: .hs .o .exe .bin + +ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32" +HS_PROG_EXT = .exe +else +HS_PROG_EXT = .bin +endif + + +TESTS = simple.x tokens.x tokens_posn.x tokens_gscan.x + +ALEX=../src/alex-inplace + +%.n.hs : %.x + $(ALEX) $(TEST_ALEX_OPTS) $< -o $@ + +%.g.hs : %.x + $(ALEX) $(TEST_ALEX_OPTS) -g $< -o $@ + +CLEAN_FILES += *.n.hs *.g.hs *.info *.hi *.bin *.exe + +ALL_TEST_HS = $(shell echo $(TESTS) | sed -e 's/\([^\. ]*\)\.\(l\)\{0,1\}x/\1.n.hs \1.g.hs/g') + +ALL_TESTS = $(patsubst %.hs, %.run, $(ALL_TEST_HS)) + +HC_OPTS += -fglasgow-exts -package lang + +%.run : %$(HS_PROG_EXT) + ./$< + +%$(HS_PROG_EXT) : %.o + $(HC) $(HC_OPTS) $($*_LD_OPTS) $< -o $@ + +all :: $(ALL_TESTS) + +include $(TOP)/mk/target.mk diff --git a/tests/simple.x b/tests/simple.x new file mode 100644 --- /dev/null +++ b/tests/simple.x @@ -0,0 +1,73 @@ +{ +-- Tests the basic operation. +module Main where + +import Data.Char (toUpper) +import Control.Monad +import System.Exit +import System.IO +} + +%wrapper "monad" + +@word = [A-Za-z]+ + +tokens :- + +$white+ ; + +<0> { + "magic" { magic } -- should override later patterns + ^ @word $ { both } -- test both trailing and left context + @word $ { eol } -- test trailing context + ^ @word { bol } -- test left context + @word { word } +} + +<0> \( { begin parens } + [A-Za-z]+ { parenword } + \) { begin 0 } + +{ +{- we can now have comments in source code? -} +word (p,_,input) len = return (take len input) + +both (p,_,input) len = return ("BOTH:"++ take len input) + +eol (p,_,input) len = return ("EOL:"++ take len input) + +bol (p,_,input) len = return ("BOL:"++ take len input) + +parenword (p,_,input) len = return (map toUpper (take len input)) + +magic (p,_,input) len = return "PING!" + +alexEOF = return "stopped." + +scanner str = runAlex str $ do + let loop = do tok <- alexMonadScan + if tok == "stopped." || tok == "error." + then return [tok] + else do toks <- loop + return (tok:toks) + loop + +main = do + let test1 = scanner str1 + when (test1 /= out1) $ + do hPutStrLn stderr "Test 1 failed:" + print test1 + exitFailure + + let test2 = scanner str2 + when (test2 /= out2) $ + do hPutStrLn stderr "Test 2 failed:" + print test2 + exitFailure + +str1 = "a b c (d e f) magic (magic) eol\nbol \nboth\n" +out1 = Right ["BOL:a","b","c","D","E","F","PING!","MAGIC","EOL:eol", "BOL:bol", "BOTH:both", "stopped."] + +str2 = "." +out2 = Left "lexical error" +} diff --git a/tests/tokens.x b/tests/tokens.x new file mode 100644 --- /dev/null +++ b/tests/tokens.x @@ -0,0 +1,40 @@ +{ +module Main (main) where +import System.Exit +} + +%wrapper "basic" + +$digit = 0-9 -- digits +$alpha = [a-zA-Z] -- alphabetic characters + +tokens :- + + $white+ ; + "--".* ; + let { \s -> Let } + in { \s -> In } + $digit+ { \s -> Int (read s) } + [\=\+\-\*\/\(\)] { \s -> Sym (head s) } + $alpha [$alpha $digit \_ \']* { \s -> Var s } + +{ +-- Each right-hand side has type :: String -> Token + +-- The token type: +data Token = + Let | + In | + Sym Char | + Var String | + Int Int | + Err + deriving (Eq,Show) + +main = if test1 /= result1 then exitFailure + else exitWith ExitSuccess + +test1 = alexScanTokens " let in 012334\n=+*foo bar__'" +result1 = [Let,In,Int 12334,Sym '=',Sym '+',Sym '*',Var "foo",Var "bar__'"] + +} diff --git a/tests/tokens_gscan.x b/tests/tokens_gscan.x new file mode 100644 --- /dev/null +++ b/tests/tokens_gscan.x @@ -0,0 +1,44 @@ +{ +module Main (main) where +import System.Exit +} + +%wrapper "gscan" + +$digit = 0-9 -- digits +$alpha = [a-zA-Z] -- alphabetic characters + +tokens :- + + $white+ ; + "--".* ; + let { tok (\p s -> Let p) } + in { tok (\p s -> In p) } + $digit+ { tok (\p s -> Int p (read s)) } + [\=\+\-\*\/\(\)] { tok (\p s -> Sym p (head s)) } + $alpha [$alpha $digit \_ \']* { tok (\p s -> Var p s) } + +{ +-- Some action helpers: +tok f p c str len cont (sc,state) = f p (take len str) : cont (sc,state) + +-- The token type: +data Token = + Let AlexPosn | + In AlexPosn | + Sym AlexPosn Char | + Var AlexPosn String | + Int AlexPosn Int | + Err AlexPosn + deriving (Eq,Show) + +main = if test1 /= result1 then exitFailure + else exitWith ExitSuccess + +test1 = alexGScan stop undefined " let in 012334\n=+*foo bar__'" + +stop p c "" (sc,s) = [] +stop p c _ (sc,s) = error "lexical error" + +result1 = [Let (AlexPn 2 1 3),In (AlexPn 6 1 7),Int (AlexPn 9 1 10) 12334,Sym (AlexPn 16 2 1) '=',Sym (AlexPn 17 2 2) '+',Sym (AlexPn 18 2 3) '*',Var (AlexPn 19 2 4) "foo",Var (AlexPn 23 2 8) "bar__'"] +} diff --git a/tests/tokens_posn.x b/tests/tokens_posn.x new file mode 100644 --- /dev/null +++ b/tests/tokens_posn.x @@ -0,0 +1,44 @@ +{ +module Main (main) where +import System.Exit +} + +%wrapper "posn" + +$digit = 0-9 -- digits +$alpha = [a-zA-Z] -- alphabetic characters + +tokens :- + + $white+ ; + "--".* ; + let { tok (\p s -> Let p) } + in { tok (\p s -> In p) } + $digit+ { tok (\p s -> Int p (read s)) } + [\=\+\-\*\/\(\)] { tok (\p s -> Sym p (head s)) } + $alpha [$alpha $digit \_ \']* { tok (\p s -> Var p s) } + +{ +-- Each right-hand side has type :: AlexPosn -> String -> Token + +-- Some action helpers: +tok f p s = f p s + +-- The token type: +data Token = + Let AlexPosn | + In AlexPosn | + Sym AlexPosn Char | + Var AlexPosn String | + Int AlexPosn Int | + Err AlexPosn + deriving (Eq,Show) + +main = if test1 /= result1 then exitFailure + else exitWith ExitSuccess + +test1 = alexScanTokens " let in 012334\n=+*foo bar__'" +result1 = [Let (AlexPn 2 1 3),In (AlexPn 6 1 7),Int (AlexPn 9 1 10) 12334,Sym (AlexPn 16 2 1) '=',Sym (AlexPn 17 2 2) '+',Sym (AlexPn 18 2 3) '*',Var (AlexPn 19 2 4) "foo",Var (AlexPn 23 2 8) "bar__'"] + + +}