BNFC-2.8.1/0000755000000000000000000000000012654616013010424 5ustar0000000000000000BNFC-2.8.1/Setup.lhs0000644000000000000000000000015512654616013012235 0ustar0000000000000000#!/usr/bin/env runghc
> module Main where
> import Distribution.Simple
> main :: IO ()
> main = defaultMain
BNFC-2.8.1/changelog0000644000000000000000000000256612654616013012307 0ustar00000000000000002.8 Grégoire Détrez May 2015
* Builds with ghc 7.10.1
* Add support for JFlex (java)
* Add an option to generate files in an other directory
* Add an experimental option that turns the AST into a parametrized
functor (in Haskell only)
* New pygment backend to generate syntax highlighters
* Bug fixes
2.7.1 Grégoire Détrez October 2014
* Generated haskell code is now warning free
* Removed unused terminal in happy
* Correctly escape backslashes in symbols
* Fix problem that was preventing custom tokens to work in OCaml if
they conflict with the build-in Ident
* BNFC build is also warning free (ghc 7.4.2)
* Test programs return non-zerro exit code on parse error
2.7.0.0 Grégoire Détrez September 2014
* Add token support for Ocaml
* New option parser
* Adds an optional argument to change Makefile name
* Add a --ghc option to derive Data, Typeable, Generic in Haskell
* New online documentation (https://bnfc.readthedocs.org)
* Derive ``Read`` for newtype decls in Haskell
* New option to get the version number --version
* Remove the F# backend
* Remove the Java4 backend
* New Applicative and Alternative instances to ``Err``
* Remove the coupling between building the parser and the pdf from
latex
* Improvement to the CNF Backend
* Bug fixes #92, #21, #34, #33, #90, #30, #60
BNFC-2.8.1/TODO0000644000000000000000000000572512654616013011125 0ustar0000000000000000Build:
- autoconf
- verify Alex version.
- tidy up Makefiles a bit
- and the generated ones too.
- Use "Makefile" everywhere.
- follow UNIX conventions...
Functionality:
- Add Bool type.
Bugs:
- Strange unicode space.
- Bison only supports 1 parser per input file.
- Write some clear docs on the Java backend.
- Java backend (and probably others)
- Need to munge Java keywords like "abstract" "private"
- Alfa.cf, C.cf fail to compile for this reason.
- I think I fixed this, but it should be verified (peteg)
- Add a message on how to run the test file (after a succesful compliation),
e.g. :
"to run the test, type : java JavaletteLight/Test "
Compilers:
- write a JavaCup script
Bug Reports:
--------------
> Fail: formats/java/CFtoJavaPrinter.hs:269: Non-exhaustive patterns in function> getCons
on Prolog.cf
Reason: No separator for a list. The same happens in C and C++.
> In Skeleton.c the visit-functions for lists has the wrong variable for
> visiting the
> list elements. It says "visitNAME(LISTNAME->LISTNAME)" but it should be
> "visitNAME(LISTNAME->NAME)".
>
> The parse tree printer and pretty printer writes a newline instead of "\n"
> for
> strings.
--------------
Java backend
If a terminal and non-terminal have the same name, there is a name clash in
the generarted .java files.
Solution: don't do this.
See C.cf for an example. Alfa.cf doesn't work either.
- "separator", etc. decs don't play nice.
- the list stuff is emitted before the top-level non-terminal.
- need to specify which non-terminal is the top-level one.
- i.e. a "start with" line must be present.
- BNFC now crashes if you don't specify an "entrypoint" pragma,
or use more than one.
Somewhere along the line of BNFC/jlex/jcup the BNFC comment-instruction
(comment "/*" "*/" ;) seems to fail. A file containing only an opening
of a comment manages to pass the parser without any trouble.
--------------
Aarne, Java:
to get "parse successful" is fast, but then it takes
quite some time to pretty-print
the parser gets confused with isolatin characters included
in string literals
Michael:
http://www.cs.princeton.edu/~appel/modern/java/JLex/current/manual.html#SECTION2.2.14
--------------
Antti-Juhani Kaijanaho:
- A token UIdent declaration (see report) causes a mysterious parse
error at end of file / perhaps conflicts with predefined Ident?
- If I use "\\/" in a production, Happy is unhappy (you use \/ as the
Happy token)
- You generate Alex 1.x source. Could you make it (optionally?)
generate Alex 2.x source?
Oh, and bnfc returns an exit code indicating success even when there is
an error.
--------------
Bjorn Bringert:
- Specifying coercions etc. for non-existing categories should
probably be an error.
- Repeated identical rules should be an error.
- Java CUP back end does not support multiple entrypoints.
--------------
Software versions:
ghc 5.04.x
bison 1.875a
flex 2.5.31
alex 2.0
happy 1.13
--------------
BNFC-2.8.1/BNFC.cabal0000644000000000000000000001414712654616013012127 0ustar0000000000000000Name: BNFC
Version: 2.8.1
cabal-version: >= 1.8
build-type: Simple
category: Development
Copyright: (c) Krasimir Angelov, Jean-Philippe Bernardy, Bjorn Bringert, Johan Broberg, Paul Callaghan, Markus Forsberg, Ola Frid, Peter Gammie, Patrik Jansson, Kristofer Johannisson, Antti-Juhani Kaijanaho, Ulf Norell, Michael Pellauer and Aarne Ranta 2002 - 2012. Free software under GNU General Public License (GPL).
License: GPL-2
License-File: LICENSE
Maintainer: bnfc-dev@googlegroups.com
Homepage: http://bnfc.digitalgrammars.com/
bug-reports: https://github.com/BNFC/bnfc/issues
Synopsis: A compiler front-end generator.
Description:
The BNF Converter is a compiler construction tool generating a compiler front-end
from a Labelled BNF grammar. It was originally written to generate Haskell,
but starting from Version 2.0, it can also be used for generating Java, C++, and C.
.
Given a Labelled BNF grammar the tool produces:
an abstract syntax as a Haskell/C++/C module or Java directory,
a case skeleton for the abstract syntax in the same language,
an Alex, JLex, or Flex lexer generator file,
a Happy, CUP, or Bison parser generator file,
a pretty-printer as a Haskell/Java/C++/C module,
a Latex file containing a readable specification of the language.
Extra-source-files: src/BNF.cf TODO changelog
Source-repository head
type: git
location: https://github.com/BNFC/bnfc.git
subdir: source
Library
hs-source-dirs: runtime, src
Build-Depends: base>=4.4 && <5, array
exposed-modules:
Algebra.RingUtils
Data.Pair
Data.Matrix.Quad
Data.Matrix.Class
Parsing.Chart
Parsing.TestProgram
Executable bnfc
Build-Depends:
base>=4.4 && <5,
mtl,
directory,
array,
process,
containers,
pretty >=1.1 && <1.2,
filepath,
deepseq
build-tools: alex, happy
Main-is: Main.hs
HS-source-dirs: src/
ghc-options: -W
extensions: OverloadedStrings RecordWildCards FlexibleContexts
Other-modules:
-- generated by cabal
Paths_BNFC,
-- Generated by bnfc
LexBNF,
ParBNF,
AbsBNF,
PrintBNF,
ErrM,
-- BNFC core
BNFC.Utils,
BNFC.CF,
BNFC.ToCNFCore,
BNFC.MultiView,
BNFC.TypeChecker,
BNFC.GetCF,
BNFC.Lexing,
BNFC.Backend.Base
BNFC.Backend.Common,
BNFC.Backend.Common.Makefile,
BNFC.Backend.Common.NamedVariables,
BNFC.Backend.Common.OOAbstract,
BNFC.Backend.Common.StrUtils,
BNFC.Options,
BNFC.WarningM,
Data.Pair,
BNFC.Backend.Utils,
BNFC.PrettyPrint,
-- Documentation backends
BNFC.Backend.Latex,
BNFC.Backend.Txt2Tag,
-- Haskell backend
BNFC.Backend.Haskell,
BNFC.Backend.Haskell.ToCNF,
BNFC.Backend.Haskell.RegToAlex,
BNFC.Backend.Haskell.CFtoTemplate,
BNFC.Backend.Haskell.CFtoAlex3,
BNFC.Backend.Haskell.CFtoAlex2,
BNFC.Backend.Haskell.CFtoAlex,
BNFC.Backend.Haskell.CFtoHappy,
BNFC.Backend.Haskell.CFtoPrinter,
BNFC.Backend.Haskell.CFtoAbstract,
BNFC.Backend.Haskell.CFtoLayout,
BNFC.Backend.Haskell.MkErrM,
BNFC.Backend.Haskell.MkSharedString,
BNFC.Backend.Haskell.HsOpts,
BNFC.Backend.Haskell.Utils,
-- Profile
BNFC.Backend.HaskellProfile,
BNFC.Backend.HaskellProfile.CFtoHappyProfile,
-- Haskell GADT
BNFC.Backend.HaskellGADT,
BNFC.Backend.HaskellGADT.HaskellGADTCommon,
BNFC.Backend.HaskellGADT.CFtoTemplateGADT,
BNFC.Backend.HaskellGADT.CFtoAbstractGADT,
-- O'Caml backend
BNFC.Backend.OCaml,
BNFC.Backend.OCaml.OCamlUtil,
BNFC.Backend.OCaml.CFtoOCamlTest,
BNFC.Backend.OCaml.CFtoOCamlShow,
BNFC.Backend.OCaml.CFtoOCamlPrinter,
BNFC.Backend.OCaml.CFtoOCamlTemplate,
BNFC.Backend.OCaml.CFtoOCamlAbs,
BNFC.Backend.OCaml.CFtoOCamlYacc,
BNFC.Backend.OCaml.CFtoOCamlLex,
-- C backend
BNFC.Backend.C,
BNFC.Backend.C.CFtoCPrinter,
BNFC.Backend.C.CFtoCSkel,
BNFC.Backend.C.CFtoBisonC,
BNFC.Backend.C.CFtoFlexC,
BNFC.Backend.C.CFtoCAbs,
BNFC.Backend.CPP.NoSTL.CFtoCVisitSkel,
-- C++ backend
BNFC.Backend.CPP.NoSTL,
BNFC.Backend.CPP.PrettyPrinter,
BNFC.Backend.CPP.NoSTL.RegToFlex,
BNFC.Backend.CPP.NoSTL.CFtoFlex,
BNFC.Backend.CPP.NoSTL.CFtoBison,
BNFC.Backend.CPP.NoSTL.CFtoCPPAbs,
-- C++ STL backend
BNFC.Backend.CPP.STL,
BNFC.Backend.CPP.STL.CFtoBisonSTL,
BNFC.Backend.CPP.STL.CFtoSTLAbs,
BNFC.Backend.CPP.STL.STLUtils,
BNFC.Backend.CPP.STL.CFtoCVisitSkelSTL,
-- C# backend
BNFC.Backend.CSharp,
BNFC.Backend.CSharp.RegToGPLEX,
BNFC.Backend.CSharp.CFtoGPLEX,
BNFC.Backend.CSharp.CSharpUtils,
BNFC.Backend.CSharp.CFtoCSharpPrinter,
BNFC.Backend.CSharp.CAbstoCSharpAbs,
BNFC.Backend.CSharp.CAbstoCSharpAbstractVisitSkeleton,
BNFC.Backend.CSharp.CAbstoCSharpVisitSkeleton,
BNFC.Backend.CSharp.CFtoGPPG,
-- Java backend
BNFC.Backend.Java
BNFC.Backend.Java.CFtoJavaAbs15,
BNFC.Backend.Java.CFtoAllVisitor,
BNFC.Backend.Java.CFtoFoldVisitor,
BNFC.Backend.Java.CFtoAbstractVisitor,
BNFC.Backend.Java.CFtoComposVisitor,
BNFC.Backend.Java.CFtoVisitSkel15,
BNFC.Backend.Java.CFtoJavaPrinter15,
BNFC.Backend.Java.CFtoJLex15,
BNFC.Backend.Java.CFtoCup15,
BNFC.Backend.Java.RegToJLex
-- XML backend
BNFC.Backend.XML
-- Pygments backend
BNFC.Backend.Pygments
-- --- Testing --------------------------------------------------------------
Test-suite unit-tests
Type: exitcode-stdio-1.0
Build-Depends: base>=4 && <5, mtl, directory, array, process, filepath, pretty,
hspec, QuickCheck >= 2.5, HUnit,
temporary, containers, deepseq
Main-is: unit-tests.hs
HS-source-dirs: src test
extensions: OverloadedStrings RecordWildCards FlexibleContexts
Other-modules:
BNFC.Backend.Common.MakefileSpec
BNFC.Backend.Haskell.CFtoHappySpec
BNFC.Backend.HaskellGADTSpec
BNFC.Backend.HaskellSpec
BNFC.OptionsSpec
BNFC.WarningMSpec
-- need to be there for alex to work
LexBNF
ParBNF
Test-suite bnfc-doctests
type: exitcode-stdio-1.0
ghc-options: -threaded
main-is: doctests.hs
build-depends: base, doctest >= 0.8
HS-source-dirs: test
BNFC-2.8.1/LICENSE0000644000000000000000000004313112654616013011433 0ustar0000000000000000 GNU GENERAL PUBLIC LICENSE
Version 2, June 1991
Copyright (C) 1989, 1991 Free Software Foundation, Inc.
59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The licenses for most software are designed to take away your
freedom to share and change it. By contrast, the GNU General Public
License is intended to guarantee your freedom to share and change free
software--to make sure the software is free for all its users. This
General Public License applies to most of the Free Software
Foundation's software and to any other program whose authors commit to
using it. (Some other Free Software Foundation software is covered by
the GNU Library General Public License instead.) You can apply it to
your programs, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
this service if you wish), that you receive source code or can get it
if you want it, that you can change the software or use pieces of it
in new free programs; and that you know you can do these things.
To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if you
distribute copies of the software, or if you modify it.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must give the recipients all the rights that
you have. You must make sure that they, too, receive or can get the
source code. And you must show them these terms so they know their
rights.
We protect your rights with two steps: (1) copyright the software, and
(2) offer you this license which gives you legal permission to copy,
distribute and/or modify the software.
Also, for each author's protection and ours, we want to make certain
that everyone understands that there is no warranty for this free
software. If the software is modified by someone else and passed on, we
want its recipients to know that what they have is not the original, so
that any problems introduced by others will not reflect on the original
authors' reputations.
Finally, any free program is threatened constantly by software
patents. We wish to avoid the danger that redistributors of a free
program will individually obtain patent licenses, in effect making the
program proprietary. To prevent this, we have made it clear that any
patent must be licensed for everyone's free use or not licensed at all.
The precise terms and conditions for copying, distribution and
modification follow.
GNU GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License applies to any program or other work which contains
a notice placed by the copyright holder saying it may be distributed
under the terms of this General Public License. The "Program", below,
refers to any such program or work, and a "work based on the Program"
means either the Program or any derivative work under copyright law:
that is to say, a work containing the Program or a portion of it,
either verbatim or with modifications and/or translated into another
language. (Hereinafter, translation is included without limitation in
the term "modification".) Each licensee is addressed as "you".
Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope. The act of
running the Program is not restricted, and the output from the Program
is covered only if its contents constitute a work based on the
Program (independent of having been made by running the Program).
Whether that is true depends on what the Program does.
1. You may copy and distribute verbatim copies of the Program's
source code as you receive it, in any medium, provided that you
conspicuously and appropriately publish on each copy an appropriate
copyright notice and disclaimer of warranty; keep intact all the
notices that refer to this License and to the absence of any warranty;
and give any other recipients of the Program a copy of this License
along with the Program.
You may charge a fee for the physical act of transferring a copy, and
you may at your option offer warranty protection in exchange for a fee.
2. You may modify your copy or copies of the Program or any portion
of it, thus forming a work based on the Program, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:
a) You must cause the modified files to carry prominent notices
stating that you changed the files and the date of any change.
b) You must cause any work that you distribute or publish, that in
whole or in part contains or is derived from the Program or any
part thereof, to be licensed as a whole at no charge to all third
parties under the terms of this License.
c) If the modified program normally reads commands interactively
when run, you must cause it, when started running for such
interactive use in the most ordinary way, to print or display an
announcement including an appropriate copyright notice and a
notice that there is no warranty (or else, saying that you provide
a warranty) and that users may redistribute the program under
these conditions, and telling the user how to view a copy of this
License. (Exception: if the Program itself is interactive but
does not normally print such an announcement, your work based on
the Program is not required to print an announcement.)
These requirements apply to the modified work as a whole. If
identifiable sections of that work are not derived from the Program,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works. But when you
distribute the same sections as part of a whole which is a work based
on the Program, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote it.
Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Program.
In addition, mere aggregation of another work not based on the Program
with the Program (or with a work based on the Program) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.
3. You may copy and distribute the Program (or a work based on it,
under Section 2) in object code or executable form under the terms of
Sections 1 and 2 above provided that you also do one of the following:
a) Accompany it with the complete corresponding machine-readable
source code, which must be distributed under the terms of Sections
1 and 2 above on a medium customarily used for software interchange; or,
b) Accompany it with a written offer, valid for at least three
years, to give any third party, for a charge no more than your
cost of physically performing source distribution, a complete
machine-readable copy of the corresponding source code, to be
distributed under the terms of Sections 1 and 2 above on a medium
customarily used for software interchange; or,
c) Accompany it with the information you received as to the offer
to distribute corresponding source code. (This alternative is
allowed only for noncommercial distribution and only if you
received the program in object code or executable form with such
an offer, in accord with Subsection b above.)
The source code for a work means the preferred form of the work for
making modifications to it. For an executable work, complete source
code means all the source code for all modules it contains, plus any
associated interface definition files, plus the scripts used to
control compilation and installation of the executable. However, as a
special exception, the source code distributed need not include
anything that is normally distributed (in either source or binary
form) with the major components (compiler, kernel, and so on) of the
operating system on which the executable runs, unless that component
itself accompanies the executable.
If distribution of executable or object code is made by offering
access to copy from a designated place, then offering equivalent
access to copy the source code from the same place counts as
distribution of the source code, even though third parties are not
compelled to copy the source along with the object code.
4. You may not copy, modify, sublicense, or distribute the Program
except as expressly provided under this License. Any attempt
otherwise to copy, modify, sublicense or distribute the Program is
void, and will automatically terminate your rights under this License.
However, parties who have received copies, or rights, from you under
this License will not have their licenses terminated so long as such
parties remain in full compliance.
5. You are not required to accept this License, since you have not
signed it. However, nothing else grants you permission to modify or
distribute the Program or its derivative works. These actions are
prohibited by law if you do not accept this License. Therefore, by
modifying or distributing the Program (or any work based on the
Program), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Program or works based on it.
6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the
original licensor to copy, distribute or modify the Program subject to
these terms and conditions. You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties to
this License.
7. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Program at all. For example, if a patent
license would not permit royalty-free redistribution of the Program by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Program.
If any portion of this section is held invalid or unenforceable under
any particular circumstance, the balance of the section is intended to
apply and the section as a whole is intended to apply in other
circumstances.
It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system, which is
implemented by public license practices. Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.
This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.
8. If the distribution and/or use of the Program is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Program under this License
may add an explicit geographical distribution limitation excluding
those countries, so that distribution is permitted only in or among
countries not thus excluded. In such case, this License incorporates
the limitation as if written in the body of this License.
9. The Free Software Foundation may publish revised and/or new versions
of the General Public License from time to time. Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.
Each version is given a distinguishing version number. If the Program
specifies a version number of this License which applies to it and "any
later version", you have the option of following the terms and conditions
either of that version or of any later version published by the Free
Software Foundation. If the Program does not specify a version number of
this License, you may choose any version ever published by the Free Software
Foundation.
10. If you wish to incorporate parts of the Program into other free
programs whose distribution conditions are different, write to the author
to ask for permission. For software which is copyrighted by the Free
Software Foundation, write to the Free Software Foundation; we sometimes
make exceptions for this. Our decision will be guided by the two goals
of preserving the free status of all derivatives of our free software and
of promoting the sharing and reuse of software generally.
NO WARRANTY
11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR OR CORRECTION.
12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.
Copyright (C)
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Also add information on how to contact you by electronic and paper mail.
If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:
Gnomovision version 69, Copyright (C) year name of author
Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License. Of course, the commands you use may
be called something other than `show w' and `show c'; they could even be
mouse-clicks or menu items--whatever suits your program.
You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the program, if
necessary. Here is a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright interest in the program
`Gnomovision' (which makes passes at compilers) written by James Hacker.
, 1 April 1989
Ty Coon, President of Vice
This General Public License does not permit incorporating your program into
proprietary programs. If your program is a subroutine library, you may
consider it more useful to permit linking proprietary applications with the
library. If this is what you want to do, use the GNU Library General
Public License instead of this License.
BNFC-2.8.1/src/0000755000000000000000000000000012654616013011213 5ustar0000000000000000BNFC-2.8.1/src/PrintBNF.hs0000644000000000000000000002320612654616013013174 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module PrintBNF where
-- pretty-printer generated by the BNF converter
import AbsBNF
import Data.Char
-- the top-level printing method
printTree :: Print a => a -> String
printTree = render . prt 0
type Doc = [ShowS] -> [ShowS]
doc :: ShowS -> Doc
doc = (:)
render :: Doc -> String
render d = rend 0 (map ($ "") $ d []) "" where
rend i ss = case ss of
"[" :ts -> showChar '[' . rend i ts
"(" :ts -> showChar '(' . rend i ts
"{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts
"}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
"}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
";" :ts -> showChar ';' . new i . rend i ts
t : "," :ts -> showString t . space "," . rend i ts
t : ")" :ts -> showString t . showChar ')' . rend i ts
t : "]" :ts -> showString t . showChar ']' . rend i ts
t :ts -> space t . rend i ts
_ -> id
new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
space t = showString t . (\s -> if null s then "" else (' ':s))
parenth :: Doc -> Doc
parenth ss = doc (showChar '(') . ss . doc (showChar ')')
concatS :: [ShowS] -> ShowS
concatS = foldr (.) id
concatD :: [Doc] -> Doc
concatD = foldr (.) id
replicateS :: Int -> ShowS -> ShowS
replicateS n f = concatS (replicate n f)
-- the printer class does the job
class Print a where
prt :: Int -> a -> Doc
prtList :: [a] -> Doc
prtList = concatD . map (prt 0)
instance Print a => Print [a] where
prt _ = prtList
instance Print Char where
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
mkEsc :: Char -> Char -> ShowS
mkEsc q s = case s of
_ | s == q -> showChar '\\' . showChar s
'\\'-> showString "\\\\"
'\n' -> showString "\\n"
'\t' -> showString "\\t"
_ -> showChar s
prPrec :: Int -> Int -> Doc -> Doc
prPrec i j = if j (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Double where
prt _ x = doc (shows x)
instance Print Ident where
prt _ (Ident i) = doc (showString ( i))
prtList es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print LGrammar where
prt i e = case e of
LGr ldefs -> prPrec i 0 (concatD [prt 0 ldefs])
instance Print LDef where
prt i e = case e of
DefAll def -> prPrec i 0 (concatD [prt 0 def])
DefSome ids def -> prPrec i 0 (concatD [prt 0 ids , doc (showString ":") , prt 0 def])
LDefView ids -> prPrec i 0 (concatD [doc (showString "views") , prt 0 ids])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Grammar where
prt i e = case e of
Grammar defs -> prPrec i 0 (concatD [prt 0 defs])
instance Print Def where
prt i e = case e of
Rule label cat items -> prPrec i 0 (concatD [prt 0 label , doc (showString ".") , prt 0 cat , doc (showString "::=") , prt 0 items])
Comment str -> prPrec i 0 (concatD [doc (showString "comment") , prt 0 str])
Comments str0 str -> prPrec i 0 (concatD [doc (showString "comment") , prt 0 str0 , prt 0 str])
Internal label cat items -> prPrec i 0 (concatD [doc (showString "internal") , prt 0 label , doc (showString ".") , prt 0 cat , doc (showString "::=") , prt 0 items])
Token id reg -> prPrec i 0 (concatD [doc (showString "token") , prt 0 id , prt 0 reg])
PosToken id reg -> prPrec i 0 (concatD [doc (showString "position") , doc (showString "token") , prt 0 id , prt 0 reg])
Entryp ids -> prPrec i 0 (concatD [doc (showString "entrypoints") , prt 0 ids])
Separator minimumsize cat str -> prPrec i 0 (concatD [doc (showString "separator") , prt 0 minimumsize , prt 0 cat , prt 0 str])
Terminator minimumsize cat str -> prPrec i 0 (concatD [doc (showString "terminator") , prt 0 minimumsize , prt 0 cat , prt 0 str])
Delimiters cat str0 str separation minimumsize -> prPrec i 0 (concatD [doc (showString "delimiters") , prt 0 cat , prt 0 str0 , prt 0 str , prt 0 separation , prt 0 minimumsize])
Coercions id n -> prPrec i 0 (concatD [doc (showString "coercions") , prt 0 id , prt 0 n])
Rules id rhss -> prPrec i 0 (concatD [doc (showString "rules") , prt 0 id , doc (showString "::=") , prt 0 rhss])
Function id args exp -> prPrec i 0 (concatD [doc (showString "define") , prt 0 id , prt 0 args , doc (showString "=") , prt 0 exp])
Layout strs -> prPrec i 0 (concatD [doc (showString "layout") , prt 0 strs])
LayoutStop strs -> prPrec i 0 (concatD [doc (showString "layout") , doc (showString "stop") , prt 0 strs])
LayoutTop -> prPrec i 0 (concatD [doc (showString "layout") , doc (showString "toplevel")])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Item where
prt i e = case e of
Terminal str -> prPrec i 0 (concatD [prt 0 str])
NTerminal cat -> prPrec i 0 (concatD [prt 0 cat])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print Cat where
prt i e = case e of
ListCat cat -> prPrec i 0 (concatD [doc (showString "[") , prt 0 cat , doc (showString "]")])
IdCat id -> prPrec i 0 (concatD [prt 0 id])
instance Print Label where
prt i e = case e of
LabNoP labelid -> prPrec i 0 (concatD [prt 0 labelid])
LabP labelid profitems -> prPrec i 0 (concatD [prt 0 labelid , prt 0 profitems])
LabPF labelid0 labelid profitems -> prPrec i 0 (concatD [prt 0 labelid0 , prt 0 labelid , prt 0 profitems])
LabF labelid0 labelid -> prPrec i 0 (concatD [prt 0 labelid0 , prt 0 labelid])
instance Print LabelId where
prt i e = case e of
Id id -> prPrec i 0 (concatD [prt 0 id])
Wild -> prPrec i 0 (concatD [doc (showString "_")])
ListE -> prPrec i 0 (concatD [doc (showString "[") , doc (showString "]")])
ListCons -> prPrec i 0 (concatD [doc (showString "(") , doc (showString ":") , doc (showString ")")])
ListOne -> prPrec i 0 (concatD [doc (showString "(") , doc (showString ":") , doc (showString "[") , doc (showString "]") , doc (showString ")")])
instance Print ProfItem where
prt i e = case e of
ProfIt intlists ns -> prPrec i 0 (concatD [doc (showString "(") , doc (showString "[") , prt 0 intlists , doc (showString "]") , doc (showString ",") , doc (showString "[") , prt 0 ns , doc (showString "]") , doc (showString ")")])
prtList es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print IntList where
prt i e = case e of
Ints ns -> prPrec i 0 (concatD [doc (showString "[") , prt 0 ns , doc (showString "]")])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Separation where
prt i e = case e of
SepNone -> prPrec i 0 (concatD [])
SepTerm str -> prPrec i 0 (concatD [doc (showString "terminator") , prt 0 str])
SepSepar str -> prPrec i 0 (concatD [doc (showString "separator") , prt 0 str])
instance Print Arg where
prt i e = case e of
Arg id -> prPrec i 0 (concatD [prt 0 id])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print Exp where
prt i e = case e of
Cons exp0 exp -> prPrec i 0 (concatD [prt 1 exp0 , doc (showString ":") , prt 0 exp])
App id exps -> prPrec i 1 (concatD [prt 0 id , prt 0 exps])
Var id -> prPrec i 2 (concatD [prt 0 id])
LitInt n -> prPrec i 2 (concatD [prt 0 n])
LitChar c -> prPrec i 2 (concatD [prt 0 c])
LitString str -> prPrec i 2 (concatD [prt 0 str])
LitDouble d -> prPrec i 2 (concatD [prt 0 d])
List exps -> prPrec i 2 (concatD [doc (showString "[") , prt 0 exps , doc (showString "]")])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 2 x])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 2 x , prt 0 xs])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print RHS where
prt i e = case e of
RHS items -> prPrec i 0 (concatD [prt 0 items])
prtList es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs])
instance Print MinimumSize where
prt i e = case e of
MNonempty -> prPrec i 0 (concatD [doc (showString "nonempty")])
MEmpty -> prPrec i 0 (concatD [])
instance Print Reg where
prt i e = case e of
RSeq reg0 reg -> prPrec i 2 (concatD [prt 2 reg0 , prt 3 reg])
RAlt reg0 reg -> prPrec i 1 (concatD [prt 1 reg0 , doc (showString "|") , prt 2 reg])
RMinus reg0 reg -> prPrec i 1 (concatD [prt 2 reg0 , doc (showString "-") , prt 2 reg])
RStar reg -> prPrec i 3 (concatD [prt 3 reg , doc (showString "*")])
RPlus reg -> prPrec i 3 (concatD [prt 3 reg , doc (showString "+")])
ROpt reg -> prPrec i 3 (concatD [prt 3 reg , doc (showString "?")])
REps -> prPrec i 3 (concatD [doc (showString "eps")])
RChar c -> prPrec i 3 (concatD [prt 0 c])
RAlts str -> prPrec i 3 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")])
RSeqs str -> prPrec i 3 (concatD [doc (showString "{") , prt 0 str , doc (showString "}")])
RDigit -> prPrec i 3 (concatD [doc (showString "digit")])
RLetter -> prPrec i 3 (concatD [doc (showString "letter")])
RUpper -> prPrec i 3 (concatD [doc (showString "upper")])
RLower -> prPrec i 3 (concatD [doc (showString "lower")])
RAny -> prPrec i 3 (concatD [doc (showString "char")])
BNFC-2.8.1/src/BNF.cf0000644000000000000000000001024412654616013012133 0ustar0000000000000000{-
BNF Converter: Language definition
Copyright (C) 2004 Author: Markus Forberg, Michael Pellauer, Aarne Ranta
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
-- A Grammar is a sequence of definitions
LGr. LGrammar ::= [LDef] ;
DefAll. LDef ::= Def ;
DefSome. LDef ::= [Ident] ":" Def ;
LDefView. LDef ::= "views" [Ident] ;
separator LDef ";" ;
Grammar . Grammar ::= [Def] ;
separator Def ";" ;
[] . [Item] ::= ;
(:) . [Item] ::= Item [Item] ;
--The rules of the grammar
Rule . Def ::= Label "." Cat "::=" [Item] ;
-- Items
Terminal . Item ::= String ;
NTerminal . Item ::= Cat ;
-- Categories
ListCat . Cat ::= "[" Cat "]" ;
IdCat . Cat ::= Ident ;
-- labels with or without profiles
LabNoP . Label ::= LabelId ;
LabP . Label ::= LabelId [ProfItem] ;
LabPF . Label ::= LabelId LabelId [ProfItem] ;
LabF . Label ::= LabelId LabelId ;
-- functional labels
Id . LabelId ::= Ident ;
Wild . LabelId ::= "_" ;
ListE . LabelId ::= "[" "]" ;
ListCons . LabelId ::= "(" ":" ")" ;
ListOne . LabelId ::= "(" ":" "[" "]" ")" ;
-- profiles (= permutation and binding patterns)
ProfIt . ProfItem ::= "(" "[" [IntList] "]" "," "[" [Integer] "]" ")" ;
Ints . IntList ::= "[" [Integer] "]" ;
separator Integer "," ;
separator IntList "," ;
terminator nonempty ProfItem "" ;
-- Pragmas
Comment . Def ::= "comment" String ;
Comments . Def ::= "comment" String String ;
Internal . Def ::= "internal" Label "." Cat "::=" [Item] ;
Token. Def ::= "token" Ident Reg ;
PosToken. Def ::= "position" "token" Ident Reg ;
Entryp. Def ::= "entrypoints" [Ident] ;
Separator. Def ::= "separator" MinimumSize Cat String ;
Terminator. Def ::= "terminator" MinimumSize Cat String ;
Delimiters. Def ::= "delimiters" Cat String String Separation MinimumSize;
Coercions. Def ::= "coercions" Ident Integer ;
Rules. Def ::= "rules" Ident "::=" [RHS] ;
Function. Def ::= "define" Ident [Arg] "=" Exp ;
SepNone. Separation ::= ;
SepTerm. Separation ::= "terminator" String;
SepSepar. Separation ::= "separator" String;
Layout. Def ::= "layout" [String] ;
LayoutStop. Def ::= "layout" "stop" [String] ;
LayoutTop. Def ::= "layout" "toplevel" ;
Arg. Arg ::= Ident ;
separator Arg "" ;
-- Expressions
Cons. Exp ::= Exp1 ":" Exp ;
App. Exp1 ::= Ident [Exp2] ;
Var. Exp2 ::= Ident ;
LitInt. Exp2 ::= Integer ;
LitChar. Exp2 ::= Char ;
LitString. Exp2 ::= String ;
LitDouble. Exp2 ::= Double ;
List. Exp2 ::= "[" [Exp] "]" ;
coercions Exp 2;
separator nonempty Exp2 "" ;
separator Exp "," ;
separator nonempty String "," ;
separator nonempty RHS "|" ;
RHS. RHS ::= [Item] ;
-- List size condition
MNonempty. MinimumSize ::= "nonempty" ;
MEmpty. MinimumSize ::= ;
-- regular expressions
RSeq. Reg2 ::= Reg2 Reg3 ;
RAlt. Reg1 ::= Reg1 "|" Reg2 ;
RMinus. Reg1 ::= Reg2 "-" Reg2 ;
RStar. Reg3 ::= Reg3 "*" ;
RPlus. Reg3 ::= Reg3 "+" ;
ROpt. Reg3 ::= Reg3 "?" ;
REps. Reg3 ::= "eps" ;
RChar. Reg3 ::= Char ; -- single character
RAlts. Reg3 ::= "[" String "]" ; -- list of alternative characters
RSeqs. Reg3 ::= "{" String "}" ; -- character sequence
RDigit. Reg3 ::= "digit" ;
RLetter. Reg3 ::= "letter" ;
RUpper. Reg3 ::= "upper" ;
RLower. Reg3 ::= "lower" ;
RAny. Reg3 ::= "char" ;
_. Reg ::= Reg1 ;
_. Reg1 ::= Reg2 ;
_. Reg2 ::= Reg3 ;
_. Reg3 ::= "(" Reg ")" ;
-- list of categories in the entrypoint pragma
(:[]). [Ident] ::= Ident ;
(:). [Ident] ::= Ident "," [Ident] ;
-- comments in BNF source
comment "--" ;
comment "{-" "-}" ;
BNFC-2.8.1/src/ErrM.hs0000644000000000000000000000143612654616013012420 0ustar0000000000000000-- BNF Converter: Error Monad
-- Copyright (C) 2004 Author: Aarne Ranta
-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
module ErrM where
-- the Error monad: like Maybe type with error msgs
import Control.Monad (MonadPlus(..), liftM)
import Control.Applicative (Applicative(..), Alternative(..))
data Err a = Ok a | Bad String
deriving (Read, Show, Eq, Ord)
instance Monad Err where
return = Ok
fail = Bad
Ok a >>= f = f a
Bad s >>= _ = Bad s
instance Applicative Err where
pure = Ok
(Bad s) <*> _ = Bad s
(Ok f) <*> o = liftM f o
instance Functor Err where
fmap = liftM
instance MonadPlus Err where
mzero = Bad "Err.mzero"
mplus (Bad _) y = y
mplus x _ = x
instance Alternative Err where
empty = mzero
(<|>) = mplus
BNFC-2.8.1/src/ParBNF.y0000644000000000000000000001577112654616013012470 0ustar0000000000000000-- This Happy file was machine-generated by the BNF converter
{
{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}
module ParBNF where
import AbsBNF
import LexBNF
import ErrM
}
%name pLGrammar LGrammar
%name pLDef LDef
%name pListLDef ListLDef
%name pGrammar Grammar
%name pListDef ListDef
%name pListItem ListItem
%name pDef Def
%name pItem Item
%name pCat Cat
%name pLabel Label
%name pLabelId LabelId
%name pProfItem ProfItem
%name pIntList IntList
%name pListInteger ListInteger
%name pListIntList ListIntList
%name pListProfItem ListProfItem
%name pSeparation Separation
%name pArg Arg
%name pListArg ListArg
%name pExp Exp
%name pExp1 Exp1
%name pExp2 Exp2
%name pListExp2 ListExp2
%name pListExp ListExp
%name pListString ListString
%name pListRHS ListRHS
%name pRHS RHS
%name pMinimumSize MinimumSize
%name pReg2 Reg2
%name pReg1 Reg1
%name pReg3 Reg3
%name pReg Reg
%name pListIdent ListIdent
-- no lexer declaration
%monad { Err } { thenM } { returnM }
%tokentype { Token }
%token
'(' { PT _ (TS _ 1) }
')' { PT _ (TS _ 2) }
'*' { PT _ (TS _ 3) }
'+' { PT _ (TS _ 4) }
',' { PT _ (TS _ 5) }
'-' { PT _ (TS _ 6) }
'.' { PT _ (TS _ 7) }
':' { PT _ (TS _ 8) }
'::=' { PT _ (TS _ 9) }
';' { PT _ (TS _ 10) }
'=' { PT _ (TS _ 11) }
'?' { PT _ (TS _ 12) }
'[' { PT _ (TS _ 13) }
']' { PT _ (TS _ 14) }
'_' { PT _ (TS _ 15) }
'char' { PT _ (TS _ 16) }
'coercions' { PT _ (TS _ 17) }
'comment' { PT _ (TS _ 18) }
'define' { PT _ (TS _ 19) }
'delimiters' { PT _ (TS _ 20) }
'digit' { PT _ (TS _ 21) }
'entrypoints' { PT _ (TS _ 22) }
'eps' { PT _ (TS _ 23) }
'internal' { PT _ (TS _ 24) }
'layout' { PT _ (TS _ 25) }
'letter' { PT _ (TS _ 26) }
'lower' { PT _ (TS _ 27) }
'nonempty' { PT _ (TS _ 28) }
'position' { PT _ (TS _ 29) }
'rules' { PT _ (TS _ 30) }
'separator' { PT _ (TS _ 31) }
'stop' { PT _ (TS _ 32) }
'terminator' { PT _ (TS _ 33) }
'token' { PT _ (TS _ 34) }
'toplevel' { PT _ (TS _ 35) }
'upper' { PT _ (TS _ 36) }
'views' { PT _ (TS _ 37) }
'{' { PT _ (TS _ 38) }
'|' { PT _ (TS _ 39) }
'}' { PT _ (TS _ 40) }
L_quoted { PT _ (TL $$) }
L_ident { PT _ (TV $$) }
L_integ { PT _ (TI $$) }
L_charac { PT _ (TC $$) }
L_doubl { PT _ (TD $$) }
%%
String :: { String } : L_quoted { $1 }
Ident :: { Ident } : L_ident { Ident $1 }
Integer :: { Integer } : L_integ { (read ( $1)) :: Integer }
Char :: { Char } : L_charac { (read ( $1)) :: Char }
Double :: { Double } : L_doubl { (read ( $1)) :: Double }
LGrammar :: { LGrammar }
LGrammar : ListLDef { LGr $1 }
LDef :: { LDef }
LDef : Def { DefAll $1 }
| ListIdent ':' Def { DefSome $1 $3 }
| 'views' ListIdent { LDefView $2 }
ListLDef :: { [LDef] }
ListLDef : {- empty -} { [] }
| LDef { (:[]) $1 }
| LDef ';' ListLDef { (:) $1 $3 }
Grammar :: { Grammar }
Grammar : ListDef { Grammar $1 }
ListDef :: { [Def] }
ListDef : {- empty -} { [] }
| Def { (:[]) $1 }
| Def ';' ListDef { (:) $1 $3 }
ListItem :: { [Item] }
ListItem : {- empty -} { [] }
| ListItem Item { flip (:) $1 $2 }
Def :: { Def }
Def : Label '.' Cat '::=' ListItem { Rule $1 $3 (reverse $5) }
| 'comment' String { Comment $2 }
| 'comment' String String { Comments $2 $3 }
| 'internal' Label '.' Cat '::=' ListItem { Internal $2 $4 (reverse $6) }
| 'token' Ident Reg { Token $2 $3 }
| 'position' 'token' Ident Reg { PosToken $3 $4 }
| 'entrypoints' ListIdent { Entryp $2 }
| 'separator' MinimumSize Cat String { Separator $2 $3 $4 }
| 'terminator' MinimumSize Cat String { Terminator $2 $3 $4 }
| 'delimiters' Cat String String Separation MinimumSize { Delimiters $2 $3 $4 $5 $6 }
| 'coercions' Ident Integer { Coercions $2 $3 }
| 'rules' Ident '::=' ListRHS { Rules $2 $4 }
| 'define' Ident ListArg '=' Exp { Function $2 (reverse $3) $5 }
| 'layout' ListString { Layout $2 }
| 'layout' 'stop' ListString { LayoutStop $3 }
| 'layout' 'toplevel' { LayoutTop }
Item :: { Item }
Item : String { Terminal $1 }
| Cat { NTerminal $1 }
Cat :: { Cat }
Cat : '[' Cat ']' { ListCat $2 }
| Ident { IdCat $1 }
Label :: { Label }
Label : LabelId { LabNoP $1 }
| LabelId ListProfItem { LabP $1 $2 }
| LabelId LabelId ListProfItem { LabPF $1 $2 $3 }
| LabelId LabelId { LabF $1 $2 }
LabelId :: { LabelId }
LabelId : Ident { Id $1 }
| '_' { Wild }
| '[' ']' { ListE }
| '(' ':' ')' { ListCons }
| '(' ':' '[' ']' ')' { ListOne }
ProfItem :: { ProfItem }
ProfItem : '(' '[' ListIntList ']' ',' '[' ListInteger ']' ')' { ProfIt $3 $7 }
IntList :: { IntList }
IntList : '[' ListInteger ']' { Ints $2 }
ListInteger :: { [Integer] }
ListInteger : {- empty -} { [] }
| Integer { (:[]) $1 }
| Integer ',' ListInteger { (:) $1 $3 }
ListIntList :: { [IntList] }
ListIntList : {- empty -} { [] }
| IntList { (:[]) $1 }
| IntList ',' ListIntList { (:) $1 $3 }
ListProfItem :: { [ProfItem] }
ListProfItem : ProfItem { (:[]) $1 }
| ProfItem ListProfItem { (:) $1 $2 }
Separation :: { Separation }
Separation : {- empty -} { SepNone }
| 'terminator' String { SepTerm $2 }
| 'separator' String { SepSepar $2 }
Arg :: { Arg }
Arg : Ident { Arg $1 }
ListArg :: { [Arg] }
ListArg : {- empty -} { [] }
| ListArg Arg { flip (:) $1 $2 }
Exp :: { Exp }
Exp : Exp1 ':' Exp { Cons $1 $3 }
| Exp1 { $1 }
Exp1 :: { Exp }
Exp1 : Ident ListExp2 { App $1 $2 }
| Exp2 { $1 }
Exp2 :: { Exp }
Exp2 : Ident { Var $1 }
| Integer { LitInt $1 }
| Char { LitChar $1 }
| String { LitString $1 }
| Double { LitDouble $1 }
| '[' ListExp ']' { List $2 }
| '(' Exp ')' { $2 }
ListExp2 :: { [Exp] }
ListExp2 : Exp2 { (:[]) $1 }
| Exp2 ListExp2 { (:) $1 $2 }
ListExp :: { [Exp] }
ListExp : {- empty -} { [] }
| Exp { (:[]) $1 }
| Exp ',' ListExp { (:) $1 $3 }
ListString :: { [String] }
ListString : String { (:[]) $1 }
| String ',' ListString { (:) $1 $3 }
ListRHS :: { [RHS] }
ListRHS : RHS { (:[]) $1 }
| RHS '|' ListRHS { (:) $1 $3 }
RHS :: { RHS }
RHS : ListItem { RHS (reverse $1) }
MinimumSize :: { MinimumSize }
MinimumSize : 'nonempty' { MNonempty }
| {- empty -} { MEmpty }
Reg2 :: { Reg }
Reg2 : Reg2 Reg3 { RSeq $1 $2 }
| Reg3 { $1 }
Reg1 :: { Reg }
Reg1 : Reg1 '|' Reg2 { RAlt $1 $3 }
| Reg2 '-' Reg2 { RMinus $1 $3 }
| Reg2 { $1 }
Reg3 :: { Reg }
Reg3 : Reg3 '*' { RStar $1 }
| Reg3 '+' { RPlus $1 }
| Reg3 '?' { ROpt $1 }
| 'eps' { REps }
| Char { RChar $1 }
| '[' String ']' { RAlts $2 }
| '{' String '}' { RSeqs $2 }
| 'digit' { RDigit }
| 'letter' { RLetter }
| 'upper' { RUpper }
| 'lower' { RLower }
| 'char' { RAny }
| '(' Reg ')' { $2 }
Reg :: { Reg }
Reg : Reg1 { $1 }
ListIdent :: { [Ident] }
ListIdent : Ident { (:[]) $1 }
| Ident ',' ListIdent { (:) $1 $3 }
{
returnM :: a -> Err a
returnM = return
thenM :: Err a -> (a -> Err b) -> Err b
thenM = (>>=)
happyError :: [Token] -> Err a
happyError ts =
Bad $ "syntax error at " ++ tokenPos ts ++
case ts of
[] -> []
[Err _] -> " due to lexer error"
_ -> " before " ++ unwords (map (id . prToken) (take 4 ts))
myLexer = tokens
}
BNFC-2.8.1/src/Main.hs0000644000000000000000000000610612654616013012436 0ustar0000000000000000{-
BNF Converter: Main file
Copyright (C) 2002-2013 Authors:
Jonas Almström Duregård, Krasimir Angelov, Jean-Philippe Bernardy, Björn Bringert, Johan Broberg, Paul Callaghan,
Grégoire Détrez, Markus Forsberg, Ola Frid, Peter Gammie, Thomas Hallgren, Patrik Jansson,
Kristofer Johannisson, Antti-Juhani Kaijanaho, Ulf Norell,
Michael Pellauer and Aarne Ranta 2002 - 2013.
Björn Bringert, Johan Broberg, Markus Forberg, Peter Gammie,
Patrik Jansson, Antti-Juhani Kaijanaho, Ulf Norell,
Michael Pellauer, Aarne Ranta
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module Main where
import BNFC.Backend.Base hiding (Backend)
import BNFC.Backend.C
import BNFC.Backend.CPP.NoSTL
import BNFC.Backend.CPP.STL
import BNFC.Backend.CSharp
import BNFC.Backend.Haskell
import BNFC.Backend.HaskellGADT
import BNFC.Backend.HaskellProfile
import BNFC.Backend.Java
import BNFC.Backend.Latex
import BNFC.Backend.OCaml
import BNFC.Backend.Pygments
import BNFC.GetCF
import BNFC.Options hiding (make)
import Paths_BNFC ( version )
import Data.Version ( showVersion )
import System.Environment (getArgs)
import System.Exit (exitFailure,exitSuccess)
import System.IO (stderr, hPutStrLn)
-- Print an error message and a (short) usage help and exit
printUsageErrors :: [String] -> IO ()
printUsageErrors msg = do
mapM_ (hPutStrLn stderr) msg
hPutStrLn stderr usage
exitFailure
main :: IO ()
main = do
args <- getArgs
case parseMode args of
UsageError e -> printUsageErrors [e]
Help -> putStrLn help >> exitSuccess
Version -> putStrLn (showVersion version) >> exitSuccess
Target options file | target options == TargetProfile ->
readFile file >>= parseCFP options TargetProfile
>>= writeFiles (outDir options) . makeHaskellProfile options
Target options file ->
readFile file >>= parseCF options (target options) >>= make (target options) options
where
make t opts cf = writeFiles (outDir opts) $ (maketarget t) opts cf
maketarget t = case t of
TargetC -> makeC
TargetCpp -> makeCppStl
TargetCppNoStl -> makeCppNoStl
TargetCSharp -> makeCSharp
TargetHaskell -> makeHaskell
TargetHaskellGadt -> makeHaskellGadt
TargetLatex -> makeLatex
TargetJava -> makeJava
TargetOCaml -> makeOCaml
TargetProfile -> error "Not implemented"
TargetPygments -> makePygments
BNFC-2.8.1/src/LexBNF.x0000644000000000000000000001410212654616013012460 0ustar0000000000000000-- -*- haskell -*-
-- This Alex file was machine-generated by the BNF converter
{
{-# OPTIONS -fno-warn-incomplete-patterns #-}
{-# OPTIONS_GHC -w #-}
module LexBNF where
import qualified Data.Bits
import Data.Word (Word8)
import Data.Char (ord)
}
$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME
$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME
$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME
$d = [0-9] -- digit
$i = [$l $d _ '] -- identifier character
$u = [\0-\255] -- universal: any character
@rsyms = -- symbols and non-identifier-like reserved words
\: | \; | \. | \: \: \= | \[ | \] | \_ | \( | \) | \, | \= | \| | \- | \* | \+ | \? | \{ | \}
:-
"--" [.]* ; -- Toss single line comments
"{-" ([$u # \-] | \-+ [$u # [\- \}]])* ("-")+ "}" ;
$white+ ;
@rsyms { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
\' ($u # [\' \\] | \\ [\\ \' n t]) \' { tok (\p s -> PT p (TC $ share s)) }
$d+ { tok (\p s -> PT p (TI $ share s)) }
$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ share s)) }
{
tok :: (Posn -> String -> Token) -> (Posn -> String -> Token)
tok f p s = f p s
share :: String -> String
share = id
data Tok =
TS !String !Int -- reserved words and symbols
| TL !String -- string literals
| TI !String -- integer literals
| TV !String -- identifiers
| TD !String -- double precision float literals
| TC !String -- character literals
deriving (Eq,Show,Ord)
data Token =
PT Posn Tok
| Err Posn
deriving (Eq,Show,Ord)
tokenPos :: [Token] -> String
tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
tokenPos _ = "end of file"
tokenPosn :: Token -> Posn
tokenPosn (PT p _) = p
tokenPosn (Err p) = p
tokenLineCol :: Token -> (Int, Int)
tokenLineCol = posLineCol . tokenPosn
posLineCol :: Posn -> (Int, Int)
posLineCol (Pn _ l c) = (l,c)
mkPosToken :: Token -> ((Int, Int), String)
mkPosToken t@(PT p _) = (posLineCol p, prToken t)
prToken :: Token -> String
prToken t = case t of
PT _ (TS s _) -> s
PT _ (TL s) -> s
PT _ (TI s) -> s
PT _ (TV s) -> s
PT _ (TD s) -> s
PT _ (TC s) -> s
Err _ -> "#Error"
data BTree = N | B String Tok BTree BTree deriving (Show)
eitherResIdent :: (String -> Tok) -> String -> Tok
eitherResIdent tv s = treeFind resWords
where
treeFind N = tv s
treeFind (B a t left right) | s < a = treeFind left
| s > a = treeFind right
| s == a = t
resWords :: BTree
resWords = b "digit" 21 (b "=" 11 (b "-" 6 (b "*" 3 (b ")" 2 (b "(" 1 N N) N) (b "," 5 (b "+" 4 N N) N)) (b "::=" 9 (b ":" 8 (b "." 7 N N) N) (b ";" 10 N N))) (b "char" 16 (b "]" 14 (b "[" 13 (b "?" 12 N N) N) (b "_" 15 N N)) (b "define" 19 (b "comment" 18 (b "coercions" 17 N N) N) (b "delimiters" 20 N N)))) (b "separator" 31 (b "letter" 26 (b "internal" 24 (b "eps" 23 (b "entrypoints" 22 N N) N) (b "layout" 25 N N)) (b "position" 29 (b "nonempty" 28 (b "lower" 27 N N) N) (b "rules" 30 N N))) (b "upper" 36 (b "token" 34 (b "terminator" 33 (b "stop" 32 N N) N) (b "toplevel" 35 N N)) (b "|" 39 (b "{" 38 (b "views" 37 N N) N) (b "}" 40 N N))))
where b s n = let bs = id s
in B bs (TS bs n)
unescapeInitTail :: String -> String
unescapeInitTail = id . unesc . tail . id where
unesc s = case s of
'\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
'\\':'n':cs -> '\n' : unesc cs
'\\':'t':cs -> '\t' : unesc cs
'"':[] -> []
c:cs -> c : unesc cs
_ -> []
-------------------------------------------------------------------
-- Alex wrapper code.
-- A modified "posn" wrapper.
-------------------------------------------------------------------
data Posn = Pn !Int !Int !Int
deriving (Eq, Show,Ord)
alexStartPos :: Posn
alexStartPos = Pn 0 1 1
alexMove :: Posn -> Char -> Posn
alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)
alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1
alexMove (Pn a l c) _ = Pn (a+1) l (c+1)
type Byte = Word8
type AlexInput = (Posn, -- current position,
Char, -- previous char
[Byte], -- pending bytes on the current char
String) -- current input string
tokens :: String -> [Token]
tokens str = go (alexStartPos, '\n', [], str)
where
go :: AlexInput -> [Token]
go inp@(pos, _, _, str) =
case alexScan inp 0 of
AlexEOF -> []
AlexError (pos, _, _, _) -> [Err pos]
AlexSkip inp' len -> go inp'
AlexToken inp' len act -> act pos (take len str) : (go inp')
alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)
alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s))
alexGetByte (p, _, [], s) =
case s of
[] -> Nothing
(c:s) ->
let p' = alexMove p c
(b:bs) = utf8Encode c
in p' `seq` Just (b, (p', c, bs, s))
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (p, c, bs, s) = c
-- | Encode a Haskell String to a list of Word8 values, in UTF8 format.
utf8Encode :: Char -> [Word8]
utf8Encode = map fromIntegral . go . ord
where
go oc
| oc <= 0x7f = [oc]
| oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6)
, 0x80 + oc Data.Bits..&. 0x3f
]
| oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12)
, 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)
, 0x80 + oc Data.Bits..&. 0x3f
]
| otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18)
, 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)
, 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)
, 0x80 + oc Data.Bits..&. 0x3f
]
}
BNFC-2.8.1/src/AbsBNF.hs0000644000000000000000000000377612654616013012617 0ustar0000000000000000
module AbsBNF where
-- Haskell module generated by the BNF converter
newtype Ident = Ident String deriving (Eq,Ord,Show,Read)
data LGrammar =
LGr [LDef]
deriving (Eq,Ord,Show,Read)
data LDef =
DefAll Def
| DefSome [Ident] Def
| LDefView [Ident]
deriving (Eq,Ord,Show,Read)
data Grammar =
Grammar [Def]
deriving (Eq,Ord,Show,Read)
data Def =
Rule Label Cat [Item]
| Comment String
| Comments String String
| Internal Label Cat [Item]
| Token Ident Reg
| PosToken Ident Reg
| Entryp [Ident]
| Separator MinimumSize Cat String
| Terminator MinimumSize Cat String
| Delimiters Cat String String Separation MinimumSize
| Coercions Ident Integer
| Rules Ident [RHS]
| Function Ident [Arg] Exp
| Layout [String]
| LayoutStop [String]
| LayoutTop
deriving (Eq,Ord,Show,Read)
data Item =
Terminal String
| NTerminal Cat
deriving (Eq,Ord,Show,Read)
data Cat =
ListCat Cat
| IdCat Ident
deriving (Eq,Ord,Show,Read)
data Label =
LabNoP LabelId
| LabP LabelId [ProfItem]
| LabPF LabelId LabelId [ProfItem]
| LabF LabelId LabelId
deriving (Eq,Ord,Show,Read)
data LabelId =
Id Ident
| Wild
| ListE
| ListCons
| ListOne
deriving (Eq,Ord,Show,Read)
data ProfItem =
ProfIt [IntList] [Integer]
deriving (Eq,Ord,Show,Read)
data IntList =
Ints [Integer]
deriving (Eq,Ord,Show,Read)
data Separation =
SepNone
| SepTerm String
| SepSepar String
deriving (Eq,Ord,Show,Read)
data Arg =
Arg Ident
deriving (Eq,Ord,Show,Read)
data Exp =
Cons Exp Exp
| App Ident [Exp]
| Var Ident
| LitInt Integer
| LitChar Char
| LitString String
| LitDouble Double
| List [Exp]
deriving (Eq,Ord,Show,Read)
data RHS =
RHS [Item]
deriving (Eq,Ord,Show,Read)
data MinimumSize =
MNonempty
| MEmpty
deriving (Eq,Ord,Show,Read)
data Reg =
RSeq Reg Reg
| RAlt Reg Reg
| RMinus Reg Reg
| RStar Reg
| RPlus Reg
| ROpt Reg
| REps
| RChar Char
| RAlts String
| RSeqs String
| RDigit
| RLetter
| RUpper
| RLower
| RAny
deriving (Eq,Ord,Show,Read)
BNFC-2.8.1/src/Data/0000755000000000000000000000000012654616013012064 5ustar0000000000000000BNFC-2.8.1/src/Data/Pair.hs0000644000000000000000000000044012654616013013311 0ustar0000000000000000module Data.Pair where
import Control.Applicative
infixl 2 :/:
data Pair a = (:/:) {leftOf :: a, rightOf :: a}
deriving (Show)
instance Functor Pair where
fmap f (a :/: b) = f a :/: f b
instance Applicative Pair where
pure a = a :/: a
(f :/: g) <*> (a :/: b) = f a :/: g b
BNFC-2.8.1/src/BNFC/0000755000000000000000000000000012654616013011723 5ustar0000000000000000BNFC-2.8.1/src/BNFC/Lexing.hs0000644000000000000000000000560412654616013013512 0ustar0000000000000000module BNFC.Lexing
( mkLexer, LexType(..) ) where
import Control.Arrow ((&&&))
import Data.List (inits)
import AbsBNF (Reg(..))
import PrintBNF
import BNFC.CF
p :: Reg -> IO ()
p = putStrLn . concat . words . printTree
-- Abstract lexer
data LexType = LexComment | LexToken String | LexSymbols
mkLexer :: CF -> [(Reg, LexType)]
mkLexer cf =
-- comments
[ (mkRegSingleLineComment s, LexComment) | s <- snd (comments cf) ]
++
[ (mkRegMultilineComment b e, LexComment) | (b,e) <- fst (comments cf) ]
++
-- user tokens
[ (reg, LexToken name) | (Cat name, reg) <- tokenPragmas cf]
++
-- predefined tokens
[ ( regIdent, LexToken "Ident" ) ]
++
-- Symbols
[ (foldl1 RAlt (map RSeqs (symbols cf)), LexSymbols ) ]
++
-- Built-ins
[ ( regInteger, LexToken "Integer")
, ( regDouble, LexToken "Double" )
, ( regString, LexToken "String" )
, ( regChar, LexToken "Char" ) ]
(<>) = RSeq
(<|>) = RAlt
-- Bult-in tokens
-- the tests make sure that they correspond to what is in the LBNF reference
-- | Ident regex
-- >>> p regIdent
-- letter(letter|digit|'_'|'\'')*
regIdent :: Reg
regIdent = RLetter <> RStar (RLetter <|> RDigit <|> RChar '_' <|> RChar '\'')
-- | Integer regex
-- >>> p regInteger
-- digit+
regInteger :: Reg
regInteger = RPlus RDigit
-- | String regex
-- >>> p regString
-- '"'(char-["\"\\"]|'\\'["\"\\nt"])*'"'
regString :: Reg
regString = RChar '"'
<> RStar ( RMinus RAny (RAlts "\"\\")
<|> (RChar '\\' <> RAlts "\"\\nt"))
<> RChar '"'
-- | Char regex
-- >>> p regChar
-- '\''(char-["'\\"]|'\\'["'\\nt"])'\''
regChar :: Reg
regChar = RChar '\''
<> (RMinus RAny (RAlts "'\\") <|> (RChar '\\' <> RAlts "'\\nt"))
<> RChar '\''
-- | Double regex
-- >>> p regDouble
-- digit+'.'digit+('e''-'?digit+)?
regDouble :: Reg
regDouble = RPlus RDigit <> RChar '.' <> RPlus RDigit
<> ROpt (RChar 'e' <> ROpt (RChar '-') <> RPlus RDigit)
-- | Create regex for single line comments
-- >>> p $ mkRegSingleLineComment "--"
-- {"--"}(char*'\n')
mkRegSingleLineComment :: String -> Reg
mkRegSingleLineComment s = RSeq (RSeqs s) (RSeq (RStar RAny) (RChar '\n'))
-- | Create regex for multiline comments
-- >>> p $ mkRegMultilineComment "<" ">"
-- '<'((char|'\n')-'>')*'>'
-- >>> p $ mkRegMultilineComment ""
-- {""}
mkRegMultilineComment :: String -> String -> Reg
mkRegMultilineComment b e =
rseq $ concat [
lit b
, [RStar (foldl1 RAlt subregex)]
, [ RStar (RChar (head e)) | length e > 1 ]
, lit e]
where
rseq = foldl1 RSeq
lit :: String -> [Reg]
lit "" = []
lit [c] = [RChar c]
lit s = [RSeqs s]
prefixes = map (init &&& last) (drop 1 (inits e))
subregex = [rseq (lit ss ++ [RMinus (RAlt RAny (RChar '\n')) (RChar s)]) | (ss,s) <- prefixes]
BNFC-2.8.1/src/BNFC/CF.hs0000644000000000000000000006233212654616013012555 0ustar0000000000000000{-# LANGUAGE PatternGuards, DeriveFunctor #-}
{-
BNF Converter: Abstract syntax
Copyright (C) 2004 Author: Markus Forberg, Michael Pellauer, Aarne Ranta
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.CF (
-- Types.
CF,
CFG(..), pragmasOfCF, -- ...
Rule, Rul(..), lookupRule,
Pragma(..),
Exp(..),
Literal,
Symbol,
KeyWord,
Cat(..), strToCat,
catString, catInteger, catDouble, catChar, catIdent,
NonTerminal,
Fun,
Tree(..),
prTree, -- print an abstract syntax tree
Data, -- describes the abstract syntax of a grammar
cf2data, -- translates a grammar to a Data object.
cf2dataLists, -- translates to a Data with List categories included.
getAbstractSyntax,
-- Literal categories, constants,
firstCat, -- the first value category in the grammar.
firstEntry, -- the first entry or the first value category
specialCats, -- ident
specialCatsP, -- all literals
specialData, -- special data
isCoercion, -- wildcards in grammar (avoid syntactic clutter)
isDefinedRule, -- defined rules (allows syntactic sugar)
isProperLabel, -- not coercion or defined rule
allCats, -- all categories of a grammar
allCatsNorm,
allCatsIdNorm,
allEntryPoints,
reservedWords,
cfTokens,
symbols,
literals,
reversibleCats,
findAllReversibleCats, -- find all reversible categories
identCat, -- transforms '[C]' to ListC (others, unchanged).
isParsable,
rulesOfCF, -- All rules of a grammar.
rulesForCat, -- rules for a given category
rulesForNormalizedCat, -- rules for a given category
ruleGroups, -- Categories are grouped with their rules.
ruleGroupsInternals, --As above, but includes internal cats.
notUniqueNames, -- list of not unique names (replaces the following 2)
-- notUniqueFuns, -- Returns a list of function labels that are not unique.
-- badInheritence, -- Returns a list of all function labels that can cause problems in languages with inheritence.
isList, -- Checks if a category is a list category.
isTokenCat,
-- Information functions for list functions.
isNilFun, -- empty list function? ([])
isOneFun, -- one element list function? (:[])
hasOneFunc,
getCons,
getSeparatorByPrecedence,
isConsFun, -- constructor function? (:)
isNilCons, -- either three of above?
isEmptyListCat, -- checks if the list permits []
revSepListRule, -- reverse a rule, if it is of form C t [C].
normCat,
isDataCat,
normCatOfList, -- Removes precendence information and enclosed List. C1 => C, C2 => C
catOfList,
comments, -- translates the pragmas into two list containing the s./m. comments
tokenPragmas, -- get the user-defined regular expression tokens
tokenNames, -- get the names of all user-defined tokens
precCat, -- get the precendence level of a Cat C1 => 1, C => 0
precLevels, -- get all precendence levels in the grammar, sorted in increasing order.
precRule, -- get the precendence level of the value category of a rule.
precCF, -- Check if the CF consists of precendence levels.
isUsedCat,
isPositionCat,
hasIdent,
hasLayout,
layoutPragmas,
normFun,
CFP, -- CF with profiles
RuleP,
FunP,
Prof,
cf2cfpRule,
cf2cfp,
cfp2cf,
trivialProf,
rulesOfCFP,
funRuleP, ruleGroupsP, allCatsP, allEntryPointsP
) where
import BNFC.Utils (prParenth,(+++))
import Control.Monad (guard)
import Data.List (nub, intersperse, sort, group, intercalate, find, sortBy)
import Data.Char
import AbsBNF (Reg())
import ParBNF (pCat)
import LexBNF (tokens)
import qualified AbsBNF
import ErrM
-- | A context free grammar consists of a set of rules and some extended
-- information (e.g. pragmas, literals, symbols, keywords)
type CF = CFG Fun
-- | A rule consists of a function name, a main category and a sequence of
-- terminals and non-terminals.
-- function_name . Main_Cat ::= sequence
type Rule = Rul Fun
-- | Polymorphic rule type for common type signatures for CF and CFP
data Rul function = Rule { funRule :: function
-- ^ The function (semantic action) of a
-- rule. In order to be able to generate
-- data types this must be a constructor
-- (or an identity function).
, valCat :: Cat -- ^ The value category
, rhsRule :: [Either Cat String]
-- ^ The list of Terminals/NonTerminals in
-- the right-hand-side of a rule.
}
deriving (Eq,Functor)
instance (Show function) => Show (Rul function) where
show (Rule f cat rhs) =
unwords (show f : "." : show cat : "::=" : map (either show id) rhs)
-- | Polymorphic CFG type for common type signatures for CF and CFP
newtype CFG function = CFG { unCFG :: (Exts,[Rul function]) }
deriving (Functor)
instance (Show function) => Show (CFG function) where
show (CFG (_,rules)) = unlines $ map show rules
type Exts = ([Pragma],Info)
-- | Info is information extracted from the CF, for easy access.
-- Literals - Char, String, Ident, Integer, Double
-- Strings are quoted strings, and Ident are unquoted.
-- Symbols - symbols in the grammar, e.g. “*”, '->'.
-- KeyWord - reserved words, e.g. 'if' 'while'
type Info = ([Literal],[Symbol],[KeyWord],[Cat])
-- Expressions for function definitions
data Exp = App String [Exp]
| LitInt Integer
| LitDouble Double
| LitChar Char
| LitString String
deriving (Eq)
instance Show Exp where
showsPrec p e =
case listView e of
Right es ->
showString "["
. foldr (.) id (intersperse (showString ", ") $ map shows es)
. showString "]"
Left (App x []) -> showString x
Left (App "(:)" [e1,e2]) ->
showParen (p>0)
$ showsPrec 1 e1
. showString " : "
. shows e2
Left (App x es) ->
showParen (p>1)
$ foldr (.) id
$ intersperse (showString " ")
$ showString x : map (showsPrec 2) es
Left (LitInt n) -> shows n
Left (LitDouble x) -> shows x
Left (LitChar c) -> shows c
Left (LitString s) -> shows s
where
listView (App "[]" []) = Right []
listView (App "(:)" [e1,e2])
| Right es <- listView e2 = Right $ e1:es
listView x = Left x
-- | Pragmas
data Pragma = CommentS String -- ^ for single line comments
| CommentM (String,String) -- ^ for multiple-line comments.
| TokenReg String Bool Reg -- ^ for tokens
| EntryPoints [Cat]
| Layout [String]
| LayoutStop [String]
| LayoutTop
| FunDef String [String] Exp
-- ...
deriving (Show)
-- | User-defined regular expression tokens
tokenPragmas :: CFG f -> [(Cat,Reg)]
tokenPragmas cf = [(TokenCat name,e) | TokenReg name _ e <- pragmasOfCF cf]
-- | The names of all user-defined tokens
tokenNames :: CFG f -> [String]
tokenNames cf = map (show.fst) (tokenPragmas cf)
layoutPragmas :: CF -> (Bool,[String],[String])
layoutPragmas cf = let ps = pragmasOfCF cf in (
not (null [() | LayoutTop <- ps]), -- if there's layout betw top-level
concat [ss | Layout ss <- ps], -- layout-block starting words
concat [ss | LayoutStop ss <- ps] -- layout-block ending words
)
hasLayout :: CF -> Bool
hasLayout cf = case layoutPragmas cf of
(t,ws,_) -> t || not (null ws) -- (True,[],_) means: top-level layout only
-- | Literal: Char, String, Ident, Integer, Double
type Literal = String
type Symbol = String
type KeyWord = String
------------------------------------------------------------------------------
-- Categories
------------------------------------------------------------------------------
-- | Categories are the Non-terminals of the grammar.
data Cat = InternalCat -- | Internal category, inserted in 1st
-- position in "internal" rules,
-- essentially ensuring that they are
-- never parsed.
| Cat String
| TokenCat String -- ^ Token types (like Ident)
| ListCat Cat
| CoercCat String Integer
deriving (Eq, Ord)
-- An alias for Cat used in many backends:
type NonTerminal = Cat
-- | Render category symbols as strings
-- >>> catToStr (Cat "Def")
-- "Def"
-- >>> catToStr (ListCat (Cat "Thing"))
-- "[Thing]"
-- >>> catToStr (CoercCat "Expr" 3)
-- "Expr3"
-- >>> catToStr (ListCat (CoercCat "Expr" 2))
-- "[Expr2]"
-- >>> catToStr (TokenCat "Abc")
-- "Abc"
catToStr InternalCat = "#"
catToStr (Cat s) = s
catToStr (TokenCat s) = s
catToStr (ListCat c) = "[" ++ show c ++ "]"
catToStr (CoercCat s i) = s ++ show i
instance Show Cat where
show = catToStr
-- | Reads a string into a category. This should only needs to handle
-- the case of simple categories (with or without coercion) since list
-- categories are parsed in the grammar already. To be on the safe side here,
-- we still call the parser function that parses categries.
-- >>> strToCat "Abc" == Cat "Abc"
-- True
-- >>> strToCat "Abc123" == CoercCat "Abc" 123
-- True
-- >>> strToCat "[Expr2]" == ListCat (CoercCat "Expr" 2)
-- True
strToCat :: String -> Cat
strToCat "#" = InternalCat
strToCat s =
case pCat (tokens s) of
Ok c -> cat2cat c
Bad _ -> Cat s -- error $ "Error parsing cat " ++ s ++ " (" ++ e ++ ")"
-- Might be one of the "Internal cat" which are not
-- really parsable...
where cat2cat (AbsBNF.IdCat (AbsBNF.Ident i)) =
case span isDigit (reverse i) of
([],c') -> Cat (reverse c')
(d,c') -> CoercCat (reverse c') (read (reverse d))
cat2cat (AbsBNF.ListCat c) = ListCat (cat2cat c)
-- Build-in categories contants
catString, catInteger, catDouble, catChar, catIdent :: Cat
catString = TokenCat "String"
catInteger = TokenCat "Integer"
catDouble = TokenCat "Double"
catChar = TokenCat "Char"
catIdent = TokenCat "Ident"
-- the parser needs these
specialCatsP :: [String]
specialCatsP = words "Ident Integer String Char Double"
-- | Does the category correspond to a data type?
isDataCat :: Cat -> Bool
isDataCat c = isDataOrListCat c && not (isList c)
isDataOrListCat :: Cat -> Bool
isDataOrListCat (CoercCat _ _) = False
isDataOrListCat (Cat ('@':_)) = False
isDataOrListCat (ListCat c) = isDataOrListCat c
isDataOrListCat _ = True
-- | Categories C1, C2,... (one digit in end) are variants of C. This function
-- returns true if two category are variants of the same abstract category.
-- E.g.
--
-- >>> eqCat (Cat "Abc") (Cat "Abc")
-- True
-- >>> eqCat (CoercCat "Abc" 3) (CoercCat "Abc" 5)
-- True
-- >>> eqCat (CoercCat "Acb" 4) (CoercCat "Abc" 4)
-- False
-- >>> eqCat (Cat "Abc") (CoercCat "Abc" 44)
-- True
eqCat :: Cat -> Cat -> Bool
eqCat (CoercCat c1 _) (CoercCat c2 _) = c1 == c2
eqCat (Cat c1 ) (CoercCat c2 _) = c1 == c2
eqCat (CoercCat c1 _) (Cat c2) = c1 == c2
eqCat c1 c2 = c1 == c2
-- | Removes precendence information. C1 => C, [C2] => [C]
normCat :: Cat -> Cat
normCat (ListCat c) = ListCat (normCat c)
normCat (CoercCat c _) = Cat c
normCat c = c
normCatOfList :: Cat -> Cat
normCatOfList = normCat . catOfList
-- | When given a list Cat, i.e. '[C]', it removes the square
-- brackets, and adds the prefix List, i.e. 'ListC'. (for Happy and
-- Latex)
-- >>> identCat (ListCat (Cat "C")) -- [C]
-- "ListC"
-- >>> identCat (CoercCat "C" 3)
-- "C3"
identCat :: Cat -> String
identCat (ListCat c) = "List" ++ identCat c
identCat c = show c
isList :: Cat -> Bool
isList (ListCat _) = True
isList _ = False
isTokenCat :: Cat -> Bool
isTokenCat (TokenCat _) = True
isTokenCat _ = False
-- | Unwraps the list constructor from the category name. Eg. [C1] => C1
-- E.g.
-- >>> catOfList (ListCat (Cat "A"))
-- A
-- >>> catOfList (Cat "B")
-- B
catOfList :: Cat -> Cat
catOfList (ListCat c) = c
catOfList c = c
------------------------------------------------------------------------------
-- Functions
------------------------------------------------------------------------------
-- | Fun is the function name of a rule.
type Fun = String
-- | Either Cat or Fun
-- | Is this function just a coercion? (Ie. the identity)
isCoercion :: Fun -> Bool
isCoercion = (== "_") -- perhaps this should be changed to "id"?
isDefinedRule :: Fun -> Bool
isDefinedRule (x:_) = isLower x
isDefinedRule [] = error "isDefinedRule: empty function name"
isProperLabel :: Fun -> Bool
isProperLabel f = not (isCoercion f || isDefinedRule f)
-- | FIXME: This is a copy of the old normCat function that some backend use
-- on Fun. Now that the type of Cat has changed, this is no longer possible
-- so this is added for those odd cases. It should be verified if this is
-- really necessary.
normFun :: Fun -> Fun
normFun f = case f of
'[':cs -> "[" ++ norm (init cs) ++ "]"
_ -> norm f
where norm = reverse . dropWhile isDigit . reverse
isNilFun, isOneFun, isConsFun, isNilCons,isConcatFun :: Fun -> Bool
isNilCons f = isNilFun f || isOneFun f || isConsFun f || isConcatFun f
isNilFun f = f == "[]"
isOneFun f = f == "(:[])"
isConsFun f = f == "(:)"
isConcatFun f = f == "(++)"
------------------------------------------------------------------------------
type Name = String
-- | Abstract syntax tree.
newtype Tree = Tree (Fun,[Tree])
-- | The abstract syntax of a grammar.
type Data = (Cat, [(Fun,[Cat])])
-- | firstCat returns the first Category appearing in the grammar.
firstCat :: CF -> Cat
firstCat = valCat . head . rulesOfCF
firstEntry :: CF -> Cat
firstEntry cf = case allEntryPoints cf of
(x:_) -> x
_ -> firstCat cf
rulesOfCF :: CFG f -> [Rul f]
rulesOfCFP :: CFP -> [RuleP]
infoOfCF :: CFG f -> Info
pragmasOfCF :: CFG f -> [Pragma]
rulesOfCF = snd . unCFG
rulesOfCFP = rulesOfCF
infoOfCF = snd . fst . unCFG
pragmasOfCF = fst . fst . unCFG
-- aggressively ban nonunique names (AR 31/5/2012)
notUniqueNames :: [Name] -> CF -> [Fun]
notUniqueNames reserved cf = [head xs | xs <- xss, length xs > 1] where
xss = group (sort names)
names = reserved ++ allCatsIdNorm cf ++ allFuns cf
allFuns g = [ f | f <- map funRule (rulesOfCF g), not (isNilCons f || isCoercion f)]
-- extract the comment pragmas.
commentPragmas :: [Pragma] -> [Pragma]
commentPragmas = filter isComment
where isComment (CommentS _) = True
isComment (CommentM _) = True
isComment _ = False
lookupRule :: Eq f => f -> [Rul f] -> Maybe (Cat, [Either Cat String])
lookupRule f = lookup f . map unRule
where unRule (Rule f' c rhs) = (f',(c,rhs))
-- | Returns all normal rules that constructs the given Cat.
rulesForCat :: CF -> Cat -> [Rule]
rulesForCat cf cat = [r | r <- rulesOfCF cf, isParsable r, valCat r == cat]
-- | Like rulesForCat but for normalized value categories.
-- I.e., `rulesForCat (Cat "Exp")` will return rules for category Exp but also
-- Exp1, Exp2... in case of coercion
rulesForNormalizedCat :: CF -> Cat -> [Rule]
rulesForNormalizedCat cf cat =
[r | r <- rulesOfCF cf, isParsable r, normCat (valCat r) == cat]
-- | As rulesForCat, but this version doesn't exclude internal rules.
rulesForCat' :: CF -> Cat -> [Rule]
rulesForCat' cf cat = [r | r <- rulesOfCF cf, valCat r == cat]
-- | Get all categories of a grammar. (No Cat w/o production returned; No duplicates)
allCats :: CFG f -> [Cat]
allCats = nub . map valCat . rulesOfCF
-- | Gets all normalized identified Categories
allCatsIdNorm :: CF -> [String]
allCatsIdNorm = nub . map (identCat . normCat) . allCats
-- | Get all normalized Cat
allCatsNorm :: CF -> [Cat]
allCatsNorm = nub . map normCat . allCats
-- | Is the category is used on an rhs?
isUsedCat :: CFG f -> Cat -> Bool
isUsedCat cf cat = cat `elem` [c | r <- rulesOfCF cf, Left c <- rhsRule r]
-- | Group all categories with their rules.
ruleGroups :: CF -> [(Cat,[Rule])]
ruleGroups cf = [(c, rulesForCat cf c) | c <- allCats cf]
-- | Group all categories with their rules including internal rules.
ruleGroupsInternals :: CF -> [(Cat,[Rule])]
ruleGroupsInternals cf = [(c, rulesForCat' cf c) | c <- allCats cf]
-- | Get all literals of a grammar. (e.g. String, Double)
literals :: CFG f -> [Cat]
literals cf = [TokenCat l | l <- lits] ++ owns
where
(lits,_,_,_) = infoOfCF cf
owns = map fst (tokenPragmas cf)
-- | Get all symbols
symbols :: CFG f -> [String]
symbols cf = syms
where (_,syms,_,_) = infoOfCF cf
-- | Get the keywords of a grammar.
reservedWords :: CFG f -> [String]
reservedWords cf = sort keywords
where (_,_,keywords,_) = infoOfCF cf
-- | Canonical, numbered list of symbols and reserved words. (These do
-- not end up in the AST.)
cfTokens :: CFG f -> [(String,Int)]
cfTokens cf = zip (sort (symbols cf ++ reservedWords cf)) [1..]
-- NOTE: some backends (incl. Haskell) assume that this list is sorted.
-- | Categories that is left-recursive transformable.
reversibleCats :: CFG f -> [Cat]
reversibleCats cf = cats
where (_,_,_,cats) = infoOfCF cf
-- | Comments can be defined by the 'comment' pragma
comments :: CF -> ([(String,String)],[String])
comments cf = case commentPragmas (pragmasOfCF cf) of
xs -> ([p | CommentM p <- xs],
[s | CommentS s <- xs])
-- built-in categories (corresponds to lexer)
-- | Whether the grammar uses the predefined Ident type.
hasIdent :: CFG f -> Bool
hasIdent cf = isUsedCat cf catIdent
-- these need new datatypes
-- | Categories corresponding to tokens. These end up in the
-- AST. (unlike tokens returned by 'cfTokens')
specialCats :: CF -> [Cat]
specialCats cf = (if hasIdent cf then (TokenCat "Ident":) else id) (map fst (tokenPragmas cf))
-- to print parse trees
prTree :: Tree -> String
prTree (Tree (fun,[])) = fun
prTree (Tree (fun,trees)) = fun +++ unwords (map pr2 trees) where
pr2 t@(Tree (_,ts)) = (if null ts then id else prParenth) (prTree t)
-- * abstract syntax trees: data type definitions
--
-- The abstract syncax, instanciated by the Data type, is the type signatures
-- of all the constructors.
-- | Return the abstract syntax of the grammar.
-- All categories are normalized, so a rule like:
-- EAdd . Exp2 ::= Exp2 "+" Exp3 ;
-- Will give the following signature: EAdd : Exp -> Exp -> Exp
getAbstractSyntax :: CF -> [(Cat, [(Fun, [Cat])])]
getAbstractSyntax cf = [ ( c, nub (constructors c) ) | c <- allCatsNorm cf ]
where
constructors cat = do
rule <- rulesOfCF cf
let f = funRule rule
guard $ not (isDefinedRule f)
guard $ not (isCoercion f)
guard $ normCat (valCat rule) == cat
let cs = [normCat c | Left c <- rhsRule rule, c /= InternalCat]
return (f, cs)
-- All the function bellow are variation arround the idea of getting the
-- abstract syntax of the grammar with some variation but they seem to do a
-- poor job at handling corner cases involving coercions. Use getAbstractSyntax
-- instead if possible.
cf2data' :: (Cat -> Bool) -> CF -> [Data]
cf2data' predicate cf =
[(cat, nub (map mkData [r | r <- rulesOfCF cf,
let f = funRule r,
not (isDefinedRule f),
not (isCoercion f), eqCat cat (valCat r)]))
| cat <- filter predicate (allCats cf)]
where
mkData (Rule f _ its) = (f,[normCat c | Left c <- its, c /= InternalCat])
cf2data :: CF -> [Data]
cf2data = cf2data' isDataCat
cf2dataLists :: CF -> [Data]
cf2dataLists = cf2data' isDataOrListCat
specialData :: CF -> [Data]
specialData cf = [(c,[(show c,[TokenCat "String"])]) | c <- specialCats cf] where
-- to deal with coercions
-- the Haskell convention: the wildcard _ is not a constructor
-- | Checks if the rule is parsable.
isParsable :: Rul f -> Bool
isParsable (Rule _ _ (Left c:_)) = c /= InternalCat
isParsable _ = True
-- | Checks if the list has a non-empty rule.
hasOneFunc :: [Rule] -> Bool
hasOneFunc = any (isOneFun . funRule)
-- | Gets the separator for a list.
getCons :: [Rule] -> String
getCons rs = case find (isConsFun . funRule) rs of
Just (Rule _ _ cats) -> seper cats
Nothing -> error $ "getCons: no construction function found in "
++ intercalate ", " (map (show . funRule) rs)
where
seper [] = []
seper (Right x:_) = x
seper (Left _:xs) = seper xs
-- | Helper function that gets the list separator by precedence level
getSeparatorByPrecedence :: [Rule] -> [(Integer,String)]
getSeparatorByPrecedence rules = [ (p, getCons (getRulesFor p)) | p <- precedences ]
where
precedences = sortBy (flip compare) $ nub $ map precRule rules
getRulesFor p = [ r | r <- rules, precRule r == p ]
isEmptyListCat :: CF -> Cat -> Bool
isEmptyListCat cf c = elem "[]" $ map funRule $ rulesForCat' cf c
isNonterm :: Either Cat String -> Bool
isNonterm (Left _) = True
isNonterm (Right _) = False
-- used in Happy to parse lists of form 'C t [C]' in reverse order
-- applies only if the [] rule has no terminals
revSepListRule :: Rul f -> Rul f
revSepListRule (Rule f c ts) = Rule f c (xs : x : sep) where
(x,sep,xs) = (head ts, init (tail ts), last ts)
-- invariant: test in findAllReversibleCats have been performed
findAllReversibleCats :: CF -> [Cat]
findAllReversibleCats cf = [c | (c,r) <- ruleGroups cf, isRev c r] where
isRev c rs = case rs of
[r1,r2] | isList c -> if isConsFun (funRule r2)
then tryRev r2 r1
else isConsFun (funRule r1) && tryRev r1 r2
_ -> False
tryRev (Rule f _ ts@(x:_:_)) r = isEmptyNilRule r &&
isConsFun f && isNonterm x && isNonterm (last ts)
tryRev _ _ = False
isEmptyNilRule :: Rul Fun -> Bool
isEmptyNilRule (Rule f _ ts) = isNilFun f && null ts
-- | Returns the precedence of a category symbol.
-- E.g.
--
-- >>> precCat (Cat "Abc")
-- 0
--
-- >>> precCat (CoercCat "Abc" 4)
-- 4
--
-- But!
-- >>> precCat (ListCat (CoercCat "Abc" 2))
-- 2
precCat :: Cat -> Integer
precCat (CoercCat _ i) = i
precCat (ListCat c) = precCat c
precCat _ = 0
precRule :: Rule -> Integer
precRule = precCat . valCat
precLevels :: CF -> [Integer]
precLevels cf = sort $ nub [ precCat c | c <- allCats cf]
precCF :: CF -> Bool
precCF cf = length (precLevels cf) > 1
-- | Does the category have a position stored in AST?
isPositionCat :: CFG f -> Cat -> Bool
isPositionCat cf cat = or [b | TokenReg name b _ <- pragmasOfCF cf, TokenCat name == cat]
-- | Grammar with permutation profile à la GF. AR 22/9/2004
type CFP = CFG FunP -- (Exts,[RuleP])
type FunP = (Fun,Prof)
type RuleP = Rul FunP -- (FunP, (Cat, [Either Cat String]))
-- | Pair of: the original function name, profile
type Prof = (Fun, [([[Int]],[Int])])
cf2cfp :: CF -> CFP
cf2cfp (CFG (es,rs)) = CFG (es, map cf2cfpRule rs)
cf2cfpRule :: Rule -> RuleP
cf2cfpRule (Rule f c its) = Rule (f, (f, trivialProf its)) c its
cfp2cf :: CFP -> CF
cfp2cf = fmap fst
trivialProf :: [Either Cat String] -> [([[Int]],[Int])]
trivialProf its = [([],[i]) | (i,_) <- zip [0..] [c | Left c <- its]]
{-# DEPRECATED rulesOfCFP, allCatsP, allEntryPointsP "Use the version without P postfix instead" #-}
funRuleP :: RuleP -> Fun
funRuleP = fst . funRule
ruleGroupsP :: CFP -> [(Cat,[RuleP])]
ruleGroupsP cf = [(c, rulesForCatP cf c) | c <- allCatsP cf]
rulesForCatP :: CFP -> Cat -> [RuleP]
rulesForCatP cf cat = [r | r <- rulesOfCFP cf, isParsable r, valCat r == cat]
allCatsP :: CFP -> [Cat]
allCatsP = allCats
-- | Categories that are entry points to the parser
allEntryPoints :: CFG f -> [Cat]
allEntryPoints cf = case concat [cats | EntryPoints cats <- pragmasOfCF cf] of
[] -> allCats cf
cs -> cs
allEntryPointsP :: CFP -> [Cat]
allEntryPointsP = allEntryPoints
BNFC-2.8.1/src/BNFC/ToCNFCore.hs0000644000000000000000000002143712654616013014010 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-
Copyright (C) 2012 Authors:
Jean-Philippe Bernardy.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-# LANGUAGE OverloadedStrings #-}
module BNFC.ToCNFCore (toCNF, isCat, group', catTag, punctuate', onRules, isUnitRule, splitOptim, second, lookupMulti,
Set, CatDescriptions, UnitRel, RHSEl, Exp(..), prettyExp, appMany, app',after) where
{-
Construction of CYK tables. The algorithm follows:
Lange, Martin; Leiß, Hans (2009), "To CNF or not to CNF? An Efficient
Yet Presentable Version of the CYK Algorithm", Informatica Didactica
-}
import BNFC.CF hiding (App,Exp)
import Control.Monad.RWS
import Control.Applicative hiding (Const)
import qualified Data.Map as M
import Data.List (nub,sortBy,sort)
import Data.Function (on)
import Data.Char (isAlphaNum,ord)
import Data.Pair
import Text.PrettyPrint.HughesPJ hiding (first,(<>))
(f *** g) (a,b) = (f a, g b)
second g = id *** g
onRules f (CFG (exts,rules)) = CFG (exts,f rules)
toCNF cf0 = (cf1,cf2,units,descriptions,neighbors)
where cf01@(CFG (exts01,_)) = funToExp . onRules delInternal $ cf0
(rules',descriptions) = toBin (rulesOfCF cf01)
cf1 = CFG (exts01,rules')
cf2 = delNull cf1
units = unitSet cf2
neighbors = neighborSet cf2
funToExp :: CFG Fun -> CFG Exp
funToExp = fmap toExp
toExp f | isCoercion f = Id
| otherwise = Con f
delInternal = filter (not . isInternalRhs . rhsRule)
where isInternalRhs (Left c:_) = c == InternalCat
isInternalRhs _ = False
isCat (Right _) = False
isCat (Left _) = True
group0 :: Eq a => [(a,[b])] -> [(a,[b])]
group0 [] = []
group0 ((a,bs):xs) = (a,bs ++ concatMap snd ys) : group0 zs
where (ys,zs) = span (\x -> fst x == a) xs
group' :: Ord a => [(a,[b])] -> [(a,[b])]
group' = group0 . sortBy (compare `on` fst)
catTag :: Either Cat String -> Doc
catTag (Left c) = "CAT_" <> text (concatMap escape (show c))
catTag (Right t) = "TOK_" <> text (concatMap escape t)
escape c | isAlphaNum c || c == '_' = [c]
escape '[' = ""
escape ']' = "_List"
escape '{' = "OPEN_"
escape '}' = "CLOS_"
escape '@' = "BIN_"
escape c = show $ ord c
punctuate' p = cat . punctuate p
--------------------------------------------------------------
-- BIN: make sure no rule has more than 2 symbols on the rhs
allocateCatName = do
n <- get
put (1+n)
return $ show n
toBin :: [Rul Exp] -> ([Rul Exp], CatDescriptions)
toBin cf = (a,w)
where (a,_,w) = runRWS (concat <$> forM cf toBinRul) () 0
type CatDescriptions = M.Map Cat Doc
-- | Convert a rule into a number of equivalent rules with at most 2
-- symbols on the rhs.
-- Also writes an explanation of what new categories are.
toBinRul :: Rul Exp -> RWS () CatDescriptions Int [Rul Exp]
toBinRul (Rule f cat rhs) | length rhs > 2 = do
cat' <- liftM Cat allocateCatName
r' <- toBinRul $ Rule f cat' p
tell $ M.singleton cat' (int (length p) <> "-prefix of " <> prettyExp f <> " " <> parens (prettyRHS p))
return $ Rule (Con "($)") cat [Left cat',l]
: r'
where l = last rhs
p = init rhs
toBinRul r = return [r]
prettyRHS = hcat . punctuate " " . map (either (text . show) (quotes . text))
---------------------------
-- Fixpoint utilities
x ∪ y = sort $ nub (x ++ y)
lookupMulti cat nullset = maybe [] id (M.lookup cat nullset)
type Set k x = M.Map k [x]
fixpointOnGrammar :: (Show k, Show x,Ord k, Ord x) => String -> (Set k x -> Rul f -> Set k x) -> CFG f -> Set k x
fixpointOnGrammar name f cf = case fixn 100 step M.empty of
Left x -> error $ "Could not find fixpoint of " ++ name ++". Last iteration:\n" ++ show x
Right x -> x
where step curSet = M.unionsWith (∪) (map (f curSet) (rulesOfCF cf))
fixn :: Eq a => Int -> (a -> a) -> a -> Either a a
fixn 0 _ x = Left x
fixn n f x = if x' == x then Right x else fixn (n-1) f x'
where x' = f x
-------------------------------------------------------
-- DEL : make sure no rule has 0 symbol on the rhs
type Nullable = Set Cat Exp
cross :: [[a]] -> [[a]]
cross [] = [[]]
cross (x:xs) = [y:ys | y <- x, ys <- cross xs]
nullRule :: Nullable -> Rul Exp -> (Cat,[Exp])
nullRule nullset (Rule f c rhs) = (c, map (appMany f) (cross (map nulls rhs)))
where nulls (Right _) = []
nulls (Left cat) = lookupMulti cat nullset
nullSet :: CFG Exp -> Nullable
nullSet = fixpointOnGrammar "nullable" (\s r -> uncurry M.singleton (nullRule s r))
-- | Replace nullable occurences by nothing, and adapt the function consequently.
delNullable :: Nullable -> Rul Exp -> [Rul Exp]
delNullable nullset r@(Rule f cat rhs) = case rhs of
[] -> []
[_] -> [r]
[r1,r2] -> [r] ++ [Rule (app' f x) cat [r2] | x <- lk' r1]
++ [Rule (app2 (isCat r1) f x) cat [r1] | x <- lk' r2]
_ -> error $ "Panic:" ++ show r ++ "should have at most two elements."
where lk' (Right _) = []
lk' (Left cat) = lookupMulti cat nullset
delNull cf = onRules (concatMap (delNullable (nullSet cf))) cf
---------------
-- UNIT
type UnitRel cat = Set (Either cat String) (Exp,cat)
-- (c,(f,c')) ∈ unitSet ⇒ f : c → c'
unitSet :: CFG Exp -> UnitRel Cat
unitSet = fixpointOnGrammar "unit set" unitRule
unitRule unitSet (Rule f c [r]) = M.singleton r $ (f,c) : [(g `appl` f,c') | (g,c') <- lookupMulti (Left c) unitSet]
where appl = case r of
Left _ -> after
Right _ -> app'
unitRule _ _ = M.empty
isUnitRule (Rule _ _ [_]) = True
isUnitRule _ = False
------------------------
-- Left/Right occurences
type RHSEl = Either Cat String
isOnLeft, isOnRight :: RHSEl -> Rul f -> Bool
isOnLeft c (Rule _ _ [c',_]) = c == c'
isOnLeft _ _ = False
isOnRight c (Rule _ _ [_,c']) = c == c'
isOnRight _ _ = False
isEntryPoint cf el = either (`elem` allEntryPoints cf) (const False) el
occurs :: (RHSEl -> Rul f -> Bool) -> RHSEl -> CFG f -> Bool
occurs where_ el cf = any (where_ el) (rulesOfCF cf)
splitLROn :: (a -> RHSEl) -> CFG f -> [a] -> Pair [a]
splitLROn f cf xs = filt <*> pure xs
where filt = filter (\c -> occurs isOnLeft (f c) cf || isEntryPoint cf (f c)) :/:
filter (\c -> occurs isOnRight (f c) cf)
isSpecial (Left (Cat ('@':'@':_))) = True
isSpecial _ = False
optim :: (a -> RHSEl) -> Pair [a] -> Pair [(a,Doc -> Doc)]
optim f (x:/:y) = map modif x :/: map modif' y
where modif a | isSpecial (f a) = (a,\x -> "(if not p then (" <> x <> ":) else id)")
| otherwise = (a,rob)
modif' a | isSpecial (f a) = (a,\x -> "(if p then (" <> x <> ":) else id)")
| otherwise = (a,rob)
rob x = "("<> x <> ":)"
splitOptim f cf xs = optim f $ splitLROn f cf $ xs
---------------------------
-- Error reporting
-- leftOf C = ⋃ { {X} ∪ leftOf X | C ::= X B ∈ Grammar or C ::= X ∈ Grammar }
leftRight pos s (Rule _ c rhs) = M.singleton (show c) (lkCat x s)
where x = pos rhs
lkCat (Right t) _ = [Right t]
lkCat (Left c) s = Left c:lookupMulti (show c) s
-- neighbors A B = ∃ A' B'. P ::= A' B' ∧ A ∈ rightOf A' ∧ B ∈ leftOf B
neighborSet cf = map (second (nub . sort)) $ group' [(x',lkCat y leftSet) | Rule _ _ [x,y] <- rulesOfCF cf, x' <- lkCat x rightSet]
where leftSet = fixpointOnGrammar "left set" (leftRight head) cf
rightSet = fixpointOnGrammar "right set" (leftRight last) cf
data Exp = Id -- identity function
| Con String -- constructor or variable
| App Exp Exp
| Exp `After` Exp
| App2 Exp Exp
deriving (Eq,Ord)
prettyExp Id = "id"
prettyExp (Con x) = text x
prettyExp (App f x) = prettyExp f <+> (parens $ prettyExp x)
prettyExp (App2 f x) = "flip" <+> parens (prettyExp f) <+> parens (prettyExp x)
prettyExp (f `After` g) = parens (prettyExp f) <> "." <> parens (prettyExp g)
instance Show Exp where show = render . prettyExp
-- | Apply in 2nd position if the flag is true, otherwise apply normally.
app2 True f x = App2 f x
app2 False f x = app' f x
infixl `app'`
app' :: Exp -> Exp -> Exp
app' (f `After` g) x = app' f (app' g x)
app' Id x = x
app' (App2 f y) x = (f `app'` x) `app'` y
app' (Con "($)") f = f
-- app' (Con "const") f = f
app' f x = App f x
after :: Exp -> Exp -> Exp
after Id f = f
after f Id = f
after f g = f `After` g
appMany f args = foldl app' f args
BNFC-2.8.1/src/BNFC/MultiView.hs0000644000000000000000000000764512654616013014220 0ustar0000000000000000{-
BNF Converter: Abstract syntax
Copyright (C) 2004 Author: Markus Forsberg, Aarne Ranta
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.MultiView where
import System.Directory ( doesFileExist, renameFile )
import qualified BNFC.CF as CF
import BNFC.Utils
import ParBNF
import PrintBNF
import Data.List(nub,partition)
import AbsBNF
-- import LexBNF
import ErrM
import Data.Char
import BNFC.TypeChecker
preprocessMCF :: FilePath -> IO ([FilePath],String)
preprocessMCF f = do
s <- readFile f
gr <- case pLGrammar $ myLexer s of
Ok g -> return g
Bad s -> error s
let name = takeWhile (/='.') f
let grs = extract name gr
let entryp = entrypoint gr
mapM_ writeCF grs
return $ (map fst grs,entryp)
extract :: String -> LGrammar -> [(FilePath, Grammar)]
extract name (LGr ldefs) =
[(file lang,Grammar [unldef ldef | ldef <- ldefs, isFor lang ldef]) |
lang <- views]
where
views = [lang | LDefView langs <- ldefs, Ident lang <- langs]
isFor lang ldef = case ldef of
DefAll _ -> True
DefSome ids _ -> elem (Ident lang) ids
_ -> False
unldef ldef = case ldef of
DefAll d -> d
DefSome _ d -> d
file lang = name ++ "_" ++ lang ++ ".cf"
--- the entrypoint is the same for all languages - could be different
entrypoint :: LGrammar -> String
entrypoint (LGr rs0) = head $
[c | Entryp (Ident c:_) <- rs] ++
[c | Rule _ (IdCat (Ident c)) _ <- rs]
where
rs = concatMap getR rs0
getR d = case d of
DefAll d -> [d]
DefSome _ d -> [d]
_ -> [] --- LDefView
writeCF :: (FilePath, Grammar) -> IO ()
writeCF (file,gr) = do
writeFile file $ printTree gr
putStrLn $ "wrote file " ++ file
---- These are Haskell specific;
---- should be generalized by inspecting the options xx
mkTestMulti :: String -> [String] -> FilePath -> [FilePath] -> IO ()
mkTestMulti cat xx file files = do
let abs = takeWhile (/='.') file
let cncs = map (takeWhile (/='.')) files
let content = testfile cat xx abs cncs
writeFile ("TestTrans" ++ abs ++ ".hs") content
mkMakefileMulti :: [String] -> FilePath -> [FilePath] -> IO ()
mkMakefileMulti xx file files = do
let abs = takeWhile (/='.') file
let cncs = map (takeWhile (/='.')) files
let content = makefile xx abs cncs
writeFile "Makefile" content
makefile xx abs cncs = unlines $
"all:" :
["\tmake -f Makefile_" ++ cnc | cnc <- cncs] ++
["\tghc --make -o TestTrans" ++ abs ++ " TestTrans" ++ abs,
""
]
testfile cat xx abs cncs = unlines $
["module Main where"] ++
["import qualified Lex" ++ cnc | cnc <- cncs] ++
["import qualified Par" ++ cnc | cnc <- cncs] ++
["import qualified Print" ++ cnc | cnc <- cncs] ++
["import Abs" ++ abs,
"import ErrM",
"import System.Environment (getArgs)",
"",
"main :: IO ()",
"main = do",
" i:o:f:_ <- getArgs",
" s <- readFile f",
" case parse i s of",
" Ok t -> putStrLn $ prin o t",
" Bad s -> error s",
"",
"parse i = case i of"
] ++
[
" " ++ sho cnc ++ " -> Par" ++ cnc ++ ".p" ++ cat ++
" . Par" ++ cnc ++ ".myLexer" | cnc <- cncs
] ++
[
"",
"prin o = case o of"
] ++
[
" " ++ sho cnc ++ " -> Print" ++ cnc ++
".printTree" | cnc <- cncs
]
where
sho = show . tail . dropWhile (/='_')
BNFC-2.8.1/src/BNFC/WarningM.hs0000644000000000000000000000120612654616013014000 0ustar0000000000000000module BNFC.WarningM where
import qualified Control.Monad.Writer as W
-- Monad that allows pure computation to output
-- warnings
type WithWarnings a = W.Writer [String] a
-- Run the computation and return both the value
-- and the warnings
run :: WithWarnings a -> (a,[String])
run = W.runWriter
-- Run the computation and print the warnings
putWarnings :: WithWarnings a -> IO a
putWarnings c = do
let (v,warnings) = run c
mapM_ putStrLn warnings
return v
hasWarnings :: WithWarnings a -> Bool
hasWarnings c = let (v,warnings) = run c in not (null warnings)
-- Output a warning
warn :: String -> WithWarnings ()
warn s = W.tell [s]
BNFC-2.8.1/src/BNFC/PrettyPrint.hs0000644000000000000000000000144512654616013014567 0ustar0000000000000000-- Extends Text.PrettyPrint
module BNFC.PrettyPrint
( module Text.PrettyPrint
, (<.>)
, codeblock
, vsep
, (<=>)
) where
import Text.PrettyPrint
-- | Pretty print separator with a dot
-- >>> "abc" <.> "py"
-- abc.py
(<.>) :: Doc -> Doc -> Doc
a <.> b = a <> "." <> b
-- | Code block. A bloc of code, surrounded by {} and indented.
-- >>> codeblock 4 ["abc", "def"]
-- {
-- abc
-- def
-- }
codeblock :: Int -> [Doc] -> Doc
codeblock indent code = lbrace $+$ nest indent (vcat code) $+$ rbrace
-- | List version of prettyPrint $+$
-- >>> vsep [text "abc", nest 4 (text "def")]
-- abc
-- def
vsep :: [Doc] -> Doc
vsep = foldl ($+$) empty
-- | Pretty print separator with = (for assignments...)
-- >>> "a" <=> "123"
-- a = 123
(<=>) :: Doc -> Doc -> Doc
a <=> b = a <+> "=" <+> b
BNFC-2.8.1/src/BNFC/GetCF.hs0000644000000000000000000004446612654616013013225 0ustar0000000000000000{-
BNF Converter: Abstract syntax
Copyright (C) 2004 Author: Markus Forsberg, Aarne Ranta
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.GetCF(parseCF, parseCFP) where
import qualified AbsBNF as Abs
import ParBNF
import BNFC.CF
import BNFC.Options
import BNFC.TypeChecker
import BNFC.Utils
import Control.Arrow (left)
import Control.Monad.State
import Data.Char
import Data.Either (partitionEithers)
import Data.List(nub,partition)
import Data.Maybe (mapMaybe)
import ErrM
-- $setup
-- >>> import PrintBNF
parseCF :: SharedOptions -> Target -> String -> IO CF
parseCF opts t s = liftM cfp2cf (parseCFP opts t s)
parseCFP :: SharedOptions -> Target -> String -> IO CFP
parseCFP opts target content = do
cfp <- runErr $ pGrammar (myLexer content)
>>= expandRules
>>= getCFP (cnf opts)
>>= markTokenCategories
let cf = cfp2cf cfp
runErr $ checkDefinitions cf
let msgs3 = checkTokens cf
let reserved = [lang opts | target == TargetJava ]
-- Warn of fail if the grammar use non unique names
case filter (not . isDefinedRule) $ notUniqueNames reserved cf of
[] -> return ()
ns| target `notElem` [TargetHaskell,TargetHaskellGadt,TargetOCaml]
-> fail $ "ERROR: names not unique: " ++ unwords ns
| otherwise
-> do putStrLn $ "Warning: names not unique: " ++ unwords ns
putStrLn "This can be an error in other back ends."
-- Print msgs3
putStrLn $ unlines msgs3
-- Print the number of rules
putStrLn $ show (length (rulesOfCF cf)) +++ "rules accepted\n"
-- Print a warning if comment delimiter are bigger than 2 characters
let c3s = [(b,e) | (b,e) <- fst (comments cf), length b > 2 || length e > 2]
unless (null c3s) $do
putStrLn "Warning: comment delimiters longer than 2 characters ignored in Haskell:"
mapM_ putStrLn [b +++ "-" +++ e | (b,e) <- c3s]
return cfp
where
runErr (Ok a) = return a
runErr (Bad msg) = fail msg
{-
case filter (not . isDefinedRule) $ notUniqueFuns cf of
[] -> case (badInheritence cf) of
[] -> return (ret,True)
xs -> do
putStrLn "Warning :"
putStrLn $ " Bad Label name in Category(s) :" ++ unwords xs
putStrLn $ " These categories have more than one Label, yet one of these"
putStrLn $ " Labels has the same name as the Category. This will almost"
putStrLn $ " certainly cause problems in languages other than Haskell.\n"
return (ret,True)
xs -> do
putStrLn $ "Warning :"
putStrLn $ " Non-unique label name(s) : " ++ unwords xs
putStrLn $ " There may be problems with the pretty-printer.\n"
case (badInheritence cf) of
[] -> return (ret,True)
xs -> do
putStrLn $ "Warning :"
putStrLn $ " Bad Label name in Category(s) :" ++ unwords xs
putStrLn $ " These categories have more than one Label, yet one of these"
putStrLn $ " Labels has the same name as the Category. This will almost"
putStrLn $ " certainly cause problems in languages other than Haskell.\n"
return (ret,True)
-}
getCFP :: Bool -> Abs.Grammar -> Err CFP
getCFP cnf (Abs.Grammar defs0) = do
let rules = inlineDelims rules0
cf0 = revs srt
srt = let literals = nub [lit | xs <- map rhsRule rules,
Left (Cat lit) <- xs,
lit `elem` specialCatsP]
(symbols,keywords) = partition notIdent reservedWords
notIdent s = null s || not (isAlpha (head s)) || any (not . isIdentRest) s
isIdentRest c = isAlphaNum c || c == '_' || c == '\''
reservedWords = nub [t | r <- rules, Right t <- rhsRule r]
in CFG((pragma,(literals,symbols,keywords,[])),rules)
revs cf1@(CFG((pragma,(literals,symbols,keywords,_)),rules)) =
CFG((pragma,(literals,symbols,keywords,findAllReversibleCats (cfp2cf cf1))),rules)
case mapMaybe (checkRule (cfp2cf cf0)) (rulesOfCF cf0) of
[] -> return ()
msgs -> fail (unlines msgs)
return cf0
where
(pragma,rules0) = partitionEithers $ concatMap transDef defs
(defs,inlineDelims) = if cnf then (defs0,id) else removeDelims defs0
-- | This function goes through each rule of a grammar and replace Cat "X" with
-- TokenCat "X" when "X" is a token type.
markTokenCategories :: CFP -> Err CFP
markTokenCategories (CFG (exts, rules)) = return $ CFG (exts, newRules)
where
newRules = [ Rule f (mark c) (map (left mark) rhs) | Rule f c rhs <- rules ]
tokenCatNames = [ n | TokenReg n _ _ <- fst exts ] ++ specialCatsP
mark = toTokenCat tokenCatNames
-- | Change the constructor of categories with the given names from Cat to
-- TokenCat
-- >>> toTokenCat ["A"] (Cat "A") == TokenCat "A"
-- True
-- >>> toTokenCat ["A"] (ListCat (Cat "A")) == ListCat (TokenCat "A")
-- True
-- >>> toTokenCat ["A"] (Cat "B") == Cat "B"
-- True
toTokenCat :: [String] -> Cat -> Cat
toTokenCat ns (Cat a) | a `elem` ns = TokenCat a
toTokenCat ns (ListCat c) = ListCat (toTokenCat ns c)
toTokenCat _ c = c
removeDelims :: [Abs.Def] -> ([Abs.Def], [RuleP] -> [RuleP])
removeDelims xs = (ys ++ map delimToSep ds,
foldr (.) id [map (inlineDelim' d) | d <- ds])
where
(ds,ys) = partition isDelim xs
isDelim (Abs.Delimiters{}) = True
isDelim _ = False
inlineDelim :: Abs.Def -> Either Cat String -> [Either Cat String]
inlineDelim (Abs.Delimiters cat open close _ _) (Left c)
| c == ListCat (transCat cat) = [Right open, Left c, Right close]
inlineDelim _ x = [x]
inlineDelim' :: Abs.Def -> RuleP -> RuleP
inlineDelim' d@(Abs.Delimiters cat _ _ _ _) r@(Rule f c rhs)
| c == ListCat (transCat cat) = r
| otherwise = Rule f c (concatMap (inlineDelim d) rhs)
inlineDelim' _ _ = error "Not a delimiters pragma"
delimToSep (Abs.Delimiters cat _ _ (Abs.SepTerm s) sz) = Abs.Terminator sz cat s
delimToSep (Abs.Delimiters cat _ _ (Abs.SepSepar s) sz) = Abs.Separator sz cat s
delimToSep (Abs.Delimiters cat _ _ Abs.SepNone sz) = Abs.Terminator sz cat ""
delimToSep x = x
transDef :: Abs.Def -> [Either Pragma RuleP]
transDef x = case x of
Abs.Rule label cat items ->
[Right $ Rule (transLabel label) (transCat cat) (map transItem items)]
Abs.Comment str -> [Left $ CommentS str]
Abs.Comments str0 str -> [Left $ CommentM (str0,str)]
Abs.Token ident reg -> [Left $ TokenReg (transIdent ident) False reg]
Abs.PosToken ident reg -> [Left $ TokenReg (transIdent ident) True reg]
Abs.Entryp idents -> [Left $ EntryPoints (map (strToCat .transIdent) idents)]
Abs.Internal label cat items ->
[Right $ Rule (transLabel label) (transCat cat) (Left InternalCat:map transItem items)]
Abs.Separator size ident str -> map (Right . cf2cfpRule) $ separatorRules size ident str
Abs.Terminator size ident str -> map (Right . cf2cfpRule) $ terminatorRules size ident str
Abs.Delimiters a b c d e -> map (Right . cf2cfpRule) $ delimiterRules a b c d e
Abs.Coercions ident int -> map (Right . cf2cfpRule) $ coercionRules ident int
Abs.Rules ident strs -> map (Right . cf2cfpRule) $ ebnfRules ident strs
Abs.Layout ss -> [Left $ Layout ss]
Abs.LayoutStop ss -> [Left $ LayoutStop ss]
Abs.LayoutTop -> [Left LayoutTop]
Abs.Function f xs e -> [Left $ FunDef (transIdent f) (map transArg xs) (transExp e)]
delimiterRules :: Abs.Cat -> String -> String -> Abs.Separation -> Abs.MinimumSize -> [Rule]
delimiterRules a0 l r (Abs.SepTerm "") size = delimiterRules a0 l r Abs.SepNone size
delimiterRules a0 l r (Abs.SepSepar "") size = delimiterRules a0 l r Abs.SepNone size
delimiterRules a0 l r sep size = [
-- recognizing a single element
Rule "(:[])" (strToCat a') (Left a : termin), -- optional terminator/separator
-- glueing two sublists
Rule "(++)" (strToCat a') [Left (strToCat a'), Left (strToCat a')],
-- starting on either side with a delimiter
Rule "[]" (strToCat c) [Right l],
Rule (if optFinal then "(:[])" else
"[]")
(strToCat d) ([Left a | optFinal] ++ [Right r]),
-- gathering chains
Rule "(++)" (strToCat c) [Left (strToCat c), Left (strToCat a')],
Rule "(++)" (strToCat d) [Left (strToCat a'), Left (strToCat d)],
-- finally, put together left and right chains
Rule "(++)" as [Left (strToCat c),Left (strToCat d)]] ++ [
-- special rule for the empty list if necessary
Rule "[]" as [Right l,Right r] | optEmpty]
where a = transCat a0
as = ListCat a
a' = '@':'@':show a
c = '@':'{':show a
d = '@':'}':show a
-- optionally separated concat. of x and y categories.
termin = case sep of
Abs.SepSepar t -> [Right t]
Abs.SepTerm t -> [Right t]
_ -> []
optFinal = case (sep,size) of
(Abs.SepSepar _,_) -> True
(Abs.SepTerm _,Abs.MNonempty) -> True
(Abs.SepNone,Abs.MNonempty) -> True
_ -> False
optEmpty = case sep of
Abs.SepSepar _ -> size == Abs.MEmpty
_ -> False
separatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> [Rule]
separatorRules size c s = if null s then terminatorRules size c s else ifEmpty [
Rule "(:[])" cs [Left c'],
Rule "(:)" cs [Left c', Right s, Left cs]
]
where
c' = transCat c
cs = ListCat c'
ifEmpty rs = if size == Abs.MNonempty
then rs
else Rule "[]" cs [] : rs
terminatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> [Rule]
terminatorRules size c s = [
ifEmpty,
Rule "(:)" cs (Left c' : s' [Left cs])
]
where
c' = transCat c
cs = ListCat c'
s' its = if null s then its else Right s : its
ifEmpty = if size == Abs.MNonempty
then Rule "(:[])" cs (Left c' : if null s then [] else [Right s])
else Rule "[]" cs []
coercionRules :: Abs.Ident -> Integer -> [Rule]
coercionRules (Abs.Ident c) n =
Rule "_" (Cat c) [Left (CoercCat c 1)] :
[Rule "_" (CoercCat c (i-1)) [Left (CoercCat c i)] | i <- [2..n]] ++
[Rule "_" (CoercCat c n) [Right "(", Left (Cat c), Right ")"]]
ebnfRules :: Abs.Ident -> [Abs.RHS] -> [Rule]
ebnfRules (Abs.Ident c) rhss =
[Rule (mkFun k its) (strToCat c) (map transItem its)
| (k, Abs.RHS its) <- zip [1 :: Int ..] rhss]
where
mkFun k i = case i of
[Abs.Terminal s] -> c' ++ "_" ++ mkName k s
[Abs.NTerminal n] -> c' ++ identCat (transCat n)
_ -> c' ++ "_" ++ show k
c' = c --- normCat c
mkName k s = if all (\c -> isAlphaNum c || elem c ("_'" :: String)) s
then s else show k
transItem :: Abs.Item -> Either Cat String
transItem x = case x of
Abs.Terminal str -> Right str
Abs.NTerminal cat -> Left (transCat cat)
transCat :: Abs.Cat -> Cat
transCat x = case x of
Abs.ListCat cat -> ListCat (transCat cat)
Abs.IdCat (Abs.Ident c) -> strToCat c
transLabel :: Abs.Label -> (Fun,Prof)
transLabel y = case y of
Abs.LabNoP f -> let g = transLabelId f in (g,(g,[])) ---- should be Nothing
Abs.LabP f p -> let g = transLabelId f in (g,(g, map transProf p))
Abs.LabPF f g p -> (transLabelId f,(transLabelId g, map transProf p))
Abs.LabF f g -> (transLabelId f,(transLabelId g, []))
where
transLabelId x = case x of
Abs.Id id -> transIdent id
Abs.Wild -> "_"
Abs.ListE -> "[]"
Abs.ListCons -> "(:)"
Abs.ListOne -> "(:[])"
transProf (Abs.ProfIt bss as) =
([map fromInteger bs | Abs.Ints bs <- bss], map fromInteger as)
transIdent :: Abs.Ident -> String
transIdent x = case x of
Abs.Ident str -> str
transArg :: Abs.Arg -> String
transArg (Abs.Arg x) = transIdent x
transExp :: Abs.Exp -> Exp
transExp e = case e of
Abs.App x es -> App (transIdent x) (map transExp es)
Abs.Var x -> App (transIdent x) []
Abs.Cons e1 e2 -> cons e1 (transExp e2)
Abs.List es -> foldr cons nil es
Abs.LitInt x -> LitInt x
Abs.LitDouble x -> LitDouble x
Abs.LitChar x -> LitChar x
Abs.LitString x -> LitString x
where
cons e1 e2 = App "(:)" [transExp e1, e2]
nil = App "[]" []
--------------------------------------------------------------------------------
--checkTokens :: CFG f -> [String]
checkTokens cf =
if null ns
then []
else ["Warning : ", -- change to error in a future version
" The following tokens accept the empty string: ",
" "++unwords ns,
" This is error-prone and will not be supported in the future."]
where
ns = map (show.fst) . filter (nullable.snd) $ tokenPragmas cf
-- | Check if a regular expression is nullable (accepts the empty string)
nullable :: Abs.Reg -> Bool
nullable r =
case r of
Abs.RSeq r1 r2 -> nullable r1 && nullable r2
Abs.RAlt r1 r2 -> nullable r1 || nullable r2
Abs.RMinus r1 r2 -> nullable r1 && not (nullable r2)
Abs.RStar _ -> True
Abs.RPlus r1 -> nullable r1
Abs.ROpt _ -> True
Abs.REps -> True
Abs.RChar _ -> False
Abs.RAlts _ -> False
Abs.RSeqs s -> null s
Abs.RDigit -> False
Abs.RLetter -> False
Abs.RUpper -> False
Abs.RLower -> False
Abs.RAny -> False
-- we should actually check that
-- (1) coercions are always between variants
-- (2) no other digits are used
checkRule :: CF -> RuleP -> Maybe String
checkRule _ (Rule _ (Cat ('@':_)) _) = Nothing -- Generated by a pragma; it's a trusted category
checkRule cf (Rule (f,_) cat rhs)
| badCoercion = Just $ "Bad coercion in rule" +++ s
| badNil = Just $ "Bad empty list rule" +++ s
| badOne = Just $ "Bad one-element list rule" +++ s
| badCons = Just $ "Bad list construction rule" +++ s
| badList = Just $ "Bad list formation rule" +++ s
| badSpecial = Just $ "Bad special category rule" +++ s
| badTypeName = Just $ "Bad type name" +++ unwords (map show badtypes) +++ "in" +++ s
| badFunName = Just $ "Bad constructor name" +++ f +++ "in" +++ s
| badMissing = Just $ "No production for" +++ unwords missing ++
", appearing in rule" +++ s +++ ". Defined categories:" +++ unwords defineds
| otherwise = Nothing
where
s = f ++ "." +++ show cat +++ "::=" +++ unwords (map (either show show) rhs) -- Todo: consider using the show instance of Rule
c = normCat cat
cs = [normCat c | Left c <- rhs]
badCoercion = isCoercion f && [c] /= cs
badNil = isNilFun f && not (isList c && null cs)
badOne = isOneFun f && not (isList c && cs == [catOfList c])
badCons = isConsFun f && not (isList c && cs == [catOfList c, c])
badList = isList c &&
not (isCoercion f || isNilCons f)
badSpecial = elem c [ Cat x | x <- specialCatsP] && not (isCoercion f)
badMissing = not (null missing)
missing = filter nodef [show c | Left c <- rhs]
nodef t = t `notElem` defineds
defineds =
show InternalCat : tokenNames cf ++ specialCatsP ++ map (show . valCat) (rulesOfCF cf)
badTypeName = not (null badtypes)
badtypes = filter isBadType $ cat : [c | Left c <- rhs]
isBadType (ListCat c) = isBadType c
isBadType InternalCat = False
isBadType (CoercCat c _) = isBadCatName c
isBadType (Cat s) = isBadCatName s
isBadType (TokenCat s) = isBadCatName s
isBadCatName s = not (isUpper (head s) || s == show InternalCat || (head s == '@'))
badFunName = not (all (\c -> isAlphaNum c || c == '_') f {-isUpper (head f)-}
|| isCoercion f || isNilCons f)
-- | Pre-processor that converts the `rules` macros to regular rules
-- by creating unique function names for them.
-- >>> :{
-- let rules1 = Abs.Rules (Abs.Ident "Foo")
-- [ Abs.RHS [Abs.Terminal "abc"]
-- , Abs.RHS [Abs.NTerminal (Abs.IdCat (Abs.Ident "A"))]
-- , Abs.RHS [Abs.Terminal "foo", Abs.Terminal "bar"]
-- , Abs.RHS [Abs.Terminal "++"]
-- ]
-- in
-- let Ok tree = expandRules (Abs.Grammar [rules1])
-- in putStrLn (printTree tree)
-- :}
-- Foo_abc . Foo ::= "abc" ;
-- FooA . Foo ::= A ;
-- Foo1 . Foo ::= "foo" "bar" ;
-- Foo2 . Foo ::= "++"
--
-- Note that if there are two `rules` macro with the same category, the
-- generated names should be uniques:
-- >>> :{
-- let rules1 = Abs.Rules (Abs.Ident "Foo")
-- [ Abs.RHS [Abs.Terminal "foo", Abs.Terminal "bar"] ]
-- in
-- let rules2 = Abs.Rules (Abs.Ident "Foo")
-- [ Abs.RHS [Abs.Terminal "foo", Abs.Terminal "foo"] ]
-- in
-- let Ok tree = expandRules (Abs.Grammar [rules1, rules2])
-- in putStrLn (printTree tree)
-- :}
-- Foo1 . Foo ::= "foo" "bar" ;
-- Foo2 . Foo ::= "foo" "foo"
--
-- This is using a State monad to remember the last used index for a category.
expandRules :: Abs.Grammar -> Err Abs.Grammar
expandRules (Abs.Grammar defs) =
return $ Abs.Grammar (concat (evalState (mapM expand defs) []))
where
expand (Abs.Rules ident rhss) = mapM (mkRule ident) rhss
expand other = return [other]
mkRule :: Abs.Ident -> Abs.RHS -> State [(String, Int)] Abs.Def
mkRule ident (Abs.RHS rhs) = do
fun <- liftM (Abs.LabNoP . Abs.Id . Abs.Ident) (mkName ident rhs)
return (Abs.Rule fun (Abs.IdCat ident) rhs)
mkName :: Abs.Ident -> [Abs.Item] -> State [(String, Int)] String
mkName (Abs.Ident cat) [Abs.Terminal s]
| all (\c -> isAlphaNum c || elem c ("_'" :: String)) s = return (cat ++ "_" ++ s)
mkName (Abs.Ident cat) [Abs.NTerminal (Abs.IdCat (Abs.Ident s))] =
return (cat ++ s)
mkName (Abs.Ident cat) _ = do
i <- liftM (maybe 1 (+1) . lookup cat) get
modify ((cat, i):)
return (cat ++ show i)
BNFC-2.8.1/src/BNFC/Utils.hs0000644000000000000000000001734712654616013013373 0ustar0000000000000000{-
BNF Converter: Abstract syntax
Copyright (C) 2004 Author: Aarne Ranta
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Utils
( (+++), (++++)
, mkName, mkNames, NameStyle(..)
, lowerCase, upperCase, mixedCase, camelCase, snakeCase
, replace, prParenth
, writeFileRep
) where
import Control.Arrow ((&&&))
import Control.DeepSeq (rnf)
import Data.Char
import Data.List (intercalate)
import System.IO (IOMode(ReadMode),hClose,hGetContents,openFile)
import System.IO.Error (tryIOError)
import System.Directory (createDirectory, doesDirectoryExist, renameFile,
removeFile)
import BNFC.PrettyPrint
infixr 5 +++
infixr 5 ++++
-- printing operations
(+++), (++++) :: String -> String -> String
a +++ b = a ++ " " ++ b
a ++++ b = a ++ "\n" ++ b
prParenth :: String -> String
prParenth s = if s == "" then "" else "(" ++ s ++ ")"
-- * List utilities
-- | Replace all occurences of a value by another value
replace :: Eq a =>
a -- ^ Value to replace
-> a -- ^ Value to replace it with
-> [a] -> [a]
replace x y xs = [ if z == x then y else z | z <- xs]
-- * File utilities
-- | Write a file, after making a backup of an existing file with the same name.
-- If an old version of the file exist and the new version is the same,
-- keep the old file and don't create a .bak file.
-- / New version by TH, 2010-09-23
writeFileRep :: FilePath -> String -> IO ()
writeFileRep path s =
either newFile updateFile =<< tryIOError (readFile' path)
where
newFile _ =
do putStrLn $ "writing new file "++path
writeFile path s
updateFile old =
do let tmp=path++".tmp"
writeFile tmp s
new <- readFile' tmp
if new==old -- test is O(1) space, O(n) time
then do putStrLn $ "no change to file "++path
removeFile tmp
else do let bak=path++".bak"
putStrLn $ "writing file "++path
++" (saving old file as "++bak++")"
renameFile path bak
renameFile tmp path
-- force reading of contents of files to achieve compatibility with
-- Windows IO handling as combining lazy IO with `readFile` and
-- 2x `renameFile` on the open `path` file complains with
-- "bnfc.exe: Makefile: MoveFileEx "Makefile" "Makefile.bak": permission
-- denied (The process cannot access the file because it is being used
-- by another process.)"
readFile' :: FilePath -> IO String
readFile' path' =
do inFile <- openFile path' ReadMode
contents <- hGetContents inFile
rnf contents `seq` hClose inFile
return contents
-- *** Naming ***
-- Because naming is hard (http://blog.codinghorror.com/i-shall-call-it-somethingmanager/)
-- | Different case style
data NameStyle = LowerCase -- ^ e.g. @lowercase@
| UpperCase -- ^ e.g. @UPPERCASE@
| SnakeCase -- ^ e.g. @snake_case@
| CamelCase -- ^ e.g. @CamelCase@
| MixedCase -- ^ e.g. @mixedCase@
deriving (Show, Eq)
-- | Generate a name in the given case style taking into account the reserved
-- word of the language. Note that despite the fact that those name are mainly
-- to be used in code rendering (type Doc), we return a String here to allow
-- further manipulation of the name (like disambiguation) which is not possible
-- in the Doc type.
-- Examples:
-- >>> mkName [] LowerCase "FooBAR"
-- "foobar"
-- >>> mkName [] UpperCase "FooBAR"
-- "FOOBAR"
-- >>> mkName [] SnakeCase "FooBAR"
-- "foo_bar"
-- >>> mkName [] CamelCase "FooBAR"
-- "FooBAR"
-- >>> mkName [] CamelCase "Foo_bar"
-- "FooBar"
-- >>> mkName [] MixedCase "FooBAR"
-- "fooBAR"
-- >>> mkName ["foobar"] LowerCase "FooBAR"
-- "foobar_"
-- >>> mkName ["foobar", "foobar_"] LowerCase "FooBAR"
-- "foobar__"
mkName :: [String] -> NameStyle -> String -> String
mkName reserved style s = notReserved name'
where
notReserved s
| s `elem` reserved = notReserved (s ++ "_")
| otherwise = s
tokens = parseIdent s
name' = case style of
LowerCase -> map toLower (concat tokens)
UpperCase -> map toUpper (concat tokens)
CamelCase -> concatMap capitalize tokens
MixedCase -> case concatMap capitalize tokens of
"" -> ""
c:cs -> toLower c:cs
SnakeCase -> map toLower (intercalate "_" tokens)
capitalize [] = []
capitalize (c:cs) = toUpper c:cs
-- | Same as above but accept a list as argument and make sure that the
-- names generated are uniques.
-- >>> mkNames ["c"] LowerCase ["A", "b_", "a_", "c"]
-- ["a1","b","a2","c_"]
mkNames :: [String] -> NameStyle -> [String] -> [String]
mkNames reserved style = disambiguateNames . map (mkName reserved style)
-- | This one takes a list of names and makes sure each is unique, appending
-- numerical suffix if needed
-- >>> disambiguateNames ["a", "b", "a", "c"]
-- ["a1","b","a2","c"]
disambiguateNames :: [String] -> [String]
disambiguateNames = disamb []
where
disamb ns1 (n:ns2)
| n `elem` (ns1 ++ ns2) = let i = length (filter (==n) ns1) + 1
in (n ++ show i) : disamb (n:ns1) ns2
| otherwise = n : disamb (n:ns1) ns2
disamb _ [] = []
-- | Heuristic to "parse" an identifier into separate componennts
--
-- >>> parseIdent "abc"
-- ["abc"]
--
-- >>> parseIdent "Abc"
-- ["Abc"]
--
-- >>> parseIdent "WhySoSerious"
-- ["Why","So","Serious"]
--
-- >>> parseIdent "why_so_serious"
-- ["why","so","serious"]
--
-- >>> parseIdent "why-so-serious"
-- ["why","so","serious"]
--
-- Some corner cases
-- >>> parseIdent "LBNFParser"
-- ["LBNF","Parser"]
--
-- >>> parseIdent "ILoveNY"
-- ["I","Love","NY"]
parseIdent :: String -> [String]
parseIdent = p [] . map (classify &&& id)
where
classify c
| isUpper c = U
| isLower c = L
| otherwise = O
p [] [] = []
p acc [] = reverse acc: p [] []
p [] ((L,c):cs) = p [c] cs
p [] ((U,c):cs) = p [c] cs
p [] ((O,_):cs) = p [] cs
p acc ((L,c1):cs@((L,_):_)) = p (c1:acc) cs
p acc ((U,c1):cs@((L,_):_)) = reverse acc:p [c1] cs
p acc ((U,c1):cs@((U,_):_)) = p (c1:acc) cs
p acc ((L,c1):cs@((U,_):_)) = reverse (c1:acc) : p [] cs
p acc ((U,c1):(O,_):cs) = reverse (c1:acc) : p [] cs
p acc ((L,c1):(O,_):cs) = reverse (c1:acc) : p [] cs
p acc ((O,_):cs) = reverse acc : p [] cs
p acc [(_,c)] = p (c:acc) []
data CharClass = U | L | O
-- | Ident to lower case
-- >>> lowerCase "MyIdent"
-- myident
lowerCase :: String -> Doc
lowerCase = text . mkName [] LowerCase
-- | Ident to upper case
-- >>> upperCase "MyIdent"
-- MYIDENT
upperCase :: String -> Doc
upperCase = text . mkName [] UpperCase
-- | Ident to camel case
-- >>> camelCase "my_ident"
-- MyIdent
camelCase :: String -> Doc
camelCase = text . mkName [] CamelCase
-- | To mixed case
-- >>> mixedCase "my_ident"
-- myIdent
mixedCase :: String -> Doc
mixedCase = text . mkName [] MixedCase
-- | To snake case
-- >>> snakeCase "MyIdent"
-- my_ident
snakeCase :: String -> Doc
snakeCase = text . mkName [] SnakeCase
BNFC-2.8.1/src/BNFC/TypeChecker.hs0000644000000000000000000001217612654616013014474 0ustar0000000000000000
module BNFC.TypeChecker where
import Control.Monad
import Data.List
import Data.Char
import BNFC.CF
import ErrM
data Base = BaseT String
| ListT Base
deriving (Eq)
data Type = FunT [Base] Base
deriving (Eq)
instance Show Base where
show (BaseT x) = x
show (ListT t) = "[" ++ show t ++ "]"
instance Show Type where
show (FunT ts t) = unwords $ map show ts ++ ["->", show t]
data Context = Ctx { ctxLabels :: [(String, Type)]
, ctxTokens :: [String]
}
catchErr :: Err a -> (String -> Err a) -> Err a
catchErr (Bad s) f = f s
catchErr (Ok x) _ = Ok x
buildContext :: CF -> Context
buildContext cf@(CFG(_,rules)) =
Ctx
[ (f, mkType cat args) | Rule f cat args <- rules
, not (isCoercion f)
, not (isNilCons f)
]
("Ident" : tokenNames cf)
where
mkType cat args = FunT [ mkBase t | Left t <- args, t /= InternalCat ]
(mkBase cat)
mkBase t
| isList t = ListT $ mkBase $ normCatOfList t
| otherwise = BaseT $ show $ normCat t
isToken :: String -> Context -> Bool
isToken x ctx = elem x $ ctxTokens ctx
extendContext :: Context -> [(String,Type)] -> Context
extendContext ctx xs = ctx { ctxLabels = xs ++ ctxLabels ctx }
lookupCtx :: String -> Context -> Err Type
lookupCtx x ctx
| isToken x ctx = return $ FunT [BaseT "String"] (BaseT x)
| otherwise =
case lookup x $ ctxLabels ctx of
Nothing -> fail $ "Undefined symbol '" ++ x ++ "'."
Just t -> return t
checkDefinitions :: CF -> Err ()
checkDefinitions cf =
do checkContext ctx
sequence_ [checkDefinition ctx f xs e | FunDef f xs e <- pragmasOfCF cf]
where
ctx = buildContext cf
checkContext :: Context -> Err ()
checkContext ctx =
mapM_ checkEntry $ groupSnd $ ctxLabels ctx
where
-- This is a very handy function which transforms a lookup table
-- with duplicate keys to a list valued lookup table with no duplicate
-- keys.
groupSnd :: Ord a => [(a,b)] -> [(a,[b])]
groupSnd =
map ((fst . head) /\ map snd)
. groupBy ((==) **.* fst)
. sortBy (compare **.* fst)
(f /\ g) x = (f x, g x)
(f **.* g) x y = f (g x) (g y)
checkEntry (f,ts) =
case nub ts of
[_] -> return ()
ts' ->
fail $ "The symbol '" ++ f ++ "' is used at conflicting types:\n" ++
unlines (map ((" " ++) . show) ts')
checkDefinition :: Context -> String -> [String] -> Exp -> Err ()
checkDefinition ctx f xs e =
void $ checkDefinition' dummyConstructors ctx f xs e
data ListConstructors = LC
{ nil :: Base -> String
, cons :: Base -> String
}
dummyConstructors :: ListConstructors
dummyConstructors = LC (const "[]") (const "(:)")
checkDefinition' :: ListConstructors -> Context -> String -> [String] -> Exp -> Err ([(String,Base)],(Exp,Base))
checkDefinition' list ctx f xs e =
do unless (isLower $ head f) $ fail "Defined functions must start with a lowercase letter."
t@(FunT ts t') <- lookupCtx f ctx `catchErr` \_ ->
fail $ "'" ++ f ++ "' must be used in a rule."
let expect = length ts
given = length xs
unless (expect == given) $ fail $ "'" ++ f ++ "' is used with type " ++ show t ++ " but defined with " ++ show given ++ " argument" ++ plural given ++ "."
e' <- checkExp list (extendContext ctx $ zip xs (map (FunT []) ts)) e t'
return (zip xs ts, (e', t'))
`catchErr` \err -> fail $ "In the definition " ++ unwords (f : xs ++ ["=",show e,";"]) ++ "\n " ++ err
where
plural 1 = ""
plural _ = "s"
checkExp :: ListConstructors -> Context -> Exp -> Base -> Err Exp
checkExp list _ (App "[]" []) (ListT t) = return (App (nil list t) [])
checkExp _ _ (App "[]" _) _ = fail "[] is applied to too many arguments."
checkExp list ctx (App "(:)" [e,es]) (ListT t) =
do e' <- checkExp list ctx e t
es' <- checkExp list ctx es (ListT t)
return $ App (cons list t) [e',es']
checkExp _ _ (App "(:)" es) _ = fail $ "(:) takes 2 arguments, but has been given " ++ show (length es) ++ "."
checkExp list ctx e@(App x es) t =
do FunT ts t' <- lookupCtx x ctx
es' <- matchArgs ts
unless (t == t') $ fail $ show e ++ " has type " ++ show t' ++ ", but something of type " ++ show t ++ " was expected."
return $ App x es'
where
matchArgs ts
| expect /= given = fail $ "'" ++ x ++ "' takes " ++ show expect ++ " arguments, but has been given " ++ show given ++ "."
| otherwise = zipWithM (checkExp list ctx) es ts
where
expect = length ts
given = length es
checkExp _ _ e@(LitInt _) (BaseT "Integer") = return e
checkExp _ _ e@(LitDouble _) (BaseT "Double") = return e
checkExp _ _ e@(LitChar _) (BaseT "Char") = return e
checkExp _ _ e@(LitString _) (BaseT "String") = return e
checkExp _ _ e t = fail $ show e ++ " does not have type " ++ show t ++ "."
BNFC-2.8.1/src/BNFC/Options.hs0000644000000000000000000003056112654616013013717 0ustar0000000000000000module BNFC.Options where
import BNFC.CF (CF)
import Data.Maybe (fromMaybe)
import Data.Version ( showVersion )
import Paths_BNFC ( version )
import System.Console.GetOpt
import System.FilePath (takeBaseName)
import Text.Printf (printf)
-- ~~~ Option data structures ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- | To decouple the option parsing from the execution of the program,
-- we introduce a data structure that holds the result of the
-- parsing of the arguments.
data Mode
-- An error has been made by the user
-- e.g. invalid argument/combination of arguments
= UsageError String
-- Basic modes: print some info and exits
| Help | Version
-- Normal mode, specifying the back end to use,
-- the option record to be passed to the backend
-- and the path of the input grammar file
| Target SharedOptions FilePath
deriving (Eq,Show,Ord)
-- | Target languages
data Target = TargetC | TargetCpp | TargetCppNoStl | TargetCSharp
| TargetHaskell | TargetHaskellGadt | TargetLatex
| TargetJava | TargetOCaml | TargetProfile | TargetPygments
deriving (Eq,Bounded, Enum,Ord)
-- Create a list of all target using the enum and bounded classes
targets :: [Target]
targets = [minBound..]
instance Show Target where
show TargetC = "C"
show TargetCpp = "C++"
show TargetCppNoStl = "C++ (without STL)"
show TargetCSharp = "C#"
show TargetHaskell = "Haskell"
show TargetHaskellGadt = "Haskell (with GADT)"
show TargetLatex = "Latex"
show TargetJava = "Java"
show TargetOCaml = "OCaml"
show TargetProfile = "Haskell (with permutation profiles)"
show TargetPygments = "Pygments"
-- | Which version of Alex is targeted?
data AlexVersion = Alex1 | Alex2 | Alex3
deriving (Show,Eq,Ord,Bounded,Enum)
-- | Happy modes
data HappyMode = Standard | GLR
deriving (Eq,Show,Bounded,Enum,Ord)
-- | This is the option record that is passed to the different backends
data SharedOptions = Options
-- Option shared by at least 2 backends
{ target :: Target
, make :: Maybe String -- ^ The name of the Makefile to generate
-- or Nothing for no Makefile.
, inPackage :: Maybe String -- ^ The hierarchical package to put
-- the modules in, or Nothing.
, cnf :: Bool -- ^ Generate CNF-like tables?
, lang :: String
-- Haskell specific:
, alexMode :: AlexVersion
, jflex :: Bool
, inDir :: Bool
, shareStrings :: Bool
, byteStrings :: Bool
, glr :: HappyMode
, xml :: Int
, ghcExtensions :: Bool
-- C++ specific
, linenumbers :: Bool -- ^ Add and set line_number field for syntax classes
-- C# specific
, visualStudio :: Bool -- ^ Generate Visual Studio solution/project files
, wcf :: Bool -- ^ Windows Communication Foundation
, functor :: Bool
, outDir :: FilePath -- ^ Target directory for generated files
} deriving (Eq,Show,Ord)
-- | We take this oportunity to define the type of the backend functions
type Backend = SharedOptions -- ^ options
-> CF -- ^ Grammar
-> IO ()
defaultOptions :: SharedOptions
defaultOptions = Options
{ cnf = False
, target = TargetHaskell
, inPackage = Nothing
, make = Nothing
, alexMode = Alex3
, inDir = False
, shareStrings = False
, byteStrings = False
, glr = Standard
, xml = 0
, ghcExtensions = False
, lang = error "lang not set"
, linenumbers = False
, visualStudio = False
, wcf = False
, functor = False
, outDir = "."
, jflex = False
}
-- ~~~ Option definition ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- This defines bnfc's "global" options, like --help
globalOptions :: [ OptDescr Mode ]
globalOptions = [
Option [] ["help"] (NoArg Help) "show help",
Option [] ["version","numeric-version"] (NoArg Version) "show version number"]
-- | Options for the target languages
-- targetOptions :: [ OptDescr Target ]
targetOptions :: [ OptDescr (SharedOptions -> SharedOptions)]
targetOptions =
[ Option "" ["java"] (NoArg (\o -> o {target = TargetJava}))
"Output Java code for use with JLex and CUP"
, Option "" ["haskell"] (NoArg (\o -> o {target = TargetHaskell}))
"Output Haskell code for use with Alex and Happy (default)"
, Option "" ["haskell-gadt"] (NoArg (\o -> o {target = TargetHaskellGadt}))
"Output Haskell code which uses GADTs"
, Option "" ["latex"] (NoArg (\o -> o {target = TargetLatex}))
"Output LaTeX code to generate a PDF description of the language"
, Option "" ["c"] (NoArg (\o -> o {target = TargetC}))
"Output C code for use with FLex and Bison"
, Option "" ["cpp"] (NoArg (\o -> o {target = TargetCpp}))
"Output C++ code for use with FLex and Bison"
, Option "" ["cpp-nostl"] (NoArg (\o -> o {target = TargetCppNoStl}))
"Output C++ code (without STL) for use with FLex and Bison"
, Option "" ["csharp"] (NoArg (\o -> o {target = TargetCSharp}))
"Output C# code for use with GPLEX and GPPG"
, Option "" ["ocaml"] (NoArg (\o -> o {target = TargetOCaml}))
"Output OCaml code for use with ocamllex and ocamlyacc"
, Option "" ["profile"] (NoArg (\o -> o {target = TargetProfile}))
"Output Haskell code for rules with permutation profiles"
, Option "" ["pygments"] (NoArg (\o -> o {target = TargetPygments}))
"Output a Python lexer for Pygments"
]
-- | A list of the options and for each of them, the target language
-- they apply to.
specificOptions :: [(OptDescr (SharedOptions -> SharedOptions), [Target])]
specificOptions =
[ ( Option ['l'] [] (NoArg (\o -> o {linenumbers = True}))
"Add and set line_number field for all syntax classes"
, [TargetCpp] )
, ( Option ['p'] []
(ReqArg (\n o -> o {inPackage = Just n}) "")
"Prepend to the package/module name"
, [TargetCpp, TargetCSharp, TargetHaskell, TargetHaskellGadt, TargetProfile, TargetJava] )
, ( Option [] ["jflex"] (NoArg (\o -> o {jflex = True}))
"Use JFlex instead of JLex for lexing"
, [TargetJava] )
, ( Option [] ["vs"] (NoArg (\o -> o {visualStudio = True}))
"Generate Visual Studio solution/project files"
, [TargetCSharp] )
, ( Option [] ["wcf"] (NoArg (\o -> o {wcf = True}))
"Add support for Windows Communication Foundation,\n by marking abstract syntax classes as DataContracts"
, [TargetCSharp] )
, ( Option ['d'] [] (NoArg (\o -> o {inDir = True}))
"Put Haskell code in modules Lang.* instead of Lang*"
, [TargetHaskell, TargetHaskellGadt, TargetProfile] )
, ( Option [] ["alex1"] (NoArg (\o -> o {alexMode = Alex1}))
"Use Alex 1.1 as Haskell lexer tool"
, [TargetHaskell, TargetHaskellGadt, TargetProfile] )
, ( Option [] ["alex2"] (NoArg (\o -> o {alexMode = Alex2}))
"Use Alex 2 as Haskell lexer tool"
, [TargetHaskell, TargetHaskellGadt, TargetProfile] )
, ( Option [] ["alex3"] (NoArg (\o -> o {alexMode = Alex3}))
"Use Alex 3 as Haskell lexer tool (default)"
, [TargetHaskell, TargetHaskellGadt, TargetProfile] )
, ( Option [] ["sharestrings"] (NoArg (\o -> o {shareStrings = True}))
"Use string sharing in Alex 2 lexer"
, [TargetHaskell, TargetHaskellGadt, TargetProfile] )
, ( Option [] ["bytestrings"] (NoArg (\o -> o {byteStrings = True}))
"Use byte string in Alex 2 lexer"
, [TargetHaskell, TargetHaskellGadt, TargetProfile] )
, ( Option [] ["glr"] (NoArg (\o -> o {glr = GLR}))
"Output Happy GLR parser"
, [TargetHaskell, TargetHaskellGadt, TargetProfile] )
, ( Option [] ["xml"] (NoArg (\o -> o {xml = 1}))
"Also generate a DTD and an XML printer"
, [TargetHaskell, TargetHaskellGadt, TargetProfile] )
, ( Option [] ["xmlt"] (NoArg (\o -> o {xml = 2}))
"DTD and an XML printer, another encoding"
, [TargetHaskell, TargetHaskellGadt, TargetProfile] )
, ( Option [] ["cnf"] (NoArg (\o -> o {cnf = True}))
"Use the CNF parser instead of happy"
, [TargetHaskell, TargetHaskellGadt, TargetProfile] )
, ( Option [] ["ghc"] (NoArg (\o -> o {ghcExtensions = True}))
"Use ghc-specific language extensions"
, [TargetHaskell, TargetHaskellGadt, TargetProfile] )
, ( Option [] ["functor"] (NoArg (\o -> o {functor = True}))
"Make the AST a functor and use it to store the position of the nodes"
, [TargetHaskell] )
]
commonOption :: [OptDescr (SharedOptions -> SharedOptions)]
commonOption =
[ Option "m" ["makefile"] (OptArg (setMakefile . fromMaybe "Makefile") "MAKEFILE")
"generate Makefile"
, Option "o" ["outputdir"] (ReqArg (\n o -> o {outDir = n}) "DIR")
"Redirects all generated files into DIR"
]
where setMakefile = \mf -> \o -> o { make = Just mf }
allOptions :: [OptDescr (SharedOptions -> SharedOptions)]
allOptions = targetOptions ++ commonOption ++ map fst specificOptions
-- ~~~ Help strings ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
title :: String
title = unlines [
"The BNF Converter, "++showVersion version,
"(c) Jonas Almström Duregård, Krasimir Angelov, Jean-Philippe Bernardy, Björn Bringert, Johan Broberg, Paul Callaghan, ",
" Grégoire Détrez, Markus Forsberg, Ola Frid, Peter Gammie, Thomas Hallgren, Patrik Jansson, ",
" Kristofer Johannisson, Antti-Juhani Kaijanaho, Ulf Norell, ",
" Michael Pellauer and Aarne Ranta 2002 - 2013.",
"Free software under GNU General Public License (GPL).",
"Bug reports to bnfc-dev@googlegroups.com."
]
usage :: String
usage = "usage: bnfc [--version] [--help] [] file.cf"
help :: String
help = unlines $
usage:""
:usageInfo "Global options" globalOptions
:usageInfo "Common option" commonOption
:usageInfo "Target languages" targetOptions
:map targetUsage helpTargets
where helpTargets = [TargetHaskell, TargetJava, TargetCpp, TargetCSharp ]
targetUsage t = usageInfo
(printf "Special options for the %s backend" (show t))
(map fst $ filter(elem t . snd)specificOptions)
-- ~~~ Parsing machinery ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- | Main parsing function
parseMode :: [String] -> Mode
parseMode args =
case args' of
[] -> Help
_ -> case getOpt' Permute globalOptions args' of
(mode:_,_,_,_) -> mode
_ -> case getOpt Permute allOptions args' of
(_,_,e:_) -> UsageError e
(_,[],_) -> UsageError "Missing grammar file"
(optionsUpdates, [grammar], []) ->
let options = foldl (.) id optionsUpdates defaultOptions in
Target (options {lang = takeBaseName grammar}) grammar
(_,_,_) -> UsageError "Too many arguments"
where args' = translateOldOptions args
isUsageError :: Mode -> Bool
isUsageError (UsageError _) = True
isUsageError _ = False
-- ~~~ Backward compatibility ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- A translating function to maintain backward compatiblicy
-- with the old option syntay
translateOldOptions :: [String] -> [String]
translateOldOptions = concatMap translateOne
where translateOne "-java" = return "--java"
translateOne "-java1.5" = return "--java"
translateOne "-c" = return "--c"
translateOne "-cpp" = return "--cpp"
translateOne "-cpp_stl" = return "--cpp"
translateOne "-cpp_no_stl" = return "--cpp-nostl"
translateOne "-csharp" = return "--csharp"
translateOne "-ocaml" = return "--ocaml"
translateOne "-fsharp" = return "fsharp"
translateOne "-haskell" = return "--haskell"
translateOne "-prof" = return "--profile"
translateOne "-gadt" = return "--haskell-gadt"
translateOne "-alex1" = return "--alex1"
translateOne "-alex2" = return "--alex2"
translateOne "-alex3" = return "--alex3"
translateOne "-sharestrings" = return "--sharestring"
translateOne "-bytestrings" = return "--bytestring"
translateOne "-glr" = return "--glr"
translateOne "-xml" = return "--xml"
translateOne "-xmlt" = return "--xmlt"
translateOne "-vs" = return "--vs"
translateOne "-wcf" = return "--wcf"
translateOne other = return other
BNFC-2.8.1/src/BNFC/Backend/0000755000000000000000000000000012654616013013252 5ustar0000000000000000BNFC-2.8.1/src/BNFC/Backend/CSharp.hs0000644000000000000000000003553312654616013014777 0ustar0000000000000000{-
BNF Converter: C# Main file
Copyright (C) 2006-2007 Author: Johan Broberg
Modified from STLTop 2006.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : C# Main file
Author : Johan Broberg (johan@pontemonti.com)
License : GPL (GNU General Public License)
Created : 20 November, 2006
Modified : 8 January, 2007 by Johan Broberg
**************************************************************
-}
module BNFC.Backend.CSharp (makeCSharp) where
import BNFC.CF
import BNFC.Options
import BNFC.Backend.Common.OOAbstract
import BNFC.Backend.Common.Makefile
import BNFC.Backend.Base
import BNFC.Backend.CSharp.CAbstoCSharpAbs
import BNFC.Backend.CSharp.CFtoGPLEX
import BNFC.Backend.CSharp.CFtoGPPG
import BNFC.Backend.CSharp.CAbstoCSharpVisitSkeleton
import BNFC.Backend.CSharp.CAbstoCSharpAbstractVisitSkeleton
import BNFC.Backend.CSharp.CFtoCSharpPrinter
import BNFC.Backend.CSharp.CSharpUtils
import System.Environment (getEnv)
import System.Directory
import System.IO
import System.IO.Error (catchIOError)
import System.Process
import Data.Maybe
import Control.Monad (when)
import qualified BNFC.Backend.Common.Makefile as Makefile
import System.FilePath ((<.>))
-- Control.Monad.State
makeCSharp :: SharedOptions -> CF -> MkFiles ()
makeCSharp opts cf = do
let namespace = fromMaybe (lang opts) maybenamespace
cabs = cf2cabs cf
absyn = cabs2csharpabs namespace cabs wcfSupport
(gplex, env) = cf2gplex namespace cf
gppg = cf2gppg namespace cf env
skeleton = cabs2csharpvisitskeleton namespace cabs
absSkeleton = cabs2csharpAbstractVisitSkeleton namespace cabs
printer = cf2csharpprinter namespace cf
mkfile "Absyn.cs" absyn
mkfile (namespace ++ ".l") gplex
liftIO $ putStrLn " (Tested with GPLEX RC1)"
mkfile (namespace ++ ".y") gppg
liftIO $ putStrLn " (Tested with GPPG 1.0)"
mkfile "AbstractVisitSkeleton.cs" absSkeleton
mkfile "VisitSkeleton.cs" skeleton
mkfile "Printer.cs" printer
mkfile "Test.cs" (csharptest namespace cf)
when vsfiles (writeVisualStudioFiles namespace)
when makefile (writeMakefile opts namespace)
where makefile = isJust $ make opts
vsfiles = visualStudio opts
wcfSupport = wcf opts
maybenamespace = inPackage opts
writeMakefile :: SharedOptions -> Namespace -> MkFiles ()
writeMakefile opts namespace = do
mkMakefile opts makefile
liftIO $ putStrLn ""
liftIO $ putStrLn "-----------------------------------------------------------------------------"
liftIO $ putStrLn "Generated Makefile, which uses mono. You may want to modify the paths to"
liftIO $ putStrLn "GPLEX and GPPG - unless you are sure that they are globally accessible (the"
liftIO $ putStrLn "default commands are \"mono gplex.exe\" and \"mono gppg.exe\", respectively."
liftIO $ putStrLn "The Makefile assumes that ShiftReduceParser.dll is located in ./bin and that"
liftIO $ putStrLn "is also where test.exe will be generated."
liftIO $ putStrLn "-----------------------------------------------------------------------------"
liftIO $ putStrLn ""
where
makefile =
(unlines [ "MONO = mono", "MONOC = gmcs"
, "MONOCFLAGS = -optimize -reference:${PARSERREF}"
, "GPLEX = ${MONO} gplex.exe", "GPPG = ${MONO} gppg.exe"
, "PARSERREF = bin/ShiftReduceParser.dll"
, "CSFILES = Absyn.cs Parser.cs Printer.cs Scanner.cs Test.cs VisitSkeleton.cs AbstractVisitSkeleton.cs" ] ++)
$ Makefile.mkRule "all" [ "test" ]
[]
$ Makefile.mkRule "clean" []
-- peteg: don't nuke what we generated - move that to the "vclean" target.
[ "rm -f " ++ namespace ++ ".pdf test" ]
$ Makefile.mkRule "distclean" [ "clean" ]
[ "rm -f ${CSFILES}"
, "rm -f " ++ unwords [namespace <.> ext | ext <- [ "l","y","tex" ]]
, "rm -f Makefile" ]
$ Makefile.mkRule "test" [ "Parser.cs", "Scanner.cs" ]
[ "@echo \"Compiling test...\""
, "${MONOC} ${MONOCFLAGS} -out:bin/test.exe ${CSFILES}" ]
$ Makefile.mkRule "Scanner.cs" [ namespace <.> "l" ]
[ "${GPLEX} /out:$@ " ++ namespace <.> "l" ]
$ Makefile.mkRule "Parser.cs" [ namespace <.> "y" ]
[ "${GPPG} /gplex " ++ namespace <.> "y > $@" ]
""
writeVisualStudioFiles :: Namespace -> MkFiles ()
writeVisualStudioFiles namespace = do
guid <- projectguid
mkfile (namespace ++ ".csproj") (csproj guid)
mkfile (namespace ++ ".sln") (sln guid)
mkfile "run-gp.bat" batchfile
liftIO $ putStrLn ""
liftIO $ putStrLn "-----------------------------------------------------------------------------"
liftIO $ putStrLn "Visual Studio solution (.sln) and project (.csproj) files were written."
liftIO $ putStrLn "The project file has a reference to GPLEX/GPPG's ShiftReduceParser. You will"
liftIO $ putStrLn "have to either copy this file to bin\\ShiftReduceParser.dll or change the"
liftIO $ putStrLn "reference so that it points to the right location (you can do this from"
liftIO $ putStrLn "within Visual Studio)."
liftIO $ putStrLn "Additionally, the project includes Parser.cs and Scanner.cs. These have not"
liftIO $ putStrLn "been generated yet. You can use the run-gp.bat file to generate them, but"
liftIO $ putStrLn "note that it requires gppg and gplex to be in your PATH."
liftIO $ putStrLn "-----------------------------------------------------------------------------"
liftIO $ putStrLn ""
where
batchfile = unlines [
"@echo off",
"gppg /gplex " ++ namespace ++ ".y > Parser.cs",
"gplex /verbose /out:Scanner.cs " ++ namespace ++ ".l"
]
sln guid = unlines [
"Microsoft Visual Studio Solution File, Format Version 9.00",
"# Visual Studio 2005",
"Project(\"{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}\") = \"" ++ namespace ++ "\", \"" ++ namespace ++ ".csproj\", \"" ++ guid ++ "\"",
"EndProject",
"Global",
" GlobalSection(SolutionConfigurationPlatforms) = preSolution",
" Debug|Any CPU = Debug|Any CPU",
" Release|Any CPU = Release|Any CPU",
" EndGlobalSection",
" GlobalSection(ProjectConfigurationPlatforms) = postSolution",
" " ++ guid ++ ".Debug|Any CPU.ActiveCfg = Debug|Any CPU",
" " ++ guid ++ ".Debug|Any CPU.Build.0 = Debug|Any CPU",
" " ++ guid ++ ".Release|Any CPU.ActiveCfg = Release|Any CPU",
" " ++ guid ++ ".Release|Any CPU.Build.0 = Release|Any CPU",
" EndGlobalSection",
" GlobalSection(SolutionProperties) = preSolution",
" HideSolutionNode = FALSE",
" EndGlobalSection",
"EndGlobal"
]
csproj guid = unlines [
"",
"",
" ",
" Debug",
" AnyCPU",
" 8.0.50727",
" 2.0",
" " ++ guid ++ "",
" Library",
" Properties",
" " ++ namespace ++ "",
" " ++ namespace ++ "",
" ",
" ",
" ",
" ",
" true",
" full",
" false",
" bin\\Debug\\",
" DEBUG;TRACE",
" prompt",
" 4",
" ",
" ",
" pdbonly",
" true",
" bin\\Release\\",
" TRACE",
" prompt",
" 4",
" ",
" ",
" ",
" ",
" ",
" ",
" ",
" ",
" ",
" ",
" ",
" ",
" ",
" ",
" False",
" bin\\ShiftReduceParser.dll",
" ",
" ",
" ",
" ",
" ",
" ",
" ",
" ",
" ",
" ",
" ",
" ",
" ",
""
]
csharptest :: Namespace -> CF -> String
csharptest namespace cf = unlines [
"/*** Compiler Front-End Test automatically generated by the BNF Converter ***/",
"/* */",
"/* This test will parse a file, print the abstract syntax tree, and then */",
"/* pretty-print the result. */",
"/* */",
"/****************************************************************************/",
"using System;",
"using System.IO;",
"using " ++ namespace ++ ".Absyn;",
"",
"namespace " ++ namespace,
"{",
" public class Test",
" {",
" public static void Main(string[] args)",
" {",
" if (args.Length > 0)",
" {",
" Stream stream = File.OpenRead(args[0]);",
" /* The default entry point is used. For other options see class Parser */",
" Parser parser = new Parser();",
" Scanner scanner = Scanner.CreateScanner(stream);",
" // Uncomment to enable trace information:",
" // parser.Trace shows what the parser is doing",
" // parser.Trace = true;",
" // scanner.Trace prints the tokens as they are parsed, one token per line",
" // scanner.Trace = true;",
" parser.scanner = scanner;",
" try",
" {",
" " ++ def ++ " parse_tree = parser.Parse" ++ def ++ "();",
" if (parse_tree != null)",
" {",
" Console.Out.WriteLine(\"Parse Successful!\");",
" Console.Out.WriteLine(\"\");",
" Console.Out.WriteLine(\"[Abstract Syntax]\");",
" Console.Out.WriteLine(\"{0}\", PrettyPrinter.Show(parse_tree));",
" Console.Out.WriteLine(\"\");",
" Console.Out.WriteLine(\"[Linearized Tree]\");",
" Console.Out.WriteLine(\"{0}\", PrettyPrinter.Print(parse_tree));",
" }",
" else",
" {",
" Console.Out.WriteLine(\"Parse NOT Successful!\");",
" }",
" }",
" catch(Exception e)",
" {",
" Console.Out.WriteLine(\"Parse NOT Successful:\");",
" Console.Out.WriteLine(e.Message);",
" Console.Out.WriteLine(\"\");",
" Console.Out.WriteLine(\"Stack Trace:\");",
" Console.Out.WriteLine(e.StackTrace);",
" }",
" }",
" else",
" {",
" Console.Out.WriteLine(\"You must specify a filename!\");",
" }",
" }",
" }",
"}"
]
where
def = show (head (allEntryPoints cf))
projectguid :: MkFiles String
projectguid = do
maybeFilePath <- findDirectory
guid <- maybe getBadGUID getGoodGUID maybeFilePath
return guid
where
getBadGUID :: MkFiles String
getBadGUID = do
liftIO $ putStrLn "-----------------------------------------------------------------------------"
liftIO $ putStrLn "Could not find Visual Studio tool uuidgen.exe to generate project GUID!"
liftIO $ putStrLn "You might want to put this tool in your PATH."
liftIO $ putStrLn "-----------------------------------------------------------------------------"
return "{00000000-0000-0000-0000-000000000000}"
getGoodGUID :: FilePath -> MkFiles String
getGoodGUID filepath = liftIO $ do
let filepath' = "\"" ++ filepath ++ "\""
(_, hOut, _, _) <- runInteractiveCommand filepath'
guid <- hGetLine hOut
return ('{' : init guid ++ "}")
findDirectory :: MkFiles (Maybe FilePath)
findDirectory = liftIO $ do
-- This works with Visual Studio 2005.
-- We will probably have to be modify this to include another environment variable name for Orcas.
-- I doubt there is any need to support VS2003? (I doubt they have patched it up to have 2.0 support?)
toolpath <- catchIOError (getEnv "VS80COMNTOOLS") (\_ -> return "C:\\Program Files\\Microsoft Visual Studio 8\\Common7\\Tools")
exists <- doesDirectoryExist toolpath
if exists
then return (Just (toolpath ++ "\\uuidgen.exe"))
-- this handles the case when the user was clever enough to add the directory to his/her PATH
else findExecutable "uuidgen.exe"
BNFC-2.8.1/src/BNFC/Backend/HaskellGADT.hs0000644000000000000000000001153012654616013015631 0ustar0000000000000000{-
BNF Converter: Haskell main file
Copyright (C) 2004-2005 Author: Markus Forberg, Peter Gammie,
Aarne Ranta, Björn Bringert
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.HaskellGADT (makeHaskellGadt) where
-- import Utils
import BNFC.Options
import BNFC.Backend.Base hiding (Backend)
import BNFC.Backend.Haskell.HsOpts
import BNFC.CF
import BNFC.Backend.Haskell.CFtoHappy
import BNFC.Backend.Haskell.CFtoAlex
import BNFC.Backend.Haskell.CFtoAlex2
import BNFC.Backend.Haskell.CFtoAlex3
import BNFC.Backend.HaskellGADT.CFtoAbstractGADT
import BNFC.Backend.HaskellGADT.CFtoTemplateGADT
import BNFC.Backend.Haskell.CFtoPrinter
import BNFC.Backend.Haskell.CFtoLayout
import BNFC.Backend.XML
import BNFC.Backend.Haskell.MkErrM
import BNFC.Backend.Haskell.MkSharedString
import qualified BNFC.Backend.Common.Makefile as Makefile
import qualified BNFC.Backend.Haskell as Haskell
import Control.Monad(when)
makeHaskellGadt :: SharedOptions -> CF -> MkFiles ()
makeHaskellGadt opts cf = do
let absMod = absFileM opts
composOpMod = composOpFileM opts
lexMod = alexFileM opts
parMod = happyFileM opts
prMod = printerFileM opts
layMod = layoutFileM opts
errMod = errFileM opts
shareMod = shareFileM opts
do
mkfile (absFile opts) $ cf2Abstract (byteStrings opts) absMod cf composOpMod
mkfile (composOpFile opts) $ composOp composOpMod
case alexMode opts of
Alex1 -> do
mkfile (alexFile opts) $ cf2alex lexMod errMod cf
liftIO $ putStrLn " (Use Alex 1.1 to compile.)"
Alex2 -> do
mkfile (alexFile opts) $ cf2alex2 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf
liftIO $ putStrLn " (Use Alex 2.0 to compile.)"
Alex3 -> do
mkfile (alexFile opts) $ cf2alex3 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf
liftIO $ putStrLn " (Use Alex 3.0 to compile.)"
mkfile (happyFile opts) $
cf2HappyS parMod absMod lexMod errMod (glr opts) (byteStrings opts) False cf
liftIO $ putStrLn " (Tested with Happy 1.15)"
mkfile (templateFile opts) $ cf2Template (templateFileM opts) absMod errMod cf
mkfile (printerFile opts) $ cf2Printer False False True prMod absMod cf
when (hasLayout cf) $ mkfile (layoutFile opts) $ cf2Layout (alexMode opts == Alex1) (inDir opts) layMod lexMod cf
mkfile (tFile opts) $ Haskell.testfile opts cf
mkfile (errFile opts) $ errM errMod cf
when (shareStrings opts) $ mkfile (shareFile opts) $ sharedString shareMod (byteStrings opts) cf
Makefile.mkMakefile opts $ Haskell.makefile opts
case xml opts of
2 -> makeXML opts True cf
1 -> makeXML opts False cf
_ -> return ()
composOp :: String -> String
composOp composOpMod = unlines
[
"{-# LANGUAGE Rank2Types, PolyKinds #-}",
"module " ++ composOpMod ++ " (Compos(..),composOp,composOpM,composOpM_,composOpMonoid,",
" composOpMPlus,composOpFold) where",
"",
"import Control.Monad.Identity",
"import Data.Monoid",
"",
"class Compos t where",
" compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)",
" -> (forall a. t a -> m (t a)) -> t c -> m (t c)",
"",
"composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c",
"composOp f = runIdentity . composOpM (Identity . f)",
"",
"composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)",
"composOpM = compos return ap",
"",
"composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()",
"composOpM_ = composOpFold (return ()) (>>)",
"",
"composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m",
"composOpMonoid = composOpFold mempty mappend",
"",
"composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b",
"composOpMPlus = composOpFold mzero mplus",
"",
"composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b",
"composOpFold z c f = unC . compos (\\_ -> C z) (\\(C x) (C y) -> C (c x y)) (C . f)",
"",
"newtype C b a = C { unC :: b }"
]
BNFC-2.8.1/src/BNFC/Backend/Txt2Tag.hs0000644000000000000000000002113712654616013015107 0ustar0000000000000000{-
BNF Converter: Latex Generator
Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.Txt2Tag (cfToTxt)where
import BNFC.CF
import AbsBNF (Reg (..))
import BNFC.Utils
import Data.List
cfToTxt :: String -> CF -> String
cfToTxt name cf = unlines [
beginDocument name,
introduction,
prtTerminals name cf,
prtBNF name cf
]
introduction :: String
introduction = concat
[
"\nThis document was automatically generated by ",
"the //BNF-Converter//.",
" It was generated together with the lexer, the parser, and the",
" abstract syntax module, which guarantees that the document",
" matches with the implementation of the language (provided no",
" hand-hacking has taken place).\n"
]
prtTerminals :: String -> CF -> String
prtTerminals name cf = unlines [
"==The lexical structure of " ++ name ++ "==",
identSection cf,
"===Literals===",
prtLiterals name cf,
unlines (map prtOwnToken (tokenPragmas cf)),
"===Reserved words and symbols===",
prtReserved name cf,
prtSymb name cf,
"===Comments===",
prtComments $ comments cf
]
identSection cf = if not (hasIdent cf) then [] else
unlines [
"===Identifiers===",
prtIdentifiers
]
prtIdentifiers :: String
prtIdentifiers = unlines
[
"Identifiers //Ident// are unquoted strings beginning with a letter,",
"followed by any combination of letters, digits, and the characters ``_ '``",
"reserved words excluded."
]
prtLiterals :: String -> CF -> String
prtLiterals _ cf =
unlines $ map stringLit $
filter (`notElem` [Cat "Ident"]) $
literals cf
stringLit :: Cat -> String
stringLit cat = unlines $ case show cat of
"Char" -> ["Character literals //Char// have the form",
"``'``//c//``'``, where //c// is any single character.",
""
]
"String" -> ["String literals //String// have the form",
"``\"``//x//``\"``}, where //x// is any sequence of any characters",
"except ``\"`` unless preceded by ``\\``.",
""]
"Integer" -> ["Integer literals //Integer// are nonempty sequences of digits.",
""]
"Double" -> ["Double-precision float literals //Double// have the structure",
"indicated by the regular expression" +++
"``digit+ '.' digit+ ('e' ('-')? digit+)?`` i.e.\\",
"two sequences of digits separated by a decimal point, optionally",
"followed by an unsigned or negative exponent.",
""]
_ -> []
prtOwnToken (name,reg) = unlines
[show name +++ "literals are recognized by the regular expression",
"```" ++
latexRegExp reg ++
"```"
]
prtComments :: ([(String,String)],[String]) -> String
prtComments (xs,ys) = concat
[
if null ys then
"There are no single-line comments in the grammar."
else
"Single-line comments begin with " ++ sing ++".",
if null xs then
"There are no multiple-line comments in the grammar."
else
"Multiple-line comments are enclosed with " ++ mult ++"."
]
where
sing = intercalate ", " $ map (symbol.prt) ys
mult = intercalate ", " $
map (\(x,y) -> symbol (prt x) ++ " and " ++ symbol (prt y)) xs
prtSymb :: String -> CF -> String
prtSymb name cf = case symbols cf of
[] -> "\nThere are no symbols in " ++ name ++ ".\n"
xs -> "The symbols used in " ++ name ++ " are the following:\n"
++
tabular 4 (three $ map (symbol.prt) xs)
prtReserved :: String -> CF -> String
prtReserved name cf = case reservedWords cf of
[] -> stringRes name ++
"\nThere are no reserved words in " ++ name ++ ".\n"
xs -> stringRes name ++
tabular 4 (three $ map quote xs)
stringRes :: String -> String
stringRes name = concat
["The set of reserved words is the set of terminals ",
"appearing in the grammar. Those reserved words ",
"that consist of non-letter characters are called symbols, and ",
"they are treated in a different way from those that ",
"are similar to identifiers. The lexer ",
"follows rules familiar from languages ",
"like Haskell, C, and Java, including longest match ",
"and spacing conventions.",
"\n\n",
"The reserved words used in " ++ name ++ " are the following:\n"]
three :: [String] -> [[String]]
three [] = []
three [x] = [[x,[],[],[]]]
three [x,y] = [[x,y,[],[]]]
three [x,y,z] = [[x,y,z,[]]]
three (x:y:z:u:xs) = [x,y,z,u] : three xs
prtBNF :: String -> CF -> String
prtBNF name cf = unlines [
"==The syntactic structure of " ++ name ++"==",
"Non-terminals are enclosed between < and >. ",
"The symbols " ++ arrow ++ " (production), " ++
delimiter ++" (union) ",
"and " ++ empty ++ " (empty rule) belong to the BNF notation. ",
"All other symbols are terminals.",
"",
prtRules (ruleGroups cf)
]
prtRules :: [(Cat,[Rule])] -> String
prtRules [] = []
prtRules ((c,[]):xs)
= tabular 3 [[nonterminal c,arrow,[]]] ++ prtRules xs
prtRules ((c, r : rs) : xs)
= tabular 3 ([[nonterminal c,arrow,prtSymbols $ rhsRule r]] ++
[[[],delimiter,prtSymbols (rhsRule y)] | y <- rs]) ++
--- "\n\n" ++ --- with empty lines good for latex, bad for html
prtRules xs
prtSymbols :: [Either Cat String] -> String
prtSymbols [] = empty
prtSymbols xs = foldr ((+++) . p) [] xs
where p (Left r) = nonterminal r
p (Right r) = terminal r
prt :: String -> String
prt s = s
empty :: String
empty = "**eps**"
symbol :: String -> String
symbol s = s
tabular :: Int -> [[String]] -> String
tabular _ xs = unlines [unwords (intersperse "|" (" " : x)) | x <- xs]
terminal :: String -> String
terminal s = "``" ++ s ++ "``"
nonterminal :: Cat -> String
nonterminal s = "//" ++ show s ++ "//"
arrow :: String
arrow = "->"
delimiter :: String
delimiter = " **|** "
beginDocument :: String -> String
beginDocument name = unlines [
"The Language " ++ name,
"BNF Converter",
"",
"",
"%This txt2tags file is machine-generated by the BNF-converter",
"%Process by txt2tags to generate html or latex",
""
]
latexRegExp :: Reg -> String
latexRegExp = quote . rex (0 :: Int) where
rex i e = case e of
RSeq reg0 reg -> ifPar i 2 $ rex 2 reg0 +++ rex 2 reg
RAlt reg0 reg -> ifPar i 1 $ rex 1 reg0 +++ "|" +++ rex 1 reg
RMinus reg0 reg -> ifPar i 1 $ rex 2 reg0 +++ "-" +++ rex 2 reg
RStar reg -> rex 3 reg ++ "*"
RPlus reg -> rex 3 reg ++ "+"
ROpt reg -> rex 3 reg ++ "?"
REps -> "eps"
RChar c -> "'" ++ [c] ++ "'"
RAlts str -> "[\"" ++ str ++ "\"]"
RSeqs str -> "{\"" ++ str ++ "\"}"
RDigit -> "digit"
RLetter -> "letter"
RUpper -> "upper"
RLower -> "lower"
RAny -> "char"
ifPar i j s = if i > j then "(" ++ s ++ ")" else s
quote s = "``" ++ s ++ "``"
BNFC-2.8.1/src/BNFC/Backend/OCaml.hs0000644000000000000000000001360412654616013014605 0ustar0000000000000000{-
BNF Converter: OCaml main file
Copyright (C) 2005 Author: Kristofer Johannisson
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
-- based on BNFC Haskell backend
module BNFC.Backend.OCaml (makeOCaml) where
import Text.PrettyPrint (render)
import BNFC.CF
import BNFC.Backend.Base hiding (Backend)
import BNFC.Backend.Common.Makefile
import BNFC.Backend.OCaml.CFtoOCamlYacc
import BNFC.Backend.OCaml.CFtoOCamlLex
import BNFC.Backend.OCaml.CFtoOCamlAbs
import BNFC.Backend.OCaml.CFtoOCamlTemplate
import BNFC.Backend.OCaml.CFtoOCamlPrinter
import BNFC.Backend.OCaml.CFtoOCamlShow
import BNFC.Backend.OCaml.CFtoOCamlTest
import BNFC.Backend.XML
import BNFC.Utils
import BNFC.Options
import System.FilePath (pathSeparator, ())
-- naming conventions
noLang :: SharedOptions -> String -> String
noLang _ name = name
withLang :: SharedOptions -> String -> String
withLang opts name = name ++ lang opts
mkMod :: (SharedOptions -> String -> String) -> String -> SharedOptions -> String
mkMod addLang name opts =
pref ++ if inDir opts then lang opts ++ "." ++ name else addLang opts name
where pref = maybe "" (++".") (inPackage opts)
mkFile :: (SharedOptions -> String -> String) -> String -> String -> SharedOptions -> FilePath
mkFile addLang name ext opts =
pref ++ if inDir opts
then lang opts name ++ ext'
else addLang opts name ++ if null ext then "" else ext'
where pref = maybe "" (\p->pkgToDir p "") (inPackage opts)
ext' = if null ext then "" else "." ++ ext
absFile, absFileM, ocamllexFile, ocamllexFileM, ocamlyaccFile, ocamlyaccFileM,
utilFile, templateFile, templateFileM, printerFile, printerFileM,
tFile :: SharedOptions -> String
absFile = mkFile withLang "Abs" "ml"
absFileM = mkMod withLang "Abs"
ocamllexFile = mkFile withLang "Lex" "mll"
ocamllexFileM = mkMod withLang "Lex"
ocamlyaccFile = mkFile withLang "Par" "mly"
ocamlyaccFileM = mkMod withLang "Par"
templateFile = mkFile withLang "Skel" "ml"
templateFileM = mkMod withLang "Skel"
printerFile = mkFile withLang "Print" "ml"
printerFileM = mkMod withLang "Print"
showFile = mkFile withLang "Show" "ml"
showFileM = mkMod withLang "Show"
tFile = mkFile withLang "Test" "ml"
utilFile = mkFile noLang "BNFC_Util" "ml"
makeOCaml :: SharedOptions -> CF -> MkFiles ()
makeOCaml opts cf = do
let absMod = absFileM opts
lexMod = ocamllexFileM opts
parMod = ocamlyaccFileM opts
prMod = printerFileM opts
showMod = showFileM opts
do
mkfile (absFile opts) $ cf2Abstract absMod cf
mkfile (ocamllexFile opts) $ cf2ocamllex lexMod parMod cf
mkfile (ocamlyaccFile opts) $
cf2ocamlyacc parMod absMod lexMod cf
mkfile (templateFile opts) $ cf2Template (templateFileM opts) absMod cf
mkfile (printerFile opts) $ cf2Printer prMod absMod cf
mkfile (showFile opts) $ cf2show showMod absMod cf
mkfile (tFile opts) $ render $ ocamlTestfile absMod lexMod parMod prMod showMod cf
mkfile (utilFile opts) $ utilM
mkMakefile opts $ makefile opts
case xml opts of
2 -> makeXML opts True cf
1 -> makeXML opts False cf
_ -> return ()
pkgToDir :: String -> FilePath
pkgToDir s = replace '.' pathSeparator s
codeDir :: SharedOptions -> FilePath
codeDir opts = let pref = maybe "" pkgToDir (inPackage opts)
dir = if inDir opts then lang opts else ""
sep = if null pref || null dir then "" else [pathSeparator]
in pref ++ sep ++ dir
makefile :: SharedOptions -> String
makefile opts =
mkRule "all" []
[ "ocamlyacc " ++ ocamlyaccFile opts
, "ocamllex " ++ ocamllexFile opts
, "ocamlc -o " ++ mkFile withLang "Test" "" opts +++
utilFile opts +++
absFile opts +++ templateFile opts +++
showFile opts +++ printerFile opts +++
mkFile withLang "Par" "mli" opts +++
mkFile withLang "Par" "ml" opts +++
mkFile withLang "Lex" "ml" opts +++
tFile opts ]
$ mkRule "clean" []
[ "-rm -f " ++ unwords (map (dir++) [ "*.cmi", "*.cmo", "*.o" ]) ]
$ mkRule "distclean" ["clean"]
[ "-rm -f " ++ unwords [ mkFile withLang "Lex" "*" opts,
mkFile withLang "Par" "*" opts,
mkFile withLang "Layout" "*" opts,
mkFile withLang "Skel" "*" opts,
mkFile withLang "Print" "*" opts,
mkFile withLang "Show" "*" opts,
mkFile withLang "Test" "*" opts,
mkFile withLang "Abs" "*" opts,
mkFile withLang "Test" "" opts,
utilFile opts,
"Makefile*" ]]
""
where dir = let d = codeDir opts in if null d then "" else d ++ [pathSeparator]
utilM :: String
utilM = unlines
["(* automatically generated by BNFC *)",
"",
"open Lexing",
"",
"(* this should really be in the parser, but ocamlyacc won't put it in the .mli *)",
"exception Parse_error of Lexing.position * Lexing.position"
]
BNFC-2.8.1/src/BNFC/Backend/Base.hs0000644000000000000000000000422212654616013014460 0ustar0000000000000000{- Backend base function. Defines the type of the backend and some usefull
- functions -}
module BNFC.Backend.Base
( Backend
, MkFiles
, execBackend
, mkfile
, liftIO
, writeFiles
) where
import BNFC.Utils (writeFileRep)
import Control.Monad.Writer
import System.Directory (createDirectoryIfMissing)
import System.FilePath (dropFileName, ())
-- | Define the type of the backend functions For more purity, instead of
-- having each backend writing the generated files to disk, they return a list
-- of pairs containing the (relative) file path and the file content. This
-- allow for 1) easier testing, 2) implement common options like changing the
-- output dir or providing a diff instead of overwritting the files on a
-- highter level and 3) more purity.
--
-- The writer monad provide a more conveignent api to generate the list. Note
-- that we still use the IO monad for now because some backend insist on
-- printing stuff to the screen while generating the files.
type MkFiles a = WriterT [(FilePath, String)] IO a
type Backend = MkFiles ()
-- | Named after execWriter, this function execute the given backend
-- and returns the generated file paths and contents.
execBackend :: MkFiles () -> IO [(FilePath, String)]
execBackend = execWriterT
-- | A specialized version of tell that adds a file and its content to the
-- list of generated files
mkfile :: FilePath -> String -> MkFiles ()
mkfile path content = tell [(path,content)]
-- | Write a set of files to disk. the first argument is the root directory
-- inside which all the generated files will be written. This root directory
-- and sub-directories will be created as needed (ex: if the files contains a
-- a/b/file.txt, `writeFiles` will create the directories `$ROOT/a` and
-- `$ROOT/a/b`)
writeFiles :: FilePath -> MkFiles () -> IO ()
writeFiles root fw = do
-- First we check that the directory exists
fb <- execBackend fw
createDirectoryIfMissing True root
mapM_ (uncurry writeFile') fb
where writeFile' :: FilePath -> String -> IO ()
writeFile' path content =
createDirectoryIfMissing True (root dropFileName path)
>> writeFileRep (root path) content
BNFC-2.8.1/src/BNFC/Backend/Haskell.hs0000644000000000000000000003011112654616013015165 0ustar0000000000000000{-
BNF Converter: Haskell main file
Copyright (C) 2004 Author: Markus Forberg, Peter Gammie, Aarne Ranta
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.Haskell (makeHaskell, AlexVersion(..), makefile, testfile) where
-- import BNFC.Utils
import BNFC.Options hiding (Backend)
import BNFC.CF
import BNFC.Backend.Base
import BNFC.Backend.Haskell.CFtoHappy
import BNFC.Backend.Haskell.CFtoAlex
import BNFC.Backend.Haskell.CFtoAlex2
import BNFC.Backend.Haskell.CFtoAlex3
import BNFC.Backend.Txt2Tag
import BNFC.Backend.Haskell.CFtoAbstract
import BNFC.Backend.Haskell.CFtoTemplate
import BNFC.Backend.Haskell.CFtoPrinter
import BNFC.Backend.Haskell.CFtoLayout
import BNFC.Backend.XML
import BNFC.Backend.Haskell.HsOpts
import BNFC.Backend.Haskell.ToCNF as ToCNF
import BNFC.Backend.Haskell.MkErrM
import BNFC.Backend.Haskell.MkSharedString
import BNFC.Backend.Haskell.Utils (parserName)
import qualified BNFC.Backend.Common.Makefile as Makefile
import System.FilePath (pathSeparator)
import Control.Monad(when,unless)
import Text.Printf (printf)
import Text.PrettyPrint
-- naming conventions
makeHaskell :: SharedOptions -> CF -> Backend
makeHaskell opts cf = do
let absMod = absFileM opts
lexMod = alexFileM opts
parMod = happyFileM opts
prMod = printerFileM opts
layMod = layoutFileM opts
errMod = errFileM opts
shareMod = shareFileM opts
do
mkfile (absFile opts) $ cf2Abstract (byteStrings opts) (ghcExtensions opts) (functor opts) absMod cf
case alexMode opts of
Alex1 -> do
mkfile (alexFile opts) $ cf2alex lexMod errMod cf
liftIO $ printf "Use Alex 1.1 to compile %s.\n" (alexFile opts)
Alex2 -> do
mkfile (alexFile opts) $ cf2alex2 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf
liftIO $ printf "Use Alex 2.0 to compile %s.\n" (alexFile opts)
Alex3 -> do
mkfile (alexFile opts) $ cf2alex3 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf
liftIO $ printf "Use Alex 3.0 to compile %s.\n" (alexFile opts)
unless (cnf opts) $ do
mkfile (happyFile opts) $
cf2HappyS parMod absMod lexMod errMod (glr opts) (byteStrings opts) (functor opts) cf
liftIO $ printf "%s Tested with Happy 1.15\n" (happyFile opts)
mkfile (tFile opts) $ testfile opts cf
mkfile (txtFile opts) $ cfToTxt (lang opts) cf
mkfile (templateFile opts) $ cf2Template (templateFileM opts) absMod errMod (functor opts) cf
mkfile (printerFile opts) $ cf2Printer (byteStrings opts) (functor opts) False prMod absMod cf
when (hasLayout cf) $ mkfile (layoutFile opts) $ cf2Layout (alex1 opts) (inDir opts) layMod lexMod cf
mkfile (errFile opts) $ errM errMod cf
when (shareStrings opts) $ mkfile (shareFile opts) $ sharedString shareMod (byteStrings opts) cf
Makefile.mkMakefile opts $ makefile opts
case xml opts of
2 -> makeXML opts True cf
1 -> makeXML opts False cf
_ -> return ()
when (cnf opts) $ do
mkfile (cnfTablesFile opts) $ ToCNF.generate opts cf
mkfile "TestCNF.hs" $ ToCNF.genTestFile opts cf
mkfile "BenchCNF.hs" $ ToCNF.genBenchmark opts
makefile :: Options -> String
makefile opts = makeA where
glr_params = if glr opts == GLR then "--glr --decode " else ""
dir = let d = codeDir opts in if null d then "" else d ++ [pathSeparator]
makeA = Makefile.mkRule "all" []
([ "happy -gca " ++ glr_params ++ happyFile opts | not (cnf opts) ] ++
[ "alex -g " ++ alexFile opts ] ++
[ if cnf opts
then "ghc --make TestCNF.hs"
else "ghc --make " ++ tFile opts ++ " -o " ++ mkFile withLang "Test" "" opts])
$ Makefile.mkRule "clean" []
[ "-rm -f " ++ unwords
(map (dir++) [ "*.log", "*.aux", "*.hi", "*.o", "*.dvi" ]) ]
$ Makefile.mkRule "distclean" ["clean"]
[ "-rm -f " ++ unwords
[ mkFile withLang "Doc" "*" opts
, mkFile withLang "Lex" "*" opts
, mkFile withLang "Par" "*" opts
, mkFile withLang "Layout" "*" opts
, mkFile withLang "Skel" "*" opts
, mkFile withLang "Print" "*" opts
, mkFile withLang "Test" "*" opts
, mkFile withLang "Abs" "*" opts
, mkFile withLang "Test" "" opts
, mkFile noLang "ErrM" "*" opts
, mkFile noLang "SharedString" "*" opts
, mkFile noLang "ComposOp" "*" opts
, dir ++ lang opts ++ ".dtd"
, mkFile withLang "XML" "*" opts
, "Makefile*" ]
, if null dir then "" else "\t-rmdir -p " ++ dir ]
""
testfile :: Options -> CF -> String
testfile opts cf
= let lay = hasLayout cf
use_xml = xml opts > 0
xpr = if use_xml then "XPrint a, " else ""
use_glr = glr opts == GLR
if_glr s = if use_glr then s else ""
firstParser = if use_glr then "the_parser" else render (parserName topType)
topType = firstEntry cf
in unlines
["-- automatically generated by BNF Converter",
"module Main where\n",
"",
"import System.IO ( stdin, hGetContents )",
"import System.Environment ( getArgs, getProgName )",
"import System.Exit ( exitFailure, exitSuccess )",
"",
"import " ++ alexFileM opts,
"import " ++ happyFileM opts,
"import " ++ templateFileM opts,
"import " ++ printerFileM opts,
"import " ++ absFileM opts,
if lay then "import " ++ layoutFileM opts else "",
if use_xml then "import " ++ xmlFileM opts else "",
if_glr "import qualified Data.Map(Map, lookup, toList)",
if_glr "import Data.Maybe(fromJust)",
"import " ++ errFileM opts,
"",
if use_glr
then "type ParseFun a = [[Token]] -> (GLRResult, GLR_Output (Err a))"
else "type ParseFun a = [Token] -> Err a",
"",
"myLLexer = " ++ if lay then "resolveLayout True . myLexer"
else "myLexer",
"",
"type Verbosity = Int",
"",
"putStrV :: Verbosity -> String -> IO ()",
"putStrV v s = if v > 1 then putStrLn s else return ()",
"",
"runFile :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()",
"runFile v p f = putStrLn f >> readFile f >>= run v p",
"",
"run :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()",
if use_glr then runGlr else runStd use_xml,
"",
"showTree :: (Show a, Print a) => Int -> a -> IO ()",
"showTree v tree",
" = do",
" putStrV v $ \"\\n[Abstract Syntax]\\n\\n\" ++ show tree",
" putStrV v $ \"\\n[Linearized tree]\\n\\n\" ++ printTree tree",
"",
"usage :: IO ()",
"usage = do",
" putStrLn $ unlines",
" [ \"usage: Call with one of the following argument combinations:\"",
" , \" --help Display this help message.\"",
" , \" (no arguments) Parse stdin verbosely.\"",
" , \" (files) Parse content of files verbosely.\"",
" , \" -s (files) Silent mode. Parse content of files silently.\"",
" ]",
" exitFailure",
"",
"main :: IO ()",
"main = do",
" args <- getArgs",
" case args of",
" [\"--help\"] -> usage",
" [] -> hGetContents stdin >>= run 2 " ++ firstParser,
" \"-s\":fs -> mapM_ (runFile 0 " ++ firstParser ++ ") fs",
" fs -> mapM_ (runFile 2 " ++ firstParser ++ ") fs",
"",
if_glr $ "the_parser :: ParseFun " ++ show topType,
if_glr $ "the_parser = lift_parser " ++ render (parserName topType),
if_glr "",
if_glr liftParser
]
runStd xml
= unlines
[ "run v p s = let ts = myLLexer s in case p ts of"
, " Bad s -> do putStrLn \"\\nParse Failed...\\n\""
, " putStrV v \"Tokens:\""
, " putStrV v $ show ts"
, " putStrLn s"
, " exitFailure"
, " Ok tree -> do putStrLn \"\\nParse Successful!\""
, " showTree v tree"
, if xml then
" putStrV v $ \"\\n[XML]\\n\\n\" ++ printXML tree"
else ""
, " exitSuccess"
]
runGlr
= unlines
[ "run v p s"
, " = let ts = map (:[]) $ myLLexer s"
, " (raw_output, simple_output) = p ts in"
, " case simple_output of"
, " GLR_Fail major minor -> do"
, " putStrLn major"
, " putStrV v minor"
, " GLR_Result df trees -> do"
, " putStrLn \"\\nParse Successful!\""
, " case trees of"
, " [] -> error \"No results but parse succeeded?\""
, " [Ok x] -> showTree v x"
, " xs@(_:_) -> showSeveralTrees v xs"
, " where"
, " showSeveralTrees :: (Print b, Show b) => Int -> [Err b] -> IO ()"
, " showSeveralTrees v trees"
, " = sequence_ "
, " [ do putStrV v (replicate 40 '-')"
, " putStrV v $ \"Parse number: \" ++ show n"
, " showTree v t"
, " | (Ok t,n) <- zip trees [1..]"
, " ]"
]
liftParser
= unlines
[ "type Forest = Data.Map.Map ForestId [Branch] -- omitted in ParX export."
, "data GLR_Output a"
, " = GLR_Result { pruned_decode :: (Forest -> Forest) -> [a]"
, " , semantic_result :: [a]"
, " }"
, " | GLR_Fail { main_message :: String"
, " , extra_info :: String"
, " }"
, ""
, "lift_parser"
, " :: (TreeDecode a, Show a, Print a)"
, " => ([[Token]] -> GLRResult) -> ParseFun a"
, "lift_parser parser ts"
, " = let result = parser ts in"
, " (\\o -> (result, o)) $"
, " case result of"
, " ParseError ts f -> GLR_Fail \"Parse failed, unexpected token(s)\\n\""
, " (\"Tokens: \" ++ show ts)"
, " ParseEOF f -> GLR_Fail \"Parse failed, unexpected EOF\\n\""
, " (\"Partial forest:\\n\""
, " ++ unlines (map show $ Data.Map.toList f))"
, " ParseOK r f -> let find f = fromJust . ((flip Data.Map.lookup) f)"
, " dec_fn f = decode (find f) r"
, " in GLR_Result (\\ff -> dec_fn $ ff f) (dec_fn f)"
]
BNFC-2.8.1/src/BNFC/Backend/XML.hs0000644000000000000000000001745412654616013014261 0ustar0000000000000000{-
BNF Converter: XML generator
Copyright (C) 2004 Author: Aarne Ranta
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.XML ---- (cf2DTD, cf2XML)
where
import BNFC.CF
import BNFC.Utils
import BNFC.Backend.Base
import BNFC.Options hiding (Backend)
import BNFC.Backend.Haskell.CFtoTemplate ()
import BNFC.Backend.Haskell.HsOpts (xmlFile, xmlFileM, absFileM)
import Data.List (intersperse, intercalate)
import Data.Char(toLower)
import Data.Maybe (fromMaybe)
type Coding = Bool ---- change to at least three values
makeXML :: SharedOptions -> Coding -> CF -> Backend
makeXML opts typ cf = do
let name = lang opts
mkfile (name ++ ".dtd") $ cf2DTD typ name cf
let absmod = "XML" ++ name
mkfile (xmlFile opts) $ cf2XMLPrinter typ opts absmod cf
-- derive a DTD from a BNF grammar. AR 21/8/2004
cf2DTD :: Coding -> String -> CF -> String
cf2DTD typ name cf = unlines [
tag "?xml version=\"1.0\" standalone=\"yes\"?",
""
]
-- | >>> tag "test"
-- ""
tag :: String -> String
tag s = "<" ++ s ++ ">"
element :: String -> [String] -> String
element t ts =
tag ("!ELEMENT " ++ t ++ " " ++ alts ts)
attlist t a =
tag ("!ATTLIST " ++ t ++ " " ++ a ++ " CDATA #REQUIRED")
elemAtt t a ts = element t ts ++++ attlist t a
elemt t = elemAtt t "name"
elemc :: Cat -> [(Fun, String)] -> String
elemc cat fs = unlines $ element (show cat) (map snd fs) : [element f [] | (f,_) <- fs]
elemEmp :: String -> String
elemEmp t = elemAtt t "value" []
alts :: [String] -> String
alts ts =
if null ts then "EMPTY" else parenth (unwords (intersperse "|" ts))
-- choose between these two encodings:
elemData b = if b then elemDataConstr else elemDataNotyp
efunDef b = if b then efunDefConstr else efunDefNotyp
endtagDef b = if b then endtagDefConstr else endtagDefNotyp
-- coding 0: ---- not finished
-- to show both types and constructors as tags;
-- lengthy, but validation guarantees type correctness
-- flag -xmlt
elemDataConstrs cf (cat,fcs) = elemc cat [(f,rhsCat cf f cs) | (f,cs) <- fcs]
efunDefConstrs = "elemFun i t x = [replicate (i+i) ' ' ++ tag t ++ \" \" ++ etag x]"
endtagDefConstrs = "endtag f c = tag (\"/\" ++ c)"
-- coding 1:
-- to show constructors as empty tags;
-- shorter than 0, but validation still guarantees type correctness
-- flag -xmlt
elemDataConstr cf (cat,fcs) = elemc cat [(f,rhsCat cf f cs) | (f,cs) <- fcs]
efunDefConstr = "elemFun i t x = [replicate (i+i) ' ' ++ tag t ++ \" \" ++ etag x]"
endtagDefConstr = "endtag f c = tag (\"/\" ++ c)"
-- coding 2:
-- constructors as tags, no types.
-- clumsy DTD, but nice trees. Validation guarantees type correctness
-- flag -xml
elemDataNotyp cf (_,fcs) = unlines [element f [rhsCatNot cf cs] | (f,cs) <- fcs]
efunDefNotyp = "elemFun i t x = [replicate (i+i) ' ' ++ tag x]"
endtagDefNotyp = "endtag f c = tag (\"/\" ++ f)"
-- to show constructors as attributes;
-- nice, but validation does not guarantee type correctness.
-- Therefore rejected.
-- elemDataAttr cf (cat,fcs) = elemt cat (nub [rhsCat cf cs | (_,cs) <- fcs])
-- efunDefAttr = "elemFun i t x = [replicate (i+i) ' ' ++ tag (t ++ \" name = \" ++ x)]"
rhsCat :: CF -> Fun -> [Cat] -> String
rhsCat cf fun cs = parenth (intercalate ", " (fun:map (symbCat cf) cs))
rhsCatNot cf cs = if null cs then "EMPTY" else intercalate", " (map (symbCatNot cf) cs)
symbCat cf c
| isList c = show (normCatOfList c) ++ if isEmptyListCat cf c then "*" else "+"
| otherwise = show c
symbCatNot cf c
| isList c = funs (normCatOfList c) ++ if isEmptyListCat cf c then "*" else "+"
| otherwise = funs c
where
funs k = case lookup k (cf2data cf) of
Just [] -> "EMPTY"
Just fcs -> parenth $ unwords $ intersperse "|" $ map fst fcs
_ -> parenth (show k) ----
parenth s = "(" ++ s ++ ")"
-- derive an XML printer from a BNF grammar
cf2XMLPrinter :: Bool -> SharedOptions -> String -> CF -> String
cf2XMLPrinter typ opts absMod cf = unlines [
prologue typ opts absMod,
integerRule cf,
doubleRule cf,
stringRule cf,
if hasIdent cf then identRule cf else "",
unlines [ownPrintRule cf own | (own,_) <- tokenPragmas cf],
rules cf
]
prologue :: Bool -> SharedOptions -> String -> String
prologue b opts _ = unlines [
"module " ++ xmlFileM opts +++ "where\n",
"-- pretty-printer generated by the BNF converter\n",
"import " ++ absFileM opts,
"import Data.Char",
"",
"-- the top-level printing method",
"printXML :: XPrint a => a -> String",
"printXML = render . prt 0",
"",
"render = unlines",
"",
"-- the printer class does the job",
"class XPrint a where",
" prt :: Int -> a -> [String]",
" prtList :: Int -> [a] -> [String]",
" prtList i = concat . map (prt i)",
"",
"instance XPrint a => XPrint [a] where",
" prt = prtList",
"",
"tag t = \"<\" ++ t ++ \">\"",
"etag t = \"<\" ++ t ++ \"/>\"",
"elemTok i t x = [replicate (i+i) ' ' ++ tag (t ++ \" value = \" ++ show x ++ \" /\")]",
"elemTokS i t x = elemTok i t (show x)",
efunDef b,
endtagDef b,
""
]
integerRule cf = showsPrintRule cf "Integer"
doubleRule cf = showsPrintRule cf "Double"
stringRule cf = showsPrintRule cf "Char" ++++ " prtList i xs = elemTok i \"String\" xs"
showsPrintRule _ t = unlines [
"instance XPrint " ++ t ++ " where",
" prt i x = elemTokS i" +++ "\"" ++ t ++ "\"" +++ "x"
]
identRule cf = ownPrintRule cf (Cat "Ident")
ownPrintRule cf cat = unlines [
"instance XPrint " ++ show cat ++ " where",
" prt i (" ++ show cat ++ posn ++ ") = elemTok i" +++ "\"" ++ show cat ++ "\"" +++ "x"
]
where
posn = if isPositionCat cf cat then " (_,x)" else " x"
rules :: CF -> String
rules cf = unlines $
map (\(s,xs) -> case_fun s (map toArgs xs)) $ cf2data cf
where
toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons)
names [] _ = []
names (x:xs) n
| x `elem` xs = (x ++ show n) : names xs (n+1)
| otherwise = x : names xs n
var (ListCat c) = var c ++ "s"
var (Cat "Ident") = "id"
var (Cat "Integer") = "n"
var (Cat "String") = "str"
var (Cat "Char") = "c"
var (Cat "Double") = "d"
var cat = map toLower (show cat)
checkRes s
| s `elem` reservedHaskell = s ++ "'"
| otherwise = s
reservedHaskell = ["case","class","data","default","deriving","do","else","if",
"import","in","infix","infixl","infixr","instance","let","module",
"newtype","of","then","type","where","as","qualified","hiding"]
ruleOf s = fromMaybe undefined $ lookupRule s (rulesOfCF cf)
--- case_fun :: Cat -> [(Constructor,Rule)] -> String
case_fun cat xs = unlines [
"instance XPrint" +++ show cat +++ "where",
" prt i" +++ "e = case e of",
unlines $ map (\ ((c,xx),_) ->
" " ++ c +++ unwords xx +++ "-> concat $ " +++
"elemFun i \"" ++ show cat ++ "\" \"" ++ c ++ "\"" +++
unwords [": prt (i+1)" +++ x | x <- xx] +++ ":" +++
"[[replicate (i+i) ' ' ++ endtag \"" ++ c ++ "\" \"" ++ show cat ++ "\"]]"
) xs
]
BNFC-2.8.1/src/BNFC/Backend/Latex.hs0000644000000000000000000002676412654616013014702 0ustar0000000000000000{-
BNF Converter: Latex Generator
Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.Latex where
import AbsBNF (Reg (..))
import BNFC.Options hiding (Backend)
import BNFC.Backend.Base
import BNFC.Backend.Common.Makefile as Makefile
import BNFC.CF
import BNFC.Utils
import Data.List
import System.FilePath ((<.>),replaceExtension)
import Text.Printf
makeLatex :: SharedOptions -> CF -> Backend
makeLatex opts cf = do
let texfile = name <.> "tex"
mkfile texfile (cfToLatex name cf)
Makefile.mkMakefile opts (makefile texfile)
where name = lang opts
cfToLatex :: String -> CF -> String
cfToLatex name cf = unlines [
"\\batchmode",
beginDocument name,
macros,
introduction,
prtTerminals name cf,
prtBNF name cf,
endDocument
]
makefile_ = makefile
makefile :: String -> String
makefile texfile =
Makefile.mkRule "all" [pdffile]
[]
$ Makefile.mkRule pdffile [texfile]
[ printf "pdflatex %s" texfile ]
$ Makefile.mkRule "clean" []
[ unwords [ "-rm", pdffile, auxfile, logfile ]]
$ Makefile.mkRule "cleanall" ["clean"]
[ "-rm Makefile " ++ texfile ]
""
where pdffile = replaceExtension texfile "pdf"
auxfile = replaceExtension texfile "aux"
logfile = replaceExtension texfile "log"
introduction :: String
introduction = concat
[
"\nThis document was automatically generated by ",
"the {\\em BNF-Converter}.",
" It was generated together with the lexer, the parser, and the",
" abstract syntax module, which guarantees that the document",
" matches with the implementation of the language (provided no",
" hand-hacking has taken place).\n"
]
prtTerminals :: String -> CF -> String
prtTerminals name cf = unlines [
"\\section*{The lexical structure of " ++ name ++ "}",
identSection cf,
"\\subsection*{Literals}",
prtLiterals name cf,
unlines (map prtOwnToken (tokenPragmas cf)),
"\\subsection*{Reserved words and symbols}",
prtReserved name cf,
prtSymb name cf,
"\\subsection*{Comments}",
prtComments $ comments cf
]
identSection cf = if not (hasIdent cf) then [] else
unlines [
"\\subsection*{Identifiers}",
prtIdentifiers
]
prtIdentifiers :: String
prtIdentifiers = unlines
[
"Identifiers \\nonterminal{Ident} are unquoted strings beginning with a letter,",
"followed by any combination of letters, digits, and the characters {\\tt \\_ '},",
"reserved words excluded."
]
prtLiterals :: String -> CF -> String
prtLiterals _ cf =
unlines $ map stringLit $
filter (`notElem` [Cat "Ident"]) $
literals cf
stringLit :: Cat -> String
stringLit cat = unlines $ case cat of
Cat "Char" -> ["Character literals \\nonterminal{Char}\\ have the form",
"\\terminal{'}$c$\\terminal{'}, where $c$ is any single character.",
""
]
Cat "String" -> ["String literals \\nonterminal{String}\\ have the form",
"\\terminal{\"}$x$\\terminal{\"}, where $x$ is any sequence of any characters",
"except \\terminal{\"}\\ unless preceded by \\verb6\\6.",
""]
Cat "Integer" -> ["Integer literals \\nonterminal{Int}\\ are nonempty sequences of digits.",
""]
Cat "Double" -> ["Double-precision float literals \\nonterminal{Double}\\ have the structure",
"indicated by the regular expression" +++
"$\\nonterminal{digit}+ \\mbox{{\\it `.'}} \\nonterminal{digit}+ (\\mbox{{\\it `e'}} \\mbox{{\\it `-'}}? \\nonterminal{digit}+)?$ i.e.\\",
"two sequences of digits separated by a decimal point, optionally",
"followed by an unsigned or negative exponent.",
""]
_ -> []
prtOwnToken (name,reg) = unlines
[ show name +++ "literals are recognized by the regular expression",
"\\(" ++
latexRegExp reg ++
"\\)"
]
prtComments :: ([(String,String)],[String]) -> String
prtComments (xs,ys) = concat
[
if null ys then
"There are no single-line comments in the grammar. \\\\"
else
"Single-line comments begin with " ++ sing ++". \\\\",
if null xs then
"There are no multiple-line comments in the grammar."
else
"Multiple-line comments are enclosed with " ++ mult ++"."
]
where
sing = intercalate ", " $ map (symbol.prt) ys
mult = intercalate ", " $
map (\(x,y) -> symbol (prt x)
++ " and " ++
symbol (prt y)) xs
prtSymb :: String -> CF -> String
prtSymb name cf = case symbols cf of
[] -> "\nThere are no symbols in " ++ name ++ ".\\\\\n"
xs -> "The symbols used in " ++ name ++ " are the following: \\\\\n"
++
tabular 3 (three $ map (symbol.prt) xs)
prtReserved :: String -> CF -> String
prtReserved name cf = case reservedWords cf of
[] -> stringRes name ++
"\nThere are no reserved words in " ++ name ++ ".\\\\\n"
xs -> stringRes name ++
tabular 3 (three $ map (reserved.prt) xs)
stringRes :: String -> String
stringRes name = concat
["The set of reserved words is the set of terminals ",
"appearing in the grammar. Those reserved words ",
"that consist of non-letter characters are called symbols, and ",
"they are treated in a different way from those that ",
"are similar to identifiers. The lexer ",
"follows rules familiar from languages ",
"like Haskell, C, and Java, including longest match ",
"and spacing conventions.",
"\n\n",
"The reserved words used in " ++ name ++ " are the following: \\\\\n"]
three :: [String] -> [[String]]
three [] = []
three [x] = [[x,[],[]]]
three [x,y] = [[x,y,[]]]
three (x:y:z:xs) = [x,y,z] : three xs
prtBNF :: String -> CF -> String
prtBNF name cf = unlines [
"\\section*{The syntactic structure of " ++ name ++"}",
"Non-terminals are enclosed between $\\langle$ and $\\rangle$. ",
"The symbols " ++ arrow ++ " (production), " ++
delimiter ++" (union) ",
"and " ++ empty ++ " (empty rule) belong to the BNF notation. ",
"All other symbols are terminals.\\\\",
prtRules (ruleGroups cf)
]
prtRules :: [(Cat,[Rule])] -> String
prtRules [] = []
prtRules ((c,[]):xs)
= tabular 3 [[nonterminal c,arrow,[]]] ++ prtRules xs
prtRules ((c, r : rs) : xs)
= tabular 3 ([[nonterminal c,arrow,prtSymbols $ rhsRule r]] ++
[[[],delimiter,prtSymbols (rhsRule y)] | y <- rs]) ++
prtRules xs
prtSymbols :: [Either Cat String] -> String
prtSymbols [] = empty
prtSymbols xs = foldr ((+++) . p) [] xs
where p (Left r) = nonterminal r --- (prt r)
p (Right r) = terminal (prt r)
prt :: String -> String
prt = concatMap escape
where escape '\\' = "$\\backslash$"
escape '~' = "\\~{}"
escape '^' = "{\\textasciicircum}"
escape c | c `elem` ("$&%#_{}" :: String) = ['\\', c]
escape c | c `elem` ("+=|<>-" :: String) = "{$" ++ [c] ++ "$}"
escape c = [c]
macros :: String
macros =
"\\newcommand{\\emptyP}{\\mbox{$\\epsilon$}}" ++++
"\\newcommand{\\terminal}[1]{\\mbox{{\\texttt {#1}}}}" ++++
"\\newcommand{\\nonterminal}[1]{\\mbox{$\\langle \\mbox{{\\sl #1 }} \\! \\rangle$}}" ++++
"\\newcommand{\\arrow}{\\mbox{::=}}" ++++
"\\newcommand{\\delimit}{\\mbox{$|$}}" ++++
"\\newcommand{\\reserved}[1]{\\mbox{{\\texttt {#1}}}}" ++++
"\\newcommand{\\literal}[1]{\\mbox{{\\texttt {#1}}}}" ++++
"\\newcommand{\\symb}[1]{\\mbox{{\\texttt {#1}}}}"
reserved :: String -> String
reserved s = "{\\reserved{" ++ s ++ "}}"
literal :: String -> String
literal s = "{\\literal{" ++ s ++ "}}"
empty :: String
empty = "{\\emptyP}"
symbol :: String -> String
symbol s = "{\\symb{" ++ s ++ "}}"
tabular :: Int -> [[String]] -> String
tabular n xs = "\n\\begin{tabular}{" ++ concat (replicate n "l") ++ "}\n" ++
concatMap (\(a:as) -> foldr (+++) "\\\\\n" (a: map ('&':) as)) xs ++
"\\end{tabular}\\\\\n"
terminal :: String -> String
terminal s = "{\\terminal{" ++ s ++ "}}"
nonterminal :: Cat -> String
nonterminal s = "{\\nonterminal{" ++ mkId (identCat s) ++ "}}" where
mkId = map mk
mk c = case c of
'_' -> '-' ---
_ -> c
arrow :: String
arrow = " {\\arrow} "
delimiter :: String
delimiter = " {\\delimit} "
beginDocument :: String -> String
beginDocument name =
"%This Latex file is machine-generated by the BNF-converter\n" ++++
"\\documentclass[a4paper,11pt]{article}" ++++
"\\author{BNF-converter}" ++++
"\\title{The Language " ++ name ++ "}" ++++
-- "\\usepackage{isolatin1}" ++++
"\\setlength{\\parindent}{0mm}" ++++
"\\setlength{\\parskip}{1mm}" ++++
"\\begin{document}\n" ++++
"\\maketitle\n"
endDocument :: String
endDocument =
"\n\\end{document}\n"
latexRegExp :: Reg -> String
latexRegExp = rex (0 :: Int) where
rex i e = case e of
RSeq reg0 reg -> ifPar i 2 $ rex 2 reg0 +++ rex 2 reg
RAlt reg0 reg -> ifPar i 1 $ rex 1 reg0 +++ "\\mid" +++ rex 1 reg
RMinus reg0 reg -> ifPar i 1 $ rex 2 reg0 +++ "-" +++ rex 2 reg
RStar reg -> rex 3 reg ++ "*"
RPlus reg -> rex 3 reg ++ "+"
ROpt reg -> rex 3 reg ++ "?"
REps -> "\\epsilon"
RChar c -> "\\mbox{`" ++ prt [c] ++ "'}"
RAlts str -> "[" ++ "\\mbox{``" ++ prt str ++ "''}" ++ "]"
RSeqs str -> "\\{" ++ "\\mbox{``" ++ prt str ++ "''}" ++ "\\}"
RDigit -> "{\\nonterminal{digit}}"
RLetter -> "{\\nonterminal{letter}}"
RUpper -> "{\\nonterminal{upper}}"
RLower -> "{\\nonterminal{lower}}"
RAny -> "{\\nonterminal{anychar}}"
ifPar i j s = if i > j then "(" ++ s ++ ")" else s
BNFC-2.8.1/src/BNFC/Backend/C.hs0000644000000000000000000001631112654616013013772 0ustar0000000000000000{-
BNF Converter: C Main file
Copyright (C) 2004 Author: Michael Pellauer
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.C (makeC) where
import BNFC.Utils
import BNFC.CF
import BNFC.Options
import BNFC.Backend.Base
import BNFC.Backend.C.CFtoCAbs
import BNFC.Backend.C.CFtoFlexC
import BNFC.Backend.C.CFtoBisonC
import BNFC.Backend.C.CFtoCSkel
import BNFC.Backend.C.CFtoCPrinter
import Data.Char
import qualified BNFC.Backend.Common.Makefile as Makefile
makeC :: SharedOptions -> CF -> MkFiles ()
makeC opts cf = do
let (hfile, cfile) = cf2CAbs prefix cf
mkfile "Absyn.h" hfile
mkfile "Absyn.c" cfile
let (flex, env) = cf2flex prefix cf
mkfile (name ++ ".l") flex
let bison = cf2Bison prefix cf env
mkfile (name ++ ".y") bison
let header = mkHeaderFile cf (allCats cf) (allEntryPoints cf) env
mkfile "Parser.h" header
let (skelH, skelC) = cf2CSkel cf
mkfile "Skeleton.h" skelH
mkfile "Skeleton.c" skelC
let (prinH, prinC) = cf2CPrinter cf
mkfile "Printer.h" prinH
mkfile "Printer.c" prinC
mkfile "Test.c" (ctest cf)
Makefile.mkMakefile opts (makefile name prefix)
where prefix :: String -- The prefix is a string used by flex and bison
-- that is prepended to generated function names.
-- In most cases we want the grammar name as the prefix
-- but in a few specific cases, this can create clashes
-- with existing functions
prefix = if name `elem` ["m","c","re","std","str"]
then name ++ "_" else name
name = lang opts
makefile :: String -> String -> String
makefile name prefix =
(unlines [ "CC = gcc",
"CCFLAGS = -g -W -Wall", "",
"FLEX = flex",
"FLEX_OPTS = -P" ++ prefix, "",
"BISON = bison",
"BISON_OPTS = -t -p" ++ prefix, "",
"OBJS = Absyn.o Lexer.o Parser.o Printer.o", ""] ++)
$ Makefile.mkRule ".PHONY" ["clean", "distclean"]
[]
$ Makefile.mkRule "all" [testName]
[]
$ Makefile.mkRule "clean" []
-- peteg: don't nuke what we generated - move that to the "vclean" target.
[ "rm -f *.o " ++ testName ++ " " ++ unwords
[ name ++ e | e <- [".aux", ".log", ".pdf",".dvi", ".ps", ""]] ]
$ Makefile.mkRule "distclean" ["clean"]
[ "rm -f " ++ unwords
[ "Absyn.h", "Absyn.c", "Test.c", "Parser.c", "Parser.h", "Lexer.c",
"Skeleton.c", "Skeleton.h", "Printer.c", "Printer.h", "Makefile " ]
++ name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex "]
$ Makefile.mkRule testName ["${OBJS}", "Test.o"]
[ "@echo \"Linking " ++ testName ++ "...\""
, "${CC} ${CCFLAGS} ${OBJS} Test.o -o " ++ testName ]
$ Makefile.mkRule "Absyn.o" [ "Absyn.c", "Absyn.h"]
[ "${CC} ${CCFLAGS} -c Absyn.c" ]
$ Makefile.mkRule "Lexer.c" [ name ++ ".l" ]
[ "${FLEX} ${FLEX_OPTS} -oLexer.c " ++ name ++ ".l" ]
$ Makefile.mkRule "Parser.c" [ name ++ ".y" ]
[ "${BISON} ${BISON_OPTS} " ++ name ++ ".y -o Parser.c" ]
$ Makefile.mkRule "Lexer.o" [ "Lexer.c", "Parser.h" ]
[ "${CC} ${CCFLAGS} -c Lexer.c " ]
$ Makefile.mkRule "Parser.o" ["Parser.c", "Absyn.h" ]
[ "${CC} ${CCFLAGS} -c Parser.c" ]
$ Makefile.mkRule "Printer.o" [ "Printer.c", "Printer.h", "Absyn.h" ]
[ "${CC} ${CCFLAGS} -c Printer.c" ]
$ Makefile.mkRule "Test.o" [ "Test.c", "Parser.h", "Printer.h", "Absyn.h" ]
[ "${CC} ${CCFLAGS} -c Test.c" ]
""
where testName = "Test" ++ name
-- | Generate a test program that parses stdin and prints the AST and it's
-- linearization
ctest :: CF -> String
ctest cf =
unlines
[
"/*** Compiler Front-End Test automatically generated by the BNF Converter ***/",
"/* */",
"/* This test will parse a file, print the abstract syntax tree, and then */",
"/* pretty-print the result. */",
"/* */",
"/****************************************************************************/",
"",
"#include ",
"#include ",
"",
"#include \"Parser.h\"",
"#include \"Printer.h\"",
"#include \"Absyn.h\"",
"",
"int main(int argc, char ** argv)",
"{",
" FILE *input;",
" " ++ def ++ " parse_tree;",
" if (argc > 1) ",
" {",
" input = fopen(argv[1], \"r\");",
" if (!input)",
" {",
" fprintf(stderr, \"Error opening input file.\\n\");",
" exit(1);",
" }",
" }",
" else input = stdin;",
" /* The default entry point is used. For other options see Parser.h */",
" parse_tree = p" ++ def ++ "(input);",
" if (parse_tree)",
" {",
" printf(\"\\nParse Succesful!\\n\");",
" printf(\"\\n[Abstract Syntax]\\n\");",
" printf(\"%s\\n\\n\", show" ++ def ++ "(parse_tree));",
" printf(\"[Linearized Tree]\\n\");",
" printf(\"%s\\n\\n\", print" ++ def ++ "(parse_tree));",
" return 0;",
" }",
" return 1;",
"}",
""
]
where
def = show $ head (allEntryPoints cf)
mkHeaderFile :: CF -> [Cat] -> [Cat] -> [(a, String)] -> String
mkHeaderFile cf cats eps env = unlines
[
"#ifndef PARSER_HEADER_FILE",
"#define PARSER_HEADER_FILE",
"",
"#include \"Absyn.h\"",
"",
"typedef union",
"{",
" int int_;",
" char char_;",
" double double_;",
" char* string_;",
(concatMap mkVar cats) ++ "} YYSTYPE;",
"",
"#define _ERROR_ 258",
mkDefines (259::Int) env,
"extern YYSTYPE yylval;",
concatMap mkFunc eps,
"",
"#endif"
]
where
mkVar s | (normCat s == s) = " " ++ (identCat s) +++ (map toLower (identCat s)) ++ "_;\n"
mkVar _ = ""
mkDefines n [] = mkString n
mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss)
mkString n = if isUsedCat cf catString
then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1)
else mkChar n
mkChar n = if isUsedCat cf catChar
then ("#define _CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1)
else mkInteger n
mkInteger n = if isUsedCat cf catInteger
then ("#define _INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1)
else mkDouble n
mkDouble n = if isUsedCat cf catDouble
then ("#define _DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1)
else mkIdent n
mkIdent n = if isUsedCat cf catIdent
then ("#define _IDENT_ " ++ show n ++ "\n")
else ""
mkFunc s | normCat s == s = identCat s ++ " p" ++ identCat s ++ "(FILE *inp);\n"
mkFunc _ = ""
BNFC-2.8.1/src/BNFC/Backend/Common.hs0000644000000000000000000000237012654616013015040 0ustar0000000000000000module BNFC.Backend.Common (renderListSepByPrecedence) where
-- Functions common to different backends
import BNFC.PrettyPrint
-- | Helper function for c-like languages that generates the code printing
-- the list separator according to the given precedence level:
--
-- >>> let my_render c = "my_render(\"" <> text c <> "\")"
-- >>> renderListSepByPrecedence "x" my_render []
--
--
-- >>> renderListSepByPrecedence "x" my_render [(0,",")]
-- my_render(",");
--
-- >>> renderListSepByPrecedence "x" my_render [(3,";"), (1, "--")]
-- switch(x)
-- {
-- case 3: my_render(";"); break;
-- default: my_render("--");
-- }
renderListSepByPrecedence :: Doc -- ^ Name of the coercion level variable
-> (String -> Doc) -- ^ render function
-> [(Integer, String)] -- ^ separators by precedence
-> Doc
renderListSepByPrecedence _ _ [] = empty
renderListSepByPrecedence _ render [(_,sep)] = render sep <> ";"
renderListSepByPrecedence var render ss = "switch(" <> var <> ")" $$ codeblock 2
( ["case" <+> integer i <:> render sep <>"; break;" | (i, sep) <- init ss]
++ ["default" <:> render sep <>";" | let (_,sep) = last ss])
where
a <:> b = a <> ":" <+> b
BNFC-2.8.1/src/BNFC/Backend/Utils.hs0000644000000000000000000000125512654616013014711 0ustar0000000000000000-- | Functions that are used in multiple backends
module BNFC.Backend.Utils (isTokenType) where
import BNFC.CF (Cat(..))
-- | Checks if a category is a token type (either built-in or user-defined)
-- The first argument is the list of user-defined token type.
-- >>> isTokenType [] (Cat "Integer")
-- True
-- >>> isTokenType [Cat "Abc"] (Cat "Abc")
-- True
-- >>> isTokenType [] (Cat "Abc")
-- False
isTokenType :: [Cat] -> Cat -> Bool
isTokenType _ (Cat "Integer") = True
isTokenType _ (Cat "Char") = True
isTokenType _ (Cat "String") = True
isTokenType _ (Cat "Double") = True
isTokenType _ (Cat "Ident") = True
isTokenType user cat | cat `elem` user = True
isTokenType _ _ = False
BNFC-2.8.1/src/BNFC/Backend/HaskellProfile.hs0000644000000000000000000002061512654616013016516 0ustar0000000000000000{-
BNF Converter: Haskell main file
Copyright (C) 2004 Author: Markus Forberg, Peter Gammie, Aarne Ranta
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.HaskellProfile (makeHaskellProfile) where
import Control.Monad (when)
import Data.Maybe (isJust)
import BNFC.CF
import BNFC.Options hiding (Backend)
import BNFC.Backend.Base
import BNFC.Backend.HaskellProfile.CFtoHappyProfile
import BNFC.Backend.Haskell.CFtoAlex
import BNFC.Backend.Haskell.CFtoAlex2
import BNFC.Backend.Haskell.MkErrM
-- naming conventions
nameMod :: String -> Bool -> String -> FilePath
nameMod name inDir lang =
if inDir
then lang ++ "." ++ name
else name ++ lang
nameFile :: String -> String -> Bool -> String -> FilePath
nameFile name ext inDir lang =
if inDir
then lang ++ "/" ++ name ++ "." ++ ext
else name ++ lang ++ "." ++ ext
absFileM, alexFile, alexFileM, happyFile, happyFileM, errFile, errFileM, tFile,
mFile :: Bool -> String -> FilePath
absFileM = nameMod "Abs"
alexFile = nameFile "Lex" "x"
alexFileM = nameMod "Lex"
happyFile = nameFile "Par" "y"
happyFileM = nameMod "Par"
tFile = nameFile "Test" "hs"
mFile inDir n = if inDir then n ++ "/" ++ "Makefile" else "Makefile"
errFile b n = if b then n ++ "/" ++ "ErrM.hs" else "ErrM.hs"
errFileM b n = if b then n ++ "." ++ "ErrM" else "ErrM"
makeHaskellProfile :: SharedOptions -> CFP -> Backend
makeHaskellProfile opts cfp = do
let absMod = absFileM (inDir opts) name
lexMod = alexFileM (inDir opts) name
parMod = happyFileM (inDir opts) name
errMod = errFileM (inDir opts) name
let cf = cfp2cf cfp
do
---- mkfile (absFile (inDir opts) name) $ cf2Abstract (absFileM (inDir opts) name) cf
if alexMode opts == Alex1 then do
mkfile (alexFile (inDir opts) name) $ cf2alex lexMod errMod cf
liftIO $ putStrLn " (Use Alex 1.1 to compile.)"
else do
mkfile (alexFile (inDir opts) name) $ cf2alex2 lexMod errMod "" False False cf
liftIO $ putStrLn " (Use Alex 2.0 to compile.)"
mkfile (happyFile (inDir opts) name) $
cf2HappyProfileS parMod absMod lexMod errMod cfp
liftIO $ putStrLn " (Tested with Happy 1.13)"
---- mkfile (templateFile (inDir opts) name) $
---- cf2Template tplMod absMod errMod cf
---- mkfile (printerFile (inDir opts) name) $ cf2Printer prMod absMod cf
---- if hasLayout cf then
---- mkfile (layoutFile (inDir opts) name) $ cf2Layout alex1 (inDir opts) layMod lexMod cf
---- else return ()
mkfile (tFile (inDir opts) name) $ testfile (inDir opts) name (xml opts>0) cf
mkfile (errFile (inDir opts) name) $ errM errMod cf
when (isJust $ make opts)
(mkfile (mFile (inDir opts) name) $ makefile (inDir opts) name)
---- case xml of
---- 2 -> makeXML name True cf
---- 1 -> makeXML name False cf
---- _ -> return ()
where name = lang opts
makefile :: Bool -> String -> String
makefile inDir name = makeA where
name' = if inDir then "" else name -- Makefile is inDir
ghcCommand = "ghc --make "++ tFile inDir name ++ " -o " ++
if inDir then name ++ "/" ++ "Test" else "Test" ++ name
makeA = unlines
[
"all:",
"\thappy -gca " ++ happyFile False name',
"\talex " ++ alexFile False name',
'\t' : if inDir then
"(" ++ "cd ..; " ++ ghcCommand ++ ")"
else ghcCommand,
"clean:",
"\t rm -f *.hi *.o",
"distclean: " ++ if inDir then "" else "clean",
if inDir then
"\t rm -rf ../" ++ name -- erase this directory!
else
"\t rm -f " ++ unwords [
"Doc" ++ name ++ ".*",
"Lex" ++ name ++ ".*",
"Par" ++ name ++ ".*",
---- "Layout" ++ name ++ ".*",
---- "Skel" ++ name ++ ".*",
---- "Print" ++ name ++ ".*",
"Test" ++ name ++ ".*",
---- "Abs" ++ name ++ ".*",
"Test" ++ name,
"ErrM.*",
---- name ++ ".dtd",
---- "XML" ++ name ++ ".*",
"Makefile*"
]
]
testfile :: Bool -> String -> Bool -> CF -> String
testfile inDir name _ cf = makeA where
makeA = let lay = hasLayout cf
in unlines
["-- automatically generated by BNF Converter",
"module Main where\n",
"",
"import Trees",
"import Profile",
"import System.IO ( stdin, hGetContents )",
"import System.Environment ( getArgs, getProgName )",
"import System.Exit ( exitFailure )",
"",
"import " ++ alexFileM inDir name,
"import " ++ happyFileM inDir name,
---- "import " ++ templateFileM inDir name,
---- "import " ++ printerFileM inDir name,
---- "import " ++ absFileM inDir name,
---- if lay then ("import " ++ layoutFileM inDir name) else "",
---- if xml then ("import " ++ xmlFileM inDir name) else "",
"import " ++ errFileM inDir name,
"",
"type ParseFun = [Token] -> Err CFTree",
"",
"myLLexer = " ++ if lay then "resolveLayout True . myLexer"
else "myLexer",
"",
"runFile :: ParseFun -> FilePath -> IO ()",
"runFile p f = readFile f >>= run p",
"",
"run :: ParseFun -> String -> IO ()",
"run p s = do",
" let ts = myLLexer s",
" let etree = p ts",
" case etree of",
" Ok tree -> do",
" case postParse tree of",
" Bad s -> do",
" putStrLn \"\\nParse Failed... CFTree:\\n\"",
" putStrLn $ prCFTree tree",
" putStrLn s",
" Ok tree -> do",
" putStrLn \"\\nParse Successful!\"",
" putStrLn $ \"\\n[Abstract Syntax]\\n\\n\" ++ prt tree",
" Bad s -> do",
" putStrLn s",
" putStrLn \"\\nParse failed... tokenization:\"",
" print ts",
"",
"usage :: IO ()",
"usage = do",
" putStrLn $ unlines",
" [ \"usage: Call with one of the following argument combinations:\"",
" , \" --help Display this help message.\"",
" , \" (no arguments) Parse stdin.\"",
" , \" (file) Parse content of file.\"",
" ]",
" exitFailure",
"",
"main :: IO ()",
"main = do",
" args <- getArgs",
" case args of",
" [\"--help\"] -> usage",
" [] -> hGetContents stdin >>= run " ++ firstParser,
" [f] -> runFile " ++ firstParser ++ " f",
" _ -> do progName <- getProgName",
" putStrLn $ progName ++ \": excess arguments.\""
]
where firstParser = 'p' : show (firstEntry cf)
BNFC-2.8.1/src/BNFC/Backend/Pygments.hs0000644000000000000000000001152012654616013015413 0ustar0000000000000000{- Generates a Pygments lexer from a BNF grammar.
-
- Resources:
- * Pygments: http://pygments.org/
- * Lexer development: http://pygments.org/docs/lexerdevelopment/
- * Token types: http://pygments.org/docs/tokens/
- -}
module BNFC.Backend.Pygments where
import AbsBNF (Reg(..))
import BNFC.Backend.Base (mkfile, Backend)
import BNFC.CF
import BNFC.Lexing
import BNFC.Options hiding (Backend)
import BNFC.Utils
import BNFC.PrettyPrint
makePygments :: SharedOptions -> CF -> Backend
makePygments opts cf = do
let lexerfile = render (lowerCase name <> "/__init__.py")
setupfile = "setup.py"
mkfile lexerfile (render $ lexer name cf)
mkfile setupfile (render $ setup name)
where name = lang opts
setup :: String -> Doc
setup name = vcat
[ "from setuptools import setup, find_packages"
, "setup" <> parens (fsep (punctuate ","
[ "name" <=> quotes ("pygment-"<>lowerCase name)
, "version" <=> "0.1"
, "packages" <=> brackets (quotes moduleName)
, "entry_points" <=> entryPoints
, "install_requires = ['pygments']"
]))
]
where
className = camelCase name <> "Lexer"
moduleName = lowerCase name
entryPoints =
braces( "'pygments.lexers':"
<> doubleQuotes (moduleName <> "=" <> moduleName <> ":" <> className))
lexer :: String -> CF -> Doc
lexer name cf = vcat
-- Import statments
[ "import pygments.lexer"
, "from pygments.token import *"
-- Declare our lexer
, "__all__" <=> brackets (doubleQuotes className)
-- define lexer
, "class" <+> className <> parens "pygments.lexer.RegexLexer" <> ":"
, indent
[ "name" <=> quotes (text name)
, "aliases" <=> brackets (quotes (lowerCase name))
-- filenames = ['*.cf', '*lbnf']
, "KEYWORDS" <=> brackets keywords
-- We override the get_tokens_unprocessed method to filter keywords
-- from identifiers
, "def get_tokens_unprocessed(self, text):"
, indent
[ "for index, token, value in super(" <> className <> ",self).get_tokens_unprocessed(text):"
, indent
[ "if token is Name and value in self.KEYWORDS:"
, indent [ "yield index, Keyword, value" ]
, "else:"
, indent [ "yield index, token, value" ]
]
]
-- The token is defined using regex
, "tokens = {"
, indent
[ "'root': ["
, indent (map prLexRule (mkLexer cf) ++ ["(r'\\s+', Token.Space)"])
, "]"
]
, "}"
]
]
where
className = camelCase name <> "Lexer"
keywords = fsep (punctuate "," (map (quotes . text) (reservedWords cf)))
indent = nest 4 . vcat
prLexRule (reg,ltype) =
parens ("r" <> quotes (pyRegex reg) <> "," <+> pyToken ltype) <> ","
pyToken LexComment = "Comment"
pyToken LexSymbols = "Operator"
pyToken (LexToken "Integer") = "Number.Integer"
pyToken (LexToken "Double") = "Number.Float"
pyToken (LexToken "Char") = "String.Char"
pyToken (LexToken "String") = "String.Double"
pyToken (LexToken _) = "Name"
-- | Convert a Reg to a python regex
-- >>> pyRegex (RSeqs "abc")
-- abc
-- >>> pyRegex (RAlt (RSeqs "::=") (RChar '.'))
-- ::=|\.
-- >>> pyRegex (RChar '=')
-- =
-- >>> pyRegex RAny
-- .
-- >>> pyRegex (RStar RAny)
-- .*
-- >>> pyRegex (RPlus (RSeqs "xxx"))
-- (xxx)+
-- >>> pyRegex (ROpt (RSeqs "abc"))
-- (abc)?
-- >>> pyRegex (RSeq (RSeqs "--") (RSeq (RStar RAny) (RChar '\n')))
-- --.*\n
-- >>> pyRegex (RStar (RSeq (RSeqs "abc") (RChar '*')))
-- (abc\*)*
-- >>> pyRegex REps
--
-- >>> pyRegex (RAlts "abc[].")
-- [abc\[\]\.]
-- >>> pyRegex RDigit
-- \d
-- >>> pyRegex RLetter
-- [a-zA-Z]
-- >>> pyRegex RUpper
-- [A-Z]
-- >>> pyRegex RLower
-- [a-z]
-- >>> pyRegex (RMinus RAny RDigit)
-- (.)(?>> pyRegex (RSeq (RAlt (RChar 'a') RAny) (RAlt (RChar 'b') (RChar 'c')))
-- (a|.)(b|c)
pyRegex :: Reg -> Doc
pyRegex reg = case reg of
RSeqs s -> text (concatMap escape s)
RAlt r1 r2 -> pyRegex r1 <> "|" <> pyRegex r2
RChar c -> text (escape c)
RAny -> char '.'
RStar RAny -> ".*"
RStar re -> parens (pyRegex re) <> char '*'
RPlus re -> parens (pyRegex re) <> char '+'
ROpt re -> parens (pyRegex re) <> char '?'
RSeq r1 r2 -> pyRegex' r1 <> pyRegex' r2
REps -> empty
RAlts cs -> brackets (hcat (map (pyRegex . RChar) cs))
RDigit -> "\\d"
RUpper -> "[A-Z]"
RLower -> "[a-z]"
RLetter -> "[a-zA-Z]"
RMinus r1 r2 -> parens (pyRegex r1) <> parens ("? pyRegex r2)
where
escape '\n' = "\\n"
escape '\t' = "\\t"
escape c | c `elem` (".'[]()|*+?{}\\" :: String) = ['\\',c]
escape c = [c]
pyRegex' r@(RAlt{}) = parens (pyRegex r)
pyRegex' r = pyRegex r
BNFC-2.8.1/src/BNFC/Backend/Java.hs0000644000000000000000000002570012654616013014473 0ustar0000000000000000{-
BNF Converter: Java Top File
Copyright (C) 2004 Author: Markus Forsberg, Peter Gammie,
Michael Pellauer, Bjorn Bringert
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
-------------------------------------------------------------------
-- |
-- Module : JavaTop
-- Copyright : (C)opyright 2003, {markus, aarne, pellauer, peteg, bringert} at cs dot chalmers dot se
-- License : GPL (see COPYING for details)
--
-- Maintainer : {markus, aarne} at cs dot chalmers dot se
-- Stability : alpha
-- Portability : Haskell98
--
-- Top-level for the Java back end.
--
-- > $Id: JavaTop15.hs,v 1.12 2007/01/08 18:20:23 aarne Exp $
-------------------------------------------------------------------
module BNFC.Backend.Java ( makeJava ) where
-------------------------------------------------------------------
-- Dependencies.
-------------------------------------------------------------------
import System.FilePath (pathSeparator)
import BNFC.Utils
import BNFC.CF
import BNFC.Options as Options
import BNFC.Backend.Base
import BNFC.Backend.Java.CFtoCup15 ( cf2Cup )
import BNFC.Backend.Java.CFtoJLex15
import BNFC.Backend.Java.CFtoJavaAbs15 ( cf2JavaAbs )
import BNFC.Backend.Java.CFtoJavaPrinter15
import BNFC.Backend.Java.CFtoVisitSkel15
import BNFC.Backend.Java.CFtoComposVisitor
import BNFC.Backend.Java.CFtoAbstractVisitor
import BNFC.Backend.Java.CFtoFoldVisitor
import BNFC.Backend.Java.CFtoAllVisitor
import qualified BNFC.Backend.Common.Makefile as Makefile
import BNFC.PrettyPrint
-------------------------------------------------------------------
-- | Build the Java output.
-- FIXME: get everything to put the files in the right places.
-- Adapt Makefile to do the business.
-------------------------------------------------------------------
makeJava :: SharedOptions -> CF -> MkFiles ()
makeJava options@Options{..} cf =
do -- Create the package directories if necessary.
let packageBase = case inPackage of
Nothing -> lang
Just p -> p ++ "." ++ lang
packageAbsyn = packageBase ++ "." ++ "Absyn"
dirBase = pkgToDir packageBase
dirAbsyn = pkgToDir packageAbsyn
let absynFiles = remDups $ cf2JavaAbs packageBase packageAbsyn cf
absynBaseNames = map fst absynFiles
absynFileNames = map (dirAbsyn ++) absynBaseNames
let writeAbsyn (filename, contents) =
mkfile (dirAbsyn ++ filename ++ ".java") contents
mapM_ writeAbsyn absynFiles
mkfile (dirBase ++ "PrettyPrinter.java") $ cf2JavaPrinter packageBase packageAbsyn cf
mkfile (dirBase ++ "VisitSkel.java") $ cf2VisitSkel packageBase packageAbsyn cf
mkfile (dirBase ++ "ComposVisitor.java") $ cf2ComposVisitor packageBase packageAbsyn cf
mkfile (dirBase ++ "AbstractVisitor.java") $ cf2AbstractVisitor packageBase packageAbsyn cf
mkfile (dirBase ++ "FoldVisitor.java") $ cf2FoldVisitor packageBase packageAbsyn cf
mkfile (dirBase ++ "AllVisitor.java") $ cf2AllVisitor packageBase packageAbsyn cf
mkfile (dirBase ++ "Test.java") $ render $ javaTest packageBase packageAbsyn cf
--- mkfile ("Test" ++ name) $ "java " ++ dirBase ++ "Test $(1)"
let (lex, env) = cf2jlex packageBase cf jflex
mkfile (dirBase ++ "Yylex") (render lex)
liftIO $ putStrLn " (Tested with JLex 1.2.6.)"
mkfile (dirBase ++ lang ++ ".cup") $ cf2Cup packageBase packageAbsyn cf env
-- FIXME: put in a doc directory?
liftIO $ putStrLn $ " (Parser created for category " ++ show (firstEntry cf) ++ ")"
liftIO $ putStrLn " (Tested with CUP 0.10k)"
Makefile.mkMakefile options $ makefile lang dirBase dirAbsyn absynFileNames jflex
where
remDups [] = []
remDups ((a,b):as) = case lookup a as of
Just {} -> remDups as
Nothing -> (a, b) : remDups as
pkgToDir :: String -> FilePath
pkgToDir s = replace '.' pathSeparator s ++ [pathSeparator]
-- FIXME get filenames right.
-- FIXME It's almost certainly better to just feed all the Java source
-- files to javac in one go.
-- Replace with an ANT script?
makefile :: String -> FilePath -> FilePath -> [String] -> Bool -> String
makefile name dirBase dirAbsyn absynFileNames jflex =
Makefile.mkVar "JAVAC" "javac"
$ Makefile.mkVar "JAVAC_FLAGS" "-sourcepath ."
$ Makefile.mkVar "JAVA" "java"
$ Makefile.mkVar "JAVA_FLAGS" ""
$ Makefile.mkVar "CUP" "java_cup.Main"
$ Makefile.mkVar "CUPFLAGS" "-nopositions -expect 100"
$ (if jflex then Makefile.mkVar "JFLEX" "jflex"
else Makefile.mkVar "JLEX" "JLex.Main" )
$ Makefile.mkRule "all" [ "test" ]
[]
$ Makefile.mkRule "test" ("absyn" : map (dirBase ++) [ "Yylex.class",
"PrettyPrinter.class",
"Test.class",
"ComposVisitor.class",
"AbstractVisitor.class",
"FoldVisitor.class",
"AllVisitor.class",
"parser.class",
"sym.class",
"Test.class"])
[]
$ Makefile.mkRule ".PHONY" ["absyn"]
[]
$ Makefile.mkRule "%.class" [ "%.java" ]
[ "${JAVAC} ${JAVAC_FLAGS} $^" ]
$ Makefile.mkRule "absyn" [absynJavaSrc]
[ "${JAVAC} ${JAVAC_FLAGS} $^" ]
$ Makefile.mkRule (dirBase ++ "Yylex.java") [ dirBase ++ "Yylex" ]
[ (if jflex then "${JFLEX} " else "${JAVA} ${JAVA_FLAGS} ${JLEX} ") ++ dirBase ++ "Yylex" ]
$ Makefile.mkRule (dirBase ++ "sym.java " ++ dirBase ++ "parser.java")
[ dirBase ++ name ++ ".cup" ]
[ "${JAVA} ${JAVA_FLAGS} ${CUP} ${CUPFLAGS} " ++ dirBase ++ name ++ ".cup"
, "mv sym.java parser.java " ++ dirBase ]
$ Makefile.mkRule (dirBase ++ "Yylex.class") [ dirBase ++ "Yylex.java",
dirBase ++ "sym.java" ]
[]
$ Makefile.mkRule (dirBase ++ "sym.class") [ dirBase ++ "sym.java" ]
[]
$ Makefile.mkRule (dirBase ++ "parser.class") [ dirBase ++ "parser.java"
, dirBase ++ "sym.java" ]
[]
$ Makefile.mkRule (dirBase ++ "PrettyPrinter.class")
[ dirBase ++ "PrettyPrinter.java" ]
[]
-- FIXME
$ Makefile.mkRule "clean" []
[ "rm -f " ++ dirAbsyn ++ "*.class" ++ " " ++ dirBase ++ "*.class" ]
$ Makefile.mkRule "distclean" [ "vclean" ]
[]
$ Makefile.mkRule "vclean" []
[ " rm -f " ++ absynJavaSrc ++ " " ++ absynJavaClass
, " rm -f " ++ dirAbsyn ++ "*.class"
-- , "rm -f " ++ "Test" ++ name
, " rmdir " ++ dirAbsyn
, " rm -f " ++ unwords (map (dirBase ++) [
"Yylex",
name ++ ".cup",
"Yylex.java",
"VisitSkel.java",
"ComposVisitor.java",
"AbstractVisitor.java",
"FoldVisitor.java",
"AllVisitor.java",
"PrettyPrinter.java",
"Skeleton.java",
"Test.java",
"sym.java",
"parser.java",
"*.class"])
, "rm -f Makefile"
, "rmdir -p " ++ dirBase ]
""
where absynJavaSrc = unwords (map (++ ".java") absynFileNames)
absynJavaClass = unwords (map (++ ".class") absynFileNames)
javaTest :: String -> String -> CF -> Doc
javaTest packageBase packageAbsyn cf = vcat
[ "package" <+> text packageBase <> ";"
, "import java_cup.runtime.*;"
, "import" <+> text packageBase <> ".*;"
, "import" <+> text packageAbsyn <> ".*;"
, "import java.io.*;"
, ""
, "public class Test"
, codeblock 2
[ "public static void main(String args[]) throws Exception"
, codeblock 2
[ "Yylex l = null;"
, "parser p;"
, "try"
, codeblock 2
[ "if (args.length == 0) l = new Yylex(new InputStreamReader(System.in));"
, "else l = new Yylex(new FileReader(args[0]));" ]
, "catch(FileNotFoundException e)"
, "{"
, " System.err.println(\"Error: File not found: \" + args[0]);"
, " System.exit(1);"
, "}"
, "p = new parser(l);"
, "/* The default parser is the first-defined entry point. */"
, "/* You may want to change this. Other options are: */"
, "/* " <> fsep (punctuate "," (showOpts (tail eps))) <> " */"
, "try"
, "{"
, " " <> text packageAbsyn <> "." <> text (show def) <+> "parse_tree = p.p"
<> text (show def) <> "();"
, " System.out.println();"
, " System.out.println(\"Parse Succesful!\");"
, " System.out.println();"
, " System.out.println(\"[Abstract Syntax]\");"
, " System.out.println();"
, " System.out.println(PrettyPrinter.show(parse_tree));"
, " System.out.println();"
, " System.out.println(\"[Linearized Tree]\");"
, " System.out.println();"
, " System.out.println(PrettyPrinter.print(parse_tree));"
, "}"
, "catch(Throwable e)"
, "{"
, " System.err.println(\"At line \" + String.valueOf(l.line_num()) + \", near \\\"\" + l.buff() + \"\\\" :\");"
, " System.err.println(\" \" + e.getMessage());"
, " System.exit(1);"
, "}"
]
]
]
where
eps = allEntryPoints cf
def = head eps
showOpts [] = []
showOpts (x:xs) | normCat x /= x = showOpts xs
| otherwise = text ('p' : identCat x) : showOpts xs
BNFC-2.8.1/src/BNFC/Backend/CPP/0000755000000000000000000000000012654616013013674 5ustar0000000000000000BNFC-2.8.1/src/BNFC/Backend/CPP/NoSTL.hs0000644000000000000000000001542212654616013015173 0ustar0000000000000000{-
BNF Converter: C++ Main file
Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.CPP.NoSTL (makeCppNoStl) where
import BNFC.Utils
import BNFC.CF
import BNFC.Options
import BNFC.Backend.Base
import BNFC.Backend.CPP.NoSTL.CFtoCPPAbs
import BNFC.Backend.CPP.NoSTL.CFtoFlex
import BNFC.Backend.CPP.NoSTL.CFtoBison
import BNFC.Backend.CPP.NoSTL.CFtoCVisitSkel
import BNFC.Backend.CPP.PrettyPrinter
import Data.Char
import qualified BNFC.Backend.Common.Makefile as Makefile
makeCppNoStl :: SharedOptions -> CF -> MkFiles ()
makeCppNoStl opts cf = do
let (hfile, cfile) = cf2CPPAbs name cf
mkfile "Absyn.H" hfile
mkfile "Absyn.C" cfile
let (flex, env) = cf2flex Nothing name cf
mkfile (name ++ ".l") flex
let bison = cf2Bison name cf env
mkfile (name ++ ".y") bison
let header = mkHeaderFile cf (allCats cf) (allEntryPoints cf) env
mkfile "Parser.H" header
let (skelH, skelC) = cf2CVisitSkel cf
mkfile "Skeleton.H" skelH
mkfile "Skeleton.C" skelC
let (prinH, prinC) = cf2CPPPrinter False Nothing cf
mkfile "Printer.H" prinH
mkfile "Printer.C" prinC
mkfile "Test.C" (cpptest cf)
Makefile.mkMakefile opts $ makefile name
where name = lang opts
makefile :: String -> String
makefile name =
(unlines [ "CC = g++",
"CCFLAGS = -g -W -Wall", "",
"FLEX = flex",
"FLEX_OPTS = -P" ++ name, "",
"BISON = bison",
"BISON_OPTS = -t -p" ++ name, "",
"OBJS = Absyn.o Lexer.o Parser.o Printer.o", "" ] ++)
$ Makefile.mkRule ".PHONY" ["clean", "distclean"]
[]
$ Makefile.mkRule "all" [testName]
[]
$ Makefile.mkRule "clean" []
-- peteg: don't nuke what we generated - move that to the "vclean" target.
[ "rm -f *.o " ++ testName ++ " " ++ unwords
[ name ++ e | e <- [".aux", ".log", ".pdf",".dvi", ".ps", ""]] ]
$ Makefile.mkRule "distclean" ["clean"]
[ "rm -f " ++ unwords
[ "Absyn.C", "Absyn.H", "Test.C", "Parser.C", "Parser.H", "Lexer.C",
"Skeleton.C", "Skeleton.H", "Printer.C", "Printer.H", "Makefile " ]
++ name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex "]
$ Makefile.mkRule (testName) [ "${OBJS}", "Test.o" ]
[ "@echo \"Linking " ++ testName ++ "...\""
, "${CC} ${CCFLAGS} ${OBJS} Test.o -o " ++ testName ]
$ Makefile.mkRule "Absyn.o" [ "Absyn.C", "Absyn.H" ]
[ "${CC} ${CCFLAGS} -c Absyn.C" ]
$ Makefile.mkRule "Lexer.C" [ name ++ ".l" ]
[ "${FLEX} -oLexer.C " ++ name ++ ".l" ]
$ Makefile.mkRule "Parser.C" [ name ++ ".y" ]
[ "${BISON} " ++ name ++ ".y -o Parser.C" ]
$ Makefile.mkRule "Lexer.o" [ "Lexer.C", "Parser.H" ]
[ "${CC} ${CCFLAGS} -c Lexer.C " ]
$ Makefile.mkRule "Parser.o" [ "Parser.C", "Absyn.H" ]
[ "${CC} ${CCFLAGS} -c Parser.C" ]
$ Makefile.mkRule "Printer.o" [ "Printer.C", "Printer.H", "Absyn.H" ]
[ "${CC} ${CCFLAGS} -c Printer.C" ]
$ Makefile.mkRule "Test.o" [ "Test.C", "Parser.H", "Printer.H", "Absyn.H" ]
[ "${CC} ${CCFLAGS} -c Test.C" ]
""
where testName = "Test" ++ name
cpptest :: CF -> String
cpptest cf =
unlines
[
"/*** Compiler Front-End Test automatically generated by the BNF Converter ***/",
"/* */",
"/* This test will parse a file, print the abstract syntax tree, and then */",
"/* pretty-print the result. */",
"/* */",
"/****************************************************************************/",
"#include ",
"#include \"Parser.H\"",
"#include \"Printer.H\"",
"#include \"Absyn.H\"",
"",
"int main(int argc, char ** argv)",
"{",
" FILE *input;",
" if (argc > 1) ",
" {",
" input = fopen(argv[1], \"r\");",
" if (!input)",
" {",
" fprintf(stderr, \"Error opening input file.\\n\");",
" exit(1);",
" }",
" }",
" else input = stdin;",
" /* The default entry point is used. For other options see Parser.H */",
" " ++ def ++ " *parse_tree = p" ++ def ++ "(input);",
" if (parse_tree)",
" {",
" printf(\"\\nParse Succesful!\\n\");",
" printf(\"\\n[Abstract Syntax]\\n\");",
" ShowAbsyn *s = new ShowAbsyn();",
" printf(\"%s\\n\\n\", s->show(parse_tree));",
" printf(\"[Linearized Tree]\\n\");",
" PrintAbsyn *p = new PrintAbsyn();",
" printf(\"%s\\n\\n\", p->print(parse_tree));",
" return 0;",
" }",
" return 1;",
"}",
""
]
where
def = show (head (allEntryPoints cf))
mkHeaderFile cf cats eps env = unlines
[
"#ifndef PARSER_HEADER_FILE",
"#define PARSER_HEADER_FILE",
"",
concatMap mkForwardDec cats,
"typedef union",
"{",
" int int_;",
" char char_;",
" double double_;",
" char* string_;",
(concatMap mkVar cats) ++ "} YYSTYPE;",
"",
"#define _ERROR_ 258",
mkDefines (259 :: Int) env,
"extern YYSTYPE yylval;",
concatMap mkFunc eps,
"",
"#endif"
]
where
mkForwardDec s | (normCat s == s) = "class " ++ (identCat s) ++ ";\n"
mkForwardDec _ = ""
mkVar s | (normCat s == s) = " " ++ (identCat s) ++"*" +++ (map toLower (identCat s)) ++ "_;\n"
mkVar _ = ""
mkDefines n [] = mkString n
mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss)
mkString n = if isUsedCat cf catString
then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1)
else mkChar n
mkChar n = if isUsedCat cf catChar
then ("#define _CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1)
else mkInteger n
mkInteger n = if isUsedCat cf catInteger
then ("#define _INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1)
else mkDouble n
mkDouble n = if isUsedCat cf catDouble
then ("#define _DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1)
else mkIdent n
mkIdent n = if isUsedCat cf catIdent
then ("#define _IDENT_ " ++ show n ++ "\n")
else ""
mkFunc s | (normCat s == s) = (identCat s) ++ "*" +++ "p" ++ (identCat s) ++ "(FILE *inp);\n"
mkFunc _ = ""
BNFC-2.8.1/src/BNFC/Backend/CPP/STL.hs0000644000000000000000000001736012654616013014701 0ustar0000000000000000{-
BNF Converter: C++ Main file
Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer
Modified from CPPTop to BNFC.Backend.CPP.STL 2006 by Aarne Ranta.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.CPP.STL (makeCppStl,) where
import BNFC.Utils
import BNFC.CF
import BNFC.Options
import BNFC.Backend.Base
import BNFC.Backend.CPP.STL.CFtoSTLAbs
import BNFC.Backend.CPP.NoSTL.CFtoFlex
import BNFC.Backend.CPP.STL.CFtoBisonSTL
import BNFC.Backend.CPP.STL.CFtoCVisitSkelSTL
import BNFC.Backend.CPP.PrettyPrinter
import BNFC.Backend.CPP.STL.STLUtils
import Data.Char
import qualified BNFC.Backend.Common.Makefile as Makefile
makeCppStl :: SharedOptions -> CF -> MkFiles ()
makeCppStl opts cf = do
let (hfile, cfile) = cf2CPPAbs (linenumbers opts) (inPackage opts) name cf
mkfile "Absyn.H" hfile
mkfile "Absyn.C" cfile
let (flex, env) = cf2flex (inPackage opts) name cf
mkfile (name ++ ".l") flex
let bison = cf2Bison (linenumbers opts) (inPackage opts) name cf env
mkfile (name ++ ".y") bison
let header = mkHeaderFile (inPackage opts) cf (allCats cf) (allEntryPoints cf) env
mkfile "Parser.H" header
let (skelH, skelC) = cf2CVisitSkel (inPackage opts) cf
mkfile "Skeleton.H" skelH
mkfile "Skeleton.C" skelC
let (prinH, prinC) = cf2CPPPrinter True (inPackage opts) cf
mkfile "Printer.H" prinH
mkfile "Printer.C" prinC
mkfile "Test.C" (cpptest (inPackage opts) cf)
Makefile.mkMakefile opts $ makefile name
where name = lang opts
makefile :: String -> String
makefile name =
(unlines [ "CC = g++",
"CCFLAGS = -g -W -Wall", "",
"FLEX = flex",
"FLEX_OPTS = -P" ++ name, "",
"BISON = bison",
"BISON_OPTS = -t -p" ++ name, "",
"OBJS = Absyn.o Lexer.o Parser.o Printer.o", "" ] ++)
$ Makefile.mkRule ".PHONY" ["clean", "distclean"]
[]
$ Makefile.mkRule "all" [testName]
[]
$ Makefile.mkRule "clean" []
-- peteg: don't nuke what we generated - move that to the "vclean" target.
[ "rm -f *.o " ++ testName ++ " " ++ unwords
[ name ++ e | e <- [".aux", ".log", ".pdf",".dvi", ".ps", ""]] ]
$ Makefile.mkRule "distclean" ["clean"]
[ "rm -f " ++ unwords
[ "Absyn.C", "Absyn.H", "Test.C", "Parser.C", "Parser.H", "Lexer.C",
"Skeleton.C", "Skeleton.H", "Printer.C", "Printer.H", "Makefile " ]
++ name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex "]
$ Makefile.mkRule (testName) [ "${OBJS}", "Test.o" ]
[ "@echo \"Linking " ++ testName ++ "...\""
, "${CC} ${CCFLAGS} ${OBJS} Test.o -o " ++ testName ]
$ Makefile.mkRule "Absyn.o" [ "Absyn.C", "Absyn.H" ]
[ "${CC} ${CCFLAGS} -c Absyn.C" ]
$ Makefile.mkRule "Lexer.C" [ name ++ ".l" ]
[ "${FLEX} -oLexer.C " ++ name ++ ".l" ]
$ Makefile.mkRule "Parser.C" [ name ++ ".y" ]
[ "${BISON} " ++ name ++ ".y -o Parser.C" ]
$ Makefile.mkRule "Lexer.o" [ "Lexer.C", "Parser.H" ]
[ "${CC} ${CCFLAGS} -c Lexer.C" ]
$ Makefile.mkRule "Parser.o" [ "Parser.C", "Absyn.H" ]
[ "${CC} ${CCFLAGS} -c Parser.C" ]
$ Makefile.mkRule "Printer.o" [ "Printer.C", "Printer.H", "Absyn.H" ]
[ "${CC} ${CCFLAGS} -c Printer.C" ]
$ Makefile.mkRule "Skeleton.o" [ "Skeleton.C", "Skeleton.H", "Absyn.H" ]
[ "${CC} ${CCFLAGS} -c Skeleton.C" ]
$ Makefile.mkRule "Test.o" [ "Test.C", "Parser.H", "Printer.H", "Absyn.H" ]
[ "${CC} ${CCFLAGS} -c Test.C" ]
""
where testName = "Test" ++ name
cpptest :: Maybe String -> CF -> String
cpptest inPackage cf =
unlines
[
"/*** Compiler Front-End Test automatically generated by the BNF Converter ***/",
"/* */",
"/* This test will parse a file, print the abstract syntax tree, and then */",
"/* pretty-print the result. */",
"/* */",
"/****************************************************************************/",
"#include ",
"#include \"Parser.H\"",
"#include \"Printer.H\"",
"#include \"Absyn.H\"",
"",
"int main(int argc, char ** argv)",
"{",
" FILE *input;",
" if (argc > 1) ",
" {",
" input = fopen(argv[1], \"r\");",
" if (!input)",
" {",
" fprintf(stderr, \"Error opening input file.\\n\");",
" exit(1);",
" }",
" }",
" else input = stdin;",
" /* The default entry point is used. For other options see Parser.H */",
" " ++ scope ++ def ++ " *parse_tree = " ++ scope ++ "p" ++ def ++ "(input);",
" if (parse_tree)",
" {",
" printf(\"\\nParse Succesful!\\n\");",
" printf(\"\\n[Abstract Syntax]\\n\");",
" " ++ scope ++ "ShowAbsyn *s = new " ++ scope ++ "ShowAbsyn();",
" printf(\"%s\\n\\n\", s->show(parse_tree));",
" printf(\"[Linearized Tree]\\n\");",
" " ++ scope ++ "PrintAbsyn *p = new " ++ scope ++ "PrintAbsyn();",
" printf(\"%s\\n\\n\", p->print(parse_tree));",
" return 0;",
" }",
" return 1;",
"}",
""
]
where
def = show (head (allEntryPoints cf))
scope = nsScope inPackage
mkHeaderFile inPackage cf cats eps env = unlines
[
"#ifndef " ++ hdef,
"#define " ++ hdef,
"",
"#include",
"#include",
"",
nsStart inPackage,
concatMap mkForwardDec cats,
"typedef union",
"{",
" int int_;",
" char char_;",
" double double_;",
" char* string_;",
(concatMap mkVar cats) ++ "} YYSTYPE;",
"",
concatMap mkFuncs eps,
nsEnd inPackage,
"",
"#define " ++ nsDefine inPackage "_ERROR_" ++ " 258",
mkDefines (259 :: Int) env,
"extern " ++ nsScope inPackage ++ "YYSTYPE " ++ nsString inPackage ++ "yylval;",
"",
"#endif"
]
where
hdef = nsDefine inPackage "PARSER_HEADER_FILE"
mkForwardDec s | (normCat s == s) = "class " ++ (identCat s) ++ ";\n"
mkForwardDec _ = ""
mkVar s | (normCat s == s) = " " ++ (identCat s) ++"*" +++ (map toLower (identCat s)) ++ "_;\n"
mkVar _ = ""
mkDefines n [] = mkString n
mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss) -- "nsDefine inPackage s" not needed (see cf2flex::makeSymEnv)
mkString n = if isUsedCat cf catString
then ("#define " ++ nsDefine inPackage "_STRING_ " ++ show n ++ "\n") ++ mkChar (n+1)
else mkChar n
mkChar n = if isUsedCat cf catChar
then ("#define " ++ nsDefine inPackage "_CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1)
else mkInteger n
mkInteger n = if isUsedCat cf catInteger
then ("#define " ++ nsDefine inPackage "_INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1)
else mkDouble n
mkDouble n = if isUsedCat cf catDouble
then ("#define " ++ nsDefine inPackage "_DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1)
else mkIdent n
mkIdent n = if isUsedCat cf catIdent
then ("#define " ++ nsDefine inPackage "_IDENT_ " ++ show n ++ "\n")
else ""
mkFuncs s | normCat s == s = identCat s ++ "*" +++ "p" ++ identCat s ++ "(FILE *inp);\n" ++
identCat s ++ "*" +++ "p" ++ identCat s ++ "(const char *str);\n"
mkFuncs _ = ""
BNFC-2.8.1/src/BNFC/Backend/CPP/PrettyPrinter.hs0000644000000000000000000005125712654616013017075 0ustar0000000000000000{-
**************************************************************
BNF Converter Module
Description : This module generates the C++ Pretty Printer.
It also generates the "show" method for
printing an abstract syntax tree.
The generated files use the Visitor design pattern.
Author : Michael Pellauer (pellauer@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 10 August, 2003
Modified : 3 September, 2003
* Added resizable buffers
**************************************************************
-}
module BNFC.Backend.CPP.PrettyPrinter (cf2CPPPrinter, prRender) where
import BNFC.CF
import BNFC.Utils ((+++))
import BNFC.Backend.Common
import BNFC.Backend.Common.NamedVariables
import BNFC.Backend.Common.StrUtils (renderCharOrString)
import Data.Char(toLower)
import BNFC.Backend.CPP.STL.STLUtils
import BNFC.PrettyPrint
--Produces (.H file, .C file)
cf2CPPPrinter :: Bool -> Maybe String -> CF -> (String, String)
cf2CPPPrinter useStl inPackage cf =
(mkHFile useStl inPackage cf groups, mkCFile useStl inPackage cf groups)
where
groups = positionRules cf ++ fixCoercions (ruleGroupsInternals cf)
positionRules :: CF -> [(Cat,[Rule])]
positionRules cf =
[(cat,[Rule (show cat) cat [Left catString, Left catInteger]]) |
cat <- filter (isPositionCat cf) $ fst (unzip (tokenPragmas cf))]
{- **** Header (.H) File Methods **** -}
--An extremely large function to make the Header File
mkHFile :: Bool -> Maybe String -> CF -> [(Cat,[Rule])] -> String
mkHFile useStl inPackage cf groups = unlines
[
printHeader,
concatMap prDataH groups,
classFooter,
showHeader,
concatMap prDataH groups,
classFooter,
footer
]
where
printHeader = unlines
[
"#ifndef " ++ hdef,
"#define " ++ hdef,
"",
"#include \"Absyn.H\"",
"#include ",
"#include ",
"#include ",
"",
nsStart inPackage,
"/* Certain applications may improve performance by changing the buffer size */",
"#define " ++ nsDefine inPackage "BUFFER_INITIAL" ++ " 2000",
"/* You may wish to change _L_PAREN or _R_PAREN */",
"#define " ++ nsDefine inPackage "_L_PAREN" ++ " '('",
"#define " ++ nsDefine inPackage "_R_PAREN" ++ " ')'",
"",
"class PrintAbsyn : public Visitor",
"{",
" protected:",
" int _n_, _i_;",
" /* The following are simple heuristics for rendering terminals */",
" /* You may wish to change them */",
" void render(Char c);",
" void render(String s);",
if useStl then "void render(char* s);" else "",
" void indent(void);",
" void backup(void);",
" public:",
" PrintAbsyn(void);",
" ~PrintAbsyn(void);",
" char* print(Visitable* v);"
]
hdef = nsDefine inPackage "PRINTER_HEADER"
classFooter = unlines $
[
" void visitInteger(Integer i);",
" void visitDouble(Double d);",
" void visitChar(Char c);",
" void visitString(String s);",
" void visitIdent(String s);"
] ++ [" void visit" ++ t ++ "(String s);" | t <- tokenNames cf] ++
[
" protected:",
" void inline bufAppend(const char* s)",
" {",
" int len = strlen(s);",
" while (cur_ + len > buf_size)",
" {",
" buf_size *= 2; /* Double the buffer size */",
" resizeBuffer();",
" }",
" for(int n = 0; n < len; n++)",
" {",
" buf_[cur_ + n] = s[n];",
" }",
" cur_ += len;",
" buf_[cur_] = 0;",
" }",
" void inline bufAppend(const char c)",
" {",
" if (cur_ == buf_size)",
" {",
" buf_size *= 2; /* Double the buffer size */",
" resizeBuffer();",
" }",
" buf_[cur_] = c;",
" cur_++;",
" buf_[cur_] = 0;",
" }",
if useStl then render (nest 2 bufAppendString) else "",
" void inline bufReset(void)",
" {",
" cur_ = 0;",
" buf_size = " ++ nsDefine inPackage "BUFFER_INITIAL" ++ ";",
" resizeBuffer();",
" memset(buf_, 0, buf_size);",
" }",
" void inline resizeBuffer(void)",
" {",
" char* temp = (char*) malloc(buf_size);",
" if (!temp)",
" {",
" fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");",
" exit(1);",
" }",
" if (buf_)",
" {",
" strcpy(temp, buf_);",
" free(buf_);",
" }",
" buf_ = temp;",
" }",
" char *buf_;",
" int cur_, buf_size;",
"};",
""
]
bufAppendString :: Doc
bufAppendString =
"void inline bufAppend(String str)"
$$ codeblock 2
[ "const char* s = str.c_str();"
, "bufAppend(s);"]
showHeader = unlines
[
"",
"class ShowAbsyn : public Visitor",
"{",
" public:",
" ShowAbsyn(void);",
" ~ShowAbsyn(void);",
" char* show(Visitable* v);"
]
footer = unlines
[
nsEnd inPackage,
"",
"#endif"
]
--Prints all the required method names and their parameters.
prDataH :: (Cat, [Rule]) -> String
prDataH (cat, rules) =
if isList cat
then concat [" void visit", cl, "(", cl, "* p);\n"]
else abstract ++ concatMap prRuleH rules
where
cl = identCat (normCat cat)
abstract = case lookupRule (show cat) rules of
Just _ -> ""
Nothing -> " void visit" ++ cl ++ "(" ++ cl ++ " *p); /* abstract class */\n"
--Prints all the methods to visit a rule.
prRuleH :: Rule -> String
prRuleH (Rule fun _ _) | isProperLabel fun = concat
[" void visit", fun, "(", fun, " *p);\n"]
prRuleH _ = ""
{- **** Implementation (.C) File Methods **** -}
--This makes the .C file by a similar method.
mkCFile :: Bool -> Maybe String -> CF -> [(Cat,[Rule])] -> String
mkCFile useStl inPackage cf groups = concat
[
header,
nsStart inPackage ++ "\n",
prRender useStl,
printEntries,
concatMap (prPrintData useStl inPackage cf) groups,
printBasics,
printTokens,
showEntries,
concatMap (prShowData useStl) groups,
showBasics,
showTokens,
nsEnd inPackage ++ "\n"
]
where
header = unlines
[
"/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/",
"",
"#include ",
"#include \"Printer.H\"",
"#define INDENT_WIDTH 2",
""
]
printEntries = unlines
[
"PrintAbsyn::PrintAbsyn(void)",
"{",
" _i_ = 0; _n_ = 0;",
" buf_ = 0;",
" bufReset();",
"}",
"",
"PrintAbsyn::~PrintAbsyn(void)",
"{",
"}",
"",
"char* PrintAbsyn::print(Visitable *v)",
"{",
" _i_ = 0; _n_ = 0;",
" bufReset();",
" v->accept(this);",
" return buf_;",
"}"
]
showEntries = unlines
[
"ShowAbsyn::ShowAbsyn(void)",
"{",
" buf_ = 0;",
" bufReset();",
"}",
"",
"ShowAbsyn::~ShowAbsyn(void)",
"{",
"}",
"",
"char* ShowAbsyn::show(Visitable *v)",
"{",
" bufReset();",
" v->accept(this);",
" return buf_;",
"}"
]
printBasics = unlines
[
"void PrintAbsyn::visitInteger(Integer i)",
"{",
" char tmp[16];",
" sprintf(tmp, \"%d\", i);",
" bufAppend(tmp);",
"}",
"void PrintAbsyn::visitDouble(Double d)",
"{",
" char tmp[16];",
" sprintf(tmp, \"%g\", d);",
" bufAppend(tmp);",
"}",
"void PrintAbsyn::visitChar(Char c)",
"{",
" bufAppend('\\'');",
" bufAppend(c);",
" bufAppend('\\'');",
"}",
"void PrintAbsyn::visitString(String s)",
"{",
" bufAppend('\\\"');",
" bufAppend(s);",
" bufAppend('\\\"');",
"}",
"void PrintAbsyn::visitIdent(String s)",
"{",
" render(s);",
"}",
""
]
printTokens = unlines
[unlines [
"void PrintAbsyn::visit" ++ t ++ "(String s)",
"{",
" render(s);",
"}",
""
] | t <- tokenNames cf
]
showBasics = unlines
[
"void ShowAbsyn::visitInteger(Integer i)",
"{",
" char tmp[16];",
" sprintf(tmp, \"%d\", i);",
" bufAppend(tmp);",
"}",
"void ShowAbsyn::visitDouble(Double d)",
"{",
" char tmp[16];",
" sprintf(tmp, \"%g\", d);",
" bufAppend(tmp);",
"}",
"void ShowAbsyn::visitChar(Char c)",
"{",
" bufAppend('\\'');",
" bufAppend(c);",
" bufAppend('\\'');",
"}",
"void ShowAbsyn::visitString(String s)",
"{",
" bufAppend('\\\"');",
" bufAppend(s);",
" bufAppend('\\\"');",
"}",
"void ShowAbsyn::visitIdent(String s)",
"{",
" bufAppend('\\\"');",
" bufAppend(s);",
" bufAppend('\\\"');",
"}",
""
]
showTokens = unlines
[unlines [
"void ShowAbsyn::visit" ++ t ++ "(String s)",
"{",
" bufAppend('\\\"');",
" bufAppend(s);",
" bufAppend('\\\"');",
"}",
""
] | t <- tokenNames cf
]
{- **** Pretty Printer Methods **** -}
--Generates methods for the Pretty Printer
prPrintData :: Bool -> Maybe String -> CF -> (Cat, [Rule]) -> String
prPrintData True {- use STL -} _ _ (cat@(ListCat _), rules) =
render $ genPrintVisitorList (cat, rules)
prPrintData False {- use STL -} _ _ (cat@(ListCat _), rules) =
genPrintVisitorListNoStl (cat, rules)
prPrintData _ inPackage cf (cat, rules) = -- Not a list
-- a position token
if isPositionCat cf cat then unlines [
"void PrintAbsyn::visit" ++ show cat ++ "(" ++ show cat ++ "* p)",
"{",
" visitIdent(p->string_);",
"}"
]
else abstract ++ concatMap (prPrintRule inPackage) rules
where
cl = identCat (normCat cat)
abstract = case lookupRule (show cat) rules of
Just _ -> ""
Nothing -> "void PrintAbsyn::visit" ++ cl ++ "(" ++ cl ++ "*p) {} //abstract class\n\n"
-- | Generate pretty printer visitor for a list category:
--
-- >>> let c = Cat "C" ; lc = ListCat c
-- >>> let rules = [Rule "[]" lc [], Rule "(:)" lc [Left c, Right "-", Left lc]]
-- >>> genPrintVisitorList (lc, rules)
-- void PrintAbsyn::visitListC(ListC *listc)
-- {
-- for (ListC::const_iterator i = listc->begin() ; i != listc->end() ; ++i)
-- {
-- (*i)->accept(this);
-- render('-');
-- }
-- }
--
-- >>> let c2 = CoercCat "C" 2 ; lc2 = ListCat c2
-- >>> let rules2 = rules ++ [Rule "[]" lc2 [], Rule "(:)" lc2 [Left c2, Right "+", Left lc2]]
-- >>> genPrintVisitorList (lc, rules2)
-- void PrintAbsyn::visitListC(ListC *listc)
-- {
-- for (ListC::const_iterator i = listc->begin() ; i != listc->end() ; ++i)
-- {
-- (*i)->accept(this);
-- switch(_i_)
-- {
-- case 2: render('+'); break;
-- default: render('-');
-- }
-- }
-- }
genPrintVisitorList :: (Cat, [Rule]) -> Doc
genPrintVisitorList (cat@(ListCat c), rules) =
"void PrintAbsyn::visit" <> text cl <> "("<> text cl <> " *" <> vname <> ")"
$$ codeblock 2
[ "for ("<> text cl <> "::const_iterator i = " <> vname <> "->begin() ; i != " <> vname <> "->end() ; ++i)"
, codeblock 2
[ if isTokenCat c
then "visit" <> text (baseName cl) <> "(*i) ;"
else "(*i)->accept(this);"
, (if hasOneFunc rules
then "if (i != " <> vname <> "->end() - 1)"
else empty)
<+> renderListSepByPrecedence "_i_" renderSep separators
]
]
where
separators = getSeparatorByPrecedence rules
cl = identCat (normCat cat)
vname = text $ map toLower cl
renderSep s = "render(" <> text (snd (renderCharOrString s)) <> ")"
genPrintVisitorList _ = error "genPrintVisitorList expects a ListCat"
-- | This is the only part of the pretty printer that differs significantly
-- between the versions with and without STL.
genPrintVisitorListNoStl :: (Cat, [Rule]) -> String
genPrintVisitorListNoStl (cat@(ListCat c), rules) = unlines
[ "void PrintAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")"
, "{"
, " while(" ++ vname ++ "!= 0)"
, " {"
, " if (" ++ vname ++ "->" ++ vname ++ "_ == 0)"
, " {"
, visitMember
, optsep
, " " ++ vname +++ "= 0;"
, " }"
, " else"
, " {"
, visitMember
, render $ nest 6 $ renderListSepByPrecedence "_i_" renderSep separators
, " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;"
, " }"
, " }"
, "}"
, ""
]
where
visitMember = if isTokenCat c
then " visit" ++ funName c ++ "(" ++ vname ++ "->" ++ member ++ ");"
else " " ++ vname ++ "->" ++ member ++ "->accept(this);"
cl = identCat (normCat cat)
ecl = identCat (normCatOfList cat)
vname = map toLower cl
member = map toLower ecl ++ "_"
optsep = if hasOneFunc rules then "" else " render(" ++ sep ++ ");"
sep = snd (renderCharOrString sep')
sep' = getCons rules
renderSep s = "render(" <> text (snd (renderCharOrString s)) <> ")"
separators = getSeparatorByPrecedence rules
genPrintVisitorListNoStl _ = error "genPrintVisitorListNoStl expects a ListCat"
--Pretty Printer methods for a rule.
prPrintRule :: Maybe String -> Rule -> String
prPrintRule inPackage r@(Rule fun _ cats) | isProperLabel fun = unlines
[
"void PrintAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")",
"{",
" int oldi = _i_;",
lparen,
cats',
rparen,
" _i_ = oldi;",
"}\n"
]
where
p = precRule r
(lparen, rparen) =
(" if (oldi > " ++ show p ++ ") render(" ++ nsDefine inPackage "_L_PAREN" ++ ");\n",
" if (oldi > " ++ show p ++ ") render(" ++ nsDefine inPackage "_R_PAREN" ++ ");\n")
cats' = concatMap (prPrintCat fnm) (numVars cats)
fnm = "p" --old names could cause conflicts
prPrintRule _ _ = ""
--This goes on to recurse to the instance variables.
prPrintCat :: String -> Either (Cat, Doc) String -> String
prPrintCat _ (Right t) = " render(" ++ t' ++ ");\n"
where t' = snd (renderCharOrString t)
prPrintCat fnm (Left (c, nt))
| isTokenCat c = " visit" ++ funName c ++ "(" ++ fnm ++ "->" ++ render nt ++ ");\n"
| isList c = " if(" ++ fnm ++ "->" ++ render nt ++ ") {" ++ accept ++ "}"
| otherwise = " " ++ accept ++ "\n"
where
accept
| c == InternalCat = "/* Internal Category */\n"
| otherwise = setI (precCat c) ++ fnm ++ "->" ++ render nt ++ "->accept(this);"
{- **** Abstract Syntax Tree Printer **** -}
--This prints the functions for Abstract Syntax tree printing.
prShowData :: Bool -> (Cat, [Rule]) -> String
prShowData True (cat@(ListCat c), _) = unlines
[
"void ShowAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")",
"{",
" for ("++ cl ++"::const_iterator i = " ++
vname++"->begin() ; i != " ++vname ++"->end() ; ++i)",
" {",
if isTokenCat c
then " visit" ++ baseName cl ++ "(*i) ;"
else " (*i)->accept(this);",
" if (i != " ++ vname ++ "->end() - 1) bufAppend(\", \");",
" }",
"}",
""
]
where
cl = identCat (normCat cat)
vname = map toLower cl
prShowData False (cat@(ListCat c), _) =
unlines
[
"void ShowAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")",
"{",
" while(" ++ vname ++ "!= 0)",
" {",
" if (" ++ vname ++ "->" ++ vname ++ "_)",
" {",
visitMember,
" bufAppend(\", \");",
" " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;",
" }",
" else",
" {",
visitMember,
" " ++ vname ++ " = 0;",
" }",
" }",
"}",
""
]
where
cl = identCat (normCat cat)
ecl = identCat (normCatOfList cat)
vname = map toLower cl
member = map toLower ecl ++ "_"
visitMember = if isTokenCat c
then " visit" ++ funName c ++ "(" ++ vname ++ "->" ++ member ++ ");"
else " " ++ vname ++ "->" ++ member ++ "->accept(this);"
prShowData _ (cat, rules) = --Not a list:
abstract ++ concatMap prShowRule rules
where
cl = identCat (normCat cat)
abstract = case lookupRule (show cat) rules of
Just _ -> ""
Nothing -> "void ShowAbsyn::visit" ++ cl ++ "(" ++ cl ++ "* p) {} //abstract class\n\n"
--This prints all the methods for Abstract Syntax tree rules.
prShowRule :: Rule -> String
prShowRule (Rule fun _ cats) | isProperLabel fun = concat
[
"void ShowAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")\n",
"{\n",
lparen,
" bufAppend(\"" ++ fun ++ "\");\n",
optspace,
cats',
rparen,
"}\n"
]
where
(optspace, lparen, rparen) = if allTerms cats
then ("","","")
else (" bufAppend(' ');\n", " bufAppend('(');\n"," bufAppend(')');\n")
cats' = if allTerms cats
then ""
else concat (insertSpaces (map (prShowCat fnm) (numVars cats)))
insertSpaces [] = []
insertSpaces (x:[]) = [x]
insertSpaces (x:xs) = if x == ""
then insertSpaces xs
else x : " bufAppend(' ');\n" : insertSpaces xs
allTerms [] = True
allTerms (Left _:_) = False
allTerms (_:zs) = allTerms zs
fnm = "p" --other names could cause conflicts
prShowRule _ = ""
-- This recurses to the instance variables of a class.
prShowCat :: String -> Either (Cat, Doc) String -> String
prShowCat _ (Right _) = ""
prShowCat fnm (Left (cat,nt))
| isTokenCat cat =
" visit" ++ funName cat ++ "(" ++ fnm ++ "->" ++ render nt ++ ");\n"
| cat == InternalCat = "/* Internal Category */\n"
| show (normCat $ strToCat $ render nt) /= render nt = accept
| otherwise =
concat [
" bufAppend('[');\n",
" if (" ++ fnm ++ "->" ++ render nt ++ ")" ++ accept,
" bufAppend(']');\n"
]
where accept = " " ++ fnm ++ "->" ++ render nt ++ "->accept(this);\n"
{- **** Helper Functions Section **** -}
-- from ListIdent to Ident
baseName = drop 4
--The visit-function name of a basic type
funName :: Cat -> String
funName (TokenCat c) | c `elem` builtin = c
where builtin = ["Integer", "Char", "String", "Double", "Ident" ]
funName _ = "Ident" --User-defined type
--The visit-function name of a basic type
-- funName :: String -> String
-- funName v =
-- if "integer_" `isPrefixOf` v then "Integer"
-- else if "char_" `isPrefixOf` v then "Char"
-- else if "string_" `isPrefixOf` v then "String"
-- else if "double_" `isPrefixOf` v then "Double"
-- else if "ident_" `isPrefixOf` v then "Ident"
-- else "Ident" --User-defined type
--Just sets the coercion level for parentheses in the Pretty Printer.
setI :: Integer -> String
setI n = "_i_ = " ++ show n ++ "; "
--An extremely simple renderer for terminals.
prRender :: Bool -> String
prRender useStl = unlines
[
"//You may wish to change render",
"void PrintAbsyn::render(Char c)",
"{",
" if (c == '{')",
" {",
" bufAppend('\\n');",
" indent();",
" bufAppend(c);",
" _n_ = _n_ + INDENT_WIDTH;",
" bufAppend('\\n');",
" indent();",
" }",
" else if (c == '(' || c == '[')",
" bufAppend(c);",
" else if (c == ')' || c == ']')",
" {",
" backup();",
" bufAppend(c);",
" }",
" else if (c == '}')",
" {",
" int t;",
" _n_ = _n_ - INDENT_WIDTH;",
" for (t=0; t 0)"
, codeblock 2
[ "bufAppend(s);"
, "bufAppend(' ');" ] ]
in if useStl then render renderString else "",
"void PrintAbsyn::render(char* s)",
"{",
" if(strlen(s) > 0)",
" {",
" bufAppend(s);",
" bufAppend(' ');",
" }",
"}",
"void PrintAbsyn::indent()",
"{",
" int n = _n_;",
" while (n > 0)",
" {",
" bufAppend(' ');",
" n--;",
" }",
"}",
"void PrintAbsyn::backup()",
"{",
" if (buf_[cur_ - 1] == ' ')",
" {",
" buf_[cur_ - 1] = 0;",
" cur_--;",
" }",
"}"
]
BNFC-2.8.1/src/BNFC/Backend/CPP/NoSTL/0000755000000000000000000000000012654616013014633 5ustar0000000000000000BNFC-2.8.1/src/BNFC/Backend/CPP/NoSTL/RegToFlex.hs0000644000000000000000000000443512654616013017034 0ustar0000000000000000module BNFC.Backend.CPP.NoSTL.RegToFlex (printRegFlex) where
-- modified from pretty-printer generated by the BNF converter
import AbsBNF
-- the top-level printing method
printRegFlex :: Reg -> String
printRegFlex = render . prt 0
-- you may want to change render and parenth
render :: [String] -> String
render = rend (0::Int) where
rend i ss = case ss of
"[" :ts -> cons "[" $ rend i ts
"(" :ts -> cons "(" $ rend i ts
t : "," :ts -> cons t $ space "," $ rend i ts
t : ")" :ts -> cons t $ cons ")" $ rend i ts
t : "]" :ts -> cons t $ cons "]" $ rend i ts
t :ts -> space t $ rend i ts
_ -> ""
cons s t = s ++ t
space t s = if null s then t else t ++ s
parenth :: [String] -> [String]
parenth ss = ["("] ++ ss ++ [")"]
-- the printer class does the job
class Print a where
prt :: Int -> a -> [String]
prtList :: [a] -> [String]
prtList = concat . map (prt 0)
instance Print a => Print [a] where
prt _ = prtList
instance Print Char where
prt _ c = [[c]]
prtList s = map (concat . prt 0) s
prPrec :: Int -> Int -> [String] -> [String]
prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])
RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])
RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])
RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])
RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])
ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])
REps -> prPrec i 3 (["[^.]"])
RChar c -> prPrec i 3 (prt 0 [mkEsc [c]])
RAlts str -> prPrec i 3 (concat [["["], prt 0 $ mkEsc str, ["]"]])
RSeqs str -> prPrec i 2 (concat (map (prt 0) $ mkEsc str))
RDigit -> prPrec i 3 (concat [["{DIGIT}"]])
RLetter -> prPrec i 3 (concat [["{LETTER}"]])
RUpper -> prPrec i 3 (concat [["{CAPITAL}"]])
RLower -> prPrec i 3 (concat [["{SMALL}"]])
RAny -> prPrec i 3 (concat [["."]])
-- Handle special characters in regular expressions.
mkEsc :: String -> String
mkEsc = concatMap escChar
where
escChar c
| c `elem` ("$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" :: String) = '\\':[c]
| otherwise = [c]
BNFC-2.8.1/src/BNFC/Backend/CPP/NoSTL/CFtoCPPAbs.hs0000644000000000000000000003152412654616013017020 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-}
{-
BNF Converter: C++ abstract syntax generator
Copyright (C) 2004 Author: Michael Pellauer
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the C++ Abstract Syntax
tree classes. It generates both a Header file
and an Implementation file, and uses the Visitor
design pattern.
Author : Michael Pellauer (pellauer@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 4 August, 2003
Modified : 22 May, 2004 / Antti-Juhani Kaijanaho
**************************************************************
-}
module BNFC.Backend.CPP.NoSTL.CFtoCPPAbs (cf2CPPAbs) where
import BNFC.CF
import BNFC.Utils((+++),(++++))
import BNFC.Backend.Common.NamedVariables
import BNFC.Backend.Common.OOAbstract
import Data.List
import Data.Char(toLower)
import Text.PrettyPrint
--The result is two files (.H file, .C file)
cf2CPPAbs :: String -> CF -> (String, String)
cf2CPPAbs _ cf = (mkHFile cf, mkCFile cf)
{- **** Header (.H) File Functions **** -}
--Makes the Header file.
mkHFile :: CF -> String
mkHFile cf = unlines
[
"#ifndef ABSYN_HEADER",
"#define ABSYN_HEADER",
"",
header,
prTypeDefs user,
"/******************** Forward Declarations ********************/\n",
concatMap prForward classes,
"",
prVisitor classes,
prVisitable,
"",
"/******************** Abstract Syntax Classes ********************/\n",
concatMap (prDataH user) (getAbstractSyntax cf),
"",
"#endif"
]
where
user = fst (unzip (tokenPragmas cf))
header = "/* ~~~ C++ Abstract Syntax Interface generated by the BNF Converter.\n ~~~ */"
classes = allClasses (cf2cabs cf)
prForward s | isProperLabel s = "class " ++ s ++ ";\n"
prForward _ = ""
--Prints interface classes for all categories.
prDataH :: [UserDef] -> Data -> String
prDataH user (cat, rules) =
case lookup (show cat) rules of
Just _ -> concatMap (prRuleH user cat) rules
Nothing -> if isList cat
then concatMap (prRuleH user cat) rules
else unlines
[
"class" +++ (identCat cat) +++ ": public Visitable {",
"public:",
" virtual" +++ (identCat cat) +++ "*clone() const = 0;",
"};\n",
concatMap (prRuleH user cat) rules
]
--Interface definitions for rules vary on the type of rule.
prRuleH :: [UserDef] -> Cat -> (Fun, [Cat]) -> String
prRuleH user c (fun, cats) =
if isNilFun fun || isOneFun fun
then "" --these are not represented in the AbSyn
else if isConsFun fun
then --this is the linked list case.
unlines
[
"class" +++ c' +++ ": public Visitable",
"{",
" public:",
render $ nest 2 $ prInstVars user vs,
" " ++ c' ++ "(const" +++ c' +++ "&);",
" " ++ c' ++ " &operator=(const" +++ c' +++ "&);",
" " ++ c' ++ "(" ++ (prConstructorH 1 vs) ++ ");",
" " ++ c' ++ "(" ++ mem +++ memstar ++ "p);",
prDestructorH c',
" " ++ c' ++ "* reverse();",
" " ++ c' ++ "* reverse(" ++ c' ++ " *l);",
" virtual void accept(Visitor *v);",
" virtual " ++ c' ++ " *clone() const;",
" void swap(" ++ c' +++ "&);",
"};"
]
else --a standard rule
unlines
[
"class" +++ fun +++ ": public" +++ super,
"{",
" public:",
render $ nest 2 $ prInstVars user vs,
" " ++ fun ++ "(const" +++ fun +++ "&);",
" " ++ fun ++ " &operator=(const" +++ fun +++ "&);",
" " ++ fun ++ "(" ++ (prConstructorH 1 vs) ++ ");",
prDestructorH fun,
" virtual void accept(Visitor *v);",
" virtual " +++ fun +++ " *clone() const;",
" void swap(" ++ fun +++ "&);",
"};\n"
]
where
vs = getVars cats
c' = identCat (normCat c);
mem = drop 4 c'
memstar = if isBasic user mem then "" else "*"
super = if show c == fun then "Visitable" else (identCat c)
prConstructorH :: Int -> [(String, b)] -> String
prConstructorH _ [] = ""
prConstructorH n ((t,_):[]) = t +++ (optstar t) ++ "p" ++ (show n)
prConstructorH n ((t,_):vs) =( t +++ (optstar t) ++ "p" ++ (show n) ++ ", ") ++ (prConstructorH (n+1) vs)
prDestructorH n = " ~" ++ n ++ "();"
optstar x = if isBasic user x
then ""
else "*"
prVisitable :: String
prVisitable = unlines
[
"class Visitable",
"{",
" public:",
-- all classes with virtual methods require a virtual destructor
" virtual ~Visitable() {}",
" virtual void accept(Visitor *v) = 0;",
"};\n"
]
prVisitor :: [String] -> String
prVisitor fs = unlines
[
"/******************** Visitor Interfaces ********************/",
"",
"class Visitor",
"{",
" public:",
" virtual ~Visitor() {}",
(concatMap (prVisitFun) fs),
footer
]
where
footer = unlines
[ --later only include used categories
" virtual void visitInteger(Integer i) = 0;",
" virtual void visitDouble(Double d) = 0;",
" virtual void visitChar(Char c) = 0;",
" virtual void visitString(String s) = 0;",
"};"
]
prVisitFun f | isProperLabel f =
" virtual void visit" ++ f ++ "(" ++ f ++ " *p) = 0;\n"
prVisitFun _ = ""
--typedefs in the Header make generation much nicer.
prTypeDefs user = unlines
[
"/******************** TypeDef Section ********************/",
"typedef int Integer;",
"typedef char Char;",
"typedef double Double;",
"typedef char* String;",
"typedef char* Ident;",
concatMap prUserDef user
]
where
prUserDef s = "typedef char* " ++ show s ++ ";\n"
-- | A class's instance variables.
-- >>> prInstVars [Cat "MyTokn"] [("MyTokn",1), ("A",1), ("A",2)]
-- MyTokn mytokn_1;
-- A *a_1, *a_2;
prInstVars :: [UserDef] -> [IVar] -> Doc
prInstVars _ [] = empty
prInstVars user vars@((t,_):_) =
text t <+> uniques <> ";" $$ prInstVars user vs'
where
(uniques, vs') = prUniques t
--these functions group the types together nicely
prUniques :: String -> (Doc, [IVar])
prUniques t = (prVars (findIndices (\(y,_) -> y == t) vars), remType t vars)
prVars = hsep . punctuate comma . map prVar
prVar x = let (t,n) = vars !! x in varLinkName t <> text (showNum n)
varLinkName z = if isBasic user z
then text (map toLower z) <> "_"
else "*" <> text (map toLower z) <> "_"
remType :: String -> [IVar] -> [IVar]
remType _ [] = []
remType t ((t2,n):ts) = if t == t2
then (remType t ts)
else (t2,n) : (remType t ts)
{- **** Implementation (.C) File Functions **** -}
--Makes the .C file
mkCFile :: CF -> String
mkCFile cf = unlines
[
header,
concatMap (prDataC user) (getAbstractSyntax cf)
]
where
user = fst (unzip (tokenPragmas cf))
header = unlines
[
"//C++ Abstract Syntax Implementation generated by the BNF Converter.",
"#include ",
"#include \"Absyn.H\""
]
--This is not represented in the implementation.
prDataC :: [UserDef] -> Data -> String
prDataC user (cat, rules) = concatMap (prRuleC user cat) rules
--Classes for rules vary based on the type of rule.
prRuleC user c (fun, cats) =
if isNilFun fun || isOneFun fun
then "" --these are not represented in the AbSyn
else if isConsFun fun
then --this is the linked list case.
unlines
[
"/******************** " ++ c' ++ " ********************/",
render $ prConstructorC user c' vs cats,
prCopyC user c' vs,
prDestructorC user c' vs,
prListFuncs user c',
prAcceptC c',
prCloneC user c' vs,
""
]
else --a standard rule
unlines
[
"/******************** " ++ fun ++ " ********************/",
render $ prConstructorC user fun vs cats,
prCopyC user fun vs,
prDestructorC user fun vs,
prAcceptC fun,
prCloneC user fun vs,
""
]
where
vs = getVars cats
c' = identCat (normCat c)
--These are all built-in list functions.
--Later we could include things like lookup,insert,delete,etc.
prListFuncs :: [UserDef] -> String -> String
prListFuncs user c = unlines
[
c ++ "::" ++ c ++ "(" ++ m +++ mstar ++ "p)",
"{",
" " ++ m' ++ " = p;",
" " ++ v ++ "= 0;",
"}",
c ++ "*" +++ c ++ "::" ++ "reverse()",
"{",
" if (" ++ v +++ "== 0) return this;",
" else",
" {",
" " ++ c ++ " *tmp =" +++ v ++ "->reverse(this);",
" " ++ v +++ "= 0;",
" return tmp;",
" }",
"}",
"",
c ++ "*" +++ c ++ "::" ++ "reverse(" ++ c ++ "* prev)",
"{",
" if (" ++ v +++ "== 0)",
" {",
" " ++ v +++ "= prev;",
" return this;",
" }",
" else",
" {",
" " ++ c +++ "*tmp =" +++ v ++ "->reverse(this);",
" " ++ v +++ "= prev;",
" return tmp;",
" }",
"}"
]
where
v = (map toLower c) ++ "_"
m = drop 4 c
mstar = if isBasic user m then "" else "*"
m' = drop 4 v
--The standard accept function for the Visitor pattern
prAcceptC :: String -> String
prAcceptC ty =
"\nvoid " ++ ty ++ "::accept(Visitor *v) { v->visit" ++ ty ++ "(this); }"
-- | The constructor just assigns the parameters to the corresponding instance
-- variables.
-- >>> prConstructorC [Cat "Integer"] "bla" [("A",1), ("Integer",1), ("A",2)] [Cat "A", Cat "Integer", Cat "A"]
-- bla::bla(A *p1, Integer p2, A *p3) { a_1 = p1; integer_ = p2; a_2 = p3; }
prConstructorC :: [UserDef] -> String -> [IVar] -> [Cat] -> Doc
prConstructorC user c vs cats =
text c <> "::" <> text c <> parens (args)
<+> "{" <+> text (prAssigns vs params) <> "}"
where
(types, params) = unzip (prParams cats (length cats) (length cats+1))
args = hsep $ punctuate "," $ zipWith prArg types params
prArg type_ name
| isBasic user type_ = text type_ <+> text name
| otherwise = text type_ <+> "*" <> text name
--Print copy constructor and copy assignment
prCopyC :: [UserDef] -> String -> [IVar] -> String
prCopyC user c vs =
c ++ "::" ++ c ++ "(const" +++ c +++ "& other) {" +++
concatMap doV vs ++++
"}" ++++
c +++ "&" ++ c ++ "::" ++ "operator=(const" +++ c +++ "& other) {" ++++
" " ++ c +++ "tmp(other);" ++++
" swap(tmp);" ++++
" return *this;" ++++
"}" ++++
"void" +++ c ++ "::swap(" ++ c +++ "& other) {" ++++
concatMap swapV vs ++++
"}\n"
where doV :: IVar -> String
doV v@(t, _)
| isBasic user t = " " ++ vn v ++ " = other." ++ vn v ++ ";\n"
| otherwise = " " ++ vn v ++ " = other." ++ vn v ++ "->clone();\n"
vn :: IVar -> String
vn (t, 0) = varName t
vn (t, n) = varName t ++ show n
swapV :: IVar -> String
swapV v = " std::swap(" ++ vn v ++ ", other." ++ vn v ++ ");\n"
--The cloner makes a new deep copy of the object
prCloneC :: [UserDef] -> String -> [IVar] -> String
prCloneC _ c _ =
c +++ "*" ++ c ++ "::clone() const {" ++++
" return new" +++ c ++ "(*this);\n}"
--The destructor deletes all a class's members.
prDestructorC :: [UserDef] -> String -> [IVar] -> String
prDestructorC user c vs =
c ++ "::~" ++ c ++"()" +++ "{" +++
(concatMap prDeletes vs) ++ "}"
where
prDeletes :: (String, Int) -> String
prDeletes (t, n) = if isBasic user t
then ""
else if n == 0
then "delete(" ++ (varName t) ++ "); "
else "delete(" ++ (varName t) ++ (show n) ++ "); "
--Prints the constructor's parameters.
prParams :: [Cat] -> Int -> Int -> [(String,String)]
prParams [] _ _ = []
prParams (c:cs) n m = (identCat c,"p" ++ (show (m-n)))
: (prParams cs (n-1) m)
--Prints the assignments of parameters to instance variables.
--This algorithm peeks ahead in the list so we don't use map or fold
prAssigns :: [IVar] -> [String] -> String
prAssigns [] _ = []
prAssigns _ [] = []
prAssigns ((t,n):vs) (p:ps) =
if n == 1 then
case findIndices (\(l,_) -> l == t) vs of
[] -> varName t +++ "=" +++ p ++ ";" +++ prAssigns vs ps
_ -> varName t ++ showNum n +++ "=" +++ p ++ ";" +++ prAssigns vs ps
else varName t ++ showNum n +++ "=" +++ p ++ ";" +++ prAssigns vs ps
{- **** Helper Functions **** -}
--Checks if something is a basic or user-defined type.
isBasic :: [UserDef] -> String -> Bool
isBasic user x =
if elem x (map show user)
then True
else case x of
"Integer" -> True
"Char" -> True
"String" -> True
"Double" -> True
"Ident" -> True
_ -> False
BNFC-2.8.1/src/BNFC/Backend/CPP/NoSTL/CFtoBison.hs0000644000000000000000000002473612654616013017031 0ustar0000000000000000{-
BNF Converter: Bison generator
Copyright (C) 2004 Author: Michael Pellauer
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
BNF Converter: C++ Bison generator
Copyright (C) 2004 Author: Michael Pellauer
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the Bison input file.
Note that because of the way bison stores results
the programmer can increase performance by limiting
the number of entry points in their grammar.
Author : Michael Pellauer (pellauer@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 6 August, 2003
Modified : 6 August, 2003
**************************************************************
-}
module BNFC.Backend.CPP.NoSTL.CFtoBison (cf2Bison) where
import BNFC.CF
import Data.List (intersperse)
import BNFC.Backend.Common.NamedVariables hiding (varName)
import BNFC.Backend.CPP.STL.CFtoBisonSTL (union)
import Data.Char (toLower,isUpper)
import BNFC.Utils ((+++))
import BNFC.TypeChecker
import ErrM
import BNFC.Backend.C.CFtoBisonC (startSymbol)
import BNFC.PrettyPrint
--This follows the basic structure of CFtoHappy.
-- Type declarations
type Rules = [(NonTerminal,[(Pattern,Action)])]
type Pattern = String
type Action = String
type MetaVar = String
--The environment comes from the CFtoFlex
cf2Bison :: String -> CF -> SymEnv -> String
cf2Bison name cf env
= unlines
[header name cf,
render $ union Nothing (allCats cf),
"%token _ERROR_",
tokens user env,
declarations cf,
startSymbol cf,
specialToks cf,
"%%",
prRules (rulesForBison name cf env)
]
where
user = fst (unzip (tokenPragmas cf))
header :: String -> CF -> String
header name cf = unlines
["/* This Bison file was machine-generated by BNFC */",
"%{",
"#include ",
"#include ",
"#include ",
"#include ",
"#include \"Absyn.H\"",
"int yyparse(void);",
"int yylex(void);",
"int yy_mylinenumber;", --- hack to get line number. AR 2006
"int initialize_lexer(FILE * inp);",
"int yywrap(void)",
"{",
" return 1;",
"}",
"void yyerror(const char *str)",
"{",
" extern char *yytext;",
" fprintf(stderr,\"error: line %d: %s at %s\\n\", ",
" yy_mylinenumber + 1, str, yytext);",
"}",
"",
definedRules cf,
unlines $ map (parseMethod name) (allCatsNorm cf), -- (allEntryPoints cf), M.F. 2004-09-14 fix of [Ty2] bug.
concatMap reverseList (filter isList (allCatsNorm cf)),
"%}"
]
definedRules :: CF -> String
definedRules cf =
unlines [ rule f xs e | FunDef f xs e <- pragmasOfCF cf]
where
ctx = buildContext cf
list = LC (const "[]") (\t -> "List" ++ unBase t)
where
unBase (ListT t) = unBase t
unBase (BaseT x) = show$normCat$strToCat x
rule f xs e =
case checkDefinition' list ctx f xs e of
Bad err -> error $ "Panic! This should have been caught already:\n" ++ err
Ok (args,(e',t)) -> unlines
[ cppType t ++ " " ++ f ++ "_ (" ++
concat (intersperse ", " $ map cppArg args) ++ ") {"
, " return " ++ cppExp e' ++ ";"
, "}"
]
where
cppType :: Base -> String
cppType (ListT (BaseT x)) = "List" ++ show (normCat (strToCat x)) ++ " *"
cppType (ListT t) = cppType t ++ " *"
cppType (BaseT x)
| isToken x ctx = "String"
| otherwise = show (normCat (strToCat x)) ++ " *"
cppArg :: (String, Base) -> String
cppArg (x,t) = cppType t ++ " " ++ x ++ "_"
cppExp :: Exp -> String
cppExp (App "[]" []) = "0"
cppExp (App x [])
| elem x xs = x ++ "_" -- argument
cppExp (App t [e])
| isToken t ctx = cppExp e
cppExp (App x es)
| isUpper (head x) = call ("new " ++ x) es
| otherwise = call (x ++ "_") es
cppExp (LitInt n) = show n
cppExp (LitDouble x) = show x
cppExp (LitChar c) = show c
cppExp (LitString s) = show s
call x es = x ++ "(" ++ concat (intersperse ", " $ map cppExp es) ++ ")"
--This generates a parser method for each entry point.
parseMethod :: String -> Cat -> String
parseMethod _ cat =
-- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm
-- then ""
-- else
unlines
[
cat' ++ "*" +++ (resultName cat') +++ "= 0;",
cat' ++"* p" ++ cat' ++ "(FILE *inp)",
"{",
" initialize_lexer(inp);",
" if (yyparse())",
" { /* Failure */",
" return 0;",
" }",
" else",
" { /* Success */",
" return" +++ (resultName cat') ++ ";",
" }",
"}"
]
where
cat' = identCat (normCat cat)
--This method generates list reversal functions for each list type.
reverseList :: Cat -> String
reverseList c = unlines
[
c' ++ "* reverse" ++ c' ++ "(" ++ c' +++ "*l)",
"{",
" " ++ c' +++"*prev = 0;",
" " ++ c' +++"*tmp = 0;",
" while (l)",
" {",
" tmp = l->" ++ v ++ ";",
" l->" ++ v +++ "= prev;",
" prev = l;",
" l = tmp;",
" }",
" return prev;",
"}"
]
where
c' = identCat (normCat c)
v = (map toLower c') ++ "_"
--declares non-terminal types.
declarations :: CF -> String
declarations cf = concatMap (typeNT cf) (allCats cf)
where --don't define internal rules
typeNT cf nt | rulesForCat cf nt /= [] = "%type <" ++ varName nt ++ "> " ++ identCat nt ++ "\n"
typeNT _ _ = ""
--declares terminal types.
tokens :: [UserDef] -> SymEnv -> String
tokens user ts = concatMap (declTok user) ts
where
declTok u (s,r) = if elem s (map show u)
then "%token " ++ r ++ " // " ++ s ++ "\n"
else "%token " ++ r ++ " // " ++ s ++ "\n"
specialToks :: CF -> String
specialToks cf = concat [
ifC catString "%token _STRING_\n",
ifC catChar "%token _CHAR_\n",
ifC catInteger "%token _INTEGER_\n",
ifC catDouble "%token _DOUBLE_\n",
ifC catIdent "%token _IDENT_\n"
]
where
ifC cat s = if isUsedCat cf cat then s else ""
--The following functions are a (relatively) straightforward translation
--of the ones in CFtoHappy.hs
rulesForBison :: String -> CF -> SymEnv -> Rules
rulesForBison _ cf env = map mkOne $ ruleGroups cf where
mkOne (cat,rules) = constructRule cf env rules cat
-- For every non-terminal, we construct a set of rules.
constructRule :: CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])
constructRule cf env rules nt = (nt,[(p,(generateAction (ruleName r) b m) +++ result) |
r0 <- rules,
let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs
then (True,revSepListRule r0)
else (False,r0),
let (p,m) = generatePatterns cf env r])
where
ruleName r = case funRule r of
"(:)" -> identCat (normCat nt)
"(:[])" -> identCat (normCat nt)
z -> z
revs = reversibleCats cf
eps = allEntryPoints cf
isEntry nt = if elem nt eps then True else False
result = if isEntry nt then (resultName (identCat (normCat nt))) ++ "= $$;" else ""
-- Generates a string containing the semantic action.
generateAction :: Fun -> Bool -> [MetaVar] -> Action
generateAction f b ms =
if isCoercion f
then (unwords ms) ++ ";"
else if f == "[]"
then "0;"
else if isDefinedRule f
then concat [ f, "_", "(", concat $ intersperse ", " ms', ");" ]
else concat ["new ", f, "(", (concat (intersperse ", " ms')), ");"]
where
ms' = if b then reverse ms else ms
-- Generate patterns and a set of metavariables indicating
-- where in the pattern the non-terminal
generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar])
generatePatterns cf env r = case rhsRule r of
[] -> ("/* empty */",[])
its -> (unwords (map mkIt its), metas its)
where
mkIt i = case i of
Left c -> case lookup (show c) env of
Just x -> x
Nothing -> typeName (identCat c)
Right s -> case lookup s env of
Just x -> x
Nothing -> s
metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 :: Int ..] its]
revIf c m = if (not (isConsFun (funRule r)) && elem c revs)
then ("reverse" ++ (identCat (normCat c)) ++ "(" ++ m ++ ")")
else m -- no reversal in the left-recursive Cons rule itself
revs = reversibleCats cf
-- We have now constructed the patterns and actions,
-- so the only thing left is to merge them into one string.
prRules :: Rules -> String
prRules [] = []
prRules ((_, []):rs) = prRules rs --internal rule
prRules ((nt,((p,a):ls)):rs) =
(unwords [nt', ":" , p, "{ $$ =", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs
where
nt' = identCat nt
pr [] = []
pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ $$ =", a , "}"])]) ++ pr ls
--Some helper functions.
resultName :: String -> String
resultName s = "YY_RESULT_" ++ s ++ "_"
--slightly stronger than the NamedVariable version.
varName :: Cat -> String
varName = (++ "_") . map toLower . identCat . normCat
typeName :: String -> String
typeName "Ident" = "_IDENT_"
typeName "String" = "_STRING_"
typeName "Char" = "_CHAR_"
typeName "Integer" = "_INTEGER_"
typeName "Double" = "_DOUBLE_"
typeName x = x
BNFC-2.8.1/src/BNFC/Backend/CPP/NoSTL/CFtoFlex.hs0000644000000000000000000001646712654616013016657 0ustar0000000000000000{-
BNF Converter: Flex generator
Copyright (C) 2004 Author: Michael Pellauer
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the Flex file. It is
similar to JLex but with a few peculiarities.
Author : Michael Pellauer (pellauer@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 5 August, 2003
Modified : 22 August, 2006 by Aarne Ranta
**************************************************************
-}
module BNFC.Backend.CPP.NoSTL.CFtoFlex (cf2flex) where
import BNFC.CF
import BNFC.Backend.CPP.NoSTL.RegToFlex
import BNFC.Backend.Common.NamedVariables
import BNFC.Backend.CPP.STL.STLUtils
--The environment must be returned for the parser to use.
cf2flex :: Maybe String -> String -> CF -> (String, SymEnv)
cf2flex inPackage name cf = (unlines
[
prelude inPackage name,
cMacros,
lexSymbols env,
restOfFlex inPackage cf env'
], env')
where
env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int)
env' = env ++ (makeSymEnv (tokenNames cf) (length env))
makeSymEnv [] _ = []
makeSymEnv (s:symbs) n = (s, nsDefine inPackage "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1))
prelude :: Maybe String -> String -> String
prelude inPackage _ = unlines
[
maybe "" (\ns -> "%option prefix=\"" ++ ns ++ "yy\"") inPackage,
"/* This FLex file was machine-generated by the BNF converter */",
"%{",
"#include ",
"#include \"Parser.H\"",
"#define YY_BUFFER_LENGTH 4096",
"extern int " ++ nsString inPackage ++ "yy_mylinenumber ;", --- hack to get line number. AR 2006
"static char YY_PARSED_STRING[YY_BUFFER_LENGTH];",
"static void YY_BUFFER_APPEND(char *s)",
"{",
" strcat(YY_PARSED_STRING, s); //Do something better here!",
"}",
"static void YY_BUFFER_RESET(void)",
"{",
" for(int x = 0; x < YY_BUFFER_LENGTH; x++)",
" YY_PARSED_STRING[x] = 0;",
"}",
"",
"%}"
]
--For now all categories are included.
--Optimally only the ones that are used should be generated.
cMacros :: String
cMacros = unlines
[
"LETTER [a-zA-Z]",
"CAPITAL [A-Z]",
"SMALL [a-z]",
"DIGIT [0-9]",
"IDENT [a-zA-Z0-9'_]",
"%START YYINITIAL COMMENT CHAR CHARESC CHAREND STRING ESCAPED",
"%%"
]
lexSymbols :: SymEnv -> String
lexSymbols ss = concatMap transSym ss
where
transSym (s,r) =
"\"" ++ s' ++ "\" \t return " ++ r ++ ";\n"
where
s' = escapeChars s
restOfFlex :: Maybe String -> CF -> SymEnv -> String
restOfFlex inPackage cf env = concat
[
lexComments inPackage (comments cf),
userDefTokens,
ifC catString strStates,
ifC catChar chStates,
ifC catDouble ("{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t " ++ ns ++ "yylval.double_ = atof(yytext); return " ++ nsDefine inPackage "_DOUBLE_" ++ ";\n"),
ifC catInteger ("{DIGIT}+ \t " ++ ns ++ "yylval.int_ = atoi(yytext); return " ++ nsDefine inPackage "_INTEGER_" ++ ";\n"),
ifC catIdent ("{LETTER}{IDENT}* \t " ++ ns ++ "yylval.string_ = strdup(yytext); return " ++ nsDefine inPackage "_IDENT_" ++ ";\n"),
"\\n ++" ++ ns ++ "yy_mylinenumber ;\n",
"[ \\t\\r\\n\\f] \t /* ignore white space. */;\n",
". \t return " ++ nsDefine inPackage "_ERROR_" ++ ";\n",
"%%\n",
footer
]
where
ifC cat s = if isUsedCat cf cat then s else ""
ns = nsString inPackage
userDefTokens = unlines $
["" ++ printRegFlex exp ++
" \t " ++ ns ++ "yylval.string_ = strdup(yytext); return " ++ sName name ++ ";"
| (name, exp) <- tokenPragmas cf]
where
sName n = case lookup (show n) env of
Just x -> x
Nothing -> (show n)
strStates = unlines --These handle escaped characters in Strings.
[
"\"\\\"\" \t BEGIN STRING;",
"\\\\ \t BEGIN ESCAPED;",
"\\\" \t " ++ ns ++ "yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return " ++ nsDefine inPackage "_STRING_" ++ ";",
". \t YY_BUFFER_APPEND(yytext);",
"n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;",
"\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;",
"\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;",
"t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;",
". \t YY_BUFFER_APPEND(yytext); BEGIN STRING;"
]
chStates = unlines --These handle escaped characters in Chars.
[
"\"'\" \tBEGIN CHAR;",
"\\\\ \t BEGIN CHARESC;",
"[^'] \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";",
"n \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\n'; return " ++ nsDefine inPackage "_CHAR_" ++ ";",
"t \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\t'; return " ++ nsDefine inPackage "_CHAR_" ++ ";",
". \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";",
"\"'\" \t BEGIN YYINITIAL;"
]
footer = unlines
[
"int " ++ ns ++ "initialize_lexer(FILE *inp) { yyrestart(inp); BEGIN YYINITIAL; }",
"int yywrap(void) { return 1; }"
]
lexComments :: Maybe String -> ([(String, String)], [String]) -> String
lexComments inPackage (m,s) =
(unlines (map (lexSingleComment inPackage) s))
++ (unlines (map (lexMultiComment inPackage) m))
lexSingleComment :: Maybe String -> String -> String
lexSingleComment inPackage c =
"\"" ++ c ++ "\"[^\\n]*\\n ++" ++ nsString inPackage ++ "yy_mylinenumber ; \t /* BNFC single-line comment */;"
--There might be a possible bug here if a language includes 2 multi-line comments.
--They could possibly start a comment with one character and end it with another.
--However this seems rare.
lexMultiComment :: Maybe String -> (String, String) -> String
lexMultiComment inPackage (b,e) = unlines [
"\"" ++ b ++ "\" \t BEGIN COMMENT;",
"\"" ++ e ++ "\" \t BEGIN YYINITIAL;",
". \t /* BNFC multi-line comment */;",
"[\\n] ++" ++ nsString inPackage ++ "yy_mylinenumber ; \t /* BNFC multi-line comment */;"
---- "\\n ++yy_mylinenumber ;"
]
--Helper function that escapes characters in strings
escapeChars :: String -> String
escapeChars [] = []
escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))
escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))
escapeChars (x:xs) = x : (escapeChars xs)
BNFC-2.8.1/src/BNFC/Backend/CPP/NoSTL/CFtoCVisitSkel.hs0000644000000000000000000002014112654616013017761 0ustar0000000000000000{-
BNF Converter: C++ Skeleton generation
Copyright (C) 2004 Author: Michael Pellauer
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the C++ Skeleton functions.
The generated files use the Visitor design pattern.
Author : Michael Pellauer (pellauer@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 9 August, 2003
Modified : 12 August, 2003
**************************************************************
-}
module BNFC.Backend.CPP.NoSTL.CFtoCVisitSkel (cf2CVisitSkel) where
import BNFC.CF
import BNFC.Utils ((+++))
import BNFC.Backend.Common.NamedVariables
import BNFC.Backend.Utils (isTokenType)
import Data.List
import Data.Char(toLower, toUpper)
import Data.Either (lefts)
import BNFC.PrettyPrint
--Produces (.H file, .C file)
cf2CVisitSkel :: CF -> (String, String)
cf2CVisitSkel cf = (mkHFile cf groups, mkCFile cf groups)
where
groups = fixCoercions (ruleGroups cf)
{- **** Header (.H) File Functions **** -}
--Generates the Header File
mkHFile :: CF -> [(Cat,[Rule])] -> String
mkHFile cf groups = unlines
[
header,
concatMap prDataH groups,
concatMap (prUserH.show) user,
footer
]
where
user = fst (unzip (tokenPragmas cf))
header = unlines
[
"#ifndef SKELETON_HEADER",
"#define SKELETON_HEADER",
"/* You might want to change the above name. */",
"",
"#include \"Absyn.H\"",
"",
"class Skeleton : public Visitor",
"{",
" public:"
]
prUserH u = " void visit" ++ u' ++ "(" ++ u ++ " p);"
where
u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem.
footer = unlines
[
" void visitIdent(String s);",
" void visitInteger(Integer i);",
" void visitDouble(Double d);",
" void visitChar(Char c);",
" void visitString(String s);",
"};",
"",
"#endif"
]
--Prints out visit functions for a category
prDataH :: (Cat, [Rule]) -> String
prDataH (cat, rules) =
if "List" `isPrefixOf` identCat cat
then concat [" void visit", cl, "(", cl, "* ", vname, ");"]
else abstract ++ concatMap prRuleH rules
where
cl = identCat (normCat cat)
vname = map toLower cl
abstract = case lookupRule (show cat) rules of
Just _ -> ""
Nothing -> " void visit" ++ cl ++ "(" ++ cl ++ "*" +++ vname ++ "); /* abstract class */\n"
--Visit functions for a rule.
prRuleH :: Rule -> String
prRuleH (Rule fun _ _) | not (isCoercion fun) = concat
[" void visit", fun, "(", fun, "* ", fnm, ");\n"]
where
fnm = map toLower fun
prRuleH _ = ""
{- **** Implementation (.C) File Functions **** -}
--Makes the .C File
mkCFile :: CF -> [(Cat,[Rule])] -> String
mkCFile cf groups = concat
[
header,
concatMap (prData user) groups,
concatMap (prUser.show) user,
footer
]
where
user = fst (unzip (tokenPragmas cf))
header = unlines [
"/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/",
"/* This implements the common visitor design pattern.",
" Note that this method uses Visitor-traversal of lists, so",
" List->accept() does NOT traverse the list. This allows different",
" algorithms to use context information differently. */",
"",
"#include \"Skeleton.H\"",
""
]
prUser x = unlines
[
"void Skeleton::visit" ++ x' ++ "(" ++ x ++ " p)",
"{",
" /* Code for " ++ x ++ " Goes Here */",
"}"
]
where
x' = ((toUpper (head x)) : (map toLower (tail x))) --this is a hack to fix a potential capitalization problem.
footer = unlines
[
"void Skeleton::visitIdent(Ident i)",
"{",
" /* Code for Ident Goes Here */",
"}",
"void Skeleton::visitInteger(Integer i)",
"{",
" /* Code for Integers Goes Here */",
"}",
"void Skeleton::visitDouble(Double d)",
"{",
" /* Code for Doubles Goes Here */",
"}",
"void Skeleton::visitChar(Char c)",
"{",
" /* Code for Chars Goes Here */",
"}",
"void Skeleton::visitString(String s)",
"{",
" /* Code for Strings Goes Here */",
"}",
""
]
--Visit functions for a category.
prData :: [UserDef] -> (Cat, [Rule]) -> String
prData user (cat, rules) =
if "List" `isPrefixOf` (identCat cat)
then unlines
[
"void Skeleton::visit" ++ cl ++ "("++ cl ++ "*" +++ vname ++ ")",
"{",
" while(" ++ vname ++ "!= 0)",
" {",
" /* Code For " ++ cl ++ " Goes Here */",
visitMember,
" " ++ vname ++ " = " ++ vname ++ "->" ++ vname ++ "_;",
" }",
"}",
""
] --Not a list:
else abstract ++ (concatMap (render . prRule user) rules)
where
cl = identCat (normCat cat)
vname = map toLower cl
ecl = identCat (normCatOfList cat)
member = map toLower ecl ++ "_"
visitMember = if isBasic user member
then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");"
else " " ++ vname ++ "->" ++ member ++ "->accept(this);"
abstract = case lookupRule (show cat) rules of
Just _ -> ""
Nothing -> "void Skeleton::visit" ++ cl ++ "(" ++ cl ++ "*" +++ vname ++ ") {} //abstract class\n\n"
-- | Visits all the instance variables of a category.
-- >>> prRule [Cat "A"] (Rule "F" (Cat "S") [Right "X", Left (Cat "A"), Left (Cat "B")])
-- void Skeleton::visitF(F* f)
-- {
-- /* Code For F Goes Here */
--
-- visitA(f->a_);
-- f->b_->accept(this);
-- }
prRule :: [UserDef] -> Rule -> Doc
prRule user (Rule fun _ cats) | not (isCoercion fun) = vcat
[ text ("void Skeleton::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")")
, codeblock 2
[ text ("/* Code For " ++ fun ++ " Goes Here */")
, ""
, cats'
]
]
where
cats' = vcat (map (prCat user fnm) (lefts (numVars cats)))
fnm = map toLower fun
prRule _ _ = ""
-- | Prints the actual instance-variable visiting.
-- >>> prCat [] "Myfun" (Cat "Integer", "integer_")
-- visitInteger(Myfun->integer_);
-- >>> prCat [] "Myfun" (ListCat (Cat "A"), "lista_")
-- if (Myfun->lista_) {Myfun->lista_->accept(this);}
-- >>> prCat [] "Myfun" (Cat "A", "a_")
-- Myfun->a_->accept(this);
prCat :: [Cat] -> String -> (Cat, Doc) -> Doc
prCat user fnm (cat, nt)
| isTokenType user cat = "visit" <> text (funName (render nt)) <> parens (fname <> "->" <> nt) <> ";"
| isList cat = "if" <+> parens (fname <> "->" <> nt) <+> braces accept
| otherwise = accept
where accept = fname <> "->" <> nt <> "->accept(this);"
fname = text fnm
--Just checks if something is a basic or user-defined type.
--This is because you don't -> a basic non-pointer type.
isBasic :: [UserDef] -> String -> Bool
isBasic user v =
if elem (init v) user'
then True
else if "integer_" `isPrefixOf` v then True
else if "char_" `isPrefixOf` v then True
else if "string_" `isPrefixOf` v then True
else if "double_" `isPrefixOf` v then True
else if "ident_" `isPrefixOf` v then True
else False
where
user' = map (map toLower.show) user
--The visit-function name of a basic type
funName :: String -> String
funName v =
if "integer_" `isPrefixOf` v then "Integer"
else if "char_" `isPrefixOf` v then "Char"
else if "string_" `isPrefixOf` v then "String"
else if "double_" `isPrefixOf` v then "Double"
else if "ident_" `isPrefixOf` v then "Ident"
else (toUpper (head v)) : (init (tail v)) --User-defined type
BNFC-2.8.1/src/BNFC/Backend/CPP/STL/0000755000000000000000000000000012654616013014336 5ustar0000000000000000BNFC-2.8.1/src/BNFC/Backend/CPP/STL/STLUtils.hs0000644000000000000000000000243412654616013016360 0ustar0000000000000000{-
BNF Converter: C++ common functions
Copyright (C) 2008 Author: Martin Ejdestig
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.CPP.STL.STLUtils where
import Data.Char
import Data.Maybe (fromMaybe)
nsDefine :: Maybe String -> String -> String
nsDefine inPackage h = maybe h (\ns -> map toUpper ns ++ "_" ++ h) inPackage
nsStart :: Maybe String -> String
nsStart = maybe "" (\ns -> "namespace " ++ ns ++ "\n{")
nsEnd :: Maybe String -> String
nsEnd = maybe "" (const "}")
nsScope :: Maybe String -> String
nsScope = maybe "" (++ "::")
nsString :: Maybe String -> String
nsString = fromMaybe ""
BNFC-2.8.1/src/BNFC/Backend/CPP/STL/CFtoCVisitSkelSTL.hs0000644000000000000000000001024312654616013020051 0ustar0000000000000000{-
BNF Converter: C++ Skeleton generation
Copyright (C) 2004 Author: Michael Pellauer
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the C++ Skeleton functions.
The generated files use the Visitor design pattern.
Author : Michael Pellauer (pellauer@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 9 August, 2003
Modified : 29 August, 2006 Aarne Ranta
**************************************************************
-}
module BNFC.Backend.CPP.STL.CFtoCVisitSkelSTL (cf2CVisitSkel) where
import BNFC.CF
import BNFC.Utils ((+++))
import Data.Char(toLower)
import BNFC.Backend.Common.OOAbstract
import BNFC.Backend.CPP.STL.STLUtils
--Produces (.H file, .C file)
cf2CVisitSkel :: Maybe String -> CF -> (String, String)
cf2CVisitSkel inPackage cf = (mkHFile inPackage cab, mkCFile inPackage cab)
where
cab = cf2cabs cf
-- **** Header (.H) File Functions ****
--Generates the Header File
mkHFile :: Maybe String -> CAbs -> String
mkHFile inPackage cf = unlines [
"#ifndef " ++ hdef,
"#define " ++ hdef,
"/* You might want to change the above name. */",
"",
"#include \"Absyn.H\"",
"",
nsStart inPackage,
"class Skeleton : public Visitor",
"{",
"public:",
unlines [" void visit" ++ b ++ "(" ++ b ++ "* p);" |
b <- classes, notElem b (defineds cf)],
unlines [" void visit" ++ show b ++ "(" ++ show b ++ " x);" | b <- basics],
"};",
nsEnd inPackage,
"",
"#endif"
]
where
hdef = nsDefine inPackage "SKELETON_HEADER"
classes = allClasses cf
basics = tokentypes cf ++ map fst basetypes
-- **** Implementation (.C) File Functions ****
--Makes the .C File
mkCFile :: Maybe String -> CAbs -> String
mkCFile inPackage cf = unlines [
headerC,
nsStart inPackage,
unlines [
"void Skeleton::visit" ++ t ++ "(" ++
t ++ "* t) {} //abstract class" | t <- absclasses cf],
unlines [prCon r | (_,rs) <- signatures cf, r <- rs],
unlines [prList cb | cb <- listtypes cf],
unlines [prBasic b | b <- tokentypes cf ++ map fst basetypes],
nsEnd inPackage
]
headerC = unlines [
"/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/",
"/* This implements the common visitor design pattern.",
" Note that this method uses Visitor-traversal of lists, so",
" List->accept() does NOT traverse the list. This allows different",
" algorithms to use context information differently. */",
"",
"#include \"Skeleton.H\"",
""
]
prBasic c = unlines [
"void Skeleton::visit" ++ c ++ "(" ++ c ++ " x)",
"{",
" /* Code for " ++ c ++ " Goes Here */",
"}"
]
prList (cl,b) = unlines [
"void Skeleton::visit" ++ cl ++ "("++ cl ++ "*" +++ vname ++ ")",
"{",
" for ("++ cl ++"::iterator i = " ++
vname++"->begin() ; i != " ++vname ++"->end() ; ++i)",
" {",
if b
then " (*i)->accept(this);"
else " visit" ++ drop 4 cl ++ "(*i) ;",
" }",
"}"
]
where
vname = map toLower cl
prCon (f,cs) = unlines [
"void Skeleton::visit" ++ f ++ "(" ++ f ++ " *" ++ v ++ ")",
"{",
" /* Code For " ++ f ++ " Goes Here */",
"",
unlines [" " ++ visitArg c | c <- cs],
"}"
]
where
v = map toLower f
visitArg (cat,isPt,var) =
if isPt
then (v ++ "->" ++ var ++ "->accept(this);")
else ("visit" ++ cat ++ "(" ++ v ++ "->" ++ var ++ ");")
BNFC-2.8.1/src/BNFC/Backend/CPP/STL/CFtoBisonSTL.hs0000644000000000000000000003166412654616013017115 0ustar0000000000000000{-
BNF Converter: C++ Bison generator
Copyright (C) 2004 Author: Michael Pellauer
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the Bison input file using
STL. The main difference to CFtoBison is in handling
lists: by using std::vector and push_back, our rules
for reverting lists are the opposite to linked lists.
Note that because of the way bison stores results
the programmer can increase performance by limiting
the number of entry points in their grammar.
Author : Michael Pellauer (pellauer@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 6 August, 2003
Modified : 19 August, 2006, by Aarne Ranta (aarne@cs.chalmers.se)
**************************************************************
-}
module BNFC.Backend.CPP.STL.CFtoBisonSTL (cf2Bison, union) where
import BNFC.CF
import Data.List (intersperse, nub)
import BNFC.Backend.Common.NamedVariables hiding (varName)
import Data.Char (toLower,isUpper)
import BNFC.Utils ((+++))
import BNFC.TypeChecker
import ErrM
import BNFC.Backend.CPP.STL.STLUtils
import BNFC.Backend.C.CFtoBisonC (startSymbol)
import BNFC.PrettyPrint
--This follows the basic structure of CFtoHappy.
-- Type declarations
type Rules = [(NonTerminal,[(Pattern,Action)])]
type Pattern = String
type Action = String
type MetaVar = String
--The environment comes from the CFtoFlex
cf2Bison :: Bool -> Maybe String -> String -> CF -> SymEnv -> String
cf2Bison ln inPackage name cf env
= unlines
[header inPackage name cf,
render $ union inPackage (positionCats cf ++ allCats cf),
maybe "" (\ns -> "%name-prefix=\"" ++ ns ++ "yy\"") inPackage,
"%token _ERROR_",
tokens user env,
declarations cf,
startSymbol cf,
specialToks cf,
"%%",
prRules (rulesForBison ln inPackage name cf env)
]
where
user = fst (unzip (tokenPragmas cf))
positionCats cf = filter (isPositionCat cf) $ fst (unzip (tokenPragmas cf))
header :: Maybe String -> String -> CF -> String
header inPackage name cf = unlines
["/* This Bison file was machine-generated by BNFC */",
"%{",
"#include ",
"#include ",
"#include ",
"#include ",
"#include ",
"#include \"Absyn.H\"",
"typedef struct yy_buffer_state *YY_BUFFER_STATE;",
"int yyparse(void);",
"int yylex(void);",
"YY_BUFFER_STATE " ++ ns ++ "yy_scan_string(const char *str);",
"void " ++ ns ++ "yy_delete_buffer(YY_BUFFER_STATE buf);",
"int " ++ ns ++ "yy_mylinenumber;", --- hack to get line number. AR 2006
"int " ++ ns ++ "initialize_lexer(FILE * inp);",
"int " ++ ns ++ "yywrap(void)",
"{",
" return 1;",
"}",
"void " ++ ns ++ "yyerror(const char *str)",
"{",
" extern char *yytext;",
" fprintf(stderr,\"error: line %d: %s at %s\\n\", ",
" yy_mylinenumber, str, yytext);",
"}",
"",
definedRules cf,
nsStart inPackage,
unlines $ map (parseMethod inPackage name) (allCatsNorm cf ++ positionCats cf), -- (allEntryPoints cf), M.F. 2004-09-14 fix of [Ty2] bug.
nsEnd inPackage,
"%}"
]
where
ns = nsString inPackage
definedRules :: CF -> String
definedRules cf =
unlines [ rule f xs e | FunDef f xs e <- pragmasOfCF cf ]
where
ctx = buildContext cf
list = LC (const "[]") (\t -> "List" ++ unBase t)
where
unBase (ListT t) = unBase t
unBase (BaseT x) = show $ normCat $ strToCat x
rule f xs e =
case checkDefinition' list ctx f xs e of
Bad err -> error $ "Panic! This should have been caught already:\n" ++ err
Ok (args,(e',t)) -> unlines
[ cppType t ++ " " ++ f ++ "_ (" ++
concat (intersperse ", " $ map cppArg args) ++ ") {"
, " return " ++ cppExp e' ++ ";"
, "}"
]
where
cppType :: Base -> String
cppType (ListT (BaseT x)) = "List" ++ show (normCat $ strToCat x) ++ " *"
cppType (ListT t) = cppType t ++ " *"
cppType (BaseT x)
| isToken x ctx = "String"
| otherwise = (show $ normCat $ strToCat x) ++ " *"
cppArg :: (String, Base) -> String
cppArg (x,t) = cppType t ++ " " ++ x ++ "_"
cppExp :: Exp -> String
cppExp (App "[]" []) = "0"
cppExp (App x [])
| elem x xs = x ++ "_" -- argument
cppExp (App t [e])
| isToken t ctx = cppExp e
cppExp (App x es)
| isUpper (head x) = call ("new " ++ x) es
| otherwise = call (x ++ "_") es
cppExp (LitInt n) = show n
cppExp (LitDouble x) = show x
cppExp (LitChar c) = show c
cppExp (LitString s) = show s
call x es = x ++ "(" ++ concat (intersperse ", " $ map cppExp es) ++ ")"
--This generates a parser method for each entry point.
parseMethod :: Maybe String -> String -> Cat -> String
parseMethod inPackage _ cat =
-- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm
-- then ""
-- else
unlines
[
"static " ++ cat' ++ "*" +++ (resultName cat') +++ "= 0;",
cat' ++"* p" ++ cat' ++ "(FILE *inp)",
"{",
" " ++ ns ++ "yy_mylinenumber = 1;", -- O.F.
" " ++ ns ++ "initialize_lexer(inp);",
" if (yyparse())",
" { /* Failure */",
" return 0;",
" }",
" else",
" { /* Success */",
" return" +++ (resultName cat') ++ ";",
" }",
"}",
cat' ++"* p" ++ cat' ++ "(const char *str)",
"{",
" YY_BUFFER_STATE buf;",
" int result;",
" " ++ ns ++ "yy_mylinenumber = 1;",
" " ++ ns ++ "initialize_lexer(0);",
" buf = " ++ ns ++ "yy_scan_string(str);",
" result = yyparse();",
" " ++ ns ++ "yy_delete_buffer(buf);",
" if (result)",
" { /* Failure */",
" return 0;",
" }",
" else",
" { /* Success */",
" return" +++ (resultName cat') ++ ";",
" }",
"}"
]
where
cat' = identCat (normCat cat)
ns = nsString inPackage
-- | The union declaration is special to Bison/Yacc and gives the type of
-- yylval. For efficiency, we may want to only include used categories here.
--
-- >>> let foo = Cat "Foo"
-- >>> union Nothing [foo, ListCat foo]
-- %union
-- {
-- int int_;
-- char char_;
-- double double_;
-- char* string_;
-- Foo* foo_;
-- ListFoo* listfoo_;
-- }
--
-- If the given list of categories is contains coerced categories, those should
-- be normalized and duplicate removed
-- E.g. if there is both [Foo] and [Foo2] we should only print one pointer:
-- ListFoo* listfoo_;
--
-- >>> let foo2 = CoercCat "Foo" 2
-- >>> union Nothing [foo, ListCat foo, foo2, ListCat foo2]
-- %union
-- {
-- int int_;
-- char char_;
-- double double_;
-- char* string_;
-- Foo* foo_;
-- ListFoo* listfoo_;
-- }
union :: Maybe String -> [Cat] -> Doc
union inPackage cats =
"%union" $$ codeblock 2 (
[ "int int_;"
, "char char_;"
, "double double_;"
, "char* string_;" ]
++ map mkPointer normCats )
where
normCats = nub (map normCat cats)
mkPointer s = scope <> text (identCat s) <> "*" <+> text (varName s) <> ";"
scope = text (nsScope inPackage)
--declares non-terminal types.
declarations :: CF -> String
declarations cf = concatMap (typeNT cf) (positionCats cf ++ allCats cf)
where --don't define internal rules
typeNT cf nt | (isPositionCat cf nt || rulesForCat cf nt /= []) = "%type <" ++ (varName nt) ++ "> " ++ (identCat nt) ++ "\n"
typeNT _ _ = ""
--declares terminal types.
tokens :: [UserDef] -> SymEnv -> String
tokens user ts = concatMap (declTok user) ts
where
declTok u (s,r) = if elem s (map show u)
then "%token " ++ r ++ " // " ++ s ++ "\n"
else "%token " ++ r ++ " // " ++ s ++ "\n"
specialToks :: CF -> String
specialToks cf = concat [
ifC catString "%token _STRING_\n",
ifC catChar "%token _CHAR_\n",
ifC catInteger "%token _INTEGER_\n",
ifC catDouble "%token _DOUBLE_\n",
ifC catIdent "%token _IDENT_\n"
]
where
ifC cat s = if isUsedCat cf cat then s else ""
--The following functions are a (relatively) straightforward translation
--of the ones in CFtoHappy.hs
rulesForBison :: Bool -> Maybe String -> String -> CF -> SymEnv -> Rules
rulesForBison ln inPackage _ cf env = (map mkOne $ ruleGroups cf) ++ posRules where
mkOne (cat,rules) = constructRule ln inPackage cf env rules cat
posRules = map mkPos $ positionCats cf
mkPos cat = (cat, [(maybe (show cat) id (lookup (show cat) env),
"$$ = new " ++ show cat ++ "($1," ++ nsString inPackage ++ "yy_mylinenumber) ; YY_RESULT_" ++
show cat ++ "_= $$ ;")])
-- For every non-terminal, we construct a set of rules.
constructRule ::
Bool -> Maybe String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])
constructRule ln inPackage cf env rules nt =
(nt,[(p,(generateAction ln inPackage nt (ruleName r) b m) +++ result) |
r0 <- rules,
let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs
then (True,revSepListRule r0)
else (False,r0),
let (p,m) = generatePatterns cf env r b])
where
ruleName r = case funRule r of
---- "(:)" -> identCat nt
---- "(:[])" -> identCat nt
z -> z
revs = reversibleCats cf
eps = allEntryPoints cf
isEntry nt = if elem nt eps then True else False
result = if isEntry nt then (nsScope inPackage ++ resultName (identCat (normCat nt))) ++ "= $$;" else ""
-- Generates a string containing the semantic action.
generateAction :: Bool -> Maybe String -> NonTerminal -> Fun -> Bool -> [(MetaVar,Bool)] -> Action
generateAction ln inPackage cat f b mbs =
reverses ++
if isCoercion f
then "$$ = " ++ (unwords ms) ++ ";"
else if (f == "[]")
then concat ["$$ = ","new ", scope, identCatV cat, "();"]
else if (f == "(:[])")
then concat ["$$ = ","new ", scope, identCatV cat, "() ; $$->push_back($1);"]
else if (f == "(:)" && b)
then "$1->push_back("++ lastms ++ ") ; $$ = $1 ;"
else if (f == "(:)")
then lastms ++ "->push_back(" ++ head ms ++ ") ; $$ = " ++ lastms ++ " ;" ---- not left rec
else if isDefinedRule f
then concat ["$$ = ", scope, f, "_", "(", concat $ intersperse ", " ms, ");" ]
else concat
["$$ = ", "new ", scope, f, "(", (concat (intersperse ", " ms)), ");" ++ addLn ln]
where
ms = map fst mbs
lastms = last ms
addLn ln = if ln then " $$->line_number = " ++ nsString inPackage ++ "yy_mylinenumber;" else "" -- O.F.
identCatV = identCat . normCat
reverses = unwords [
"std::reverse(" ++ m ++"->begin(),"++m++"->end()) ;" |
(m,True) <- mbs]
scope = nsScope inPackage
-- Generate patterns and a set of metavariables indicating
-- where in the pattern the non-terminal
generatePatterns :: CF -> SymEnv -> Rule -> Bool -> (Pattern,[(MetaVar,Bool)])
generatePatterns cf env r _ = case rhsRule r of
[] -> ("/* empty */",[])
its -> (unwords (map mkIt its), metas its)
where
mkIt i = case i of
Left c -> case lookup (show c) env of
Just x | not (isPositionCat cf c) -> x
_ -> typeName (identCat c)
Right s -> case lookup s env of
Just x -> x
Nothing -> s
metas its = [('$': show i,revert c) | (i,Left c) <- zip [1 :: Int ..] its]
-- notice: reversibility with push_back vectors is the opposite
-- of right-recursive lists!
revert c = (isList c) &&
not (isConsFun (funRule r)) && notElem c revs
revs = reversibleCats cf
-- We have now constructed the patterns and actions,
-- so the only thing left is to merge them into one string.
prRules :: Rules -> String
prRules [] = []
prRules ((_, []):rs) = prRules rs --internal rule
prRules ((nt,((p,a):ls)):rs) =
(unwords [nt', ":" , p, "{ ", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs
where
nt' = identCat nt
pr [] = []
pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ ", a , "}"])]) ++ pr ls
--Some helper functions.
resultName :: String -> String
resultName s = "YY_RESULT_" ++ s ++ "_"
--slightly stronger than the NamedVariable version.
varName :: Cat -> String
varName = (++ "_") . map toLower . identCat . normCat
typeName :: String -> String
typeName "Ident" = "_IDENT_"
typeName "String" = "_STRING_"
typeName "Char" = "_CHAR_"
typeName "Integer" = "_INTEGER_"
typeName "Double" = "_DOUBLE_"
typeName x = x
BNFC-2.8.1/src/BNFC/Backend/CPP/STL/CFtoSTLAbs.hs0000644000000000000000000001655712654616013016554 0ustar0000000000000000{-
BNF Converter: C++ abstract syntax generator
Copyright (C) 2004 Author: Michael Pellauer
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the C++ Abstract Syntax
tree classes. It generates both a Header file
and an Implementation file, and uses the Visitor
design pattern. It uses STL (Standard Template Library).
Author : Michael Pellauer (pellauer@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 4 August, 2003
Modified : 22 May, 2004 / Antti-Juhani Kaijanaho
29 August, 2006 / Aarne Ranta
**************************************************************
-}
module BNFC.Backend.CPP.STL.CFtoSTLAbs (cf2CPPAbs) where
import BNFC.Backend.Common.OOAbstract
import BNFC.CF
import BNFC.Utils((+++))
import Data.List
import BNFC.Backend.CPP.STL.STLUtils
--The result is two files (.H file, .C file)
cf2CPPAbs :: Bool -> Maybe String -> String -> CF -> (String, String)
cf2CPPAbs ln inPackage _ cf = (mkHFile ln inPackage cab, mkCFile inPackage cab)
where
cab = cf2cabs cf
-- **** Header (.H) File Functions **** --
--Makes the Header file.
mkHFile :: Bool -> Maybe String -> CAbs -> String
mkHFile ln inPackage cf = unlines
[
"#ifndef " ++ hdef,
"#define " ++ hdef,
"",
"#include",
"#include",
"",
"//C++ Abstract Syntax Interface generated by the BNF Converter.",
nsStart inPackage,
"/******************** TypeDef Section ********************/",
"",
unlines ["typedef " ++ d ++ " " ++ c ++ ";" | (c,d) <- basetypes],
"",
unlines ["typedef std::string " ++ s ++ ";" | s <- tokentypes cf],
"",
"/******************** Forward Declarations ********************/",
"",
unlines ["class " ++ c ++ ";" | c <- classes, notElem c (defineds cf)],
"",
"/******************** Visitor Interfaces ********************/",
prVisitor cf,
"",
prVisitable,
"",
"/******************** Abstract Syntax Classes ********************/",
"",
unlines [prAbs ln c | c <- absclasses cf],
"",
unlines [prCon (c,r) | (c,rs) <- signatures cf, r <- rs],
"",
unlines [prList c | c <- listtypes cf],
nsEnd inPackage,
"#endif"
]
where
classes = allClasses cf
hdef = nsDefine inPackage "ABSYN_HEADER"
-- auxiliaries
prVisitable :: String
prVisitable = unlines [
"class Visitable",
"{",
" public:",
-- all classes with virtual methods require a virtual destructor
" virtual ~Visitable() {}",
" virtual void accept(Visitor *v) = 0;",
"};"
]
prVisitor :: CAbs -> String
prVisitor cf = unlines [
"class Visitor",
"{",
"public:",
" virtual ~Visitor() {}",
unlines
[" virtual void visit"++c++"("++c++" *p) = 0;" | c <- allClasses cf,
notElem c (defineds cf)],
"",
unlines
[" virtual void visit"++c++"(" ++c++" x) = 0;" | c <- allNonClasses cf],
"};"
]
prAbs :: Bool -> String -> String
prAbs ln c = unlines [
"class " ++ c ++ " : public Visitable",
"{",
"public:",
" virtual " ++ c ++ " *clone() const = 0;",
if ln then " int line_number;" else "",
"};"
]
prCon :: (String, CAbsRule) -> String
prCon (c,(f,cs)) = unlines [
"class " ++f++ " : public " ++ c,
"{",
"public:",
unlines
[" "++ typ +++ pointerIf st var ++ ";" | (typ,st,var) <- cs],
" " ++ f ++ "(const " ++ f ++ " &);",
" " ++ f ++ " &operator=(const " ++f++ " &);",
" " ++ f ++ "(" ++ conargs ++ ");",
-- Typ *p1, PIdent *p2, ListStm *p3);
" ~" ++f ++ "();",
" virtual void accept(Visitor *v);",
" virtual " ++f++ " *clone() const;",
" void swap(" ++f++ " &);",
"};"
]
where
conargs = concat $ intersperse ", "
[x +++ pointerIf st ("p" ++ show i) | ((x,st,_),i) <- zip cs [1..]]
prList :: (String,Bool) -> String
prList (c,b) = unlines [
"class " ++c++ " : public Visitable, public std::vector<" ++bas++ ">",
"{",
"public:",
" virtual void accept(Visitor *v);",
" virtual " ++ c ++ " *clone() const;",
"};"
]
where
bas = drop 4 c ++ -- drop List
if b then "*" else ""
-- **** Implementation (.C) File Functions **** --
mkCFile :: Maybe String -> CAbs -> String
mkCFile inPackage cf = unlines $ [
"//C++ Abstract Syntax Implementation generated by the BNF Converter.",
"#include ",
"#include ",
"#include ",
"#include ",
"#include \"Absyn.H\"",
nsStart inPackage,
unlines [prConC r | (_,rs) <- signatures cf, r <- rs],
unlines [prListC c | (c,_) <- listtypes cf],
nsEnd inPackage
]
prConC :: CAbsRule -> String
prConC fcs@(f,_) = unlines [
"/******************** " ++ f ++ " ********************/",
prConstructorC fcs,
prCopyC fcs,
prDestructorC fcs,
prAcceptC f,
prCloneC f,
""
]
prListC :: String -> String
prListC c = unlines [
"/******************** " ++ c ++ " ********************/",
"",
prAcceptC c,
"",
prCloneC c
]
--The standard accept function for the Visitor pattern
prAcceptC :: String -> String
prAcceptC ty = unlines [
"void " ++ ty ++ "::accept(Visitor *v)",
"{",
" v->visit" ++ ty ++ "(this);",
"}"
]
--The cloner makes a new deep copy of the object
prCloneC :: String -> String
prCloneC c = unlines [
c +++ "*" ++ c ++ "::clone() const",
"{",
" return new" +++ c ++ "(*this);",
"}"
]
--The constructor assigns the parameters to the corresponding instance variables.
prConstructorC :: CAbsRule -> String
prConstructorC (f,cs) = unlines [
f ++ "::" ++ f ++ "(" ++ conargs ++ ")",
"{",
unlines [" " ++ c ++ " = " ++ p ++ ";" | (c,p) <- zip cvs pvs],
"}"
]
where
cvs = [c | (_,_,c) <- cs]
pvs = ['p' : show i | ((_,_,_),i) <- zip cs [1..]]
conargs = intercalate ", "
[x +++ pointerIf st v | ((x,st,_),v) <- zip cs pvs]
--Copy constructor and copy assignment
prCopyC :: CAbsRule -> String
prCopyC (c,cs) = unlines [
c ++ "::" ++ c ++ "(const" +++ c +++ "& other)",
"{",
unlines [" " ++ cv ++ " = other." ++ cloneIf st cv ++ ";" | (_,st,cv) <- cs],
"}",
"",
c +++ "&" ++ c ++ "::" ++ "operator=(const" +++ c +++ "& other)",
"{",
" " ++ c +++ "tmp(other);",
" swap(tmp);",
" return *this;",
"}",
"",
"void" +++ c ++ "::swap(" ++ c +++ "& other)",
"{",
unlines [" std::swap(" ++ cv ++ ", other." ++ cv ++ ");" | (_,_,cv) <- cs],
"}"
]
where
cloneIf st cv = if st then (cv ++ "->clone()") else cv
--The destructor deletes all a class's members.
prDestructorC :: CAbsRule -> String
prDestructorC (c,cs) = unlines [
c ++ "::~" ++ c ++"()",
"{",
unlines [" delete(" ++ cv ++ ");" | (_,isPointer,cv) <- cs, isPointer],
"}"
]
BNFC-2.8.1/src/BNFC/Backend/HaskellGADT/0000755000000000000000000000000012654616013015275 5ustar0000000000000000BNFC-2.8.1/src/BNFC/Backend/HaskellGADT/HaskellGADTCommon.hs0000644000000000000000000000613012654616013021025 0ustar0000000000000000{-
BNF Converter: Haskell GADT back-end common stuff
Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.HaskellGADT.HaskellGADTCommon (Constructor(..), cf2cons, isTreeType) where
import BNFC.CF
import Data.Char
data Constructor = Constructor {
consCat :: Cat,
consFun :: Fun,
consPrec :: Integer,
consVars :: [(Cat,String)],
consRhs :: [Either Cat String]
}
-- | Get category, function, and rhs categories paired with variable names.
cf2cons :: CF -> [Constructor]
cf2cons cf = [ Constructor { consCat = cat,
consFun = fun,
consPrec = precFun cf fun,
consVars = zip cats (mkVars cats),
consRhs = rhsFun cf fun}
| (cat,rules) <- cf2data cf, (fun,cats) <- rules]
++ [ Constructor { consCat = cat,
consFun = show cat,
consPrec = 0,
consVars = [(Cat "String","str")],
consRhs = [Left (Cat "String")]}
| cat <- specialCats cf]
where mkVars cats = mkUnique (map catToVar cats) (0 :: Int)
mkUnique [] _ = []
mkUnique (x:xs) n | elem x xs || n > 0 = (x ++ show n) : mkUnique xs (n+1)
| otherwise = x : mkUnique xs n
-- | Make a variable name for a category.
catToVar :: Cat -> String
catToVar = checkRes . var
where var (ListCat cat) = var cat ++ "s"
var (Cat "Ident") = "i"
var (Cat "Integer") = "n"
var (Cat "String") = "str"
var (Cat "Char") = "c"
var (Cat "Double") = "d"
var xs = map toLower $show xs
checkRes s | elem s reservedHaskell = s ++ "'"
| otherwise = s
reservedHaskell = ["case","class","data","default","deriving","do","else","if",
"import","in","infix","infixl","infixr","instance","let","module",
"newtype","of","then","type","where","as","qualified","hiding"]
-- | Get the rule for a function.
ruleFun :: CF -> Fun -> Rule
ruleFun cf f = head $ filter (\r -> funRule r == f) $ rulesOfCF cf
-- | Get the precedence of a function.
precFun :: CF -> Fun -> Integer
precFun cf f = precRule $ ruleFun cf f
-- | Get the RHS of a function
rhsFun :: CF -> Fun -> [Either Cat String]
rhsFun cf f = rhsRule $ ruleFun cf f
isTreeType :: CF -> Cat -> Bool
isTreeType cf c | isList c = isTreeType cf (catOfList c)
| otherwise = c `elem` (allCats cf ++ specialCats cf)
BNFC-2.8.1/src/BNFC/Backend/HaskellGADT/CFtoAbstractGADT.hs0000644000000000000000000001373112654616013020615 0ustar0000000000000000{-
BNF Converter: GADT Abstract syntax Generator
Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.HaskellGADT.CFtoAbstractGADT (cf2Abstract) where
import BNFC.CF
import BNFC.Utils((+++))
import Data.List(intersperse,intercalate,nub)
import BNFC.Backend.HaskellGADT.HaskellGADTCommon
-- to produce a Haskell module
cf2Abstract :: Bool -> String -> CF -> String -> String
cf2Abstract byteStrings name cf composOpMod = unlines $ [
"{-# LANGUAGE GADTs, KindSignatures, DataKinds #-}",
"module" +++ name +++ "(" ++ concat (intersperse ", " exports) ++ ")" +++ "where",
"",
"import " ++ composOpMod,
"",
"import Data.Monoid (mappend)",
(if byteStrings then "import qualified Data.ByteString.Char8 as BS" else ""),
"",
"-- Haskell module generated by the BNF converter",
""]
++ prDummyTypes cf
++ [""]
++ prTreeType byteStrings cf
++ [""]
++ prCompos cf
++ [""]
++ prShow cf
++ [""]
++ prEq cf
++ [""]
++ prOrd cf
where exports = ["Tree(..)"]
++ getTreeCats cf
++ ["johnMajorEq"]
++ ["module " ++ composOpMod]
getTreeCats :: CF -> [String]
getTreeCats cf = nub $ map show $ filter (not . isList) $ map consCat $ cf2cons cf
prDummyTypes :: CF -> [String]
prDummyTypes cf = [prDummyData] ++ map prDummyType cats
where
cats = getTreeCats cf
prDummyData = "data Tag =" +++ intercalate " | " (map mkRealType cats)
prDummyType cat = "type" +++ cat +++ "= Tree" +++ mkRealType cat
mkRealType :: String -> String
mkRealType cat = cat ++ "_" -- FIXME: make sure that there is no such category already
prTreeType :: Bool -> CF -> [String]
prTreeType byteStrings cf = ["data Tree :: Tag -> * where"] ++ map ((" "++) . prTreeCons) (cf2cons cf)
where
prTreeCons c
| isPositionCat cf cat = fun +++ ":: ((Int,Int),"++stringType++") -> Tree" +++ mkRealType (show cat)
| otherwise = fun +++ "::" +++ concat [show c +++ "-> " | (c,_) <- consVars c] ++ "Tree" +++ mkRealType (show cat)
where (cat,fun) = (consCat c, consFun c)
stringType
| byteStrings = "BS.ByteString"
| otherwise = "String"
prCompos :: CF -> [String]
prCompos cf =
["instance Compos Tree where",
" compos r a f t = case t of"]
++ map (" "++) (concatMap prComposCons cs
++ if not (all isRecursive cs) then ["_ -> r t"] else [])
where
cs = cf2cons cf
prComposCons c
| isRecursive c = [consFun c +++ unwords (map snd (consVars c)) +++ "->" +++ rhs c]
| otherwise = []
isRecursive c = any (isTreeType cf) (map fst (consVars c))
rhs c = "r" +++ consFun c +++ unwords (map prRec (consVars c))
where prRec (cat,var) | not (isTreeType cf cat) = "`a`" +++ "r" +++ var
| isList cat = "`a` foldr (a . a (r (:)) . f) (r [])" +++ var
| otherwise = "`a`" +++ "f" +++ var
prShow :: CF -> [String]
prShow cf = ["instance Show (Tree c) where",
" showsPrec n t = case t of"]
++ map (" "++) (map prShowCons cs)
++ [" where opar n = if n > 0 then showChar '(' else id",
" cpar n = if n > 0 then showChar ')' else id"]
where
cs = cf2cons cf
prShowCons c | null vars = fun +++ "->" +++ "showString" +++ show fun
| otherwise = fun +++ unwords (map snd vars) +++ "->"
+++ "opar n . showString" +++ show fun
+++ unwords [". showChar ' ' . showsPrec 1 " ++ x | (_,x) <- vars]
+++ ". cpar n"
where (fun, vars) = (consFun c, consVars c)
prEq :: CF -> [String]
prEq cf = ["instance Eq (Tree c) where (==) = johnMajorEq",
"",
"johnMajorEq :: Tree a -> Tree b -> Bool"]
++ map (prEqCons) (cf2cons cf)
++ ["johnMajorEq _ _ = False"]
where prEqCons c
| null vars = "johnMajorEq" +++ fun +++ fun +++ "=" +++ "True"
| otherwise = "johnMajorEq" +++ "(" ++ fun +++ unwords vars ++ ")"
+++ "(" ++ fun +++ unwords vars' ++ ")" +++ "="
+++ (concat $ intersperse " && " $ zipWith (\x y -> x +++ "==" +++ y) vars vars')
where (fun, vars) = (consFun c, map snd (consVars c))
vars' = map (++"_") vars
prOrd :: CF -> [String]
prOrd cf = ["instance Ord (Tree c) where",
" compare x y = compare (index x) (index y) `mappend` compareSame x y"] ++
["index :: Tree c -> Int"] ++
zipWith (\ c i -> mkIndex c i) cs [0..] ++
["compareSame :: Tree c -> Tree c -> Ordering"] ++
map mkCompareSame cs ++
["compareSame x y = error \"BNFC error:\" compareSame"]
where cs = cf2cons cf
mkCompareSame c
| null vars = "compareSame" +++ fun +++ fun +++ "=" +++ "EQ"
| otherwise = "compareSame" +++ "(" ++ fun +++ unwords vars ++ ")"
+++ "(" ++ fun +++ unwords vars' ++ ")" +++ "="
+++ foldr1 (\x y -> "mappend (" ++ x ++") ("++y++")") cc
where (fun, vars) = (consFun c, map snd (consVars c))
vars' = map (++"_") vars
cc = zipWith (\x y -> "compare"+++x+++y) vars vars'
mkIndex c i = "index" +++ "(" ++ consFun c
+++ unwords (replicate (length (consVars c)) "_") ++ ")"
+++ "=" +++ show i
BNFC-2.8.1/src/BNFC/Backend/HaskellGADT/CFtoTemplateGADT.hs0000644000000000000000000000424512654616013020625 0ustar0000000000000000{-
BNF Converter: GADT Template Generator
Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.HaskellGADT.CFtoTemplateGADT (
cf2Template
) where
import BNFC.CF
import BNFC.Utils((+++))
import Data.List (groupBy)
import BNFC.Backend.HaskellGADT.HaskellGADTCommon
type ModuleName = String
cf2Template :: ModuleName -> ModuleName -> ModuleName -> CF -> String
cf2Template skelName absName errName cf = unlines $
[
"{-# LANGUAGE GADTs #-}",
"module "++ skelName ++ " where",
"",
"-- Haskell module generated by the BNF converter",
"",
"import " ++ absName,
"import " ++ errName,
"type Result = Err String\n",
"failure :: Show a => a -> Result",
"failure x = Bad $ \"Undefined case: \" ++ show x",
"",
"transTree :: Tree c -> Result",
"transTree t = case t of"]
++ map prConsCase (cf2cons cf)
++ [""]
++ concatMap ((++[""]) . uncurry prCatTrans) (catCons cf)
prConsCase :: Constructor -> String
prConsCase c =
" " ++ consFun c +++ unwords (map snd (consVars c)) +++ "-> failure t"
catCons :: CF -> [(Cat,[Constructor])]
catCons cf = [ (consCat (head cs),cs) | cs <- groupBy catEq $ cf2cons cf]
catEq :: Constructor -> Constructor -> Bool
catEq c1 c2 = consCat c1 == consCat c2
prCatTrans :: Cat -> [Constructor] -> [String]
prCatTrans cat cs = ["trans" ++ show cat +++ "::" +++ show cat +++ "-> Result",
"trans" ++ show cat +++ "t = case t of"]
++ map prConsCase cs
BNFC-2.8.1/src/BNFC/Backend/OCaml/0000755000000000000000000000000012654616013014245 5ustar0000000000000000BNFC-2.8.1/src/BNFC/Backend/OCaml/CFtoOCamlPrinter.hs0000644000000000000000000002102312654616013017712 0ustar0000000000000000{-
BNF Converter: Pretty-printer generator
Copyright (C) 2005 Author: Kristofer Johannisson
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
-- based on BNFC Haskell backend
module BNFC.Backend.OCaml.CFtoOCamlPrinter (cf2Printer) where
import BNFC.CF
import BNFC.Utils
import Data.List (intersperse, sortBy)
import Data.Char(toLower)
import BNFC.Backend.OCaml.OCamlUtil
import BNFC.PrettyPrint
import BNFC.Backend.Haskell.CFtoPrinter (compareRules)
-- derive pretty-printer from a BNF grammar. AR 15/2/2002
cf2Printer :: String -> String -> CF -> String
cf2Printer name absMod cf = unlines [
prologue name absMod,
charRule cf,
integerRule cf,
doubleRule cf,
stringRule cf,
if hasIdent cf then identRule cf else "",
unlines [ownPrintRule cf own | (own,_) <- tokenPragmas cf],
rules cf
]
prologue :: String -> String -> String
prologue _ absMod = unlines [
"(* pretty-printer generated by the BNF converter *)\n",
"open " ++ absMod,
"open Printf",
"",
"(* We use string buffers for efficient string concatenation.",
" A document takes a buffer and an indentation, has side effects on the buffer",
" and returns a new indentation. The indentation argument indicates the level",
" of indentation to be used if a new line has to be started (because of what is",
" already in the buffer) *)",
"type doc = Buffer.t -> int -> int",
"",
"let rec printTree (printer : int -> 'a -> doc) (tree : 'a) : string = ",
" let buffer_init_size = 16 (* you may want to change this *)",
" in let buffer = Buffer.create buffer_init_size",
" in ",
" let _ = printer 0 tree buffer 0 in (* discard return value *)",
" Buffer.contents buffer",
"",
"let indent_width = 4",
"",
"let indent (i: int) : string = ",
" let s = String.make (i+1) ' ' in",
" String.set s 0 '\\n';",
" s",
"",
"(* this render function is written for C-style languages, you may want to change it *)",
"let render (s : string) : doc = fun buf i -> ",
" (* invariant: last char of the buffer is never whitespace *)",
" let n = Buffer.length buf in",
" let last = if n = 0 then None else Some (Buffer.nth buf (n-1)) in",
" let whitespace = match last with",
" None -> \"\" ",
" | Some '{' -> indent i",
" | Some '}' -> (match s with",
" \";\" -> \"\"",
" | _ -> indent i)",
" | Some ';' -> indent i",
" | (Some '[') | (Some '(') -> \"\"",
" | Some _ -> (match s with",
" \",\" | \")\" | \"]\" -> \"\"",
" | _ -> \" \") in",
" let newindent = match s with",
" \"{\" -> i + indent_width",
" | \"}\" -> i - indent_width",
" | _ -> i in",
" Buffer.add_string buf whitespace;",
" Buffer.add_string buf s;",
" newindent",
"",
"let emptyDoc : doc = fun buf i -> i",
"",
"let concatD (ds : doc list) : doc = fun buf i -> ",
" List.fold_left (fun accIndent elemDoc -> elemDoc buf accIndent) (emptyDoc buf i) ds",
"",
"let parenth (d:doc) : doc = concatD [render \"(\"; d; render \")\"]",
"",
"let prPrec (i:int) (j:int) (d:doc) : doc = if j String
rules cf = unlines $ mutualDefs $
map (\(s,xs) -> case_fun s (map toArgs xs) ++ ifList cf s) $ cf2data cf
where
reserved = "i":"e":reservedOCaml
toArgs (cons,args) = ((cons, mkNames reserved LowerCase (map var args)), ruleOf cons)
names [] _ = []
names (x:xs) n
| elem x xs = (x ++ show n) : names xs (n+1)
| otherwise = x : names xs n
var (ListCat c) = var c ++ "s"
var (Cat "Ident") = "id"
var (Cat "Integer") = "n"
var (Cat "String") = "str"
var (Cat "Char") = "c"
var (Cat "Double") = "d"
var xs = map toLower (show xs)
checkRes s
| elem s reservedOCaml = s ++ "'"
| otherwise = s
ruleOf s = maybe undefined id $ lookupRule s (rulesOfCF cf)
--- case_fun :: Cat -> [(Constructor,Rule)] -> String
case_fun cat xs = unlines [
-- "instance Print" +++ cat +++ "where",
prtFun cat +++"(i:int)" +++ "(e:" ++ fixType cat ++ ") : doc = match e with",
unlines $ insertBar $ map (\ ((c,xx),r) ->
" " ++ c +++ mkTuple xx +++ "->" +++
"prPrec i" +++ show (precCat (fst r)) +++ mkRhs xx (snd r)) xs
]
-- ifList cf cat = mkListRule $ nil cat ++ one cat ++ cons cat where
-- nil cat = [" [] -> " ++ mkRhs [] its |
-- Rule f c its <- rulesOfCF cf, isNilFun f , normCatOfList c == cat]
-- one cat = [" | [x] -> " ++ mkRhs ["x"] its |
-- Rule f c its <- rulesOfCF cf, isOneFun f , normCatOfList c == cat]
-- cons cat = [" | x::xs -> " ++ mkRhs ["x","xs"] its |
-- Rule f c its <- rulesOfCF cf, isConsFun f , normCatOfList c == cat]
-- mkListRule [] = ""
-- mkListRule rs = unlines $ ("and prt" ++ fixTypeUpper cat ++ "ListBNFC" +++ "_ es : doc = match es with"):rs
ifList :: CF -> Cat -> String
ifList cf cat = case cases of
[] -> ""
first:rest -> render $ vcat
[ "and prt" <> text (fixTypeUpper cat) <> "ListBNFC i es : doc = match (i, es) with"
, nest 4 first
, nest 2 $ vcat (map ("|" <+>) rest)
]
where
rules = sortBy compareRules $ rulesForNormalizedCat cf (ListCat cat)
cases = [ mkPrtListCase r | r <- rules ]
-- | Pattern match on the list constructor and the coercion level
-- >>> mkPrtListCase (Rule "[]" (ListCat (Cat "Foo")) [])
-- (_,[]) -> (concatD [])
-- >>> mkPrtListCase (Rule "(:[])" (ListCat (Cat "Foo")) [Left (Cat "Foo")])
-- (_,[x]) -> (concatD [prtFoo 0 x])
-- >>> mkPrtListCase (Rule "(:)" (ListCat (Cat "Foo")) [Left (Cat "Foo"), Left (ListCat (Cat "Foo"))])
-- (_,x::xs) -> (concatD [prtFoo 0 x ; prtFooListBNFC 0 xs])
-- >>> mkPrtListCase (Rule "[]" (ListCat (CoercCat "Foo" 2)) [])
-- (2,[]) -> (concatD [])
-- >>> mkPrtListCase (Rule "(:[])" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2)])
-- (2,[x]) -> (concatD [prtFoo 2 x])
-- >>> mkPrtListCase (Rule "(:)" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2), Left (ListCat (CoercCat "Foo" 2))])
-- (2,x::xs) -> (concatD [prtFoo 2 x ; prtFooListBNFC 2 xs])
mkPrtListCase :: Rule -> Doc
mkPrtListCase (Rule f (ListCat c) rhs)
| isNilFun f = parens (precPattern <> "," <> "[]") <+> "->" <+> body
| isOneFun f = parens (precPattern <> "," <> "[x]") <+> "->" <+> body
| isConsFun f = parens (precPattern <> "," <>"x::xs") <+> "->" <+> body
| otherwise = empty -- (++) constructor
where
precPattern = case precCat c of 0 -> "_" ; p -> integer p
body = text $ mkRhs ["x", "xs"] rhs
mkRhs args its =
"(concatD [" ++ unwords (intersperse ";" (mk args its)) ++ "])"
where
mk args (Left InternalCat : items) = mk args items
mk (arg:args) (Left c : items) = (prt c +++ arg) : mk args items
mk args (Right s : items) = ("render " ++ show s) : mk args items
mk _ _ = []
prt c = prtFun c +++ show (precCat c)
prtFun :: Cat -> String
prtFun (ListCat c) = prtFun c ++ "ListBNFC"
prtFun c = "prt" ++ fixTypeUpper (normCat c)
BNFC-2.8.1/src/BNFC/Backend/OCaml/CFtoOCamlTemplate.hs0000644000000000000000000000465212654616013020053 0ustar0000000000000000{-
BNF Converter: Template Generator
Copyright (C) 2005 Author: Kristofer Johannisson
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
-- based on BNFC Haskell backend
module BNFC.Backend.OCaml.CFtoOCamlTemplate (
cf2Template
) where
import BNFC.CF
import Data.Char
import BNFC.Backend.OCaml.OCamlUtil
type ModuleName = String
type Constructor = String
cf2Template :: ModuleName -> ModuleName -> CF -> String
cf2Template skelName absName cf = unlines
[
"module "++ skelName ++ " = struct\n",
"(* OCaml module generated by the BNF converter *)\n",
"open " ++ absName ++ "\n",
"type result = string\n",
"let failure x = failwith \"Undefined case.\" (* x discarded *)\n",
unlines $ mutualDefs $ map (\(s,xs) -> case_fun s (toArgs xs)) $ specialData cf ++ cf2data cf,
"end"
]
where toArgs [] = []
toArgs ((cons,args):xs)
= (cons ++ " " ++ (mkTuple $ names (map (checkRes . var) args) (0 :: Int))) : toArgs xs
names :: [String] -> Int -> [String]
names [] _ = []
names (x:xs) n
| elem x xs = (x ++ show n) : names xs (n+1)
| otherwise = x : names xs n
var (ListCat c) = var c ++ "s"
var (Cat "Ident") = "id"
var (Cat "Integer") = "n"
var (Cat "String") = "str"
var (Cat "Char") = "c"
var (Cat "Double") = "d"
var cat = map toLower (show cat)
checkRes s
| elem s reservedOCaml = s ++ "'"
| otherwise = s
case_fun :: Cat -> [Constructor] -> String
case_fun cat xs =
unlines $
["trans" ++ show cat ++ " (x : " ++ fixType cat ++ ") : result = match x with",
unlines $ insertBar $ map (\s -> s ++ " -> " ++ "failure x") xs]
BNFC-2.8.1/src/BNFC/Backend/OCaml/CFtoOCamlLex.hs0000644000000000000000000002435112654616013017026 0ustar0000000000000000{-
BNF Converter: ocamllex Generator
Copyright (C) 2005 Author: Kristofer Johannisson
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
-- based on BNFC Haskell backend
module BNFC.Backend.OCaml.CFtoOCamlLex (cf2ocamllex) where
import Control.Arrow ((&&&))
import Data.List
import Data.Char
import Text.PrettyPrint hiding (render)
import qualified Text.PrettyPrint as PP
import BNFC.CF
import AbsBNF
import BNFC.Backend.OCaml.CFtoOCamlYacc (terminal)
import BNFC.Utils ((+++))
cf2ocamllex :: String -> String -> CF -> String
cf2ocamllex _ parserMod cf =
unlines $ intercalate [""] [
header parserMod cf,
definitions cf,
[PP.render (rules cf)]
]
header :: String -> CF -> [String]
header parserMod cf = [
"(* This ocamllex file was machine-generated by the BNF converter *)",
"{",
"open " ++ parserMod,
"open Lexing",
"",
hashtables cf,
"",
"let unescapeInitTail (s:string) : string =",
" let rec unesc s = match s with",
" '\\\\'::c::cs when List.mem c ['\\\"'; '\\\\'; '\\\''] -> c :: unesc cs",
" | '\\\\'::'n'::cs -> '\\n' :: unesc cs",
" | '\\\\'::'t'::cs -> '\\t' :: unesc cs",
" | '\\\"'::[] -> []",
" | c::cs -> c :: unesc cs",
" | _ -> []",
" (* explode/implode from caml FAQ *)",
" in let explode (s : string) : char list =",
" let rec exp i l =",
" if i < 0 then l else exp (i - 1) (s.[i] :: l) in",
" exp (String.length s - 1) []",
" in let implode (l : char list) : string =",
" let res = String.create (List.length l) in",
" let rec imp i = function",
" | [] -> res",
" | c :: l -> res.[i] <- c; imp (i + 1) l in",
" imp 0 l",
" in implode (unesc (List.tl (explode s)))",
"",
"let incr_lineno (lexbuf:Lexing.lexbuf) : unit =",
" let pos = lexbuf.lex_curr_p in",
" lexbuf.lex_curr_p <- { pos with",
" pos_lnum = pos.pos_lnum + 1;",
" pos_bol = pos.pos_cnum;",
" }",
"}"
]
-- | set up hashtables for reserved symbols and words
hashtables :: CF -> String
hashtables cf = ht "symbol_table" (symbols cf ) ++ "\n" ++
ht "resword_table" (reservedWords cf)
where ht _ syms | null syms = ""
ht table syms = unlines [
"let" +++ table +++ "= Hashtbl.create " ++ show (length syms),
"let _ = List.iter (fun (kwd, tok) -> Hashtbl.add" +++ table
+++ "kwd tok)",
" [" ++ concat (intersperse ";" keyvals) ++ "]"
]
where keyvals = map (\(x,y) -> "(" ++ x ++ ", " ++ y ++ ")")
(zip (map show syms) (map (terminal cf) syms))
definitions :: CF -> [String]
definitions cf = concat [
cMacros,
rMacros cf,
uMacros cf
]
cMacros :: [String]
cMacros = [
"let l = ['a'-'z' 'A'-'Z' '\\192' - '\\255'] # ['\\215' '\\247'] (* isolatin1 letter FIXME *)",
"let c = ['A'-'Z' '\\192'-'\\221'] # ['\\215'] (* capital isolatin1 letter FIXME *)",
"let s = ['a'-'z' '\\222'-'\\255'] # ['\\247'] (* small isolatin1 letter FIXME *)",
"let d = ['0'-'9'] (* digit *)",
"let i = l | d | ['_' '\\''] (* identifier character *)",
"let u = ['\\000'-'\\255'] (* universal: any character *)"
]
rMacros :: CF -> [String]
rMacros cf =
let symbs = symbols cf
in
(if null symbs then [] else [
"let rsyms = (* reserved words consisting of special symbols *)",
" " ++ unwords (intersperse "|" (map mkEsc symbs))
])
where
mkEsc s = "\"" ++ concat (map f s) ++ "\""
f x = if x `elem` ['"','\\'] then "\\" ++ [x] else [x]
-- user macros, derived from the user-defined tokens
uMacros :: CF -> [String]
uMacros cf = ["let " ++ name ++ " = " ++ rep | (name, rep, _) <- userTokens cf]
-- returns the tuple of (reg_name, reg_representation, token_name)
userTokens :: CF -> [(String, String, String)]
userTokens cf =
let regName = map toLower . show in
[(regName name, printRegOCaml reg, show name) | (name, reg) <- tokenPragmas cf]
-- | Make OCamlLex rule
-- >>> mkRule "token" [("REGEX1","ACTION1"),("REGEX2","ACTION2"),("...","...")]
-- rule token =
-- parse REGEX1 {ACTION1}
-- | REGEX2 {ACTION2}
-- | ... {...}
--
-- If no regex are given, we dont create a lexer rule:
-- >>> mkRule "empty" []
--
mkRule :: Doc -> [(Doc,Doc)] -> Doc
mkRule _ [] = empty
mkRule entrypoint (r1:rn) = vcat
[ "rule" <+> entrypoint <+> "="
, nest 2 $ hang "parse" 4 $ vcat
(nest 2 (mkOne r1):map (("|" <+>) . mkOne) rn) ]
where
mkOne (regex, action) = regex <+> braces action
-- | Create regex for single line comments
-- >>> mkRegexSingleLineComment "--"
-- "--" (_ # '\n')*
mkRegexSingleLineComment :: String -> Doc
mkRegexSingleLineComment s =
doubleQuotes (text s) <+> "(_ # '\\n')*"
-- | Create regex for multiline comments
-- >>> mkRegexMultilineComment ""
-- ""
mkRegexMultilineComment :: String -> String -> Doc
mkRegexMultilineComment b e =
lit b
<+> parens ( hsep $ intersperse "|" subregexs ) <> "*"
<+> lit [head e] <> "*"
<+> lit e
where
lit :: String -> Doc
lit "" = empty
lit [c] = quotes (char c)
lit s = doubleQuotes (text s)
prefix = map (init &&& last) (drop 1 (inits e))
subregexs = [ lit ss <+> parens ("u #" <+> brackets (lit [s])) | (ss,s) <- prefix]
-- | Uses the function from above to make a lexer rule from the CF grammar
rules :: CF -> Doc
rules cf = mkRule "token" $
-- comments
[ (mkRegexSingleLineComment s, "token lexbuf") | s <- singleLineC ]
++
[ (mkRegexMultilineComment b e, "token lexbuf") | (b,e) <- multilineC]
++
-- user tokens
[ (text n , tokenAction (text t)) | (n,_,t) <- userTokens cf]
++
-- predefined tokens
[ ( "l i*", tokenAction "Ident" ) ]
++
[ ( "rsyms"
, "let id = lexeme lexbuf in try Hashtbl.find symbol_table id with Not_found -> failwith (\"internal lexer error: reserved symbol \" ^ id ^ \" not found in hashtable\")" )
| not (null (symbols cf))]
++
-- integers
[ ( "d+", "let i = lexeme lexbuf in TOK_Integer (int_of_string i)" )
-- doubles
, ( "d+ '.' d+ ('e' ('-')? d+)?"
, "let f = lexeme lexbuf in TOK_Double (float_of_string f)" )
-- strings
, ( "'\\\"' ((u # ['\\\"' '\\\\' '\\n']) | ('\\\\' ('\\\"' | '\\\\' | '\\\'' | 'n' | 't')))* '\\\"'"
, "let s = lexeme lexbuf in TOK_String (unescapeInitTail s)" )
-- chars
, ( "'\\'' ((u # ['\\\'' '\\\\']) | ('\\\\' ('\\\\' | '\\\'' | 'n' | 't'))) '\\\''"
, "let s = lexeme lexbuf in TOK_Char s.[1]")
-- spaces
, ( "[' ' '\\t']", "token lexbuf")
-- new lines
, ( "'\\n'", "incr_lineno lexbuf; token lexbuf" )
-- end of file
, ( "eof", "TOK_EOF" )
]
where
(multilineC, singleLineC) = comments cf
tokenAction t = case reservedWords cf of
[] -> "let l = lexeme lexbuf in TOK_" <> t <>" l"
_ -> "let l = lexeme lexbuf in try Hashtbl.find resword_table l with Not_found -> TOK_" <> t <+> "l"
-------------------------------------------------------------------
-- Modified from the inlined version of @RegToAlex@.
-------------------------------------------------------------------
-- modified from pretty-printer generated by the BNF converter
-- the top-level printing method
printRegOCaml :: Reg -> String
printRegOCaml = render . prt 0
-- you may want to change render and parenth
render :: [String] -> String
render = rend 0
where rend :: Int -> [String] -> String
rend i ss = case ss of
"[" :ts -> cons "[" $ rend i ts
"(" :ts -> cons "(" $ rend i ts
t : "," :ts -> cons t $ space "," $ rend i ts
t : ")" :ts -> cons t $ cons ")" $ rend i ts
t : "]" :ts -> cons t $ cons "]" $ rend i ts
t :ts -> space t $ rend i ts
_ -> ""
cons s t = s ++ t
space t s = if null s then t else t ++ " " ++ s
parenth :: [String] -> [String]
parenth ss = ["("] ++ ss ++ [")"]
-- the printer class does the job
class Print a where
prt :: Int -> a -> [String]
prtList :: [a] -> [String]
prtList = concat . map (prt 0)
instance Print a => Print [a] where
prt _ = prtList
instance Print Char where
prt _ c = [show c] -- if isAlphaNum c then [[c]] else ['\\':[c]]
prtList s = [show s] -- map (concat . prt 0) s
prPrec :: Int -> Int -> [String] -> [String]
prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])
RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])
RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])
RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])
RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])
ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])
REps -> prPrec i 3 (["\"\""]) -- special construct for eps in ocamllex?
RChar c -> prPrec i 3 (concat [prt 0 c])
RAlts str -> prPrec i 3 (concat [["["], [concatMap show str], ["]"]])
RSeqs str -> prPrec i 2 (concat (map (prt 0) str))
RDigit -> prPrec i 3 (concat [["d"]])
RLetter -> prPrec i 3 (concat [["l"]])
RUpper -> prPrec i 3 (concat [["c"]])
RLower -> prPrec i 3 (concat [["s"]])
RAny -> prPrec i 3 (concat [["u"]])
BNFC-2.8.1/src/BNFC/Backend/OCaml/OCamlUtil.hs0000644000000000000000000000462512654616013016441 0ustar0000000000000000{-
BNF Converter: OCaml backend utility module
Copyright (C) 2005 Author: Kristofer Johannisson
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.OCaml.OCamlUtil where
import BNFC.CF
import BNFC.Utils
import Data.Char (toLower, toUpper)
-- Translate Haskell types to OCaml types
-- Note: OCaml (data-)types start with lowercase letter
fixType :: Cat -> String
fixType (ListCat c) = fixType c +++ "list"
fixType (TokenCat "Integer") = "int"
fixType (TokenCat "Double") = "float"
fixType cat = let c:cs = show cat in
let ls = toLower c : cs in
if (elem ls reservedOCaml) then (ls ++ "T") else ls
-- as fixType, but leave first character in upper case
fixTypeUpper :: Cat -> String
fixTypeUpper c = case fixType c of
[] -> []
c:cs -> toUpper c : cs
reservedOCaml :: [String]
reservedOCaml = [
"and","as","assert","asr","begin","class",
"constraint","do","done","downto","else","end",
"exception","external","false","for","fun","function",
"functor","if","in","include","inherit","initializer",
"land","lazy","let","list","lor","lsl","lsr",
"lxor","match","method","mod","module","mutable",
"new","object","of","open","or","private",
"rec","sig","struct","then","to","true",
"try","type","val","virtual","when","while","with"]
mkTuple :: [String] -> String
mkTuple [] = ""
mkTuple [x] = x
mkTuple (x:xs) = "(" ++ foldl (\acc e -> acc ++ "," +++ e) x xs ++ ")"
insertBar :: [String] -> [String]
insertBar [] = []
insertBar [x] = [" " ++ x]
insertBar (x:xs) = (" " ++ x ) : map (" | " ++) xs
mutualDefs :: [String] -> [String]
mutualDefs defs = case defs of
[] -> []
[d] -> ["let rec" +++ d]
d:ds -> ("let rec" +++ d) : map ("and" +++) ds
BNFC-2.8.1/src/BNFC/Backend/OCaml/CFtoOCamlShow.hs0000644000000000000000000001155012654616013017213 0ustar0000000000000000{-
BNF Converter: Non-pretty-printer generator (no "deriving Show" in OCaml...)
Copyright (C) 2005 Author: Kristofer Johannisson
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
-- there is no "deriving Show" in OCaml, although there are solutions based
-- on camlp4. Here we generate our own "show module".
module BNFC.Backend.OCaml.CFtoOCamlShow (cf2show) where
import BNFC.CF
import BNFC.Utils
import Data.List (intersperse)
import Data.Char(toLower)
import BNFC.Backend.OCaml.OCamlUtil
cf2show :: String -> String -> CF -> String
cf2show name absMod cf = unlines [
prologue name absMod,
integerRule cf,
doubleRule cf,
if hasIdent cf then identRule cf else "",
unlines [ownPrintRule cf own | (own,_) <- tokenPragmas cf],
rules cf
]
prologue :: String -> String -> String
prologue _ absMod = unlines [
"(* show functions generated by the BNF converter *)\n",
"open " ++ absMod,
"",
"(* use string buffers for efficient string concatenations *)",
"type showable = Buffer.t -> unit",
"",
"let show (s : showable) : string = ",
" let init_size = 16 in (* you may want to adjust this *)",
" let b = Buffer.create init_size in",
" s b;",
" Buffer.contents b",
" ",
"let emptyS : showable = fun buf -> ()",
"",
"let c2s (c:char) : showable = fun buf -> Buffer.add_char buf c",
"let s2s (s:string) : showable = fun buf -> Buffer.add_string buf s",
"",
"let ( >> ) (s1 : showable) (s2 : showable) : showable = fun buf -> s1 buf; s2 buf",
"",
"let showChar (c:char) : showable = fun buf -> ",
" Buffer.add_string buf (\"'\" ^ Char.escaped c ^ \"'\")",
"",
"let showString (s:string) : showable = fun buf -> ",
" Buffer.add_string buf (\"\\\"\" ^ String.escaped s ^ \"\\\"\")",
"",
"let showList (showFun : 'a -> showable) (xs : 'a list) : showable = fun buf -> ",
" let rec f ys = match ys with",
" [] -> ()",
" | [y] -> showFun y buf",
" | y::ys -> showFun y buf; Buffer.add_string buf \"; \"; f ys ",
" in",
" Buffer.add_char buf '[';",
" f xs;",
" Buffer.add_char buf ']'",
""
]
integerRule _ = "let showInt (i:int) : showable = s2s (string_of_int i)"
doubleRule _ = "let showFloat (f:float) : showable = s2s (string_of_float f)"
identRule cf = ownPrintRule cf (Cat "Ident")
ownPrintRule cf own = unlines $ [
"let rec" +++ showsFun own +++ "(" ++ show own ++ posn ++ ") : showable = s2s \""
++ show own ++ " \" >> showString i"
]
where
posn = if isPositionCat cf own then " (_,i)" else " i"
-- copy and paste from CFtoTemplate
rules :: CF -> String
rules cf = unlines $ mutualDefs $
map (\(s,xs) -> case_fun s (map toArgs xs)) $ cf2data cf -- ++ ifList cf s
where
toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)),
ruleOf cons)
names [] _ = []
names (x:xs) n
| elem x xs = (x ++ show n) : names xs (n+1)
| otherwise = x : names xs n
var (ListCat c) = var c ++ "s"
var (Cat "Ident") = "id"
var (Cat "Integer") = "n"
var (Cat "String") = "str"
var (Cat "Char") = "c"
var (Cat "Double") = "d"
var cat = map toLower (show cat)
checkRes s
| elem s reservedOCaml = s ++ "'"
| otherwise = s
ruleOf s = maybe undefined id $ lookupRule s (rulesOfCF cf)
--- case_fun :: Cat -> [(Constructor,Rule)] -> String
case_fun cat xs = unlines [
-- "instance Print" +++ cat +++ "where",
showsFun cat +++ "(e:" ++ fixType cat ++ ") : showable = match e with",
unlines $ insertBar $ map (\ ((c,xx),r) ->
" " ++ c +++ mkTuple xx +++ "->" +++
"s2s" +++ show c +++
case mkRhs xx (snd r) of {[] -> []; str -> ">> c2s ' ' >> " ++ str}
)
xs
]
mkRhs args its =
case unwords (intersperse " >> s2s \", \" >> " (mk args its)) of
[] -> ""
str -> "c2s '(' >> " ++ str ++ " >> c2s ')'"
where
mk args (Left InternalCat : items) = mk args items
mk (arg:args) (Left c : items) = (showsFun c +++ arg) : mk args items
mk args (Right _ : items) = mk args items
mk _ _ = []
showsFun :: Cat -> String
showsFun c = case c of
ListCat t -> "showList" +++ showsFun t
_ -> "show" ++ (fixTypeUpper $ normCat c)
BNFC-2.8.1/src/BNFC/Backend/OCaml/CFtoOCamlYacc.hs0000644000000000000000000002033412654616013017152 0ustar0000000000000000{-
BNF Converter: ocamlyacc Generator
Copyright (C) 2005 Author: Kristofer Johannisson
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
-- based on BNFC Haskell backend
module BNFC.Backend.OCaml.CFtoOCamlYacc
(
cf2ocamlyacc, terminal
)
where
import BNFC.CF
import Data.List (intersperse,nub)
import Data.Char
import BNFC.Utils ((+++))
import BNFC.Backend.OCaml.OCamlUtil
-- Type declarations
type Pattern = String
type Action = String
type MetaVar = String
-- The main function, that given a CF
-- generates a ocamlyacc module.
cf2ocamlyacc :: String -> String -> String -> CF -> String
cf2ocamlyacc name absName lexName cf
= unlines
[header name absName lexName cf,
declarations absName cf,
"%%",
rules cf
]
header :: String -> String -> String -> CF -> String
header _ absName _ cf = unlines
["/* This ocamlyacc file was machine-generated by the BNF converter */",
"%{",
"open " ++ absName,
"open Lexing",
"",
definedRules cf,
"%}"
]
definedRules :: CF -> String
definedRules cf = unlines [mkDef f xs e | FunDef f xs e <- pragmasOfCF cf]
where
mkDef f xs e =
"let " ++ f ++ " " ++ mkTuple xs ++ " = " ++ ocamlExp e
where
ocamlExp :: Exp -> String
ocamlExp (App s es) = s ++ ' ' : mkTuple (map ocamlExp es)
ocamlExp (LitInt i) = show i
ocamlExp (LitDouble d) = show d
ocamlExp (LitChar c) = "\'" ++ c : "\'"
ocamlExp (LitString s) = "\"" ++ s ++ "\""
declarations :: String -> CF -> String
declarations absName cf = unlines
[tokens (symbols cf) (reservedWords cf),
specialTokens cf,
entryPoints absName cf
]
tokens :: [String] -> [String] -> String
tokens symbols reswords = unlines
[
if (length reswords) > 0
then "%token" +++ concat (intersperse " " (map ("TOK_" ++) reswords))
else ""
,
concatMap (\(s,n) -> "\n%token SYMB" ++ (show n) +++ "/*" +++ s +++ "*/")
(zip symbols [1..])
]
-- | map a CF terminal into a ocamlyacc token
terminal :: CF -> String -> String
terminal cf s | s `elem` reservedWords cf = "TOK_" ++ s
terminal cf s = case lookup s (zip (symbols cf) [1..]) of
Just i -> "SYMB" ++ show i
Nothing -> error $ "CFtoOCamlYacc: terminal " ++ show s ++ " not defined in CF."
-- | map a CF nonterminal into a ocamlyacc symbol
nonterminal :: Cat -> String
nonterminal c = map spaceToUnderscore (fixType c)
where spaceToUnderscore ' ' = '_'
spaceToUnderscore x = x
specialTokens :: CF -> String
specialTokens cf = unlines ("%token TOK_EOF" : map aux (nub $ ["Ident","String","Integer","Double","Char"] ++ map show (literals cf)))
where aux cat = "%token" +++ (case cat of
"Ident" -> ""
"String" -> ""
"Integer" -> ""
"Double" -> ""
"Char" -> ""
_ -> "" )
+++ "TOK_" ++ cat
entryPoints :: String -> CF -> String
entryPoints absName cf = unlines $
("%start" +++
concat (intersperse " " (map epName eps)))
:
(map typing eps)
where eps = (nub $ map normCat (allEntryPoints cf))
typing :: Cat -> String
typing c = "%type" +++ "<" ++ qualify c ++ ">" +++ epName c
qualify c = if c `elem` [ TokenCat "Integer", TokenCat "Double", TokenCat "Char",
TokenCat "String", ListCat (TokenCat "Integer"),
ListCat (TokenCat "Double"),
ListCat (TokenCat "Char"),
ListCat (TokenCat "String") ]
then fixType c
else absName ++ "." ++ fixType c
epName :: Cat -> String
epName c = "p" ++ capitalize (nonterminal c)
where capitalize s = case s of
[] -> []
c:cs -> toUpper c : cs
entryPointRules :: CF -> String
entryPointRules cf = unlines $ map mkRule (nub $ map normCat (allEntryPoints cf))
where
mkRule :: Cat -> String
mkRule s = unlines [
epName s ++ " : " ++ nonterminal s ++ " TOK_EOF { $1 }",
" | error { raise (BNFC_Util.Parse_error (Parsing.symbol_start_pos (), Parsing.symbol_end_pos ())) };"
]
rules :: CF -> String
rules cf = unlines [
entryPointRules cf,
(unlines $ map (prOne . mkOne) (ruleGroups cf)),
specialRules cf
]
where
mkOne (cat,rules) = constructRule cf rules cat
prOne (_,[]) = [] -- nt has only internal use
prOne (nt,((p,a):ls)) =
unwords [nt', ":" , p, "{", a, "}", "\n" ++ pr ls] ++ ";\n"
where
nt' = nonterminal nt
pr [] = []
pr ((p,a):ls) =
unlines [(concat $ intersperse " " [" |", p, "{", a , "}"])] ++ pr ls
-- For every non-terminal, we construct a set of rules. A rule is a sequence of
-- terminals and non-terminals, and an action to be performed
-- As an optimization, a pair of list rules [C] ::= "" | C k [C]
-- is left-recursivized into [C] ::= "" | [C] C k.
-- This could be generalized to cover other forms of list rules.
constructRule :: CF -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])
constructRule cf rules nt = (nt,[(p,generateAction nt (funRule r) (mkFlip b m)) |
r0 <- rules,
let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs
then (True,revSepListRule r0)
else (False,r0),
let (p,m) = generatePatterns cf r])
where
revs = reversibleCats cf
mkFlip doit xs = case xs of
a:b:rest | doit -> b:a:rest
_ -> xs
-- Generates a string containing the semantic action.
-- An action can for example be: Sum $1 $2, that is, construct an AST
-- with the constructor Sum applied to the two metavariables $1 and $2.
generateAction :: NonTerminal -> Fun -> [MetaVar] -> Action
generateAction _ f ms = (if isCoercion f then "" else f') +++ mkTuple ms
where f' = case f of -- ocaml cons is somehow not a standard infix oper, right?
"(:[])" -> "(fun x -> [x])"
"(:)" -> "(fun (x,xs) -> x::xs)"
_ -> f
generatePatterns :: CF -> Rule -> (Pattern,[MetaVar])
generatePatterns cf r = case rhsRule r of
[] -> ("/* empty */",[])
its -> (unwords (map mkIt its), metas its)
where
mkIt i = case i of
Left c -> nonterminal c
Right s -> terminal cf s
metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its]
revIf c m = if (not (isConsFun (funRule r)) && elem c revs)
then ("(List.rev " ++ m ++ ")")
else m -- no reversal in the left-recursive Cons rule itself
revs = reversibleCats cf
specialRules :: CF -> String
specialRules cf = unlines $
map aux (literals cf)
where
aux cat =
case cat of
TokenCat "Ident" -> "ident : TOK_Ident { Ident $1 };"
TokenCat "String" -> "string : TOK_String { $1 };"
TokenCat "Integer" -> "int : TOK_Integer { $1 };"
TokenCat "Double" -> "float : TOK_Double { $1 };"
TokenCat "Char" -> "char : TOK_Char { $1 };"
own -> (fixType own) ++ " : TOK_" ++ show own ++
" { " ++ show own ++ " ("++ posn ++ "$1)};"
-- PCC: take "own" as type name? (manual says newtype)
where -- ignore position categories for now
posn = "" -- if isPositionCat cf cat then "mkPosToken " else ""
BNFC-2.8.1/src/BNFC/Backend/OCaml/CFtoOCamlTest.hs0000644000000000000000000000643712654616013017222 0ustar0000000000000000{-
BNF Converter: Generate main/test module for OCaml
Copyright (C) 2005 Author: Kristofer Johannisson
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.OCaml.CFtoOCamlTest where
import Text.PrettyPrint
import BNFC.CF
import BNFC.Backend.OCaml.OCamlUtil
-- | OCaml comment
-- >>> comment "I'm a comment"
-- (* I'm a comment *)
comment :: Doc -> Doc
comment d = "(*" <+> d <+> "*)"
-- | OCaml String concatenation
-- >>> "print a" <^> doubleQuotes "abc"
-- print a ^ "abc"
a <^> b = a <+> "^" <+> b
-- | Generate a test program in OCaml
ocamlTestfile :: String -> String -> String -> String -> String -> CF -> Doc
ocamlTestfile absM lexM parM printM showM cf =
let
lexerName = text lexM <> ".token"
parserName = text parM <> ".p" <> topTypeC
printerName =
text printM <> ".printTree " <> text printM <> ".prt" <> topTypeC
showFun =
parens ("fun x ->" <+> text showM <> ".show"
<+> parens (text showM <> ".show" <> topTypeC <+> "x"))
topTypeC = text $ fixTypeUpper (firstEntry cf)
topType = text absM <> "." <> text (fixType (firstEntry cf))
in vcat
[ comment "automatically generated by the BNF Converter"
, ""
, "open Lexing"
, ""
, "let parse (c : in_channel) :" <+> topType <+> "="
, nest 4 (parserName <+> lexerName <+> "(Lexing.from_channel c)")
, ";;"
, ""
, "let showTree (t : " <> topType <> ") : string ="
, nest 4 (fsep ( punctuate "^"
[ doubleQuotes "[Abstract syntax]\\n\\n"
, showFun <+> "t"
, doubleQuotes "\\n\\n"
, doubleQuotes "[Linearized tree]\\n\\n"
, printerName <+> "t"
, doubleQuotes "\\n" ] ) )
, ";;"
, ""
, "let main () ="
, nest 4 $ vcat
[ "let channel ="
, nest 4 $ vcat
[ "if Array.length Sys.argv > 1 then open_in Sys.argv.(1)"
, "else stdin" ]
, "in"
, "try"
, nest 4 $ vcat
[ "print_string (showTree (parse channel));"
, "flush stdout;"
, "exit 0"]
, "with BNFC_Util.Parse_error (start_pos, end_pos) ->"
, nest 4 $ vcat
[ "Printf.printf \"Parse error at %d.%d-%d.%d\\n\""
, nest 4 $ vcat
[ "start_pos.pos_lnum (start_pos.pos_cnum - start_pos.pos_bol)"
, "end_pos.pos_lnum (end_pos.pos_cnum - end_pos.pos_bol);" ]
, "exit 1" ]]
, ";;"
, ""
, "main ();;" ]
BNFC-2.8.1/src/BNFC/Backend/OCaml/CFtoOCamlAbs.hs0000644000000000000000000000463312654616013017004 0ustar0000000000000000{-
BNF Converter: OCaml Abstract Syntax Generator
Copyright (C) 2005 Author: Kristofer Johannisson
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
-- based on BNFC Haskell backend
module BNFC.Backend.OCaml.CFtoOCamlAbs (cf2Abstract) where
import Text.PrettyPrint
import BNFC.CF
import BNFC.Utils((+++))
import Data.List(intersperse)
import BNFC.Backend.OCaml.OCamlUtil
-- to produce an OCaml module
cf2Abstract :: String -> CF -> String
cf2Abstract _ cf = unlines $
"(* OCaml module generated by the BNF converter *)\n\n" :
mutualRecDefs (map (prSpecialData cf) (specialCats cf) ++ map prData (cf2data cf))
-- allow mutual recursion so that we do not have to sort the type definitions in
-- dependency order
mutualRecDefs :: [String] -> [String]
mutualRecDefs ss = case ss of
[] -> []
[x] -> ["type" +++ x]
x:xs -> ("type" +++ x) : map ("and" +++) xs
prData :: Data -> String
prData (cat,rules) =
fixType cat +++ "=\n " ++
concat (intersperse "\n | " (map prRule rules)) ++
"\n"
prRule (fun,[]) = fun
prRule (fun,cats) = fun +++ "of" +++ render (mkTupleType cats)
-- | Creates an OCaml type tuple by intercalating * between type names
-- >>> mkTupleType [Cat "A"]
-- a
--
-- >>> mkTupleType [Cat "A", Cat "Abc", Cat "S"]
-- a * abc * s
mkTupleType :: [Cat] -> Doc
mkTupleType = hsep . intersperse (char '*') . map (text . fixType)
prSpecialData :: CF -> Cat -> String
prSpecialData cf cat = fixType cat +++ "=" +++ show cat +++ "of" +++ contentSpec cf cat
-- unwords ["newtype",cat,"=",cat,contentSpec cf cat,"deriving (Eq,Ord,Show)"]
contentSpec :: CF -> Cat -> String
contentSpec cf cat = -- if isPositionCat cf cat then "((Int,Int),String)" else "String"
if isPositionCat cf cat then "((int * int) * string)" else "string"
BNFC-2.8.1/src/BNFC/Backend/HaskellProfile/0000755000000000000000000000000012654616013016156 5ustar0000000000000000BNFC-2.8.1/src/BNFC/Backend/HaskellProfile/CFtoHappyProfile.hs0000644000000000000000000001715512654616013021701 0ustar0000000000000000{-
BNF Converter: Happy Generator
Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.HaskellProfile.CFtoHappyProfile
(
cf2HappyProfileS
)
where
import BNFC.CF
--import Lexer
import Data.List (intersperse)
-- Type declarations
type Rules = [(NonTerminal,[(Pattern,Action)])]
type Pattern = String
type Action = String
type MetaVar = String
-- default naming
tokenName = "Token"
-- The main function, that given a CF and a CFCat to parse according to,
-- generates a happy module.
cf2HappyProfileS :: String -> String -> String -> String -> CFP -> String
cf2HappyProfileS = cf2Happy
cf2Happy :: String -> String -> String -> String -> CFP -> String
cf2Happy name absName lexName errName cf
= unlines
[header name absName lexName errName,
declarations (allEntryPoints cf),
tokens (symbols cf ++ reservedWords cf),
specialToks cf,
delimiter,
specialRules cf,
prRules (rulesForHappy cf),
finalize cf]
-- construct the header.
header :: String -> String -> String -> String -> String
header modName _ lexName errName = unlines
["-- This Happy file was machine-generated by the BNF converter",
"{",
"module " ++ modName ++ " where",
---- "import " ++ absName,
"import Trees",
"import " ++ lexName,
"import " ++ errName,
"}"
]
-- The declarations of a happy file.
declarations :: [Cat] -> String
declarations ns = unlines
[generateP ns,
"%monad { Err } { thenM } { returnM }",
"%tokentype { " ++ tokenName ++ " }"]
where generateP [] = []
generateP (n:ns) = concat ["%name p",n'," ",n',"\n",generateP ns]
where n' = identCat n
-- The useless delimiter symbol.
delimiter :: String
delimiter = "\n%%\n"
-- Generate the list of tokens and their identifiers.
tokens :: [String] -> String
tokens toks = "%token \n" ++ prTokens toks
where prTokens [] = []
prTokens (t:tk) = " " ++ (convert t) ++
" { " ++ oneTok t ++ " }\n" ++
prTokens tk
oneTok t = "PT _ (TS " ++ show t ++ ")"
-- Happy doesn't allow characters such as åäö to occur in the happy file. This
-- is however not a restriction, just a naming paradigm in the happy source file.
convert :: String -> String
convert "\\" = concat ['\'':"\\\\","\'"]
convert xs = concat ['\'':(escape xs),"\'"]
where escape [] = []
escape ('\'':xs) = '\\':'\'':escape xs
escape (x:xs) = x:escape xs
rulesForHappy :: CFP -> Rules
rulesForHappy cf = map mkOne $ ruleGroupsP cf where
mkOne (cat,rules) = constructRule cf rules cat
-- For every non-terminal, we construct a set of rules. A rule is a sequence of
-- terminals and non-terminals, and an action to be performed
-- As an optimization, a pair of list rules [C] ::= "" | C k [C]
-- is left-recursivized into [C] ::= "" | [C] C k.
-- This could be generalized to cover other forms of list rules.
constructRule :: CFP -> [RuleP] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])
constructRule cf rules nt = (nt,[(p,generateAction nt (revF b r) m) |
r0 <- rules,
let (b,r) = if isConsFun (funRuleP r0) && elem (valCat r0) revs
then (True,revSepListRule r0)
else (False,r0),
let (p,m) = generatePatterns cf r])
where
---- left rec optimization does not work yet
revF _ r = ---- if b then ("flip " ++ funRuleP r) else (funRuleP r)
funRule r
revs = reversibleCats cf
-- Generates a string containing the semantic action.
-- An action can for example be: Sum $1 $2, that is, construct an AST
-- with the constructor Sum applied to the two metavariables $1 and $2.
generateAction :: NonTerminal -> FunP -> [MetaVar] -> Action
generateAction _ (_,(h,p)) ms = unwords (if isCoercion h then args else fun ++ mss)
where
fun = ["mkFunTree",show h,show p]
mss = ["["] ++ intersperse "," ms ++ ["]"]
args = intersperse "," ms
-- Generate patterns and a set of metavariables indicating
-- where in the pattern the non-terminal
generatePatterns :: CFP -> RuleP -> (Pattern,[MetaVar])
generatePatterns cf r = case rhsRule r of
[] -> ("{- empty -}",[])
its -> (unwords (map mkIt its), metas its)
where
mkIt i = case i of
Left c -> identCat c
Right s -> convert s
metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its]
revIf c m = if (not (isConsFun (funRuleP r)) && elem c revs)
then ("(reverse " ++ m ++ ")")
else m -- no reversal in the left-recursive Cons rule itself
revs = reversibleCats cf
-- We have now constructed the patterns and actions,
-- so the only thing left is to merge them into one string.
prRules :: Rules -> String
prRules = unlines . map prOne
where
prOne (_,[]) = [] -- nt has only internal use
prOne (nt,(p,a):ls) =
unwords [nt', "::", "{", "CFTree", "}\n" ++
nt', ":" , p, "{", a, "}", '\n' : pr ls] ++ "\n"
where
nt' = identCat nt
pr [] = []
pr ((p,a):ls) =
unlines [(concat $ intersperse " " [" |", p, "{", a , "}"])] ++ pr ls
-- Finally, some haskell code.
finalize :: CFP -> String
finalize _ = unlines
[
"{",
"\nreturnM :: a -> Err a",
"returnM = return",
"\nthenM :: Err a -> (a -> Err b) -> Err b",
"thenM = (>>=)",
"\nhappyError :: [" ++ tokenName ++ "] -> Err a",
"happyError ts =",
" Bad $ \"syntax error at \" ++ tokenPos ts ++ " ++
"if null ts then [] else " ++
"(\" before \" ++ " ++ "unwords (map prToken (take 4 ts)))",
"\nmyLexer = tokens",
"}"
]
-- aarne's modifs 8/1/2002:
-- Markus's modifs 11/02/2002
-- GF literals
specialToks :: CFP -> String
specialToks cf = unlines $
(map aux (literals cf))
where aux cat =
case cat of
Cat "Ident" -> "L_ident { PT _ (TV $$) }"
Cat "String" -> "L_quoted { PT _ (TL $$) }"
Cat "Integer" -> "L_integ { PT _ (TI $$) }"
Cat "Double" -> "L_doubl { PT _ (TD $$) }"
Cat "Char" -> "L_charac { PT _ (TC $$) }"
own -> "L_" ++ show own ++ " { PT _ (T_" ++ show own ++ " " ++ posn ++ ") }"
where
posn = if isPositionCat cf cat then "_" else "$$"
specialRules :: CFP -> String
specialRules cf = unlines $
map aux (literals cf)
where
aux cat =
case cat of
Cat "Ident" -> "Ident : L_ident { mkAtTree (AV (Ident $1)) }"
Cat "String" -> "String : L_quoted { mkAtTree (AS $1) }"
Cat "Integer" -> "Integer : L_integ { mkAtTree (AI ((read $1) :: Integer)) }"
Cat "Double" -> "Double : L_doubl { (read $1) :: Double }" ----
Cat "Char" -> "Char : L_charac { (read $1) :: Char }" ----
own -> show own ++ " : L_" ++ show own ++ " { " ++ show own ++ " ("++ posn ++ "$1)}"
where
posn = if isPositionCat cf cat then "mkPosToken " else ""
BNFC-2.8.1/src/BNFC/Backend/CSharp/0000755000000000000000000000000012654616013014432 5ustar0000000000000000BNFC-2.8.1/src/BNFC/Backend/CSharp/CAbstoCSharpVisitSkeleton.hs0000644000000000000000000001024012654616013021763 0ustar0000000000000000{-
BNF Converter: C# Visit Skeleton Generator
Copyright (C) 2006 Author: Johan Broberg
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the C# Visit Skeleton.
The generated file uses the Visitor design pattern.
Author : Johan Broberg (johan@pontemonti.com)
License : GPL (GNU General Public License)
Created : 30 November, 2006
Modified : 21 January, 2007 by Johan Broberg
**************************************************************
-}
module BNFC.Backend.CSharp.CAbstoCSharpVisitSkeleton (cabs2csharpvisitskeleton) where
import BNFC.Utils ((+++))
import Data.List
import BNFC.Backend.Common.OOAbstract hiding (basetypes)
import BNFC.Backend.CSharp.CSharpUtils
--Produces .cs file
cabs2csharpvisitskeleton :: Namespace -> CAbs -> String
cabs2csharpvisitskeleton namespace cabs = unlines [
"/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/",
"/* This implements the common visitor design pattern. To make sure that",
" compile errors occur when code in the Visitor don't match the abstract",
" syntaxt, the \"abstract visit skeleton\" is used.",
" ",
" Replace the R and A parameters with the desired return",
" and context types.*/",
"",
"namespace " ++ namespace ++ ".VisitSkeleton",
"{",
" #region Classes",
unlinesInlineMap (prCon namespace) (signatures cabs),
" #endregion",
" ",
" #region Token types",
unlinesInlineMap (prBasic namespace) (tokentypes cabs),
" #endregion",
"}"
]
prBasic namespace c = unlinesInline [
" public class " ++ c ++ "Visitor : Abstract" ++ c ++ "Visitor",
" {",
" public override R Visit(" ++ identifier namespace (typename c) +++ varname c ++ ", A arg)",
" {",
" /* Code for " ++ c ++ " Goes Here */",
" return default(R);",
" }",
" }"
]
prCon :: Namespace -> (String, [CAbsRule]) -> String
prCon namespace (c,fs) = unlinesInline [
" public class " ++ c ++ "Visitor : Abstract" ++ c ++ "Visitor",
" {",
unlinesInlineMap (prVisit namespace) (map cabsrule2csharpabsrule fs),
" }"
]
prVisit :: Namespace -> CSharpAbsRule -> String
prVisit namespace (f,cs) = unlinesInline [
" public override R Visit(" ++ identifier namespace f +++ varname f ++ ", A arg)",
" {",
" /* Code For " ++ f ++ " Goes Here */",
unlinesInline $ map (prVisitArg namespace (varname f)) cs,
" return default(R);",
" }"
]
prVisitArg :: Namespace -> String -> (String, Bool, VariableName, PropertyName) -> String
prVisitArg namespace vname (cat, _, var, prop)
| cat `elem` (map fst basetypes) = " // " ++ vname ++ "." ++ prop
-- var /= "list_" is a dummy fix to make sure that a category named "List" doesn't get interpreted as a List.
-- this isn't very good though, and should be fixed somehow.
| "list" `isPrefixOf` var && var /= "list_" = listAccept
| otherwise = " " ++ vname ++ "." ++ prop ++ ".Accept(new " ++ cat ++ "Visitor(), arg);"
where
listtype = typename (drop 4 cat)
listAccept = unlinesInline [
" foreach(" ++ identifier namespace listtype ++ " x in " ++ vname ++ "." ++ prop ++ ")",
" {",
if listtype `notElem` (map snd basetypes)
then " x.Accept(new " ++ listtype ++ "Visitor(), arg);"
else " // x",
" }"
]
BNFC-2.8.1/src/BNFC/Backend/CSharp/RegToGPLEX.hs0000644000000000000000000000454012654616013016611 0ustar0000000000000000module BNFC.Backend.CSharp.RegToGPLEX (printRegGPLEX) where
-- modified from RegToFlex
import AbsBNF
-- the top-level printing method
printRegGPLEX :: Reg -> String
printRegGPLEX = render . prt 0
-- you may want to change render and parenth
render :: [String] -> String
render = rend (0::Int) where
rend i ss = case ss of
"[" :ts -> cons "[" $ rend i ts
"(" :ts -> cons "(" $ rend i ts
t : "," :ts -> cons t $ space "," $ rend i ts
t : ")" :ts -> cons t $ cons ")" $ rend i ts
t : "]" :ts -> cons t $ cons "]" $ rend i ts
t :ts -> space t $ rend i ts
_ -> ""
cons s t = s ++ t
space t s = if null s then t else t ++ s
parenth :: [String] -> [String]
parenth ss = ["("] ++ ss ++ [")"]
-- the printer class does the job
class Print a where
prt :: Int -> a -> [String]
prtList :: [a] -> [String]
prtList = concat . map (prt 0)
instance Print a => Print [a] where
prt _ = prtList
instance Print Char where
prt _ c = [[c]]
prtList s = map (concat . prt 0) s
prPrec :: Int -> Int -> [String] -> [String]
prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])
RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])
RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])
RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])
RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])
ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])
REps -> prPrec i 3 (["[^.]"])
RChar c -> prPrec i 3 (prt 0 [mkEsc [c]])
RAlts str -> prPrec i 3 (concat [["["], prt 0 $ mkEsc str, ["]"]])
RSeqs str -> prPrec i 2 (concat (map (prt 0) $ mkEsc str))
RDigit -> prPrec i 3 (concat [["{digit}"]])
RLetter -> prPrec i 3 (concat [["{alpha}"]])
RUpper -> prPrec i 3 (concat [["{alphaCapital}"]])
RLower -> prPrec i 3 (concat [["{alphaSmall}"]])
RAny -> prPrec i 3 (concat [["."]])
-- Handle special characters in regular expressions.
mkEsc :: String -> String
mkEsc = concatMap escChar
where
escChar c
| c `elem` ("$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" :: String) = '\\':[c]
| otherwise = [c]
BNFC-2.8.1/src/BNFC/Backend/CSharp/CAbstoCSharpAbstractVisitSkeleton.hs0000644000000000000000000000675612654616013023470 0ustar0000000000000000{-
BNF Converter: C# Abstract Visit Skeleton Generator
Copyright (C) 2006 Author: Johan Broberg
Modified from BNFC.Backend.CSharp.CAbstoCSharpVisitSkeleton
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates an Abstract Visit Skeleton for C#.
This can be useful if you often make changes to your
grammar and want to keep your own changes (not having to
merge with the new visit skeleton each time), while still
getting compile errors if your code is no longer correct.
The generated file uses the Visitor design pattern.
This could have been generated from within
CAbstoVisitSkeleton, but that would have made it more
difficult to actually use it (and the visit skeleton).
Author : Johan Broberg (johan@pontemonti.com)
License : GPL (GNU General Public License)
Created : 19 December, 2006
Modified : 19 December, 2006 by Johan Broberg
**************************************************************
-}
module BNFC.Backend.CSharp.CAbstoCSharpAbstractVisitSkeleton (cabs2csharpAbstractVisitSkeleton) where
import BNFC.CF
import BNFC.Utils ((+++))
import BNFC.Backend.Common.OOAbstract hiding (basetypes)
import BNFC.Backend.CSharp.CSharpUtils
--Produces .cs file
cabs2csharpAbstractVisitSkeleton :: Namespace -> CAbs -> String
cabs2csharpAbstractVisitSkeleton namespace cabs = unlines [
"/*** BNFC-Generated Abstract Visitor Design Pattern Skeleton. ***/",
"/* This implements the common visitor design pattern.",
" Replace the R and A parameters with the desired return",
" and context types.*/",
"",
"namespace " ++ namespace ++ ".VisitSkeleton",
"{",
" #region Classes",
unlinesInlineMap (prCon namespace) (signatures cabs),
" #endregion",
" ",
" #region Token types",
unlinesInlineMap (prBasic namespace) (tokentypes cabs),
" #endregion",
"}"
]
prBasic namespace c = unlinesInline [
" public abstract class Abstract" ++ c ++ "Visitor : " ++ identifier namespace c ++ ".Visitor",
" {",
" public abstract R Visit(" ++ identifier namespace (typename c) +++ varname c ++ ", A arg);",
" }"
]
prCon :: Namespace -> (String, [CAbsRule]) -> String
prCon namespace (c,fs) = unlinesInline [
" public abstract class Abstract" ++ c ++ "Visitor : " ++ identifier namespace c ++ ".Visitor",
" {",
unlinesInlineMap (prVisit namespace) fs,
" }"
]
prVisit :: Namespace -> (Fun, [(String, Bool, String)]) -> String
prVisit namespace (f,_) = unlinesInline [
" public abstract R Visit(" ++ identifier namespace f +++ varname f ++ ", A arg);"
]
BNFC-2.8.1/src/BNFC/Backend/CSharp/CFtoGPLEX.hs0000644000000000000000000002216612654616013016430 0ustar0000000000000000{-
BNF Converter: C# GPLEX Generator
Copyright (C) 2006 Author: Johan Broberg
Modified from CFtoFlex
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the GPLEX file.
Author : Johan Broberg (johan@pontemonti.com)
License : GPL (GNU General Public License)
Created : 23 November, 2006
Modified : 17 December, 2006 by Johan Broberg
**************************************************************
-}
module BNFC.Backend.CSharp.CFtoGPLEX (cf2gplex) where
import BNFC.CF
import BNFC.Backend.CSharp.RegToGPLEX
import BNFC.Backend.Common.NamedVariables
import Data.List
import BNFC.Backend.CSharp.CSharpUtils
--The environment must be returned for the parser to use.
cf2gplex :: Namespace -> CF -> (String, SymEnv)
cf2gplex namespace cf = (unlines [
prelude namespace,
cMacros,
prettyprinter $ (lexSymbols env) ++ (gplex namespace cf env'),
"%%"
], env')
where
env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int)
env' = env ++ (makeSymEnv (tokenNames cf) (length env))
-- GPPG doesn't seem to like tokens beginning with an underscore, so they (the underscores, nothing else) have been removed.
makeSymEnv [] _ = []
makeSymEnv (s:symbs) n = (s, "SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1))
prelude :: Namespace -> String
prelude namespace = unlines [
"/* This GPLex file was machine-generated by the BNF converter */",
"",
"%namespace " ++ namespace,
"",
"%{",
" /// ",
" /// Buffer for escaped characters in strings.",
" /// ",
" private System.Text.StringBuilder strBuffer = new System.Text.StringBuilder();",
"",
" /// ",
" /// Change to enable output - useful for debugging purposes",
" /// ",
" public bool Trace = false;",
"",
" /// ",
" /// Culture-independent IFormatProvider for numbers. ",
" /// This is just a \"wrapper\" for System.Globalization.NumberFormatInfo.InvariantInfo.",
" /// ",
" /// ",
" /// This should be used when parsing numbers. Otherwise the parser might fail: ",
" /// culture en-US uses a dot as decimal separator, while for example sv-SE uses a comma. ",
" /// BNFC uses dot as decimal separator for Double values, so if your culture is sv-SE ",
" /// the parse will fail if this InvariantInfo isn't used.",
" /// ",
" private static System.Globalization.NumberFormatInfo InvariantFormatInfo = System.Globalization.NumberFormatInfo.InvariantInfo;",
"",
" /// ",
" /// Convenience method to create scanner AND initialize it correctly.",
" /// As long as you don't want to enable trace output, this is all you ",
" /// need to call and give to the parser to be able to parse.",
" /// ",
" public static Scanner CreateScanner(Stream stream)",
" {",
" Scanner scanner = new Scanner(stream);",
" scanner.Begin();",
" return scanner;",
" }",
"",
" /// ",
" /// Sets the scanner to the correct initial state (YYINITIAL). ",
" /// You should call this method prior to calling parser.Parse().",
" /// ",
" public void Begin()",
" {",
" BEGIN(YYINITIAL);",
" }",
"",
" /// ",
" /// Convenience method to \"reset\" the buffer for escaped characters in strings.",
" /// ",
" private void BufferReset()",
" {",
" this.strBuffer = new System.Text.StringBuilder();",
" }",
"",
"%}",
""
]
--For now all categories are included.
--Optimally only the ones that are used should be generated.
cMacros :: String
cMacros = unlines
[
"alpha [a-zA-Z]",
"alphaCapital [A-Z]",
"alphaSmall [a-z]",
"digit [0-9]",
"ident [a-zA-Z0-9'_]",
-- start states, must be defined one at a time
"%s YYINITIAL",
"%s COMMENT",
"%s CHAR",
"%s CHARESC",
"%s CHAREND",
"%s STRING",
"%s ESCAPED",
"%%"
]
lexSymbols :: SymEnv -> [(String, String)]
lexSymbols ss = map transSym ss
where
transSym (s,r) =
("\"" ++ s' ++ "\"" , "if(Trace) System.Console.Error.WriteLine(yytext); return (int)Tokens." ++ r ++ ";")
where
s' = escapeChars s
gplex :: Namespace -> CF -> SymEnv -> [(String, String)]
gplex namespace cf env = concat [
lexComments (comments cf),
userDefTokens,
ifC catString strStates,
ifC catChar charStates,
ifC catDouble [("{digit}+\".\"{digit}+(\"e\"(\\-)?{digit}+)?" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.double_ = Double.Parse(yytext, InvariantFormatInfo); return (int)Tokens.DOUBLE_;")],
ifC catInteger [("{digit}+" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.int_ = Int32.Parse(yytext, InvariantFormatInfo); return (int)Tokens.INTEGER_;")],
ifC catIdent [("{alpha}{ident}*" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.string_ = yytext; return (int)Tokens.IDENT_;")],
[("[ \\t\\r\\n\\f]" , "/* ignore white space. */;")],
[("." , "return (int)Tokens.error;")]
]
where
ifC cat s = if isUsedCat cf cat then s else []
userDefTokens = map tokenline (tokenPragmas cf)
where
tokenline (name, exp) = ("" ++ printRegGPLEX exp , action name)
action n = "if(Trace) System.Console.Error.WriteLine(yytext); yylval." ++ varName (show$normCat n) ++ " = new " ++ identifier namespace (show n) ++ "(yytext); return (int)Tokens." ++ sName n ++ ";"
sName n = case lookup (show n) env of
Just x -> x
Nothing -> show n
-- These handle escaped characters in Strings.
strStates = [
("\"\\\"\"" , "BEGIN(STRING);"),
("\\\\" , "BEGIN(ESCAPED);"),
("\\\"" , "yylval.string_ = this.strBuffer.ToString(); BufferReset(); BEGIN(YYINITIAL); return (int)Tokens.STRING_;"),
("." , "this.strBuffer.Append(yytext);"),
("n" , "this.strBuffer.Append(\"\\n\"); BEGIN(STRING);"),
("\\\"" , "this.strBuffer.Append(\"\\\"\"); BEGIN(STRING);"),
("\\\\" , "this.strBuffer.Append(\"\\\\\"); BEGIN(STRING);"),
("t" , "this.strBuffer.Append(\"\\t\"); BEGIN(STRING);"),
("." , "this.strBuffer.Append(yytext); BEGIN(STRING);")
]
-- These handle escaped characters in Chars.
charStates = [
("\"'\"" , "BEGIN(CHAR);"),
("\\\\" , "BEGIN(CHARESC);"),
("[^']" , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"),
("n" , "BEGIN(CHAREND); yylval.char_ = '\\n'; return (int)Tokens.CHAR_;"),
("t" , "BEGIN(CHAREND); yylval.char_ = '\\t'; return (int)Tokens.CHAR_;"),
("." , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"),
("\"'\"" , "BEGIN(YYINITIAL);")
]
lexComments :: ([(String, String)], [String]) -> [(String, String)]
lexComments (m,s) = (map lexSingleComment s) ++ (concatMap lexMultiComment m)
lexSingleComment :: String -> (String, String)
lexSingleComment c =
("\"" ++ c ++ "\"[^\\n]*\\n" , "/* BNFC single-line comment */;")
--There might be a possible bug here if a language includes 2 multi-line comments.
--They could possibly start a comment with one character and end it with another.
--However this seems rare.
lexMultiComment :: (String, String) -> [(String, String)]
lexMultiComment (b,e) = [
("\"" ++ b ++ "\"" , "BEGIN(COMMENT);"),
("\"" ++ e ++ "\"" , "BEGIN(YYINITIAL);"),
("." , "/* BNFC multi-line comment */;"),
("[\\n]" , "/* BNFC multi-line comment */;")
]
-- Used to print the lexer rules; makes sure that all rules are equally indented, to make the GPLEX file a little more readable.
prettyprinter :: [(String, String)] -> String
prettyprinter xs = unlines $ map prettyprinter' xs
where
padlength = 1 + (last $ sort $ map length $ map fst xs)
prettyprinter' (x, y) = x ++ replicate (padlength - length x) ' ' ++ y
BNFC-2.8.1/src/BNFC/Backend/CSharp/CSharpUtils.hs0000644000000000000000000001325312654616013017173 0ustar0000000000000000{-
BNF Converter: Utility Functions for C#
Copyright (C) 2006 Author: Johan Broberg
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module provides utility functions for the
C# format.
Author : Johan Broberg (johan@pontemonti.com)
License : GPL (GNU General Public License)
Created : 23 November, 2006
Modified : 21 January, 2007 by Johan Broberg
**************************************************************
-}
module BNFC.Backend.CSharp.CSharpUtils where
import BNFC.CF
import Data.Char (toLower)
import Data.List
import BNFC.Backend.Common.OOAbstract hiding (basetypes)
type Namespace = String
--The visit-function name of a basic type
visitFunName :: String -> String
visitFunName v =
if "integer_" `isPrefixOf` v then "Integer"
else if "char_" `isPrefixOf` v then "Char"
else if "string_" `isPrefixOf` v then "String"
else if "double_" `isPrefixOf` v then "Double"
else if "ident_" `isPrefixOf` v then "Ident"
else "Ident" --User-defined type
isUserDefined :: String -> Bool
isUserDefined v = v `notElem` (map classVar (map fst basetypes))
basetypes = [
("Integer","int"),
("Char", "char"),
("Double", "double"),
("String", "string"),
("Ident", "string")
]
typename :: String -> String
typename name
| name == "Char" = "char"
| name == "Double" = "double"
| name == "Ident" = "string"
| name == "Integer" = "int"
| name == "String" = "string"
| otherwise = name
-- Creates a variable name.
-- To make sure that no reserved keyword is generated, an underscore is added at the end. Not very pretty, but effective.
varname :: String -> String
varname name = (map toLower name) ++ "_"
-- Given a variable name (in an abstract syntax class), returns ".ToString()" if the name doesn't match one of the basetypes.
toString :: String -> String
toString v = if isUserDefined v then ".ToString()" else ""
-- Prepends namespace ".Absyn." to typ unless it is one of the basetypes
identifier :: Namespace -> String -> String
identifier namespace typ
| typ `elem` (map snd basetypes) = typ
| otherwise = namespace ++ ".Absyn." ++ typ
-- Removes empty lines, and removes the line-break at the end.
-- This can be useful if you want to use unlines "inside" unlines and don't want a whole lot of "useless" line-breaks.
unlinesInline :: [String] -> String
unlinesInline xs = concat $ intersperse "\n" $ filter (\x -> x /= "") xs
unlinesInlineMap :: (a -> String) -> [a] -> String
unlinesInlineMap fun xs = unlinesInline $ intersperse " " $ filter (\x -> x /= "") $ map fun xs
--Helper function that escapes characters in strings
escapeChars :: String -> String
escapeChars [] = []
escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))
escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))
escapeChars (x:xs) = x : (escapeChars xs)
isAlsoCategory :: Fun -> String -> Bool
isAlsoCategory f c = f == c
flattenSignatures :: CAbs -> [(String, CSharpAbsRule)]
flattenSignatures cabs = [(c,r) | (c,rs) <- signatures cabs, r <- map cabsrule2csharpabsrule rs]
type VariableName = String
type PropertyName = String
-- Just like CAbsRule in OOAbstract, except this also has PropertyName.
-- (valcat,(constr,args)), True = is class (not basic), class variable stored
type CSharpAbsRule = (Fun,[(String,Bool,VariableName,PropertyName)])
cabsrule2csharpabsrule :: CAbsRule -> CSharpAbsRule
cabsrule2csharpabsrule (f, cabsrule) = (f, addPropertyNames cabsrule)
-- This generates names for properties. It's done the same way as generation of variable names in OOAbstract->cf2cabs
-- A property name uses the same casing as its category, but has an underscore at the end
addPropertyNames :: [(String, Bool, String)] -> [(String, Bool, VariableName, PropertyName)]
addPropertyNames cs = [(c,b,v,p) | ((c,b,v),p) <- zip cs (properties [] (map propertyName [c | (c,_,_) <- cs]))]
--- creating new names is quadratic, but parameter lists are short
--- this should conform with Michael's naming
where
properties seen vv = case vv of
[] -> vv
v:vs -> case length (filter (==v) seen) of
0 | elem v vs -> (v ++ "1"): properties (v:seen) vs
0 -> v : properties (v:seen) vs
n -> (v ++ show (n+1)) : properties (v:seen) vs
propertyName :: String -> PropertyName
propertyName c = c ++ "_"
-- Given a rule's definition, it goes through and nicely the properties by type.
-- Does the same thing as numVars in NamedVariables, except the varName part
numProps :: [(String, Int)] -> [Either Cat b] -> [Either String b]
numProps _env [] = []
numProps env ((Right f) : fs) = (Right f) : (numProps env fs)
numProps env ((Left f) : fs) =
case lookup f' env of
Nothing -> (Left f') : (numProps ((f',1):env) fs)
Just n -> (Left $ f' ++ (show $ n + 1)) : (numProps ((f',n+1):env) fs)
where
f' = propertyName (identCat (normCat f))
BNFC-2.8.1/src/BNFC/Backend/CSharp/CAbstoCSharpAbs.hs0000644000000000000000000002103512654616013017671 0ustar0000000000000000{-
BNF Converter: C# Abstract Syntax Generator
Copyright (C) 2006-2007 Author: Johan Broberg
Modified from CFtoSTLAbs
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the C# Abstract Syntax
tree classes. It uses the Visitor design
pattern.
Author : Johan Broberg (johan@pontemonti.com)
License : GPL (GNU General Public License)
Created : 22 November, 2006
Modified : 21 January, 2007 by Johan Broberg
**************************************************************
-}
module BNFC.Backend.CSharp.CAbstoCSharpAbs (cabs2csharpabs) where
import BNFC.Backend.Common.OOAbstract
import BNFC.CF
import BNFC.Utils((+++))
import Data.List
import Data.Maybe
import BNFC.Backend.CSharp.CSharpUtils
--The result is one file (.cs)
cabs2csharpabs :: Namespace -> CAbs -> Bool -> String
cabs2csharpabs namespace cabs useWCF = unlinesInline [
"//C# Abstract Syntax Interface generated by the BNF Converter.",
-- imports
"using System;",
if useWCF then "using System.Runtime.Serialization;" else "",
"using System.Collections.Generic;",
"namespace " ++ namespace ++ ".Absyn",
"{",
" #region Token Classes",
prTokenBaseType useWCF,
unlinesInlineMap (prToken namespace useWCF) (tokentypes cabs),
" #endregion",
" ",
" #region Abstract Syntax Classes",
unlinesInlineMap (prAbs namespace useWCF) abstractclasses,
" ",
unlinesInlineMap (prCon namespace useWCF) (flattenSignatures cabs),
" ",
" #region Lists",
unlinesInlineMap (prList namespace) (listtypes cabs),
" #endregion",
" #endregion",
"}"
]
where
-- an abstract class is a category which does not contain rules
abstractclasses = [ (cat, (map fst cabsrules)) | (cat, cabsrules) <- signatures cabs, cat `notElem` (map fst cabsrules) ]
-- auxiliaries
prDataContract :: Bool -> [String] -> String
prDataContract False _ = ""
prDataContract True [] = " [DataContract]"
prDataContract True funs = unlinesInline [
prDataContract True [],
unlinesInline $ map prDataContract' funs
]
where
prDataContract' :: String -> String
prDataContract' fun = " [KnownType(typeof(" ++ fun ++ "))]"
prDataMember :: Bool -> String
prDataMember False = ""
prDataMember True = " [DataMember]"
prTokenBaseType :: Bool -> String
prTokenBaseType useWCF = unlinesInline [
prDataContract useWCF [],
" public class TokenBaseType",
" {",
prDataMember useWCF,
" private string str;",
" ",
" public TokenBaseType(string str)",
" {",
" this.str = str;",
" }",
" ",
" public override string ToString()",
" {",
" return this.str;",
" }",
" }",
" "
]
prToken :: Namespace -> Bool -> String -> String
prToken namespace useWCF name = unlinesInline [
prDataContract useWCF [],
" public class " ++ name ++ " : " ++ identifier namespace "TokenBaseType",
" {",
" public " ++ name ++ "(string str) : base(str)",
" {",
" }",
prAccept namespace name Nothing,
prVisitor namespace [name],
prEquals namespace name ["ToString()"],
prHashCode namespace name ["ToString()"],
" }"
]
prAbs :: Namespace -> Bool -> (String, [String]) -> String
prAbs namespace useWCF (cat, funs) = unlinesInline [
prDataContract useWCF funs,
" public abstract class " ++ cat,
" {",
" public abstract R Accept(" ++ identifier namespace cat ++ ".Visitor v, A arg);",
prVisitor namespace funs,
" }"
]
prVisitor :: Namespace -> [String] -> String
prVisitor namespace funs = unlinesInline [
" ",
" public interface Visitor",
" {",
unlinesInline (map prVisitFun funs),
" }"
]
where
prVisitFun f = " R Visit(" ++ identifier namespace f ++ " p, A arg);"
prCon :: Namespace -> Bool -> (String,CSharpAbsRule) -> String
prCon namespace useWCF (c,(f,cs)) = unlinesInline [
prDataContract useWCF [],
" public class " ++ f ++ ext,
" {",
-- Instance variables
unlines [prInstVar typ var | (typ,_,var,_) <- cs],
prConstructor namespace (f,cs),
unlinesInline [prProperty typ var prop | (typ,_,var,prop) <- cs],
prEquals namespace f propnames,
prHashCode namespace f propnames,
-- print Accept method, override keyword needed for classes inheriting an abstract class
prAccept namespace c (if isAlsoCategory f c then Nothing else (Just " override")),
-- if this label is also a category, we need to print the Visitor interface
-- (if not, it was already printed in the abstract class)
if isAlsoCategory f c then prVisitor namespace [c] else "",
" }"
]
where
-- This handles the case where a LBNF label is the same as the category.
ext = if isAlsoCategory f c then "" else " : " ++ identifier namespace (identCat $ strToCat c)
propnames = [prop | (_, _, _, prop) <- cs]
prInstVar typ var = unlinesInline [
" private " ++ identifier namespace (typename typ) +++ var ++ ";"
]
prProperty typ var prop = unlinesInline [
" ",
prDataMember useWCF,
" public " ++ identifier namespace (typename typ) +++ prop,
" {",
" get",
" {",
" return this." ++ var ++ ";",
" }",
" set",
" {",
" this." ++ var ++ " = value;",
" }",
" }"
]
-- Creates the Equals() methods
prEquals :: Namespace -> Fun -> [String] -> String
prEquals namespace c vars = unlinesInline [
" ",
" public override bool Equals(Object obj)",
" {",
" if(this == obj)",
" {",
" return true;",
" }",
" if(obj is " ++ identifier namespace c ++ ")",
" {",
" return this.Equals((" ++ identifier namespace c ++ ")obj);",
" }",
" return base.Equals(obj);",
" }",
" ",
" public bool Equals(" ++ identifier namespace c ++ " obj)",
" {",
" if(this == obj)",
" {",
" return true;",
" }",
" return " ++ prEqualsVars vars ++ ";",
" }"
]
where
prEqualsVars [] = "true"
prEqualsVars vs = concat $ intersperse " && " $ map equalVar vs
equalVar v = "this." ++ v ++ ".Equals(obj." ++ v ++ ")"
-- Creates the GetHashCode() method.
prHashCode :: Namespace -> Fun -> [String] -> String
prHashCode _ _ vars = unlinesInline [
" ",
" public override int GetHashCode()",
" {",
" return " ++ prHashVars vars ++ ";",
" }"
]
where
aPrime = 37
prHashVars [] = show aPrime
prHashVars (v:vs) = prHashVars' (hashVar v) vs
prHashVars' r [] = r
prHashVars' r (v:vs) = prHashVars' (show aPrime ++ "*" ++ "(" ++ r ++ ")+" ++ hashVar v) vs
hashVar var = "this." ++ var ++ ".GetHashCode()"
prList :: Namespace -> (String,Bool) -> String
prList namespace (c,_) = unlinesInline [
" public class " ++ c ++ " : List<" ++ identifier namespace (typename bas) ++ ">",
" {",
" }"
]
where
bas = drop 4 c -- drop List
-- The standard Accept method for the Visitor pattern
prAccept :: Namespace -> String -> Maybe String -> String
prAccept namespace cat maybeOverride = unlinesInline [
" ",
" public" ++ fromMaybe "" maybeOverride ++ " R Accept(" ++ identifier namespace cat ++ ".Visitor visitor, A arg)",
" {",
" return visitor.Visit(this, arg);",
" }"
]
-- The constructor assigns the parameters to the corresponding instance variables.
prConstructor :: Namespace -> CSharpAbsRule -> String
prConstructor namespace (f,cs) = unlinesInline [
" public " ++ f ++ "(" ++ conargs ++ ")",
" {",
unlinesInline [" " ++ c ++ " = " ++ p ++ ";" | (c,p) <- zip cvs pvs],
" }"
]
where
cvs = [c | (_,_,c,_) <- cs]
pvs = ["p" ++ show i | ((_,_,_,_),i) <- zip cs [1..]]
conargs = concat $ intersperse ", "
[identifier namespace (typename x) +++ v | ((x,_,_,_),v) <- zip cs pvs]
BNFC-2.8.1/src/BNFC/Backend/CSharp/CFtoCSharpPrinter.hs0000644000000000000000000003365612654616013020303 0ustar0000000000000000{-
BNF Converter: C# Pretty Printer Generator
Copyright (C) 2006 Author: Johan Broberg
Modified from CFtoSTLPrinter
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the C# Pretty Printer.
It also generates the "show" method for
printing an abstract syntax tree.
Author : Johan Broberg (johan@pontemonti.com)
License : GPL (GNU General Public License)
Created : 26 November, 2006
Modified : 21 January, 2007 by Johan Broberg
**************************************************************
-}
module BNFC.Backend.CSharp.CFtoCSharpPrinter (cf2csharpprinter) where
import BNFC.CF
import BNFC.Utils ((+++))
import BNFC.Backend.Common.NamedVariables
import Data.List
import Data.Char(toLower)
import Data.Maybe
import BNFC.Backend.CSharp.CSharpUtils
--Produces .cs file
cf2csharpprinter :: Namespace -> CF -> String
cf2csharpprinter namespace cf = unlinesInline [
header namespace cf,
" ",
entrypoints namespace cf,
" ",
" #region (Internal) Print Methods",
unlinesInlineMap (prData namespace user) groups,
" #endregion",
" ",
" #region (Internal) Show Methods",
unlinesInlineMap (shData namespace user) groups,
" #endregion",
" }",
" #endregion",
"}"
]
where
groups = fixCoercions (ruleGroupsInternals cf)
user = [n | (n,_) <- tokenPragmas cf]
header :: Namespace -> CF -> String
header namespace cf = unlinesInline [
"/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/",
" ",
-- imports
"using System;",
"using System.Text; // for StringBuilder",
"using " ++ namespace ++ ".Absyn;",
" ",
"namespace " ++ namespace,
"{",
" #region Pretty-printer class",
" public class PrettyPrinter",
" {",
" #region Misc rendering functions",
" // You may wish to change these:",
" private const int BUFFER_INITIAL_CAPACITY = 2000;",
" private const int INDENT_WIDTH = 2;",
" private const string LEFT_PARENTHESIS = \"(\";",
" private const string RIGHT_PARENTHESIS = \")\";",
" private static System.Globalization.NumberFormatInfo InvariantFormatInfo = System.Globalization.NumberFormatInfo.InvariantInfo;",
" ",
" private static int _n_ = 0;",
" private static StringBuilder buffer = new StringBuilder(BUFFER_INITIAL_CAPACITY);",
" ",
" //You may wish to change render",
" private static void Render(String s)",
" {",
" if(s == \"{\")",
" {",
" buffer.Append(\"\\n\");",
" Indent();",
" buffer.Append(s);",
" _n_ = _n_ + INDENT_WIDTH;",
" buffer.Append(\"\\n\");",
" Indent();",
" }",
" else if(s == \"(\" || s == \"[\")",
" buffer.Append(s);",
" else if(s == \")\" || s == \"]\")",
" {",
" Backup();",
" buffer.Append(s);",
" buffer.Append(\" \");",
" }",
" else if(s == \"}\")",
" {",
" int t;",
" _n_ = _n_ - INDENT_WIDTH;",
" for(t=0; t 0)",
" {",
" buffer.Append(' ');",
" n--;",
" }",
" }",
" ",
" private static void Backup()",
" {",
" if(buffer[buffer.Length - 1] == ' ')",
" {",
" buffer.Length = buffer.Length - 1;",
" }",
" }",
" ",
" private static void Trim()",
" {",
" while(buffer.Length > 0 && buffer[0] == ' ')",
" buffer.Remove(0, 1); ",
" while(buffer.Length > 0 && buffer[buffer.Length-1] == ' ')",
" buffer.Remove(buffer.Length-1, 1);",
" }",
" ",
" private static string GetAndReset()",
" {",
" Trim();",
" string strReturn = buffer.ToString();",
" Reset();",
" return strReturn;",
" }",
" ",
" private static void Reset()",
" {",
" buffer.Remove(0, buffer.Length);",
" }",
" #endregion"
]
prToken :: Namespace -> String -> String
prToken namespace token = unlinesInline [
" private static void PrintInternal(" ++ identifier namespace token ++ " token, int _i_)",
" {",
" buffer.Append('\\\"');",
" buffer.Append(token.ToString());",
" buffer.Append('\\\"');",
" }"
]
shToken :: Namespace -> String -> String
shToken namespace token = unlinesInline [
" private static void ShowInternal(" ++ identifier namespace token ++ " token)",
" {",
" Render(token.ToString());",
" }"
]
entrypoints :: Namespace -> CF -> String
entrypoints namespace cf = unlinesInline [
" #region Print Entry Points",
unlinesInlineMap prEntryPoint (allCats cf),
" #endregion",
" ",
" #region Show Entry Points",
unlinesInlineMap shEntryPoint (allCats cf),
" #endregion"
]
where
prEntryPoint cat | (normCat cat) == cat = unlinesInline [
" public static string Print(" ++ identifier namespace (identCat cat) ++ " cat)",
" {",
" PrintInternal(cat, 0);",
" return GetAndReset();",
" }"
]
prEntryPoint _ = ""
shEntryPoint cat | (normCat cat) == cat = unlinesInline [
" public static String Show(" ++ identifier namespace (identCat cat) ++ " cat)",
" {",
" ShowInternal(cat);",
" return GetAndReset();",
" }"
]
shEntryPoint _ = ""
prData :: Namespace -> [UserDef] -> (Cat, [Rule]) -> String
prData namespace user (cat, rules)
-- list
| isList cat = unlinesInline [
" private static void PrintInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p, int _i_)",
" {",
(prList user cat rules),
" }"
]
-- not a list
| otherwise = unlinesInline [
" private static void PrintInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p, int _i_)",
" {",
-- first rule starts with "if", the rest of them start with "else if".
-- this isn't very pretty, but does the job and produces nice code.
prRule namespace Nothing firstRule,
unlinesInline $ map (prRule namespace (Just "else ")) otherRules,
" }"
]
where
-- Removes the rules at the beginning of the list which won't be used by the prRule function.
rules' = dropWhile (\r -> isCoercion (funRule r) || isDefinedRule (funRule r)) rules
firstRule = head rules'
otherRules = tail rules'
prRule :: Namespace -> Maybe String -> Rule -> String
prRule namespace maybeElse r@(Rule fun _c cats)
| not (isCoercion fun || isDefinedRule fun) = unlinesInline [
" " ++ fromMaybe "" maybeElse ++ "if(p is " ++ identifier namespace fun ++ ")",
" {",
" " ++ identifier namespace fun +++ fnm ++ " = (" ++ identifier namespace fun ++ ")p;",
" if(_i_ > " ++ (show p) ++ ") Render(LEFT_PARENTHESIS);",
cats',
" if(_i_ > " ++ (show p) ++ ") Render(RIGHT_PARENTHESIS);",
" }"
]
where
p = precRule r
cats' = case cats of
[] -> ""
_ -> unlinesInline $ map (prCat fnm) (zip (fixOnes (numProps [] cats)) (map getPrec cats))
fnm = '_' : map toLower fun
getPrec (Right {}) = 0
getPrec (Left c) = precCat c
prRule _nm _ _ = ""
prList :: [UserDef] -> Cat -> [Rule] -> String
prList _ _ rules = unlinesInline [
" for(int i=0; i < p.Count; i++)",
" {",
" PrintInternal(p[i], 0);",
" if(i < p.Count - 1)",
" {",
" Render(\"" ++ escapeChars sep ++ "\");",
" }",
" else",
" {",
" Render(\"" ++ optsep ++ "\");",
" }",
" }"
]
where
sep = getCons rules
optsep = if hasOneFunc rules then "" else escapeChars sep
prCat fnm (c, p) =
case c of
Right t -> " Render(\"" ++ escapeChars t ++ "\");"
Left nt
| "string" `isPrefixOf` nt -> " PrintQuoted(" ++ fnm ++ "." ++ nt ++ ");"
| isInternalVar nt -> ""
| otherwise -> " PrintInternal(" ++ fnm ++ "." ++ nt ++ ", " ++ show p ++ ");"
--The following methods generate the Show function.
shData :: Namespace -> [UserDef] -> (Cat, [Rule]) -> String
shData namespace user (cat, rules)
| isList cat = unlinesInline [
" private static void ShowInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p)",
" {",
(shList user cat rules),
" }"
]
| otherwise = unlinesInline [
" private static void ShowInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p)",
" {",
unlinesInline $ map (shRule namespace) rules,
" }"
]
shRule :: Namespace -> Rule -> String
shRule namespace (Rule fun _c cats)
| not (isCoercion fun || isDefinedRule fun) = unlinesInline [
" if(p is " ++ identifier namespace fun ++ ")",
" {",
" " ++ identifier namespace fun +++ fnm ++ " = (" ++ identifier namespace fun ++ ")p;",
lparen,
" Render(\"" ++ (escapeChars fun) ++ "\");",
cats',
rparen,
" }"
]
where
cats' | allTerms cats = ""
| otherwise = unlinesInline $ map (shCat fnm) (fixOnes (numProps [] cats))
lparen | allTerms cats = ""
| otherwise = " Render(\"(\");"
rparen | allTerms cats = ""
| otherwise = " Render(\")\");"
allTerms [] = True
allTerms ((Left {}):_) = False
allTerms (_:zs) = allTerms zs
fnm = '_' : map toLower fun
shRule _nm _ = ""
shList :: [UserDef] -> Cat -> [Rule] -> String
shList _ _ _rules = unlinesInline [
" for(int i=0; i < p.Count; i++)",
" {",
" ShowInternal(p[i]);",
" if(i < p.Count - 1)",
" Render(\",\");",
" }"
]
shCat fnm c =
case c of
Right {} -> ""
Left nt
| "list" `isPrefixOf` nt -> unlinesInline [
" Render(\"[\");",
" ShowInternal(" ++ fnm ++ "." ++ nt ++ ");",
" Render(\"]\");"
]
| isInternalVar nt -> ""
| otherwise -> " ShowInternal(" ++ fnm ++ "." ++ nt ++ ");"
isInternalVar x = x == show InternalCat ++ "_"
BNFC-2.8.1/src/BNFC/Backend/CSharp/CFtoGPPG.hs0000644000000000000000000002302112654616013016275 0ustar0000000000000000{-
BNF Converter: C# GPPG Generator
Copyright (C) 2006 Author: Johan Broberg
Modified from CFtoBisonSTL.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the GPPG input file.
Author : Johan Broberg (johan@pontemonti.com)
License : GPL (GNU General Public License)
Created : 24 November, 2006
Modified : 17 December, 2006 by Johan Broberg
**************************************************************
-}
module BNFC.Backend.CSharp.CFtoGPPG (cf2gppg) where
import BNFC.CF
import Data.List (intersperse)
import BNFC.Backend.Common.NamedVariables hiding (varName)
import Data.Char (toLower)
import BNFC.Utils ((+++))
import BNFC.TypeChecker
import ErrM
import BNFC.Backend.Common.OOAbstract hiding (basetypes)
import BNFC.Backend.CSharp.CSharpUtils
--This follows the basic structure of CFtoHappy.
-- Type declarations
type Rules = [(NonTerminal,[(Pattern,Action)])]
type Pattern = String
type Action = String
type MetaVar = String
--The environment comes from the CFtoGPLEX
cf2gppg :: Namespace -> CF -> SymEnv -> String
cf2gppg namespace cf env = unlines [
header namespace cf,
union namespace (positionCats cf ++ allCats cf ++ map strToCat (tokentypes (cf2cabs cf))),
tokens user env,
declarations cf,
"",
specialToks cf,
"",
"%%",
prRules (rulesForGPPG namespace cf env)
]
where
user = fst (unzip (tokenPragmas cf))
positionCats cf = filter (isPositionCat cf) $ fst (unzip (tokenPragmas cf))
header :: Namespace -> CF -> String
header namespace cf = unlines [
"/* This GPPG file was machine-generated by BNFC */",
"",
"%namespace " ++ namespace,
"%{",
definedRules namespace cf,
unlinesInline $ map (parseMethod namespace) (allCatsNorm cf ++ positionCats cf),
"%}"
]
definedRules :: Namespace -> CF -> String
definedRules _ cf = unlinesInline [
if null [ rule f xs e | FunDef f xs e <- pragmasOfCF cf ]
then ""
else error "Defined rules are not yet available in C# mode!"
]
where
ctx = buildContext cf
list = LC (const "[]") (\t -> "List" ++ unBase t)
where
unBase (ListT t) = unBase t
unBase (BaseT x) = show$normCat$strToCat x
rule f xs e =
case checkDefinition' list ctx f xs e of
Bad err -> error $ "Panic! This should have been caught already:\n" ++ err
Ok (_,(_,_)) -> unlinesInline [
"Defined Rule goes here"
]
--This generates a parser method for each entry point.
parseMethod :: Namespace -> Cat -> String
parseMethod namespace cat = unlinesInline [
" " ++ returntype +++ returnvar ++ " = null;",
" public " ++ returntype ++ " Parse" ++ cat' ++ "()",
" {",
" if(this.Parse())",
" {",
" return " ++ returnvar ++ ";",
" }",
" else",
" {",
" throw new Exception(\"Could not parse input stream!\");",
" }",
" }",
" "
]
where
cat' = identCat (normCat cat)
returntype = identifier namespace cat'
returnvar = resultName cat'
--The union declaration is special to GPPG/GPLEX and gives the type of yylval.
--For efficiency, we may want to only include used categories here.
union :: Namespace -> [Cat] -> String
union namespace cats = unlines $ filter (\x -> x /= "\n") [
"%union",
"{",
" public int int_;",
" public char char_;",
" public double double_;",
" public string string_;",
unlinesInline $ map catline cats,
"}"
]
where --This is a little weird because people can make [Exp2] etc.
catline cat | (identCat cat /= show cat) || ((normCat cat) == cat) =
" public " ++ identifier namespace (identCat (normCat cat)) +++ (varName (show$normCat cat)) ++ ";"
catline _ = ""
--declares non-terminal types.
declarations :: CF -> String
declarations cf = unlinesInline $ map (typeNT cf) (positionCats cf ++ allCats cf)
where --don't define internal rules
typeNT cf nt | (isPositionCat cf nt || rulesForCat cf nt /= []) = "%type <" ++ (varName (show$normCat nt)) ++ "> " ++ (show$normCat nt)
typeNT _ _ = ""
--declares terminal types.
tokens :: [UserDef] -> SymEnv -> String
tokens user ts = concatMap (declTok user) ts
where
declTok u (s,r) = if elem s (map show u)
then "%token<" ++ varName (show$normCat$strToCat s) ++ "> " ++ r ++ " // " ++ show s ++ "\n"
else "%token " ++ r ++ " // " ++ show s ++ "\n"
specialToks :: CF -> String
specialToks cf = unlinesInline [
ifC catString "%token STRING_",
ifC catChar "%token CHAR_",
ifC catInteger "%token INTEGER_",
ifC catDouble "%token DOUBLE_",
ifC catIdent "%token IDENT_"
]
where
ifC cat s = if isUsedCat cf cat then s else ""
--The following functions are a (relatively) straightforward translation
--of the ones in CFtoHappy.hs
rulesForGPPG :: Namespace -> CF -> SymEnv -> Rules
rulesForGPPG namespace cf env = (map mkOne $ ruleGroups cf) ++ posRules where
mkOne (cat,rules) = constructRule namespace cf env rules cat
posRules = map mkPos $ positionCats cf
mkPos cat = (cat, [(maybe (show cat) id (lookup (show cat) env),
"$$ = new " ++ show cat ++ "($1);")])
-- For every non-terminal, we construct a set of rules.
constructRule :: Namespace ->
CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])
constructRule namespace cf env rules nt =
(nt,[(p,(generateAction namespace nt (ruleName r) b m) +++ result) |
r0 <- rules,
let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs
then (True,revSepListRule r0)
else (False,r0),
let (p,m) = generatePatterns cf env r b])
where
ruleName r = case funRule r of
---- "(:)" -> identCat nt
---- "(:[])" -> identCat nt
z -> z
revs = reversibleCats cf
eps = allEntryPoints cf
isEntry nt = if elem nt eps then True else False
result = if isEntry nt then (resultName (identCat (normCat nt))) ++ "= $$;" else ""
-- Generates a string containing the semantic action.
-- This was copied from CFtoCup15, with only a few small modifications
generateAction :: Namespace -> NonTerminal -> Fun -> Bool -> [(MetaVar, Bool)]
-> Action
generateAction namespace nt f rev mbs
| isNilFun f = "$$ = new " ++ identifier namespace c ++ "();"
| isOneFun f = "$$ = new " ++ identifier namespace c ++ "(); $$.Add(" ++ p_1 ++ ");"
| isConsFun f && not rev = "$$ = " ++ p_2 ++ "; " ++ p_2 ++ ".Insert(0, " ++ p_1 ++ ");"
| isConsFun f && rev = "$$ = " ++ p_1 ++ "; " ++ p_1 ++ ".Add(" ++ p_2 ++ ");"
| isCoercion f = "$$ = " ++ p_1 ++ ";"
| isDefinedRule f = "$$ = " ++ f ++ "_" ++ "(" ++ concat (intersperse "," ms) ++ ");"
| otherwise = "$$ = new " ++ identifier namespace c ++ "(" ++ concat (intersperse "," ms) ++ ");"
where
c = if isNilFun f || isOneFun f || isConsFun f
then identCat (normCat nt) else f
ms = map fst mbs
p_1 = ms!!0
p_2 = ms!!1
-- Generate patterns and a set of metavariables indicating
-- where in the pattern the non-terminal
generatePatterns :: CF -> SymEnv -> Rule -> Bool -> (Pattern,[(MetaVar,Bool)])
generatePatterns cf env r _ = case rhsRule r of
[] -> ("/* empty */",[])
its -> (unwords (map mkIt its), metas its)
where
mkIt i = case i of
Left c -> case lookup (show c) env of
-- This used to be x, but that didn't work if we had a symbol "String" in env, and tried to use a normal String - it would use the symbol...
Just x | not (isPositionCat cf c) && (show c) `notElem` (map fst basetypes) -> x
_ -> typeName (identCat c)
Right s -> case lookup s env of
Just x -> x
Nothing -> s
metas its = [('$': show i,revert c) | (i,Left c) <- zip [1 :: Int ..] its]
-- notice: reversibility with push_back vectors is the opposite
-- of right-recursive lists!
revert c = (isList c) &&
not (isConsFun (funRule r)) && notElem c revs
revs = reversibleCats cf
-- We have now constructed the patterns and actions,
-- so the only thing left is to merge them into one string.
prRules :: Rules -> String
prRules [] = []
prRules ((_, []):rs) = prRules rs --internal rule
prRules ((nt,(p,a):ls):rs) =
(unwords [nt', ":" , p, "{ ", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs
where
nt' = identCat nt
pr [] = []
pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ ", a , "}"])]) ++ pr ls
--Some helper functions.
resultName :: String -> String
resultName s = "YY_RESULT_" ++ s ++ "_"
--slightly stronger than the NamedVariable version.
varName :: String -> String
varName s = (map toLower (identCat $ strToCat s)) ++ "_"
typeName :: String -> String
typeName "Ident" = "IDENT_"
typeName "String" = "STRING_"
typeName "Char" = "CHAR_"
typeName "Integer" = "INTEGER_"
typeName "Double" = "DOUBLE_"
typeName x = x
BNFC-2.8.1/src/BNFC/Backend/Haskell/0000755000000000000000000000000012654616013014635 5ustar0000000000000000BNFC-2.8.1/src/BNFC/Backend/Haskell/CFtoLayout.hs0000644000000000000000000002650212654616013017227 0ustar0000000000000000{-
BNF Converter: Layout handling Generator
Copyright (C) 2004 Author: Aarne Ranta
Copyright (C) 2005 Bjorn Bringert
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.Haskell.CFtoLayout where
import Data.List (sort)
import BNFC.CF
layoutOpen = "{"
layoutClose = "}"
layoutSep = ";"
cf2Layout :: Bool -> Bool -> String -> String -> CF -> String
cf2Layout alex1 _ layName lexName cf =
let
(top,lay,stop) = layoutPragmas cf
in unlines $ [
"module " ++ layName ++ " where",
"",
"import " ++ lexName,
if alex1 then "import Alex" else "",
"",
"import Data.Maybe (isNothing, fromJust)",
"",
"-- Generated by the BNF Converter",
"",
"-- local parameters",
"",
"",
"topLayout :: Bool",
"topLayout = " ++ show top,
"",
"layoutWords, layoutStopWords :: [String]",
"layoutWords = " ++ show lay,
"layoutStopWords = " ++ show stop,
"",
"-- layout separators",
"",
"",
"layoutOpen, layoutClose, layoutSep :: String",
"layoutOpen = " ++ show layoutOpen,
"layoutClose = " ++ show layoutClose,
"layoutSep = " ++ show layoutSep,
"",
"-- | Replace layout syntax with explicit layout tokens.",
"resolveLayout :: Bool -- ^ Whether to use top-level layout.",
" -> [Token] -> [Token]",
"resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit]",
" where",
" -- Do top-level layout if the function parameter and the grammar say so.",
" tl = tp && topLayout",
"",
" res :: Maybe Token -- ^ The previous token, if any.",
" -> [Block] -- ^ A stack of layout blocks.",
" -> [Token] -> [Token]",
"",
" -- The stack should never be empty.",
" res _ [] ts = error $ \"Layout error: stack empty. Tokens: \" ++ show ts",
"",
" res _ st (t0:ts)",
" -- We found an open brace in the input,",
" -- put an explicit layout block on the stack.",
" -- This is done even if there was no layout word,",
" -- to keep opening and closing braces.",
" | isLayoutOpen t0 = moveAlong (Explicit:st) [t0] ts",
"",
" -- We are in an implicit layout block",
" res pt st@(Implicit n:ns) (t0:ts)",
"",
" -- End of implicit block by a layout stop word",
" | isStop t0 =",
" -- Exit the current block and all implicit blocks",
" -- more indented than the current token",
" let (ebs,ns') = span (`moreIndent` column t0) ns",
" moreIndent (Implicit x) y = x > y",
" moreIndent Explicit _ = False",
" -- the number of blocks exited",
" b = 1 + length ebs",
" bs = replicate b layoutClose",
" -- Insert closing braces after the previous token.",
" (ts1,ts2) = splitAt (1+b) $ addTokens (afterPrev pt) bs (t0:ts)",
" in moveAlong ns' ts1 ts2",
"",
" -- End of an implicit layout block",
" | newLine pt t0 && column t0 < n = ",
" -- Insert a closing brace after the previous token.",
" let b:t0':ts' = addToken (afterPrev pt) layoutClose (t0:ts)",
" -- Repeat, with the current block removed from the stack",
" in moveAlong ns [b] (t0':ts')",
"",
" res pt st (t0:ts)",
" -- Start a new layout block if the first token is a layout word",
" | isLayout t0 =",
" case ts of",
" -- Explicit layout, just move on. The case above",
" -- will push an explicit layout block.",
" t1:_ | isLayoutOpen t1 -> moveAlong st [t0] ts",
" -- at end of file, the start column doesn't matter",
" _ -> let col = if null ts then column t0 else column (head ts)",
" -- insert an open brace after the layout word",
" b:ts' = addToken (nextPos t0) layoutOpen ts",
" -- save the start column",
" st' = Implicit col:st ",
" in -- Do we have to insert an extra layoutSep?",
" case st of",
" Implicit n:_",
" | newLine pt t0 && column t0 == n",
" && not (isNothing pt ||",
" isTokenIn [layoutSep,layoutOpen] (fromJust pt)) ->",
" let b':t0':b'':ts'' =",
" addToken (afterPrev pt) layoutSep (t0:b:ts')",
" in moveAlong st' [b',t0',b''] ts'",
" _ -> moveAlong st' [t0,b] ts'",
"",
" -- If we encounter a closing brace, exit the first explicit layout block.",
" | isLayoutClose t0 = ",
" let st' = drop 1 (dropWhile isImplicit st)",
" in if null st' ",
" then error $ \"Layout error: Found \" ++ layoutClose ++ \" at (\" ",
" ++ show (line t0) ++ \",\" ++ show (column t0) ",
" ++ \") without an explicit layout block.\"",
" else moveAlong st' [t0] ts",
"",
" -- Insert separator if necessary.",
" res pt st@(Implicit n:ns) (t0:ts)",
" -- Encounted a new line in an implicit layout block.",
" | newLine pt t0 && column t0 == n = ",
" -- Insert a semicolon after the previous token.",
" -- unless we are the beginning of the file,",
" -- or the previous token is a semicolon or open brace.",
" if isNothing pt || isTokenIn [layoutSep,layoutOpen] (fromJust pt)",
" then moveAlong st [t0] ts",
" else let b:t0':ts' = addToken (afterPrev pt) layoutSep (t0:ts)",
" in moveAlong st [b,t0'] ts'",
"",
" -- Nothing to see here, move along.",
" res _ st (t:ts) = moveAlong st [t] ts",
"",
" -- At EOF: skip explicit blocks.",
" res (Just t) (Explicit:bs) [] | null bs = []",
" | otherwise = res (Just t) bs []",
"",
" -- If we are using top-level layout, insert a semicolon after",
" -- the last token, if there isn't one already",
" res (Just t) [Implicit _n] []",
" | isTokenIn [layoutSep] t = []",
" | otherwise = addToken (nextPos t) layoutSep []",
"",
" -- At EOF in an implicit, non-top-level block: close the block",
" res (Just t) (Implicit _n:bs) [] =",
" let c = addToken (nextPos t) layoutClose []",
" in moveAlong bs c []",
"",
" -- This should only happen if the input is empty.",
" res Nothing _st [] = []",
"",
" -- | Move on to the next token.",
" moveAlong :: [Block] -- ^ The layout stack.",
" -> [Token] -- ^ Any tokens just processed.",
" -> [Token] -- ^ the rest of the tokens.",
" -> [Token]",
" moveAlong _ [] _ = error $ \"Layout error: moveAlong got [] as old tokens\"",
" moveAlong st ot ts = ot ++ res (Just $ last ot) st ts",
"",
" newLine :: Maybe Token -> Token -> Bool",
" newLine pt t0 = case pt of",
" Nothing -> True",
" Just t -> line t /= line t0",
"",
"data Block = Implicit Int -- ^ An implicit layout block with its start column.",
" | Explicit",
" deriving Show",
"",
"type Position = Posn",
"",
"-- | Check if s block is implicit.",
"isImplicit :: Block -> Bool",
"isImplicit (Implicit _) = True",
"isImplicit _ = False",
"",
"-- | Insert a number of tokens at the begninning of a list of tokens.",
"addTokens :: Position -- ^ Position of the first new token.",
" -> [String] -- ^ Token symbols.",
" -> [Token] -- ^ The rest of the tokens. These will have their",
" -- positions updated to make room for the new tokens .",
" -> [Token]",
"addTokens p ss ts = foldr (addToken p) ts ss",
"",
"-- | Insert a new symbol token at the begninning of a list of tokens.",
"addToken :: Position -- ^ Position of the new token.",
" -> String -- ^ Symbol in the new token.",
" -> [Token] -- ^ The rest of the tokens. These will have their",
" -- positions updated to make room for the new token.", " -> [Token]",
"addToken p s ts = sToken p s : map (incrGlobal p (length s)) ts",
"",
"-- | Get the position immediately to the right of the given token.",
"-- If no token is given, gets the first position in the file.",
"afterPrev :: Maybe Token -> Position",
"afterPrev = maybe (Pn 0 1 1) nextPos",
"",
"-- | Get the position immediately to the right of the given token.",
"nextPos :: Token -> Position",
"nextPos t = Pn (g + s) l (c + s + 1)",
" where Pn g l c = position t",
" s = tokenLength t",
"",
"-- | Add to the global and column positions of a token.",
"-- The column position is only changed if the token is on",
"-- the same line as the given position.",
"incrGlobal :: Position -- ^ If the token is on the same line",
" -- as this position, update the column position.",
" -> Int -- ^ Number of characters to add to the position.",
" -> Token -> Token",
"incrGlobal (Pn _ l0 _) i (PT (Pn g l c) t) =",
" if l /= l0 then PT (Pn (g + i) l c) t",
" else PT (Pn (g + i) l (c + i)) t",
"incrGlobal _ _ p = error $ \"cannot add token at \" ++ show p",
"",
"-- | Create a symbol token.",
"sToken :: Position -> String -> Token",
"sToken p s = PT p (TS s i)",
" where",
" i = case s of"] ++
[ " " ++ show s ++ " -> " ++ show i
| (s, i) <- zip resws [1..]
] ++
[" _ -> error $ \"not a reserved word: \" ++ show s",
"",
"-- | Get the position of a token.",
"position :: Token -> Position",
"position t = case t of",
" PT p _ -> p",
" Err p -> p",
"",
"-- | Get the line number of a token.",
"line :: Token -> Int",
"line t = case position t of Pn _ l _ -> l",
"",
"-- | Get the column number of a token.",
"column :: Token -> Int",
"column t = case position t of Pn _ _ c -> c",
"",
"-- | Check if a token is one of the given symbols.",
"isTokenIn :: [String] -> Token -> Bool",
"isTokenIn ts t = case t of",
" PT _ (TS r _) | elem r ts -> True",
" _ -> False",
"",
"-- | Check if a word is a layout start token.",
"isLayout :: Token -> Bool",
"isLayout = isTokenIn layoutWords",
"",
"-- | Check if a token is a layout stop token.",
"isStop :: Token -> Bool",
"isStop = isTokenIn layoutStopWords",
"",
"-- | Check if a token is the layout open token.",
"isLayoutOpen :: Token -> Bool",
"isLayoutOpen = isTokenIn [layoutOpen]",
"",
"-- | Check if a token is the layout close token.",
"isLayoutClose :: Token -> Bool",
"isLayoutClose = isTokenIn [layoutClose]",
"",
"-- | Get the number of characters in the token.",
"tokenLength :: Token -> Int",
"tokenLength t = length $ prToken t",
""
]
where
resws = sort (reservedWords cf ++ symbols cf)
BNFC-2.8.1/src/BNFC/Backend/Haskell/MkErrM.hs0000644000000000000000000000402612654616013016330 0ustar0000000000000000{-
BNF Converter: Haskell error monad
Copyright (C) 2004-2007 Author: Markus Forberg, Peter Gammie,
Aarne Ranta, Björn Bringert
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.Haskell.MkErrM where
errM :: String -> b -> String
errM errMod _ =
unlines
["-- BNF Converter: Error Monad"
,"-- Copyright (C) 2004 Author: Aarne Ranta"
,""
,"-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE."
,"module " ++ errMod ++ " where"
,""
,"-- the Error monad: like Maybe type with error msgs"
,""
,"import Control.Monad (MonadPlus(..), liftM)"
,"import Control.Applicative (Applicative(..), Alternative(..))"
,""
,"data Err a = Ok a | Bad String"
," deriving (Read, Show, Eq, Ord)"
,""
,"instance Monad Err where"
," return = Ok"
," fail = Bad"
," Ok a >>= f = f a"
," Bad s >>= _ = Bad s"
,""
,"instance Applicative Err where"
," pure = Ok"
," (Bad s) <*> _ = Bad s"
," (Ok f) <*> o = liftM f o"
,""
,""
,"instance Functor Err where"
," fmap = liftM"
,""
,"instance MonadPlus Err where"
," mzero = Bad \"Err.mzero\""
," mplus (Bad _) y = y"
," mplus x _ = x"
,""
,"instance Alternative Err where"
," empty = mzero"
," (<|>) = mplus"]BNFC-2.8.1/src/BNFC/Backend/Haskell/CFtoAlex.hs0000644000000000000000000001601112654616013016635 0ustar0000000000000000{-
BNF Converter: Alex 1.1 Generator
Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.Haskell.CFtoAlex (cf2alex) where
import BNFC.CF
import BNFC.Backend.Haskell.RegToAlex
import Data.List
cf2alex :: String -> String -> CF -> String
cf2alex name errMod cf = unlines $ intercalate [""] [
prelude name errMod,
cMacros,
rMacros cf,
restOfAlex cf
]
prelude :: String -> String -> [String]
prelude name errMod = [
"-- This Alex file was machine-generated by the BNF converter",
"%{",
"module " ++ name ++ " where",
"",
"import Alex",
"import " ++ errMod,
"%}"
]
{- ----
cf2alex :: String -> CF -> String
cf2alex name cf = unlines $ concat $ intersperse [""] [
prelude name,
cMacros,
rMacros cf,
restOfAlex cf
]
prelude :: String -> [String]
prelude name = [
"-- This Alex file was machine-generated by the BNF converter",
"%{",
"module Lex" ++ name ++ " where",
"",
"import Alex",
"import ErrM",
"%}"
]
-}
cMacros :: [String]
cMacros = [
"{ ^l = [a-zA-Z^192-^255] # [^215 ^247]} -- isolatin1 letter",
"{ ^c = [A-Z^192-^221] # [^215]} -- capital isolatin1 letter",
"{ ^s = [a-z^222-^255] # [^247]} -- small isolatin1 letter",
"{ ^d = [0-9] } -- digit",
"{ ^i = [^l^d^'^_] } -- identifier character",
"{ ^u = [^0-^255] } -- universal: any character"
]
rMacros :: CF -> [String]
rMacros cf =
let symbs = symbols cf
in
(if null symbs then [] else [
"{ %s = -- reserved words consisting of special symbols",
" " ++ unwords (intersperse "|" (map mkEsc symbs)),
"}"
])
where
mkEsc = unwords . map ( f . (:[]))
f s = if all isSpec s then '^':s else s
isSpec = flip elem ("$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" :: String)
restOfAlex :: CF -> [String]
restOfAlex cf = [
"\"tokens_lx\"/\"tokens_acts\":-",
lexComments (comments cf),
"<> ::= ^w+",
pTSpec (symbols cf,[]), -- modif Markus 12/02 - 2002
userDefTokenTypes,
identAndRes,
ifC catString " ::= ^\" ([^u # [^\"^\\^n]] | (^\\ (^\" | ^\\ | ^' | n | t)))* ^\"" ++
"%{ string p = PT p . TL . unescapeInitTail %}",
ifC catChar " ::= ^\' (^u # [^\'^\\] | ^\\ [^\\ ^\' n t]) ^' %{ char p = PT p . TC %}",
ifC catInteger " ::= ^d+ %{ int p = PT p . TI %}",
ifC catDouble
" ::= ^d+ ^. ^d+ (e (^-)? ^d+)? %{ double p = PT p . TD %}",
"",
"%{ ",
"",
"data Tok =",
" TS String -- reserved words",
" | TL String -- string literals",
" | TI String -- integer literals",
" | TV String -- identifiers",
" | TD String -- double precision float literals",
" | TC String -- character literals",
userDefTokenConstrs,
" deriving (Eq,Show)",
"",
"data Token = ",
" PT Posn Tok",
" | Err Posn",
" deriving Show",
"",
"tokenPos (PT (Pn _ l _) _ :_) = \"line \" ++ show l",
"tokenPos (Err (Pn _ l _) :_) = \"line \" ++ show l",
"tokenPos _ = \"end of file\"",
"",
"posLineCol (Pn _ l c) = (l,c)",
"mkPosToken t@(PT p _) = (posLineCol p, prToken t)",
"",
"prToken t = case t of",
" PT _ (TS s) -> s",
" PT _ (TI s) -> s",
" PT _ (TV s) -> s",
" PT _ (TD s) -> s",
" PT _ (TC s) -> s",
userDefTokenPrint,
" _ -> show t",
"",
"tokens:: String -> [Token]",
"tokens inp = scan tokens_scan inp",
"",
"tokens_scan:: Scan Token",
"tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx",
" where",
" stop_act p \"\" = []",
" stop_act p inp = [Err p]",
"",
"eitherResIdent :: (String -> Tok) -> String -> Tok",
"eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where",
" isResWord s = isInTree s $",
" " ++ show (sorted2tree $ sort resws),
"",
"data BTree = N | B String BTree BTree deriving (Show)",
"",
"isInTree :: String -> BTree -> Bool",
"isInTree x tree = case tree of",
" N -> False",
" B a left right",
" | x < a -> isInTree x left",
" | x > a -> isInTree x right",
" | x == a -> True",
"",
"unescapeInitTail :: String -> String",
"unescapeInitTail = unesc . tail where",
" unesc s = case s of",
" '\\\\':c:cs | elem c ['\\\"', '\\\\', '\\\''] -> c : unesc cs",
" '\\\\':'n':cs -> '\\n' : unesc cs",
" '\\\\':'t':cs -> '\\t' : unesc cs",
" '\"':[] -> []",
" c:cs -> c : unesc cs",
" _ -> []",
"%}"
]
where
ifC cat s = if isUsedCat cf cat then s else ""
lexComments ([],[]) = []
lexComments (xs,s1:ys) = "<> ::= " ++ ('^':intersperse '^' s1) ++ " [.]* ^n\n" ++ lexComments (xs,ys)
lexComments (([l1,l2],[r1,r2]):xs,[]) = concat
[
"<> ::= ",
'^':l1:' ':'^':l2:" ([^u # ^",
l2:"] | ^",
r1:" [^u # ^",
r2:"])* (^",
r1:")+ ^",
r2:"\n",
lexComments (xs,[])
]
lexComments (_ : xs, []) = lexComments (xs,[])
--- lexComments (xs,(_:ys)) = lexComments (xs,ys)
pTSpec ([],[]) = ""
pTSpec xp =
" ::= " ++ aux xp ++ "%{ pTSpec p = PT p . TS %}"
aux (_,[]) = " %s "
aux ([],_) = " %r "
aux (_,_) = " %s | %r "
userDefTokenTypes = unlines
[" ::= " ++ printRegAlex exp ++
"%{ mk_" ++ show name ++ " p = PT p . eitherResIdent T_" ++ show name ++ " %}"
| (name,exp) <- tokenPragmas cf]
userDefTokenConstrs = unlines
[" | T_" ++ name ++ " String" | name <- tokenNames cf]
userDefTokenPrint = unlines
[" PT _ (T_" ++ name ++ " s) -> s" | name <- tokenNames cf]
identAndRes = --This has to be there for Reserved Words. Michael
" ::= ^l ^i* %{ ident p = PT p . eitherResIdent TV %}"
--ifC "Ident" " ::= ^l ^i* %{ ident p = PT p . eitherResIdent TV %}"
resws = reservedWords cf
data BTree = N | B String BTree BTree deriving (Show)
sorted2tree :: [String] -> BTree
sorted2tree [] = N
sorted2tree xs = B x (sorted2tree t1) (sorted2tree t2) where
(t1, x : t2) = splitAt (length xs `div` 2) xs
BNFC-2.8.1/src/BNFC/Backend/Haskell/RegToAlex.hs0000644000000000000000000000562312654616013017031 0ustar0000000000000000{-
BNF Converter: Regular expression pretty printer
Copyright (C) 2004 Author: BNF Converter, Aarne Ranta
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.Haskell.RegToAlex (printRegAlex) where
-- modified from pretty-printer generated by the BNF converter
import AbsBNF
import Data.Char
-- the top-level printing method
printRegAlex :: Reg -> String
printRegAlex = render . prt 0
-- you may want to change render and parenth
render :: [String] -> String
render = rend (0::Int) where
rend i ss = case ss of
"[" :ts -> cons "[" $ rend i ts
"(" :ts -> cons "(" $ rend i ts
t : "," :ts -> cons t $ space "," $ rend i ts
t : ")" :ts -> cons t $ cons ")" $ rend i ts
t : "]" :ts -> cons t $ cons "]" $ rend i ts
t :ts -> space t $ rend i ts
_ -> ""
cons s t = s ++ t
space t s = if null s then t else t ++ " " ++ s
parenth :: [String] -> [String]
parenth ss = ["("] ++ ss ++ [")"]
-- the printer class does the job
class Print a where
prt :: Int -> a -> [String]
prtList :: [a] -> [String]
prtList = concat . map (prt 0)
instance Print a => Print [a] where
prt _ = prtList
instance Print Char where
prt _ c = if isAlphaNum c then [[c]] else ['^':[c]]
prtList s = map (concat . prt 0) s
prPrec :: Int -> Int -> [String] -> [String]
prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])
RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])
RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])
RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])
RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])
ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])
REps -> prPrec i 3 (["$"])
RChar c -> prPrec i 3 (concat [prt 0 c])
RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]])
RSeqs str -> prPrec i 2 (concat (map (prt 0) str))
RDigit -> prPrec i 3 (concat [["^d"]])
RLetter -> prPrec i 3 (concat [["^l"]])
RUpper -> prPrec i 3 (concat [["^c"]])
RLower -> prPrec i 3 (concat [["^s"]])
RAny -> prPrec i 3 (concat [["^u"]])
BNFC-2.8.1/src/BNFC/Backend/Haskell/MkSharedString.hs0000644000000000000000000000500612654616013020057 0ustar0000000000000000{-
BNF Converter: Haskell string sharing
Copyright (C) 2004-2007 Author: Björn Bringert
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.Haskell.MkSharedString where
sharedString :: String -> Bool -> b -> String
sharedString shareMod byteString _ = unlines $
if byteString
then
[
"module " ++ shareMod ++ " (shareString) where",
"",
"import Data.Map as M",
"import Data.IORef",
"import qualified Data.ByteString.Char8 as BS",
"import System.IO.Unsafe (unsafePerformIO)",
"",
"{-# NOINLINE stringPoolRef #-}",
"stringPoolRef :: IORef (M.Map BS.ByteString BS.ByteString)",
"stringPoolRef = unsafePerformIO $ newIORef M.empty",
"",
"{-# NOINLINE shareString #-}",
"shareString :: BS.ByteString -> BS.ByteString",
"shareString s = unsafePerformIO $ do",
" stringPool <- readIORef stringPoolRef",
" case M.lookup s stringPool of",
" Just s' -> return s'",
" Nothing -> do let s' = BS.copy s",
" writeIORef stringPoolRef $! M.insert s' s' stringPool",
" return s'"
]
else
[
"module " ++ shareMod ++ " (shareString) where",
"",
"import Data.HashTable as H",
"import System.IO.Unsafe (unsafePerformIO)",
"",
"{-# NOINLINE stringPool #-}",
"stringPool :: HashTable String String",
"stringPool = unsafePerformIO $ new (==) hashString",
"",
"{-# NOINLINE shareString #-}",
"shareString :: String -> String",
"shareString s = unsafePerformIO $ do",
" mv <- H.lookup stringPool s",
" case mv of",
" Just s' -> return s'",
" Nothing -> do",
" H.insert stringPool s s",
" return s"
]
BNFC-2.8.1/src/BNFC/Backend/Haskell/CFtoTemplate.hs0000644000000000000000000001023512654616013017521 0ustar0000000000000000{-
BNF Converter: Template Generator
Copyright (C) 2004 Author: Markus Forberg
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.Haskell.CFtoTemplate (cf2Template) where
import BNFC.Backend.Haskell.Utils (catvars)
import BNFC.CF
import BNFC.PrettyPrint
type ModuleName = String
cf2Template :: ModuleName -> ModuleName -> ModuleName -> Bool -> CF -> String
cf2Template skelName absName errName functor cf = unlines
[ "module "++ skelName ++ " where\n"
, "-- Haskell module generated by the BNF converter\n"
, "import " ++ absName
, "import " ++ errName
, "type Result = Err String\n"
, "failure :: Show a => a -> Result"
, "failure x = Bad $ \"Undefined case: \" ++ show x\n"
, unlines $ map (render . \(s,xs) -> case_fun functor s xs) $ specialData cf ++ cf2data cf
]
{- ----
cf2Template :: ModuleName -> CF -> String
cf2Template name cf = unlines
[
"module Skel"++ name ++ " where\n",
"-- Haskell module generated by the BNF converter\n",
"import Abs" ++ name,
"import ErrM",
"type Result = Err String\n",
"failure :: Show a => a -> Result",
"failure x = Bad $ \"Undefined case: \" ++ show x\n",
unlines $ map (\(s,xs) -> case_fun s (toArgs xs)) $ specialData cf ++ cf2data cf
]
where toArgs [] = []
toArgs ((cons,args):xs)
= (cons ++ " " ++ names False (map (checkRes . var) args) (1 :: Int)) : toArgs xs
names _ [] _ = []
names b (x:xs) n
| elem x xs = (x ++ show n) ++ " " ++ names True xs (n+1)
| otherwise = (x ++ if b then show n else "") ++ " " ++ names b xs (if b then n+1 else n)
var ('[':xs) = var (init xs) ++ "s"
var "Ident" = "id"
var "Integer" = "n"
var "String" = "str"
var "Char" = "c"
var "Double" = "d"
var xs = map toLower xs
checkRes s
| elem s reservedHaskell = s ++ "'"
| otherwise = s
reservedHaskell = ["case","class","data","default","deriving","do","else","if",
"import","in","infix","infixl","infixr","instance","let","module",
"newtype","of","then","type","where","as","qualified","hiding"]
-}
-- |
-- >>> case_fun False (Cat "Expr") [("EInt", [TokenCat "Integer"]), ("EAdd", [Cat "Expr", Cat "Expr"])]
-- transExpr :: Expr -> Result
-- transExpr x = case x of
-- EInt integer -> failure x
-- EAdd expr1 expr2 -> failure x
--
-- >>> case_fun True (Cat "Expr") [("EInt", [TokenCat "Integer"]), ("EAdd", [Cat "Expr", Cat "Expr"])]
-- transExpr :: Show a => Expr a -> Result
-- transExpr x = case x of
-- EInt _ integer -> failure x
-- EAdd _ expr1 expr2 -> failure x
--
-- TokenCat are not generated as functors:
-- >>> case_fun True (TokenCat "MyIdent") [("MyIdent", [TokenCat "String"])]
-- transMyIdent :: MyIdent -> Result
-- transMyIdent x = case x of
-- MyIdent string -> failure x
case_fun :: Bool -> Cat -> [(Fun,[Cat])] -> Doc
case_fun functor' cat xs = vcat
[ fname <+> "::" <+> iffunctor "Show a =>" <+> type_ <+> "-> Result"
, fname <+> "x = case x of"
, nest 2 $ vcat (map mkOne xs)
]
where
-- If the functor option is set AND the category is not a token type,
-- then the type is a functor.
iffunctor doc | functor' && not (isTokenCat cat) = doc
| otherwise = empty
type_ = cat' <+> iffunctor "a"
fname = "trans" <> cat'
cat' = text (show cat)
mkOne (cons, args) =
let ns = catvars args -- names False (map (checkRes .var) args) 1
in text cons <+> iffunctor "_" <+> hsep ns <+> "-> failure x"
BNFC-2.8.1/src/BNFC/Backend/Haskell/HsOpts.hs0000644000000000000000000001066712654616013016423 0ustar0000000000000000module BNFC.Backend.Haskell.HsOpts where
import BNFC.Utils
import BNFC.Options
import System.FilePath (pathSeparator, (<.>))
import Data.List (intercalate)
import Data.Maybe (catMaybes)
type Options = SharedOptions
alex1 opts = alexMode opts == Alex1
absFile, absFileM,
alexFile, alexFileM,
composOpFile, composOpFileM,
gfAbs,
happyFile, happyFileM,
errFile, errFileM,
templateFile, templateFileM,
printerFile, printerFileM,
layoutFile, layoutFileM,
tFile :: Options -> String
absFile = mkFile withLang "Abs" "hs"
absFileM = mkMod withLang "Abs"
alexFile = mkFile withLang "Lex" "x"
alexFileM = mkMod withLang "Lex"
happyFile = mkFile withLang "Par" "y"
happyFileM = mkMod withLang "Par"
txtFile = mkFile withLang "Doc" "txt"
templateFile = mkFile withLang "Skel" "hs"
templateFileM = mkMod withLang "Skel"
printerFile = mkFile withLang "Print" "hs"
printerFileM = mkMod withLang "Print"
gfAbs = mkFile withLang "" "Abs.gf"
tFile = mkFile withLang "Test" "hs"
errFile = mkFile noLang "ErrM" "hs"
errFileM = mkMod noLang "ErrM"
shareFile = mkFile noLang "SharedString" "hs"
shareFileM = mkMod noLang "SharedString"
layoutFileM = mkMod withLang "Layout"
layoutFile = mkFile withLang "Layout" "hs"
cnfTablesFile = mkFile withLang "CnfTables" "hs"
cnfTablesFileM= mkMod withLang "CnfTables"
xmlFile = mkFile withLang "XML" "hs"
xmlFileM = mkMod withLang "XML"
composOpFile = mkFile noLang "ComposOp" "hs"
composOpFileM = mkMod noLang "ComposOp"
noLang :: Options -> String -> String
noLang _ name = name
withLang :: Options -> String -> String
withLang opts name = name ++ mkName [] CamelCase (lang opts)
pkgToDir :: String -> FilePath
pkgToDir s = replace '.' pathSeparator s
-- |
-- >>> mkMod withLang "Abstract" defaultOptions { lang = "abc" }
-- "AbstractAbc"
-- >>> mkMod noLang "Abstract" defaultOptions { lang = "abc" }
-- "Abstract"
-- >>> mkMod withLang "Abstract" defaultOptions { lang = "abc", inPackage = Just "A.B.C" }
-- "A.B.C.AbstractAbc"
-- >>> mkMod withLang "Abstract" defaultOptions { lang = "abc", inDir = True }
-- "Abc.Abstract"
-- >>> mkMod withLang "Abstract" defaultOptions { lang = "abc", inDir = True, inPackage = Just "A.B.C" }
-- "A.B.C.Abc.Abstract"
mkMod :: (Options -> String -> String) -> String -> Options -> String
mkMod addLang name opts = mkNamespace opts <.> mod
where
[] <.> s = s
s1 <.> s2 = s1 ++ "." ++ s2
mod | inDir opts = name
| otherwise = addLang opts name
-- |
-- >>> mkFile withLang "Abstract" "hs" defaultOptions { lang = "abc" }
-- "AbstractAbc.hs"
-- >>> mkFile noLang "Abstract" "hs" defaultOptions { lang = "abc" }
-- "Abstract.hs"
-- >>> mkFile withLang "Abstract" "" defaultOptions { lang = "abc" }
-- "AbstractAbc"
-- >>> mkFile noLang "Abstract" "" defaultOptions { lang = "abc" }
-- "Abstract"
-- >>> mkFile withLang "Abstract" "hs" defaultOptions { lang = "abc", inDir = True }
-- "Abc/Abstract.hs"
-- >>> mkFile withLang "Abstract" "hs" defaultOptions { lang = "abc", inDir = True, inPackage = Just "A.B.C" }
-- "A/B/C/Abc/Abstract.hs"
mkFile :: (Options -> String -> String) -> String -> String -> Options -> FilePath
mkFile addLang name ext opts = pkgToDir (mkMod addLang name opts) <.> ext
mkFileName :: String -> String -> FilePath
mkFileName module' ext = pkgToDir module' <.> ext
-- | Determine the modules' namespace
--
-- >>> mkNamespace defaultOptions
-- ""
-- >>> mkNamespace defaultOptions { lang = "Bla", inDir = True }
-- "Bla"
-- >>> mkNamespace defaultOptions { inPackage = Just "My.Cool.Package" }
-- "My.Cool.Package"
-- >>> mkNamespace defaultOptions { lang = "bla_bla", inDir = True }
-- "BlaBla"
-- >>> mkNamespace defaultOptions { lang = "bla", inDir = True, inPackage = Just "P"}
-- "P.Bla"
mkNamespace :: Options -> FilePath
mkNamespace opts = intercalate "." $ catMaybes [inPackage opts, dir]
where
dir | inDir opts = Just (mkName [] CamelCase (lang opts))
| otherwise = Nothing
-- | Determine the directory corresponding to the modules' namespace
--
-- >>> codeDir defaultOptions
-- ""
-- >>> codeDir defaultOptions { lang = "Bla", inDir = True }
-- "Bla"
-- >>> codeDir defaultOptions { inPackage = Just "My.Cool.Package" }
-- "My/Cool/Package"
-- >>> codeDir defaultOptions { lang = "bla_bla", inDir = True }
-- "BlaBla"
-- >>> codeDir defaultOptions { lang = "bla", inDir = True, inPackage = Just "P"}
-- "P/Bla"
codeDir :: Options -> FilePath
codeDir = pkgToDir . mkNamespace
BNFC-2.8.1/src/BNFC/Backend/Haskell/CFtoAbstract.hs0000644000000000000000000001521412654616013017513 0ustar0000000000000000{-
BNF Converter: Abstract syntax Generator
Copyright (C) 2004 Author: Markus Forberg
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.Haskell.CFtoAbstract (cf2Abstract) where
import BNFC.CF
import BNFC.Utils((+++))
import BNFC.Backend.Haskell.Utils (catToType, catvars)
import Text.PrettyPrint
-- to produce a Haskell module
cf2Abstract :: Bool -- ^ Use ByteString instead of String
-> Bool -- ^ Use GHC specific extensions
-> Bool -- ^ Make the tree a functor
-> String -- ^ module name
-> CF -- ^ Grammar
-> String
cf2Abstract byteStrings ghcExtensions functor name cf = unlines $
(if ghcExtensions then "{-# LANGUAGE DeriveDataTypeable #-}" else "") :
(if ghcExtensions then "{-# LANGUAGE DeriveGeneric #-}" else "") :
("module "++name +++ "where\n") :
"-- Haskell module generated by the BNF converter\n" :
(if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "") :
(if ghcExtensions then "import Data.Data (Data,Typeable)" else "") :
(if ghcExtensions then "import GHC.Generics (Generic)" else "") :
(map (render . \c -> prSpecialData byteStrings (isPositionCat cf c) derivingClasses c) (specialCats cf)
++ map (render . prData functor derivingClasses) (cf2data cf))
where
derivingClasses = ["Eq","Ord","Show","Read"]
++ if ghcExtensions then ["Data","Typeable","Generic"] else []
-- | >>> prData False ["Eq", "Ord", "Show", "Read"] (Cat "C", [("C1", [Cat "C"]), ("CIdent", [Cat "Ident"])])
-- data C = C1 C | CIdent Ident
-- deriving (Eq, Ord, Show, Read)
--
--
-- Nota that the layout adapts if it doesn't fit in a line:
-- >>> prData False ["Show"] (Cat "C", [("CAbracadabra",[]),("CEbrecedebre",[]),("CIbricidibri",[]),("CObrocodobro",[]),("CUbrucudubru",[])])
-- data C
-- = CAbracadabra
-- | CEbrecedebre
-- | CIbricidibri
-- | CObrocodobro
-- | CUbrucudubru
-- deriving (Show)
--
--
-- The if the first argument is True, generate a functor:
-- >>> prData True ["Show"] (Cat "C", [("C1", [Cat "C"]), ("CIdent", [TokenCat "Ident"])])
-- data C a = C1 a (C a) | CIdent a Ident
-- deriving (Show)
--
-- instance Functor C where
-- fmap f x = case x of
-- C1 a c -> C1 (f a) (fmap f c)
-- CIdent a ident -> CIdent (f a) ident
--
-- The case for lists
-- >>> prData True ["Show"] (Cat "ExpList", [("Exps", [ListCat (Cat "Exp")])])
-- data ExpList a = Exps a [Exp a]
-- deriving (Show)
--
-- instance Functor ExpList where
-- fmap f x = case x of
-- Exps a exps -> Exps (f a) (map (fmap f) exps)
prData :: Bool -> [String] -> Data -> Doc
prData functor derivingClasses (cat,rules) =
hang ("data" <+> dataType) 4 (constructors rules)
$+$ nest 2 (deriving_ derivingClasses)
$+$ ""
$+$ if functor then genFunctorInstance (cat, rules) else empty
where
prRule (fun,cats) =
hsep $ concat [[text fun], ["a" | functor], map prArg cats]
dataType =
if functor then text (show cat) <+> "a"
else text (show cat)
prArg c = catToType (if functor then Just "a" else Nothing) c
constructors [] = empty
constructors (h:t) = sep ("=" <+> prRule h : map (("|" <+>) . prRule) t)
-- | Generate a functor instance declaration:
-- >>> genFunctorInstance (Cat "C", [("C1", [Cat "C", Cat "C"]), ("CIdent", [TokenCat "Ident"])])
-- instance Functor C where
-- fmap f x = case x of
-- C1 a c1 c2 -> C1 (f a) (fmap f c1) (fmap f c2)
-- CIdent a ident -> CIdent (f a) ident
-- >>> genFunctorInstance (Cat "SomeLists", [("Ints", [ListCat (TokenCat "Integer")]), ("Exps", [ListCat (Cat "Exp")])])
-- instance Functor SomeLists where
-- fmap f x = case x of
-- Ints a integers -> Ints (f a) integers
-- Exps a exps -> Exps (f a) (map (fmap f) exps)
--
genFunctorInstance :: Data -> Doc
genFunctorInstance (cat, cons) =
"instance Functor" <+> text (show cat) <+> "where"
$+$ nest 4 ( "fmap f x = case x of" $+$ nest 4 (vcat (map mkCase cons)))
where
mkCase (f,args) =
let variables = catvars args
in text f <+> "a" <+> hsep variables
<+> "->" <+> text f <+> "(f a)" <+> hsep (map reccurse (zip args variables))
-- We reccursively call fmap on non-terminals only if they are not
-- token categories
reccurse (TokenCat _, var) = var
reccurse (ListCat (TokenCat _), var) = var
reccurse (ListCat _, var) = parens ("map (fmap f)" <+> var)
reccurse (_, var) = parens ("fmap f" <+> var)
-- | Generate a newtype declaration for Ident types
--
-- >>> prSpecialData False False ["Show"] (Cat "Ident")
-- newtype Ident = Ident String deriving (Show)
--
-- >>> prSpecialData False True ["Show"] (Cat "Ident")
-- newtype Ident = Ident ((Int,Int),String) deriving (Show)
--
-- >>> prSpecialData True False ["Show"] (Cat "Ident")
-- newtype Ident = Ident BS.ByteString deriving (Show)
--
-- >>> prSpecialData True True ["Show"] (Cat "Ident")
-- newtype Ident = Ident ((Int,Int),BS.ByteString) deriving (Show)
prSpecialData :: Bool -- ^ If True, use ByteString instead of String
-> Bool -- ^ If True, store the token position
-> [String] -- ^ Derived classes
-> Cat -- ^ Category
-> Doc
prSpecialData byteStrings position classes cat =
hang newtype_ 2 (deriving_ classes)
where
ppcat = text (show cat)
newtype_ = "newtype" <+> ppcat <+> "=" <+> ppcat <+> contentSpec
contentSpec | position = parens ( "(Int,Int)," <> stringType)
| otherwise = stringType
stringType | byteStrings = "BS.ByteString"
| otherwise = "String"
-- | Generate 'deriving' clause
-- >>> deriving_ ["Show","Read"]
-- deriving (Show, Read)
deriving_ :: [String] -> Doc
deriving_ cls = "deriving" <+> parens (hsep (punctuate "," (map text cls)))
BNFC-2.8.1/src/BNFC/Backend/Haskell/CFtoAlex3.hs0000644000000000000000000003352612654616013016732 0ustar0000000000000000{-
BNF Converter: Alex 3.0 Generator
Copyright (C) 2012 Author: Antti-Juhani Kaijanaho
Copyright (C) 2004 Author: Peter Gammie
(C)opyright 2003, {aarne,markus,peteg} at cs dot chalmers dot se
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.Haskell.CFtoAlex3 (cf2alex3) where
import BNFC.CF
import Data.List
-- For BNFC.Backend.Haskell.RegToAlex, see below.
import AbsBNF
import Data.Char
cf2alex3 :: String -> String -> String -> Bool -> Bool -> CF -> String
cf2alex3 name errMod shareMod shareStrings byteStrings cf =
unlines $ intercalate [""] [
prelude name errMod shareMod shareStrings byteStrings,
cMacros,
rMacros cf,
restOfAlex shareMod shareStrings byteStrings cf
]
prelude :: String -> String -> String -> Bool -> Bool -> [String]
prelude name _ shareMod shareStrings byteStrings = [
"-- -*- haskell -*-",
"-- This Alex file was machine-generated by the BNF converter",
"{",
"{-# OPTIONS -fno-warn-incomplete-patterns #-}",
"{-# OPTIONS_GHC -w #-}",
"module " ++ name ++ " where",
"",
-- "import " ++ errMod,
if shareStrings then "import " ++ shareMod else "",
if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "",
"import qualified Data.Bits",
"import Data.Word (Word8)",
"import Data.Char (ord)",
"}",
""
]
cMacros :: [String]
cMacros = [
"$l = [a-zA-Z\\192 - \\255] # [\\215 \\247] -- isolatin1 letter FIXME",
"$c = [A-Z\\192-\\221] # [\\215] -- capital isolatin1 letter FIXME",
"$s = [a-z\\222-\\255] # [\\247] -- small isolatin1 letter FIXME",
"$d = [0-9] -- digit",
"$i = [$l $d _ '] -- identifier character",
"$u = [\\0-\\255] -- universal: any character"
]
rMacros :: CF -> [String]
rMacros cf =
let symbs = symbols cf
in
(if null symbs then [] else [
"@rsyms = -- symbols and non-identifier-like reserved words",
" " ++ unwords (intersperse "|" (map mkEsc symbs))
])
where
mkEsc = unwords . esc
esc s = if null a then rest else show a : rest
where (a,r) = span isAlphaNum s
rest = case r of
[] -> []
(c:xs) -> s : esc xs
where s = if isPrint c then ['\\',c]
else '\\':show (ord c)
restOfAlex :: String -> Bool -> Bool -> CF -> [String]
restOfAlex _ shareStrings byteStrings cf = [
":-",
lexComments (comments cf),
"$white+ ;",
pTSpec (symbols cf),
userDefTokenTypes,
ident,
ifC catString ("\\\" ([$u # [\\\" \\\\ \\n]] | (\\\\ (\\\" | \\\\ | \\' | n | t)))* \\\"" ++
"{ tok (\\p s -> PT p (TL $ share $ unescapeInitTail s)) }"),
ifC catChar "\\\' ($u # [\\\' \\\\] | \\\\ [\\\\ \\\' n t]) \\' { tok (\\p s -> PT p (TC $ share s)) }",
ifC catInteger "$d+ { tok (\\p s -> PT p (TI $ share s)) }",
ifC catDouble "$d+ \\. $d+ (e (\\-)? $d+)? { tok (\\p s -> PT p (TD $ share s)) }",
"",
"{",
"",
"tok :: (Posn -> String -> Token) -> (Posn -> String -> Token)",
"tok f p s = f p s",
"",
"share :: "++stringType++" -> "++stringType,
"share = " ++ if shareStrings then "shareString" else "id",
"",
"data Tok =",
" TS !"++stringType++" !Int -- reserved words and symbols",
" | TL !"++stringType++" -- string literals",
" | TI !"++stringType++" -- integer literals",
" | TV !"++stringType++" -- identifiers",
" | TD !"++stringType++" -- double precision float literals",
" | TC !"++stringType++" -- character literals",
userDefTokenConstrs,
" deriving (Eq,Show,Ord)",
"",
"data Token =",
" PT Posn Tok",
" | Err Posn",
" deriving (Eq,Show,Ord)",
"",
"tokenPos :: [Token] -> String",
"tokenPos (PT (Pn _ l _) _ :_) = \"line \" ++ show l",
"tokenPos (Err (Pn _ l _) :_) = \"line \" ++ show l",
"tokenPos _ = \"end of file\"",
"",
"tokenPosn :: Token -> Posn",
"tokenPosn (PT p _) = p",
"tokenPosn (Err p) = p",
"",
"tokenLineCol :: Token -> (Int, Int)",
"tokenLineCol = posLineCol . tokenPosn",
"",
"posLineCol :: Posn -> (Int, Int)",
"posLineCol (Pn _ l c) = (l,c)",
"",
"mkPosToken :: Token -> ((Int, Int), String)",
"mkPosToken t@(PT p _) = (posLineCol p, prToken t)",
"",
"prToken :: Token -> String",
"prToken t = case t of",
" PT _ (TS s _) -> s",
" PT _ (TL s) -> show s",
" PT _ (TI s) -> s",
" PT _ (TV s) -> s",
" PT _ (TD s) -> s",
" PT _ (TC s) -> s",
userDefTokenPrint,
"",
"data BTree = N | B "++stringType++" Tok BTree BTree deriving (Show)",
"",
"eitherResIdent :: ("++stringType++" -> Tok) -> "++stringType++" -> Tok",
"eitherResIdent tv s = treeFind resWords",
" where",
" treeFind N = tv s",
" treeFind (B a t left right) | s < a = treeFind left",
" | s > a = treeFind right",
" | s == a = t",
"",
"resWords :: BTree",
"resWords = " ++ show (sorted2tree $ cfTokens cf),
" where b s n = let bs = "++stringPack++" s",
" in B bs (TS bs n)",
"",
"unescapeInitTail :: "++stringType++" -> "++stringType++"",
"unescapeInitTail = "++stringPack++" . unesc . tail . "++stringUnpack++" where",
" unesc s = case s of",
" '\\\\':c:cs | elem c ['\\\"', '\\\\', '\\\''] -> c : unesc cs",
" '\\\\':'n':cs -> '\\n' : unesc cs",
" '\\\\':'t':cs -> '\\t' : unesc cs",
" '\"':[] -> []",
" c:cs -> c : unesc cs",
" _ -> []",
"",
"-------------------------------------------------------------------",
"-- Alex wrapper code.",
"-- A modified \"posn\" wrapper.",
"-------------------------------------------------------------------",
"",
"data Posn = Pn !Int !Int !Int",
" deriving (Eq, Show,Ord)",
"",
"alexStartPos :: Posn",
"alexStartPos = Pn 0 1 1",
"",
"alexMove :: Posn -> Char -> Posn",
"alexMove (Pn a l c) '\\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)",
"alexMove (Pn a l c) '\\n' = Pn (a+1) (l+1) 1",
"alexMove (Pn a l c) _ = Pn (a+1) l (c+1)",
"",
"type Byte = Word8",
"",
"type AlexInput = (Posn, -- current position,",
" Char, -- previous char",
" [Byte], -- pending bytes on the current char",
" "++stringType++") -- current input string",
"",
"tokens :: "++stringType++" -> [Token]",
"tokens str = go (alexStartPos, '\\n', [], str)",
" where",
" go :: AlexInput -> [Token]",
" go inp@(pos, _, _, str) =",
" case alexScan inp 0 of",
" AlexEOF -> []",
" AlexError (pos, _, _, _) -> [Err pos]",
" AlexSkip inp' len -> go inp'",
" AlexToken inp' len act -> act pos ("++stringTake++" len str) : (go inp')",
"",
"alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)",
"alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s))",
"alexGetByte (p, _, [], s) =",
" case "++stringUncons++" s of",
" "++stringNilP++" -> Nothing",
" "++stringConsP++" ->",
" let p' = alexMove p c",
" (b:bs) = utf8Encode c",
" in p' `seq` Just (b, (p', c, bs, s))",
"",
"alexInputPrevChar :: AlexInput -> Char",
"alexInputPrevChar (p, c, bs, s) = c",
"",
"-- | Encode a Haskell String to a list of Word8 values, in UTF8 format.",
"utf8Encode :: Char -> [Word8]",
"utf8Encode = map fromIntegral . go . ord",
" where",
" go oc",
" | oc <= 0x7f = [oc]",
"",
" | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6)",
" , 0x80 + oc Data.Bits..&. 0x3f",
" ]",
"",
" | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12)",
" , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)",
" , 0x80 + oc Data.Bits..&. 0x3f",
" ]",
" | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18)",
" , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)",
" , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)",
" , 0x80 + oc Data.Bits..&. 0x3f",
" ]",
"}"
]
where
(stringType,stringTake,stringUncons,stringPack,stringUnpack,stringNilP,stringConsP)
| byteStrings = ("BS.ByteString", "BS.take", "BS.uncons", "BS.pack", "BS.unpack", "Nothing", "Just (c,s)")
| otherwise = ("String", "take", "", "id", "id", "[]", "(c:s)" )
ifC cat s = if isUsedCat cf cat then s else ""
lexComments ([],[]) = []
lexComments (xs,s1:ys) = '\"' : s1 ++ "\"" ++ " [.]* ; -- Toss single line comments\n" ++ lexComments (xs, ys)
lexComments (([l1,l2],[r1,r2]):xs,[]) = concat
[
'\"':l1:l2:"\" ([$u # \\", -- FIXME quotes or escape?
r1:"] | \\",
r1:"+ [$u # [\\",
r1:" \\",
r2:"]])* (\"",
r1:"\")+ \"",
r2:"\" ;\n",
lexComments (xs, [])
]
lexComments (_ : xs, []) = lexComments (xs,[])
--- lexComments (xs,(_:ys)) = lexComments (xs,ys)
-- tokens consisting of special symbols
pTSpec [] = ""
pTSpec _ = "@rsyms { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }"
userDefTokenTypes = unlines
[printRegAlex exp ++
" { tok (\\p s -> PT p (eitherResIdent (T_" ++ show name ++ " . share) s)) }"
| (name,exp) <- tokenPragmas cf]
userDefTokenConstrs = unlines
[" | T_" ++ name ++ " !"++stringType | name <- tokenNames cf]
userDefTokenPrint = unlines
[" PT _ (T_" ++ name ++ " s) -> s" | name <- tokenNames cf]
ident =
"$l $i* { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }"
--ifC "Ident" " ::= ^l ^i* { ident p = PT p . eitherResIdent TV }"
data BTree = N | B String Int BTree BTree
instance Show BTree where
showsPrec _ N = showString "N"
showsPrec n (B s k l r) = wrap (showString "b " . shows s . showChar ' '. shows k . showChar ' '
. showsPrec 1 l . showChar ' '
. showsPrec 1 r)
where wrap f = if n > 0 then showChar '(' . f . showChar ')' else f
sorted2tree :: [(String,Int)] -> BTree
sorted2tree [] = N
sorted2tree xs = B x n (sorted2tree t1) (sorted2tree t2) where
(t1, (x,n) : t2) = splitAt (length xs `div` 2) xs
-------------------------------------------------------------------
-- Inlined version of @BNFC.Backend.Haskell.RegToAlex@.
-- Syntax has changed...
-------------------------------------------------------------------
-- modified from pretty-printer generated by the BNF converter
-- the top-level printing method
printRegAlex :: Reg -> String
printRegAlex = render . prt 0
-- you may want to change render and parenth
render :: [String] -> String
render = rend 0
where rend :: Int -> [String] -> String
rend i ss = case ss of
"[" :ts -> cons "[" $ rend i ts
"(" :ts -> cons "(" $ rend i ts
t : "," :ts -> cons t $ space "," $ rend i ts
t : ")" :ts -> cons t $ cons ")" $ rend i ts
t : "]" :ts -> cons t $ cons "]" $ rend i ts
t :ts -> space t $ rend i ts
_ -> ""
cons s t = s ++ t
space t s = if null s then t else t ++ " " ++ s
parenth :: [String] -> [String]
parenth ss = ["("] ++ ss ++ [")"]
-- the printer class does the job
class Print a where
prt :: Int -> a -> [String]
prtList :: [a] -> [String]
prtList = concatMap (prt 0)
instance Print a => Print [a] where
prt _ = prtList
instance Print Char where
prt _ c = case c of
'\n' -> ["\\n"]
'\t' -> ["\\t"]
c | isAlphaNum c -> [[c]]
c | isPrint c -> ['\\':[c]]
c -> ['\\':show (ord c)]
prtList = map (concat . prt 0)
prPrec :: Int -> Int -> [String] -> [String]
prPrec i j = if j prPrec i 2 (prt 2 reg0 ++ prt 3 reg)
RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])
RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])
RStar reg -> prPrec i 3 (prt 3 reg ++ ["*"])
RPlus reg -> prPrec i 3 (prt 3 reg ++ ["+"])
ROpt reg -> prPrec i 3 (prt 3 reg ++ ["?"])
REps -> prPrec i 3 ["()"]
RChar c -> prPrec i 3 (prt 0 c)
RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]])
RSeqs str -> prPrec i 2 (concatMap (prt 0) str)
RDigit -> prPrec i 3 ["$d"]
RLetter -> prPrec i 3 ["$l"]
RUpper -> prPrec i 3 ["$c"]
RLower -> prPrec i 3 ["$s"]
RAny -> prPrec i 3 ["$u"]
BNFC-2.8.1/src/BNFC/Backend/Haskell/Utils.hs0000644000000000000000000000577712654616013016311 0ustar0000000000000000module BNFC.Backend.Haskell.Utils
( parserName
, hsReservedWords
, catToType
, catvars
) where
import Text.PrettyPrint
import BNFC.CF (Cat(..), identCat, normCat)
import BNFC.Utils (mkNames, NameStyle(..))
-- | Create a valid parser function name for a given category
-- >>> parserName (Cat "Abcd")
-- pAbcd
-- >>> parserName (ListCat (Cat "Xyz"))
-- pListXyz
parserName :: Cat -> Doc
parserName = ("p" <>) . text . identCat
-- | Haskell's reserved words
hsReservedWords :: [String]
hsReservedWords =
[ "as"
, "case"
, "class"
, "data"
, "default"
, "deriving"
, "do"
, "else"
, "hiding"
, "if"
, "import"
, "in"
, "infix"
, "infixl"
, "infixr"
, "instance"
, "let"
, "module"
, "newtype"
, "of"
, "qualified"
, "then"
, "type"
, "where"
]
-- | Render a category from the grammar to a Haskell type
-- >>> catToType Nothing (Cat "A")
-- A
-- >>> catToType Nothing (ListCat (Cat "A"))
-- [A]
-- >>> catToType Nothing (TokenCat "Ident")
-- Ident
--
-- Note that there is no haskell type for coerced categories: they should be
-- normalized
-- >>> catToType Nothing (CoercCat "Expr" 2)
-- Expr
--
-- If a type parameter is given it is added to the type name:
-- >>> catToType (Just "a") (Cat "A")
-- (A a)
--
-- >>> catToType (Just "a") (ListCat (Cat "A"))
-- [A a]
--
-- but not added to Token categories:
-- >>> catToType (Just "a") (TokenCat "Integer")
-- Integer
--
-- >>> catToType (Just "a") (ListCat (TokenCat "Integer"))
-- [Integer]
--
-- >>> catToType Nothing (ListCat (CoercCat "Exp" 2))
-- [Exp]
--
-- >>> catToType (Just "()") (ListCat (CoercCat "Exp" 2))
-- [Exp ()]
catToType :: Maybe Doc -> Cat -> Doc
catToType param cat = maybeParens $ catToType' param cat
where
maybeParens = case (param,cat) of
(Just _, Cat _) -> parens
_ -> id
catToType' _ InternalCat = error "Can't create a haskell type for internal category"
catToType' Nothing c = text $ show $ normCat c
catToType' (Just p) (Cat c) = text c <+> p
catToType' (Just p) (CoercCat c _) = text c <+> p
catToType' (Just _) (TokenCat c) = text c
catToType' (Just p) (ListCat c) = lbrack <> catToType' (Just p) c <> rbrack
-- | gives you a list of variables usable for pattern matching.
-- Ex: if you have the rule Aba. S ::= A B A ; with the generated data type
-- data S = Aba A B A
-- Given the lit of categories in the RHS of the rule (A B A), we generate the
-- list [a1,b,a2] to be used in a pattern matching like
-- case s of
-- Aba a1 b a2 -> ...
-- ...
--
-- >>> catvars [Cat "A", Cat "B", Cat "A"]
-- [a1,b,a2]
--
-- It should avoid reserved words
-- >>> catvars [Cat "IF", Cat "Case", Cat "Type", Cat "If"]
-- [if_1,case_,type_,if_2]
--
-- It uses an -s to mark lists:
-- >>> catvars [Cat "A", ListCat (Cat "A"), ListCat (ListCat (Cat "A"))]
-- [a,as_,ass]
catvars :: [Cat] -> [Doc]
catvars = map text . mkNames hsReservedWords LowerCase . map var
where
var (ListCat c) = var c ++ "s"
var xs = show xs
BNFC-2.8.1/src/BNFC/Backend/Haskell/CFtoHappy.hs0000644000000000000000000002731312654616013017034 0ustar0000000000000000{-
BNF Converter: Happy Generator
Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.Haskell.CFtoHappy (cf2HappyS, convert) where
import BNFC.CF
import BNFC.Backend.Common.StrUtils (escapeChars)
import BNFC.Backend.Haskell.Utils (parserName, catToType)
--import Lexer
import Data.Char
import BNFC.Options (HappyMode(..))
import BNFC.PrettyPrint
-- Type declarations
type Rules = [(NonTerminal,[(Pattern,Action)])]
type Pattern = String
type Action = String
type MetaVar = String
-- default naming
tokenName = "Token"
-- Happy mode
cf2HappyS :: String -- ^ This module's name
-> String -- ^ Abstract syntax module name
-> String -- ^ Lexer module name
-> String -- ^ ErrM module name
-> HappyMode -- ^ Happy mode
-> Bool -- ^ Use bytestring?
-> Bool -- ^ AST is a functor?
-> CF -- ^ Grammar
-> String -- ^ Generated code
---- cf2HappyS :: String -> CF -> String
cf2HappyS = cf2Happy
-- The main function, that given a CF and a CFCat to parse according to,
-- generates a happy module.
cf2Happy name absName lexName errName mode byteStrings functor cf
= unlines
[header name absName lexName errName mode byteStrings,
render $ declarations mode (allEntryPoints cf),
tokens (cfTokens cf),
specialToks cf,
delimiter,
specialRules byteStrings cf,
render $ prRules functor (rulesForHappy absName functor cf),
finalize byteStrings cf]
-- construct the header.
header :: String -> String -> String -> String -> HappyMode -> Bool -> String
header modName absName lexName errName mode byteStrings = unlines
["-- This Happy file was machine-generated by the BNF converter",
"{",
"{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}",
case mode of
Standard -> "module " ++ modName ++ " where"
GLR -> "-- module name filled in by Happy",
"import " ++ absName,
"import " ++ lexName,
"import " ++ errName,
if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "",
"}"
]
-- | The declarations of a happy file.
-- >>> declarations Standard [Cat "A", Cat "B", ListCat (Cat "B")]
-- %name pA A
-- %name pB B
-- %name pListB ListB
-- -- no lexer declaration
-- %monad { Err } { thenM } { returnM }
-- %tokentype {Token}
declarations :: HappyMode -> [Cat] -> Doc
declarations mode ns = vcat
[ vcat $ map generateP ns
, case mode of
Standard -> "-- no lexer declaration"
GLR -> "%lexer { myLexer } { Err _ }",
"%monad { Err } { thenM } { returnM }",
"%tokentype" <+> braces (text tokenName) ]
where generateP n = "%name" <+> parserName n <+> text n'
where n' = identCat n
-- The useless delimiter symbol.
delimiter :: String
delimiter = "\n%%\n"
-- Generate the list of tokens and their identifiers.
tokens :: [(String,Int)] -> String
tokens toks = "%token\n" ++ prTokens toks
where prTokens [] = []
prTokens ((t,k):tk) = " " ++ render (convert t) ++
" { " ++ oneTok t k ++ " }\n" ++
prTokens tk
oneTok _ k = "PT _ (TS _ " ++ show k ++ ")"
-- Happy doesn't allow characters such as åäö to occur in the happy file. This
-- is however not a restriction, just a naming paradigm in the happy source file.
convert :: String -> Doc
convert = quotes . text . escapeChars
rulesForHappy :: String -> Bool -> CF -> Rules
rulesForHappy absM functor cf = map mkOne $ ruleGroups cf
where
mkOne (cat,rules) = (cat, map (constructRule absM functor reversibles) rules)
reversibles = reversibleCats cf
-- | For every non-terminal, we construct a set of rules. A rule is a sequence
-- of terminals and non-terminals, and an action to be performed
-- >>> constructRule "Foo" False [] (Rule "EPlus" (Cat "Exp") [Left (Cat "Exp"), Right "+", Left (Cat "Exp")])
-- ("Exp '+' Exp","Foo.EPlus $1 $3")
--
-- If we're using functors, it adds an void value:
-- >>> constructRule "Foo" True [] (Rule "EPlus" (Cat "Exp") [Left (Cat "Exp"), Right "+", Left (Cat "Exp")])
-- ("Exp '+' Exp","Foo.EPlus () $1 $3")
--
-- List constructors should not be prefixed by the abstract module name:
-- >>> constructRule "Foo" False [] (Rule "(:)" (ListCat (Cat "A")) [Left (Cat "A"), Right",", Left (ListCat (Cat "A"))])
-- ("A ',' ListA","(:) $1 $3")
-- >>> constructRule "Foo" False [] (Rule "(:[])" (ListCat (Cat "A")) [Left (Cat "A")])
-- ("A","(:[]) $1")
--
-- Coercion are much simpler:
-- >>> constructRule "Foo" True [] (Rule "_" (Cat "Exp") [Right "(", Left (Cat "Exp"), Right ")"])
-- ("'(' Exp ')'","$2")
--
-- As an optimization, a pair of list rules [C] ::= "" | C k [C] is
-- left-recursivized into [C] ::= "" | [C] C k.
-- This could be generalized to cover other forms of list rules.
-- >>> constructRule "Foo" False [ListCat (Cat "A")] (Rule "(:)" (ListCat (Cat "A")) [Left (Cat "A"), Right",", Left (ListCat (Cat "A"))])
-- ("ListA A ','","flip (:) $1 $2")
--
-- Note that functors don't concern list constructors:
-- >>> constructRule "Abs" True [ListCat (Cat "A")] (Rule "(:)" (ListCat (Cat "A")) [Left (Cat "A"), Right",", Left (ListCat (Cat "A"))])
-- ("ListA A ','","flip (:) $1 $2")
constructRule :: String -> Bool -> [Cat] -> Rule -> (Pattern,Action)
constructRule absName functor revs r0@(Rule fun cat _) = (pattern, action)
where
(pattern,metavars) = generatePatterns revs r
action | isCoercion fun = unwords metavars
| isConsFun fun && elem cat revs = unwords ("flip" : fun : metavars)
| isNilCons fun = unwords (underscore fun : metavars)
| functor = unwords (underscore fun : "()" : metavars)
| otherwise = unwords (underscore fun : metavars)
r | isConsFun (funRule r0) && elem (valCat r0) revs = revSepListRule r0
| otherwise = r0
underscore f | isConsFun f || isNilCons f = f
| isDefinedRule f = absName ++ "." ++ f ++ "_"
| otherwise = absName ++ "." ++ f
-- Generate patterns and a set of metavariables indicating
-- where in the pattern the non-terminal
generatePatterns :: [Cat] -> Rule -> (Pattern,[MetaVar])
generatePatterns revs r = case rhsRule r of
[] -> ("{- empty -}",[])
its -> (unwords (map mkIt its), metas its)
where
mkIt i = case i of
Left c -> identCat c
Right s -> render (convert s)
metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its]
revIf c m = if not (isConsFun (funRule r)) && elem c revs
then "(reverse " ++ m ++ ")"
else m -- no reversal in the left-recursive Cons rule itself
-- We have now constructed the patterns and actions,
-- so the only thing left is to merge them into one string.
-- |
-- >>> prRules False [(Cat "Expr", [("Integer", "EInt $1"), ("Expr '+' Expr", "EPlus $1 $3")])]
-- Expr :: { Expr }
-- Expr : Integer { EInt $1 } | Expr '+' Expr { EPlus $1 $3 }
--
-- if there's a lot of cases, print on several lignes:
-- >>> prRules False [(Cat "Expr", [("Abcd", "Action"), ("P2", "A2"), ("P3", "A3"), ("P4", "A4"), ("P5","A5")])]
-- Expr :: { Expr }
-- Expr : Abcd { Action }
-- | P2 { A2 }
-- | P3 { A3 }
-- | P4 { A4 }
-- | P5 { A5 }
--
-- >>> prRules False [(Cat "Internal", [])] -- nt has only internal use
--
--
-- The functor case:
-- >>> prRules True [(Cat "Expr", [("Integer", "EInt () $1"), ("Expr '+' Expr", "EPlus () $1 $3")])]
-- Expr :: { (Expr ()) }
-- Expr : Integer { EInt () $1 } | Expr '+' Expr { EPlus () $1 $3 }
--
-- A list with coercion: in the type signature we need to get rid of the
-- coercion
-- >>> prRules True [(ListCat (CoercCat "Exp" 2), [("Exp2", "(:[]) $1"), ("Exp2 ',' ListExp2","(:) $1 $3")])]
-- ListExp2 :: { [Exp ()] }
-- ListExp2 : Exp2 { (:[]) $1 } | Exp2 ',' ListExp2 { (:) $1 $3 }
prRules :: Bool -> Rules -> Doc
prRules functor = vcat . map prOne
where
type' = catToType (if functor then Just "()" else Nothing)
prOne (_,[]) = empty -- nt has only internal use
prOne (nt,(p,a):ls) =
hsep [ nt', "::", "{", type' nt, "}" ]
$$ nt' <+> sep (pr ":" (p, a) : map (pr "|") ls)
where
nt' = text (identCat nt)
pr pre (p,a) = hsep [pre, text p, "{", text a , "}"]
-- Finally, some haskell code.
finalize :: Bool -> CF -> String
finalize byteStrings cf = unlines $
[
"{",
"\nreturnM :: a -> Err a",
"returnM = return",
"\nthenM :: Err a -> (a -> Err b) -> Err b",
"thenM = (>>=)",
"\nhappyError :: [" ++ tokenName ++ "] -> Err a",
"happyError ts =",
" Bad $ \"syntax error at \" ++ tokenPos ts ++ ",
" case ts of",
" [] -> []",
" [Err _] -> \" due to lexer error\"",
" _ -> \" before \" ++ unwords (map ("++stringUnpack++" . prToken) (take 4 ts))",
"",
"myLexer = tokens"
] ++ definedRules cf ++ [ "}" ]
where
stringUnpack
| byteStrings = "BS.unpack"
| otherwise = "id"
definedRules cf = [ mkDef f xs e | FunDef f xs e <- pragmasOfCF cf ]
where
mkDef f xs e = unwords $ (f ++ "_") : xs' ++ ["=", show e']
where
xs' = map (++"_") xs
e' = underscore e
underscore (App x es)
| isLower $ head x = App (x ++ "_") $ map underscore es
| otherwise = App x $ map underscore es
underscore e = e
-- aarne's modifs 8/1/2002:
-- Markus's modifs 11/02/2002
-- GF literals
specialToks :: CF -> String
specialToks cf = unlines (map aux (literals cf))
where aux cat =
case show cat of
"Ident" -> "L_ident { PT _ (TV $$) }"
"String" -> "L_quoted { PT _ (TL $$) }"
"Integer" -> "L_integ { PT _ (TI $$) }"
"Double" -> "L_doubl { PT _ (TD $$) }"
"Char" -> "L_charac { PT _ (TC $$) }"
own -> "L_" ++ own ++ " { PT _ (T_" ++ own ++ " " ++ posn ++ ") }"
where
posn = if isPositionCat cf cat then "_" else "$$"
specialRules :: Bool -> CF -> String
specialRules byteStrings cf = unlines $
map aux (literals cf)
where
aux cat =
case show cat of
"Ident" -> "Ident :: { Ident } : L_ident { Ident $1 }"
"String" -> "String :: { String } : L_quoted { "++stringUnpack++" $1 }"
"Integer" -> "Integer :: { Integer } : L_integ { (read ("++stringUnpack++" $1)) :: Integer }"
"Double" -> "Double :: { Double } : L_doubl { (read ("++stringUnpack++" $1)) :: Double }"
"Char" -> "Char :: { Char } : L_charac { (read ("++stringUnpack++" $1)) :: Char }"
own -> own ++ " :: { " ++ own ++ "} : L_" ++ own ++ " { " ++ own ++ " ("++ posn ++ "$1)}"
-- PCC: take "own" as type name? (manual says newtype)
where
posn = if isPositionCat cf cat then "mkPosToken " else ""
stringUnpack
| byteStrings = "BS.unpack"
| otherwise = ""
BNFC-2.8.1/src/BNFC/Backend/Haskell/CFtoPrinter.hs0000644000000000000000000002575112654616013017402 0ustar0000000000000000{-
BNF Converter: Pretty-printer generator
Copyright (C) 2004 Author: Aarne Ranta
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module BNFC.Backend.Haskell.CFtoPrinter (cf2Printer, compareRules) where
import BNFC.Backend.Haskell.Utils (hsReservedWords)
import BNFC.CF
import BNFC.Utils
import Data.Char(toLower)
import Data.Either (lefts)
import Data.List (sortBy)
import Data.Maybe (fromJust)
import Text.PrettyPrint
-- derive pretty-printer from a BNF grammar. AR 15/2/2002
cf2Printer :: Bool -> Bool -> Bool -> String -> String -> CF -> String
cf2Printer byteStrings functor useGadt name absMod cf = unlines [
prologue byteStrings useGadt name absMod,
integerRule cf,
doubleRule cf,
if hasIdent cf then identRule byteStrings cf else "",
unlines [ownPrintRule byteStrings cf own | (own,_) <- tokenPragmas cf],
rules functor cf
]
prologue :: Bool -> Bool -> String -> String -> String
prologue byteStrings useGadt name absMod = unlines $
["{-# LANGUAGE GADTs, TypeSynonymInstances, FlexibleInstances #-}" | useGadt]
++ [
"{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}",
"module " ++ name +++ "where\n",
"-- pretty-printer generated by the BNF converter\n",
"import " ++ absMod,
"import Data.Char",
(if byteStrings then "import qualified Data.ByteString.Char8 as BS" else ""),
"",
"-- the top-level printing method",
"printTree :: Print a => a -> String",
"printTree = render . prt 0",
"",
"type Doc = [ShowS] -> [ShowS]",
"",
"doc :: ShowS -> Doc",
"doc = (:)",
"",
"render :: Doc -> String",
"render d = rend 0 (map ($ \"\") $ d []) \"\" where",
" rend i ss = case ss of",
" \"[\" :ts -> showChar '[' . rend i ts",
" \"(\" :ts -> showChar '(' . rend i ts",
" \"{\" :ts -> showChar '{' . new (i+1) . rend (i+1) ts",
" \"}\" : \";\":ts -> new (i-1) . space \"}\" . showChar ';' . new (i-1) . rend (i-1) ts",
" \"}\" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts",
" \";\" :ts -> showChar ';' . new i . rend i ts",
" t : \",\" :ts -> showString t . space \",\" . rend i ts",
" t : \")\" :ts -> showString t . showChar ')' . rend i ts",
" t : \"]\" :ts -> showString t . showChar ']' . rend i ts",
" t :ts -> space t . rend i ts",
" _ -> id",
" new i = showChar '\\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace",
" space t = showString t . (\\s -> if null s then \"\" else (' ':s))",
"",
"parenth :: Doc -> Doc",
"parenth ss = doc (showChar '(') . ss . doc (showChar ')')",
"",
"concatS :: [ShowS] -> ShowS",
"concatS = foldr (.) id",
"",
"concatD :: [Doc] -> Doc",
"concatD = foldr (.) id",
"",
"replicateS :: Int -> ShowS -> ShowS",
"replicateS n f = concatS (replicate n f)",
"",
"-- the printer class does the job",
"class Print a where",
" prt :: Int -> a -> Doc",
" prtList :: Int -> [a] -> Doc",
" prtList i = concatD . map (prt i)",
"",
"instance Print a => Print [a] where",
" prt = prtList",
"",
"instance Print Char where",
" prt _ s = doc (showChar '\\'' . mkEsc '\\'' s . showChar '\\'')",
" prtList _ s = doc (showChar '\"' . concatS (map (mkEsc '\"') s) . showChar '\"')",
"",
"mkEsc :: Char -> Char -> ShowS",
"mkEsc q s = case s of",
" _ | s == q -> showChar '\\\\' . showChar s",
" '\\\\'-> showString \"\\\\\\\\\"",
" '\\n' -> showString \"\\\\n\"",
" '\\t' -> showString \"\\\\t\"",
" _ -> showChar s",
"",
"prPrec :: Int -> Int -> Doc -> Doc",
"prPrec i j = if j CF -> String
rules functor cf = unlines $
map (\(s,xs) -> render (case_fun functor s (map toArgs xs)) ++++ ifList cf s) $ cf2data cf
where
toArgs (cons,_) = (cons, ruleOf cons)
ruleOf s = fromJust $ lookupRule s (rulesOfCF cf)
-- |
-- >>> case_fun False (Cat "A") [("AA", (Cat "AB", [Right "xxx"]))]
-- instance Print A where
-- prt i e = case e of
-- AA -> prPrec i 0 (concatD [doc (showString "xxx")])
case_fun :: Bool -> Cat -> [(String, (Cat, [Either Cat String]))] -> Doc
case_fun functor cat xs = vcat
[ "instance Print" <+> type_ <+> "where"
, nest 2 $ vcat
[ "prt i e = case e of"
, nest 2 $ vcat (map (mkPrintCase functor) xs)
]
]
where
type_ | functor = parens (text (show cat) <+> "a")
| otherwise = text (show cat)
-- When writing the Print instance for a category (in case_fun), we have
-- a different case for each constructor for this category.
-- >>> mkPrintCase False ("AA", (Cat "A", [Right "xxx"]))
-- AA -> prPrec i 0 (concatD [doc (showString "xxx")])
--
-- Coercion levels are passed to prPrec
-- >>> mkPrintCase False ("EInt", (CoercCat "Expr" 2, [Left (TokenCat "Integer")]))
-- EInt n -> prPrec i 2 (concatD [prt 0 n])
-- >>> mkPrintCase False ("EPlus", (CoercCat "Expr" 1, [Left (Cat "Expr"), Right "+", Left (Cat "Expr")]))
-- EPlus expr0 expr -> prPrec i 1 (concatD [prt 0 expr0, doc (showString "+"), prt 0 expr])
--
-- If the AST is a functor, ignore first argument
-- >>> mkPrintCase True ("EInt", (CoercCat "Expr" 2, [Left (TokenCat "Integer")]))
-- EInt _ n -> prPrec i 2 (concatD [prt 0 n])
--
-- Skip intertal categories
-- >>> mkPrintCase True ("EInternal", (Cat "Expr", [Left InternalCat, Left (Cat "Expr")]))
-- EInternal _ expr -> prPrec i 0 (concatD [prt 0 expr])
mkPrintCase :: Bool -> (Fun, (Cat, [Either Cat String])) -> Doc
mkPrintCase functor (f, (cat, rhs)) =
text f <+> (if functor then "_" else empty) <+> hsep variables <+> "->"
<+> "prPrec i" <+> integer (precCat cat) <+> mkRhs (map render variables) rhs
where
-- Creating variables names used in pattern matching. In addition to
-- haskell's reserved words, `e` and `i` are used in the printing function
-- and should be avoided
names = map var (filter (/=InternalCat) $ lefts rhs)
variables = map text $ mkNames ("e":"i":hsReservedWords) LowerCase names
var (ListCat c) = var c ++ "s"
var (TokenCat "Ident") = "id"
var (TokenCat "Integer") = "n"
var (TokenCat "String") = "str"
var (TokenCat "Char") = "c"
var (TokenCat "Double") = "d"
var xs = map toLower $ show xs
ifList :: CF -> Cat -> String
ifList cf cat = render $ nest 2 $ vcat [ mkPrtListCase r | r <- rules ]
where
rules = sortBy compareRules $ rulesForNormalizedCat cf (ListCat cat)
-- | Pattern match on the list constructor and the coercion level
-- >>> mkPrtListCase (Rule "[]" (ListCat (Cat "Foo")) [])
-- prtList _ [] = (concatD [])
-- >>> mkPrtListCase (Rule "(:[])" (ListCat (Cat "Foo")) [Left (Cat "FOO")])
-- prtList _ [x] = (concatD [prt 0 x])
-- >>> mkPrtListCase (Rule "(:)" (ListCat (Cat "Foo")) [Left (Cat "Foo"), Left (ListCat (Cat "Foo"))])
-- prtList _ (x:xs) = (concatD [prt 0 x, prt 0 xs])
-- >>> mkPrtListCase (Rule "[]" (ListCat (CoercCat "Foo" 2)) [])
-- prtList 2 [] = (concatD [])
-- >>> mkPrtListCase (Rule "(:[])" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2)])
-- prtList 2 [x] = (concatD [prt 2 x])
-- >>> mkPrtListCase (Rule "(:)" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2), Left (ListCat (CoercCat "Foo" 2))])
-- prtList 2 (x:xs) = (concatD [prt 2 x, prt 2 xs])
mkPrtListCase :: Rule -> Doc
mkPrtListCase (Rule f (ListCat c) rhs)
| isNilFun f = "prtList" <+> precPattern <+> "[]" <+> "=" <+> body
| isOneFun f = "prtList" <+> precPattern <+> "[x]" <+> "=" <+> body
| isConsFun f = "prtList" <+> precPattern <+> "(x:xs)" <+> "=" <+> body
| otherwise = empty -- (++) constructor
where
precPattern = case precCat c of 0 -> "_" ; p -> integer p
body = mkRhs ["x", "xs"] rhs
-- | Define an ordering on lists' rules with the following properties:
-- - rules with a higher coercion level should come first, i.e. the rules for
-- [Foo3] are before rules for [Foo1] and they are both lower than rules for
-- [Foo].
-- - [] < [_] < _:_
-- This is desiged to correctly order the rules in the prtList function so that
-- the pattern matching works as expectd.
--
-- >>> compareRules (Rule "[]" (ListCat (CoercCat "Foo" 3)) []) (Rule "[]" (ListCat (CoercCat "Foo" 1)) [])
-- LT
-- >>> compareRules (Rule "[]" (ListCat (CoercCat "Foo" 3)) []) (Rule "[]" (ListCat (Cat "Foo")) [])
-- LT
-- >>> compareRules (Rule "[]" (ListCat (Cat "Foo")) []) (Rule "(:[])" (ListCat (Cat "Foo")) [])
-- LT
-- >>> compareRules (Rule "(:[])" (ListCat (Cat "Foo")) []) (Rule "(:)" (ListCat (Cat "Foo")) [])
-- LT
compareRules :: Rule -> Rule -> Ordering
compareRules r1 r2 | precRule r1 > precRule r2 = LT
compareRules r1 r2 | precRule r1 < precRule r2 = GT
compareRules (Rule "[]" _ _) (Rule "[]" _ _) = EQ
compareRules (Rule "[]" _ _) _ = LT
compareRules (Rule "(:[])" _ _) (Rule "[]" _ _) = GT
compareRules (Rule "(:[])" _ _) (Rule "(:[])" _ _) = EQ
compareRules (Rule "(:[])" _ _) (Rule "(:)" _ _) = LT
compareRules (Rule "(:)" _ _) (Rule "(:)" _ _) = EQ
compareRules (Rule "(:)" _ _) _ = GT
compareRules _ _ = EQ
-- |
-- >>> mkRhs ["expr1", "n", "expr2"] [Left (Cat "Expr"), Right "-", Left (TokenCat "Integer"), Left (Cat "Expr")]
-- (concatD [prt 0 expr1, doc (showString "-"), prt 0 n, prt 0 expr2])
--
-- Coercions on the right hand side should be passed to prt:
-- >>> mkRhs ["expr1"] [Left (CoercCat "Expr" 2)]
-- (concatD [prt 2 expr1])
-- >>> mkRhs ["expr2s"] [Left (ListCat (CoercCat "Expr" 2))]
-- (concatD [prt 2 expr2s])
mkRhs :: [String] -> [Either Cat String] -> Doc
mkRhs args its =
parens ("concatD" <+> brackets (hsep (punctuate "," (mk args its))))
where
mk args (Left InternalCat : items) = mk args items
mk (arg:args) (Left c : items) = (prt c <+> text arg) : mk args items
mk args (Right s : items) = ("doc (showString" <+> text (show s) <> ")") : mk args items
mk _ _ = []
prt c = "prt" <+> integer (precCat c)
BNFC-2.8.1/src/BNFC/Backend/Haskell/CFtoAlex2.hs0000644000000000000000000003043312654616013016723 0ustar0000000000000000{-
BNF Converter: Alex 2.0 Generator
Copyright (C) 2004 Author: Peter Gammie
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
-------------------------------------------------------------------
-- |
-- Module : BNFC.Backend.Haskell.CFtoAlex2
-- Copyright : (C)opyright 2003, {aarne,markus,peteg} at cs dot chalmers dot se
-- License : GPL (see COPYING for details)
--
-- Maintainer : {markus,aarne} at cs dot chalmers dot se
-- Stability : alpha
-- Portability : Haskell98
--
-- Hacked version of @BNFC.Backend.Haskell.CFtoAlex@ to cope with Alex2.
--
-------------------------------------------------------------------
module BNFC.Backend.Haskell.CFtoAlex2 (cf2alex2) where
import BNFC.CF
import Data.List
-- For RegToAlex, see below.
import AbsBNF
import Data.Char
cf2alex2 :: String -> String -> String -> Bool -> Bool -> CF -> String
cf2alex2 name errMod shareMod shareStrings byteStrings cf =
unlines $ intercalate [""] [
prelude name errMod shareMod shareStrings byteStrings,
cMacros,
rMacros cf,
restOfAlex shareMod shareStrings byteStrings cf
]
prelude :: String -> String -> String -> Bool -> Bool -> [String]
prelude name _ shareMod shareStrings byteStrings = [
"-- -*- haskell -*-",
"-- This Alex file was machine-generated by the BNF converter",
"{",
"{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}",
"module " ++ name ++ " where",
"",
-- "import " ++ errMod,
if shareStrings then "import " ++ shareMod else "",
if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "",
"}",
""
]
cMacros :: [String]
cMacros = [
"$l = [a-zA-Z\\192 - \\255] # [\\215 \\247] -- isolatin1 letter FIXME",
"$c = [A-Z\\192-\\221] # [\\215] -- capital isolatin1 letter FIXME",
"$s = [a-z\\222-\\255] # [\\247] -- small isolatin1 letter FIXME",
"$d = [0-9] -- digit",
"$i = [$l $d _ '] -- identifier character",
"$u = [\\0-\\255] -- universal: any character"
]
rMacros :: CF -> [String]
rMacros cf =
let symbs = symbols cf
in
(if null symbs then [] else [
"@rsyms = -- symbols and non-identifier-like reserved words",
" " ++ unwords (intersperse "|" (map mkEsc symbs))
])
where
mkEsc = unwords . esc
esc s = if null a then rest else show a : rest
where (a,r) = span isAlphaNum s
rest = case r of
[] -> []
(c:xs) -> s : esc xs
where s = if isPrint c then ['\\',c]
else '\\':show (ord c)
restOfAlex :: String -> Bool -> Bool -> CF -> [String]
restOfAlex _ shareStrings byteStrings cf = [
":-",
lexComments (comments cf),
"$white+ ;",
pTSpec (symbols cf),
userDefTokenTypes,
ident,
ifC catString ("\\\" ([$u # [\\\" \\\\ \\n]] | (\\\\ (\\\" | \\\\ | \\' | n | t)))* \\\"" ++
"{ tok (\\p s -> PT p (TL $ share $ unescapeInitTail s)) }"),
ifC catChar "\\\' ($u # [\\\' \\\\] | \\\\ [\\\\ \\\' n t]) \\' { tok (\\p s -> PT p (TC $ share s)) }",
ifC catInteger "$d+ { tok (\\p s -> PT p (TI $ share s)) }",
ifC catDouble "$d+ \\. $d+ (e (\\-)? $d+)? { tok (\\p s -> PT p (TD $ share s)) }",
"",
"{",
"",
"tok f p s = f p s",
"",
"share :: "++stringType++" -> "++stringType,
"share = " ++ if shareStrings then "shareString" else "id",
"",
"data Tok =",
" TS !"++stringType++" !Int -- reserved words and symbols",
" | TL !"++stringType++" -- string literals",
" | TI !"++stringType++" -- integer literals",
" | TV !"++stringType++" -- identifiers",
" | TD !"++stringType++" -- double precision float literals",
" | TC !"++stringType++" -- character literals",
userDefTokenConstrs,
" deriving (Eq,Show,Ord)",
"",
"data Token = ",
" PT Posn Tok",
" | Err Posn",
" deriving (Eq,Show,Ord)",
"",
"tokenPos (PT (Pn _ l _) _ :_) = \"line \" ++ show l",
"tokenPos (Err (Pn _ l _) :_) = \"line \" ++ show l",
"tokenPos _ = \"end of file\"",
"",
"posLineCol (Pn _ l c) = (l,c)",
"mkPosToken t@(PT p _) = (posLineCol p, prToken t)",
"",
"prToken t = case t of",
" PT _ (TS s _) -> s",
" PT _ (TL s) -> show s",
" PT _ (TI s) -> s",
" PT _ (TV s) -> s",
" PT _ (TD s) -> s",
" PT _ (TC s) -> s",
userDefTokenPrint,
"",
"data BTree = N | B "++stringType++" Tok BTree BTree deriving (Show)",
"",
"eitherResIdent :: ("++stringType++" -> Tok) -> "++stringType++" -> Tok",
"eitherResIdent tv s = treeFind resWords",
" where",
" treeFind N = tv s",
" treeFind (B a t left right) | s < a = treeFind left",
" | s > a = treeFind right",
" | s == a = t",
"",
"resWords = " ++ show (sorted2tree $ zip (sort resws) [1..]),
" where b s n = let bs = "++stringPack++" s",
" in B bs (TS bs n)",
"",
"unescapeInitTail :: "++stringType++" -> "++stringType++"",
"unescapeInitTail = "++stringPack++" . unesc . tail . "++stringUnpack++" where",
" unesc s = case s of",
" '\\\\':c:cs | elem c ['\\\"', '\\\\', '\\\''] -> c : unesc cs",
" '\\\\':'n':cs -> '\\n' : unesc cs",
" '\\\\':'t':cs -> '\\t' : unesc cs",
" '\"':[] -> []",
" c:cs -> c : unesc cs",
" _ -> []",
"",
"-------------------------------------------------------------------",
"-- Alex wrapper code.",
"-- A modified \"posn\" wrapper.",
"-------------------------------------------------------------------",
"",
"data Posn = Pn !Int !Int !Int",
" deriving (Eq, Show,Ord)",
"",
"alexStartPos :: Posn",
"alexStartPos = Pn 0 1 1",
"",
"alexMove :: Posn -> Char -> Posn",
"alexMove (Pn a l c) '\\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)",
"alexMove (Pn a l c) '\\n' = Pn (a+1) (l+1) 1",
"alexMove (Pn a l c) _ = Pn (a+1) l (c+1)",
"",
"type AlexInput = (Posn, -- current position,",
" Char, -- previous char",
" "++stringType++") -- current input string",
"",
"tokens :: "++stringType++" -> [Token]",
"tokens str = go (alexStartPos, '\\n', str)",
" where",
" go :: AlexInput -> [Token]",
" go inp@(pos, _, str) =",
" case alexScan inp 0 of",
" AlexEOF -> []",
" AlexError (pos, _, _) -> [Err pos]",
" AlexSkip inp' len -> go inp'",
" AlexToken inp' len act -> act pos ("++stringTake++" len str) : (go inp')",
"",
"alexGetChar :: AlexInput -> Maybe (Char,AlexInput)",
"alexGetChar (p, _, s) =",
" case "++stringUncons++" s of",
" "++stringNilP++" -> Nothing",
" "++stringConsP++" ->",
" let p' = alexMove p c",
" in p' `seq` Just (c, (p', c, s))",
"",
"alexInputPrevChar :: AlexInput -> Char",
"alexInputPrevChar (p, c, s) = c",
"}"
]
where
(stringType,stringTake,stringUncons,stringPack,stringUnpack,stringNilP,stringConsP)
| byteStrings = ("BS.ByteString", "BS.take", "BS.uncons", "BS.pack", "BS.unpack", "Nothing", "Just (c,s)")
| otherwise = ("String", "take", "", "id", "id", "[]", "(c:s)" )
ifC cat s = if isUsedCat cf cat then s else ""
lexComments ([],[]) = []
lexComments (xs,s1:ys) = '\"' : s1 ++ "\"" ++ " [.]* ; -- Toss single line comments\n" ++ lexComments (xs, ys)
lexComments (([l1,l2],[r1,r2]):xs,[]) = concat
[
'\"':l1:l2:"\" ([$u # \\", -- FIXME quotes or escape?
r1:"] | \\",
r1:"+ [$u # [\\",
r1:" \\",
r2:"]])* (\"",
r1:"\")+ \"",
r2:"\" ; \n",
lexComments (xs, [])
]
lexComments (_:xs,[]) = lexComments (xs,[])
--- lexComments (xs,(_:ys)) = lexComments (xs,ys)
-- tokens consisting of special symbols
pTSpec [] = ""
pTSpec _ = "@rsyms { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }"
userDefTokenTypes = unlines
[printRegAlex exp ++
" { tok (\\p s -> PT p (eitherResIdent (T_" ++ show name ++ " . share) s)) }"
| (name,exp) <- tokenPragmas cf]
userDefTokenConstrs = unlines
[" | T_" ++ name ++ " !"++stringType | name <- tokenNames cf]
userDefTokenPrint = unlines
[" PT _ (T_" ++ name ++ " s) -> s" | name <- tokenNames cf]
ident =
"$l $i* { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }"
--ifC "Ident" " ::= ^l ^i* { ident p = PT p . eitherResIdent TV }"
resws = reservedWords cf ++ symbols cf
data BTree = N | B String Int BTree BTree
instance Show BTree where
showsPrec _ N = showString "N"
showsPrec n (B s k l r) = wrap (showString "b " . shows s . showChar ' '. shows k . showChar ' '
. showsPrec 1 l . showChar ' '
. showsPrec 1 r)
where wrap f = if n > 0 then showChar '(' . f . showChar ')' else f
sorted2tree :: [(String,Int)] -> BTree
sorted2tree [] = N
sorted2tree xs = B x n (sorted2tree t1) (sorted2tree t2) where
(t1,(x,n):t2) = splitAt (length xs `div` 2) xs
-------------------------------------------------------------------
-- Inlined version of @BNFC.Backend.Haskell.RegToAlex@.
-- Syntax has changed...
-------------------------------------------------------------------
-- modified from pretty-printer generated by the BNF converter
-- the top-level printing method
printRegAlex :: Reg -> String
printRegAlex = render . prt 0
-- you may want to change render and parenth
render :: [String] -> String
render = rend 0
where rend :: Int -> [String] -> String
rend i ss = case ss of
"[" :ts -> cons "[" $ rend i ts
"(" :ts -> cons "(" $ rend i ts
t : "," :ts -> cons t $ space "," $ rend i ts
t : ")" :ts -> cons t $ cons ")" $ rend i ts
t : "]" :ts -> cons t $ cons "]" $ rend i ts
t :ts -> space t $ rend i ts
_ -> ""
cons s t = s ++ t
space t s = if null s then t else t ++ " " ++ s
parenth :: [String] -> [String]
parenth ss = ["("] ++ ss ++ [")"]
-- the printer class does the job
class Print a where
prt :: Int -> a -> [String]
prtList :: [a] -> [String]
prtList = concatMap (prt 0)
instance Print a => Print [a] where
prt _ = prtList
instance Print Char where
prt _ c = if isAlphaNum c then [[c]] else ['\\':[c]]
prtList = map (concat . prt 0)
prPrec :: Int -> Int -> [String] -> [String]
prPrec i j = if j prPrec i 2 (prt 2 reg0 ++ prt 3 reg)
RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])
RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])
RStar reg -> prPrec i 3 (prt 3 reg ++ ["*"])
RPlus reg -> prPrec i 3 (prt 3 reg ++ ["+"])
ROpt reg -> prPrec i 3 (prt 3 reg ++ ["?"])
REps -> prPrec i 3 ["()"]
RChar c -> prPrec i 3 (prt 0 c)
RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]])
RSeqs str -> prPrec i 2 (concatMap (prt 0) str)
RDigit -> prPrec i 3 ["$d"]
RLetter -> prPrec i 3 ["$l"]
RUpper -> prPrec i 3 ["$c"]
RLower -> prPrec i 3 ["$s"]
RAny -> prPrec i 3 ["$u"]
BNFC-2.8.1/src/BNFC/Backend/Haskell/ToCNF.hs0000644000000000000000000002131512654616013016104 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-
Copyright (C) 2012 Authors:
Jean-Philippe Bernardy.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-# LANGUAGE OverloadedStrings #-}
module BNFC.Backend.Haskell.ToCNF (generate, genTestFile, genBenchmark) where
{-
Construction of CYK tables. The algorithm follows:
Lange, Martin; Leiß, Hans (2009), "To CNF or not to CNF? An Efficient
Yet Presentable Version of the CYK Algorithm", Informatica Didactica
-}
import BNFC.ToCNFCore
import BNFC.CF hiding (App,Exp)
import BNFC.Backend.Haskell.HsOpts
import Control.Monad.RWS
import Control.Applicative hiding (Const)
import qualified Data.Map as M
import Data.Pair
import Text.PrettyPrint.HughesPJ hiding (first,(<>))
-- Code generation
incomment x = "{-" <> x <> "-}"
generate opts cf0 = render $ vcat [header opts
,genShowFunction cf0
,genCatTags cf1
,genDesc cf1 descriptions
,genNeighborSet neighbors
,genCombTable units (onRules (filter (not . isUnitRule)) cf)
,genTokTable units cf
,incomment $ vcat
["Normalised grammar:"
,text $ show cf
,"Unit relation:"
,prettyUnitSet units
]
]
where (cf1,cf,units,descriptions,neighbors) = toCNF cf0
class Pretty a where
pretty :: a -> Doc
instance (Pretty k, Pretty v) => Pretty (Set k v) where
pretty s = sep [pretty k <> " --> " <> pretty v | (k,x) <- M.assocs s, v <- x]
instance Pretty (Either Cat String) where
pretty (Left x) = text $ show x
pretty (Right x) = quotes $ text x
instance Pretty String where
pretty = text
prettyUnitSet units = vcat [prettyExp f <> " : " <> catTag cat <> " --> " <> text (show cat') | (cat,x) <- M.assocs units, (f,cat') <- x]
header opts
= vcat ["{-# LANGUAGE MagicHash, FlexibleInstances #-}"
,"module " <> text (cnfTablesFileM opts) <> " where"
,"import GHC.Prim"
,"import GHC.Exts"
,"import Control.Applicative hiding (Const)"
,"import Algebra.RingUtils"
,"import Parsing.Chart ()"
,"import " <> text (absFileM opts)
,"import " <> text (alexFileM opts)
,"import " <> text ( printerFileM opts)
,"readInteger :: String -> Integer"
,"readInteger = read"
,"readDouble :: String -> Double"
,"readDouble = read"
,"instance RingP [(CATEGORY,Any)] where"
," mul p a b = trav [map (app tx ty) l :/: map (app tx ty) r | (x,tx) <- a, (y,ty) <- b, let l:/:r = combine p x y]"
," where trav :: [Pair [a]] -> Pair [a]"
," trav [] = pure []"
," trav (x:xs) = (++) <$> x <*> trav xs"
," app tx ty (z,f) = (z, f tx ty)"
]
genShowFunction cf = hang "showAst (cat,ast) = case cat of " 6
(vcat [catTag (Left cat) <> " -> printTree ((unsafeCoerce# ast)::" <> text (show cat) <> ")"
| cat <- filter isDataCat $ allCats cf] $$
"_ -> \"Unprintable category\"")
genCatTags :: CFG Exp -> Doc
genCatTags cf = "data CATEGORY = " <> punctuate' "|" (map catTag (allSyms cf)) $$
" deriving (Eq,Ord,Show)"
genDesc :: CFG Exp -> CatDescriptions -> Doc
genDesc cf descs = vcat ["describe " <> catTag s <> " = " <> text (show (descOf s)) | s <- allSyms cf]
where descOf :: Either Cat String -> String
descOf (Right x) = "token " <> x
descOf (Left x) = maybe (show x) render $ M.lookup x descs
genCombTable :: UnitRel Cat -> CFG Exp -> Doc
genCombTable units cf =
"combine :: Bool -> CATEGORY -> CATEGORY -> Pair [(CATEGORY, Any -> Any -> Any)]"
$$ genCombine units cf
$$ "combine _ _ _ = pure []"
allSyms :: CFG Exp -> [Either Cat String]
allSyms cf = map Left (allCats cf ++ literals cf) ++ map (Right . fst) (cfTokens cf)
ppPair (x,y) = parens $ x <> comma <> " " <> y
unsafeCoerce' = app' (Con "unsafeCoerce#")
prettyPair (x :/: y) = sep [x,":/:",y]
prettyListFun xs = parens $ sep (map (<> "$") xs) <> "[]"
genCombine :: UnitRel Cat -> CFG Exp -> Doc
genCombine units cf = vcat $ map genEntry $ group' $ map (alt units) (rulesOfCF cf)
where genEntry :: ((RHSEl,RHSEl),[(Cat,Exp)]) -> Doc
genEntry ((r1,r2),cs) = "combine p " <> catTag r1 <> " " <> catTag r2 <> " = " <> prettyPair (genList <$> splitOptim (Left . fst) cf cs)
mkLam body = "\\x y -> " <> body
genList xs = prettyListFun [p (ppPair (catTag . Left $ x, mkLam . prettyExp . unsafeCoerce' $ y)) | ((x,y),p) <- xs]
alt :: UnitRel Cat -> Rul Exp -> ((RHSEl,RHSEl),[(Cat,Exp)])
alt units (Rule f c [r1,r2]) = ((r1,r2),initial:others)
where initial = (c, f `appMany` args)
others = [(c', f' `app'` (f `appMany` args)) | (f',c') <- lookupMulti (Left c) units]
args = map (unsafeCoerce' . Con) $ ["x"|isCat r1]++["y"|isCat r2]
alt _ _ = error "Only works with binary rules"
genTokTable :: UnitRel Cat -> CFG Exp -> Doc
genTokTable units cf = "tokenToCats :: Bool -> Token -> Pair [(CATEGORY,Any)]" $$
vcat (map (genSpecEntry cf units) (tokInfo cf)) $$
vcat (map (genTokEntry cf units) (cfTokens cf)) $$
"tokenToCats p t = error (\"unknown token: \" ++ show t)"
tokInfo cf = (catChar,"TC",Con "head"):
(catString,"TL",Id):
(catInteger,"TI",Con "readInteger"):
(catDouble,"TD",Con "readDouble"):
[(catIdent,"TV",Con "Ident")|hasIdent cf] ++
[(t,"T_" <> text (show t),(Con (show t))) | (t,_) <- tokenPragmas cf]
genTokCommon cf xs = prettyPair (gen <$> splitOptim fst cf xs)
where gen ys = prettyListFun [p (ppPair (catTag x,y)) | ((x,y),p) <- ys]
genSpecEntry cf units (tokName,constrName,fun) = "tokenToCats p (PT (Pn _ l c) (" <> constrName <> " x)) = " <> genTokCommon cf xs
where xs = map (second (prettyExp . (\f -> unsafeCoerce' (f `app'` tokArgs)))) $
(Left tokName, fun) : [(Left c,f `after` fun) | (f,c) <- lookupMulti (Left tokName) units]
tokArgs | isPositionCat cf tokName = Con "((l,c),x)"
| otherwise = Con "x"
genTokEntry cf units (tok,x) =
" -- " <> text tok $$
"tokenToCats p (PT posn (TS _ " <> int x <> ")) = " <> genTokCommon cf xs
where xs = (Right tok, tokVal) :
[(Left c,prettyExp (unsafeCoerce' f)) | (f,c) <- lookupMulti (Right tok) units]
tokVal = "error" <> (text $ show $ "cannot access value of token: " ++ tok)
ppList = brackets . punctuate' ", "
genNeighborSet ns = vcat
["neighbors " <> catTag x <> " = " <> ppList (map catTag y)
| (x,y) <- ns] $$
"neighbors _ = []"
------------------------
-- Test file generation
genTestFile opts _ = render $ vcat
["module Main where"
,"import " <> text ( alexFileM opts)
,"import " <> text ( cnfTablesFileM opts)
,"import Parsing.TestProgram"
,"main = mainTest showAst tokenToCats tokens tokenLineCol describe neighbors"]
genBenchmark opts = render $ vcat
["import System.Environment ( getArgs )"
,"import "<> text ( alexFileM opts) <> " as Lexer"
,"import "<> text ( cnfTablesFileM opts) <> " as Parser"
,"import GHC.Exts"
,"import Parsing.Chart"
,"import Criterion.Main"
,"import Algebra.RingUtils"
,"import Control.Applicative"
,"type T = [(CATEGORY,Any)]"
,"pLGrammar :: [Pair T] -> MT2 T"
,"pLGrammar = mkTree"
,"main = do"
," f:_ <- getArgs"
," s <- readFile f"
," let ts = zipWith tokenToCats (cycle [False,True]) (Lexer.tokens s)"
," (ts1,x:ts2) = splitAt (length ts `div` 2) ts"
," cs = [mkTree ts1,mkTree' ts2]"
," work [c1,c2] = show $ map fst $ root $ mergein False c1 x c2"
," defaultMain [bench f $ nf work cs] -- note the hack!!!"
]
BNFC-2.8.1/src/BNFC/Backend/C/0000755000000000000000000000000012654616013013434 5ustar0000000000000000BNFC-2.8.1/src/BNFC/Backend/C/CFtoFlexC.hs0000644000000000000000000001507412654616013015554 0ustar0000000000000000{-
BNF Converter: C flex generator
Copyright (C) 2004 Author: Michael Pellauer
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the Flex file. It is
similar to JLex but with a few peculiarities.
Author : Michael Pellauer (pellauer@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 5 August, 2003
Modified : 10 August, 2003
**************************************************************
-}
module BNFC.Backend.C.CFtoFlexC (cf2flex) where
import BNFC.CF
import BNFC.Backend.CPP.NoSTL.RegToFlex
import BNFC.Backend.Common.NamedVariables
--The environment must be returned for the parser to use.
cf2flex :: String -> CF -> (String, SymEnv)
cf2flex name cf = (unlines
[
prelude name,
cMacros,
lexSymbols env,
restOfFlex cf env'
], env')
where
env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int)
env' = env ++ (makeSymEnv (tokenNames cf) (length env))
makeSymEnv [] _ = []
makeSymEnv (s:symbs) n = (s, "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1))
prelude :: String -> String
prelude name = unlines
[
"/* -*- c -*- This FLex file was machine-generated by the BNF converter */",
"%option noyywrap",
"%{",
"#define yylval " ++ name ++ "lval",
"#define YY_BUFFER_APPEND " ++ name ++ "_BUFFER_APPEND",
"#define YY_BUFFER_RESET " ++ name ++ "_BUFFER_RESET",
"#define initialize_lexer " ++ name ++ "_initialize_lexer",
"#include ",
"#include \"Parser.h\"",
"#define YY_BUFFER_LENGTH 4096",
"extern int yy_mylinenumber ;",
"char YY_PARSED_STRING[YY_BUFFER_LENGTH];",
"void YY_BUFFER_APPEND(char *s)",
"{",
" strcat(YY_PARSED_STRING, s); //Do something better here!",
"}",
"void YY_BUFFER_RESET(void)",
"{",
" int x;",
" for(x = 0; x < YY_BUFFER_LENGTH; x++)",
" YY_PARSED_STRING[x] = 0;",
"}",
"",
"%}"
]
--For now all categories are included.
--Optimally only the ones that are used should be generated.
cMacros :: String
cMacros = unlines
[
"LETTER [a-zA-Z]",
"CAPITAL [A-Z]",
"SMALL [a-z]",
"DIGIT [0-9]",
"IDENT [a-zA-Z0-9'_]",
"%START YYINITIAL COMMENT CHAR CHARESC CHAREND STRING ESCAPED",
"%%"
]
lexSymbols :: SymEnv -> String
lexSymbols ss = concatMap transSym ss
where
transSym (s,r) =
"\"" ++ s' ++ "\" \t return " ++ r ++ ";\n"
where
s' = escapeChars s
restOfFlex :: CF -> SymEnv -> String
restOfFlex cf env = concat
[
lexComments (comments cf),
userDefTokens,
ifC catString strStates,
ifC catChar chStates,
ifC catDouble "{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t yylval.double_ = atof(yytext); return _DOUBLE_;\n",
ifC catInteger "{DIGIT}+ \t yylval.int_ = atoi(yytext); return _INTEGER_;\n",
ifC catIdent "{LETTER}{IDENT}* \t yylval.string_ = strdup(yytext); return _IDENT_;\n",
"\\n ++yy_mylinenumber ;\n",
"[ \\t\\r\\n\\f] \t /* ignore white space. */;\n",
". \t return _ERROR_;\n",
"%%\n",
footer
]
where
ifC cat s = if isUsedCat cf cat then s else ""
userDefTokens = unlines $
["" ++ printRegFlex exp ++
" \t yylval.string_ = strdup(yytext); return " ++ sName name ++ ";"
| (name, exp) <- tokenPragmas cf]
where
sName n = case lookup (show n) env of
Just x -> x
Nothing -> show n
strStates = unlines --These handle escaped characters in Strings.
[
"\"\\\"\" \t BEGIN STRING;",
"\\\\ \t BEGIN ESCAPED;",
"\\\" \t yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return _STRING_;",
". \t YY_BUFFER_APPEND(yytext);",
"n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;",
"\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;",
"\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;",
"t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;",
". \t YY_BUFFER_APPEND(yytext); BEGIN STRING;"
]
chStates = unlines --These handle escaped characters in Chars.
[
"\"'\" \tBEGIN CHAR;",
"\\\\ \t BEGIN CHARESC;",
"[^'] \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;",
"n \t BEGIN CHAREND; yylval.char_ = '\\n'; return _CHAR_;",
"t \t BEGIN CHAREND; yylval.char_ = '\\t'; return _CHAR_;",
". \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;",
"\"'\" \t BEGIN YYINITIAL;"
]
footer = "void initialize_lexer(FILE *inp) { yyrestart(inp); BEGIN YYINITIAL; }"
lexComments :: ([(String, String)], [String]) -> String
lexComments (m,s) =
(unlines (map lexSingleComment s))
++ (unlines (map lexMultiComment m))
lexSingleComment :: String -> String
lexSingleComment c =
"\"" ++ c ++ "\"[^\\n]*\\n ++yy_mylinenumber; \t /* BNFC single-line comment */;"
--There might be a possible bug here if a language includes 2 multi-line comments.
--They could possibly start a comment with one character and end it with another.
--However this seems rare.
lexMultiComment :: (String, String) -> String
lexMultiComment (b,e) = unlines [
"\"" ++ b ++ "\" \t BEGIN COMMENT;",
"\"" ++ e ++ "\" \t BEGIN YYINITIAL;",
". \t /* BNFC multi-line comment */;",
"[\\n] ++yy_mylinenumber ; \t /* BNFC multi-line comment */;"
]
--Helper function that escapes characters in strings
escapeChars :: String -> String
escapeChars [] = []
escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))
escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))
escapeChars (x:xs) = x : (escapeChars xs)
BNFC-2.8.1/src/BNFC/Backend/C/CFtoCAbs.hs0000644000000000000000000002427612654616013015367 0ustar0000000000000000{-
BNF Converter: C Abstract syntax
Copyright (C) 2004 Author: Michael Pellauer
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the C Abstract Syntax
tree classes. It generates both a Header file
and an Implementation file, and Appel's C
method.
Author : Michael Pellauer (pellauer@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 15 September, 2003
Modified : 15 September, 2003
**************************************************************
-}
module BNFC.Backend.C.CFtoCAbs (cf2CAbs) where
import BNFC.CF
import BNFC.PrettyPrint
import BNFC.Utils((+++))
import BNFC.Backend.Common.NamedVariables
import Data.Function (on)
import Data.List
import Data.Char(toLower)
--The result is two files (.H file, .C file)
cf2CAbs :: String -> CF -> (String, String)
cf2CAbs _ cf = (mkHFile cf, mkCFile cf)
{- **** Header (.H) File Functions **** -}
--Makes the Header file.
mkHFile :: CF -> String
mkHFile cf = unlines
[
"#ifndef ABSYN_HEADER",
"#define ABSYN_HEADER",
"",
header,
prTypeDefs user,
"/******************** Forward Declarations ********************/\n",
concatMap prForward classes,
"",
"/******************** Abstract Syntax Classes ********************/\n",
concatMap prDataH (getAbstractSyntax cf),
"",
"#endif"
]
where
user = fst (unzip (tokenPragmas cf))
header = "/* C++ Abstract Syntax Interface generated by the BNF Converter.*/\n"
rules = getRules cf
classes = nub (rules ++ getClasses (allCats cf))
prForward s | not (isCoercion s) = unlines
[
"struct " ++ s ++ "_;",
"typedef struct " ++ s ++ "_ *" ++ s ++ ";"
]
prForward _ = ""
getRules cf = (map testRule (rulesOfCF cf))
getClasses = map show . filter (\c -> identCat (normCat c) == show c)
testRule (Rule f c _) =
if isList c
then if isConsFun f
then identCat (normCat c)
else "_" --ignore this
else "_"
-- | Prints struct definitions for all categories.
prDataH :: Data -> String
prDataH (cat, rules) =
if isList cat
then unlines
[
"struct " ++ c' ++ "_",
"{",
" " ++ mem +++ varName mem ++ ";",
" " ++ c' +++ varName c' ++ ";",
"};",
"",
c' ++ " make_" ++ c' ++ "(" ++ mem ++ " p1, " ++ c' ++ " p2);"
]
else unlines
[
"struct " ++ show cat ++ "_",
"{",
" enum { " ++ intercalate ", " (map prKind rules) ++ " } kind;",
" union",
" {",
concatMap prUnion rules ++ " } u;",
"};",
"",
concatMap (prRuleH cat) rules
]
where
c' = identCat (normCat cat)
mem = identCat (normCatOfList cat)
prKind (fun, _) = "is_" ++ fun
prUnion (_, []) = ""
prUnion (fun, cats) = " struct { " ++ (render $ prInstVars (getVars cats)) ++ " } " ++ (memName fun) ++ ";\n"
--Interface definitions for rules vary on the type of rule.
prRuleH :: Cat -> (Fun, [Cat]) -> String
prRuleH c (fun, cats) =
if isNilFun fun || isOneFun fun || isConsFun fun
then "" --these are not represented in the AbSyn
else --a standard rule
show c ++ " make_" ++ fun ++ "(" ++ (prParamsH 0 (getVars cats)) ++ ");\n"
where
prParamsH :: Int -> [(String, a)] -> String
prParamsH _ [] = ""
prParamsH n ((t,_):[]) = t ++ " p" ++ (show n)
prParamsH n ((t,_):vs) = (t ++ " p" ++ (show n) ++ ", ") ++ (prParamsH (n+1) vs)
--typedefs in the Header make generation much nicer.
prTypeDefs user = unlines
[
"/******************** TypeDef Section ********************/",
"typedef int Integer;",
"typedef char Char;",
"typedef double Double;",
"typedef char* String;",
"typedef char* Ident;",
concatMap prUserDef user
]
where
prUserDef s = "typedef char* " ++ show s ++ ";\n"
-- | A class's instance variables. Print the variables declaration by grouping
-- together the variables of the same type.
-- >>> prInstVars [("A", 1)]
-- A a_1;
-- >>> prInstVars [("A",1),("A",2),("B",1)]
-- A a_1, a_2; B b_1;
prInstVars :: [IVar] -> Doc
prInstVars =
hsep . map prInstVarsOneType . groupBy ((==) `on` fst) . sort
where
prInstVarsOneType ivars = text (fst (head ivars))
<+> hsep (punctuate comma (map prIVar ivars))
<> semi
prIVar (s, i) = text (varName s) <> text (showNum i)
{- **** Implementation (.C) File Functions **** -}
--Makes the .C file
mkCFile :: CF -> String
mkCFile cf = unlines
[
header,
concatMap (render . prDataC) (getAbstractSyntax cf)
]
where
header = unlines
[
"/* C Abstract Syntax Implementation generated by the BNF Converter. */",
"",
"#include ",
"#include ",
"#include \"Absyn.h\"",
""
]
--This is not represented in the implementation.
--This is not represented in the implementation.
prDataC :: Data -> Doc
prDataC (cat, rules) = vsep $ map (prRuleC cat) rules
-- | Classes for rules vary based on the type of rule.
--
-- * Empty list constructor, these are not represented in the AbSyn
-- >>> prRuleC (ListCat (Cat "A")) ("[]", [Cat "A", Cat "B", Cat "B"])
--
--
-- * Linked list case. These are all built-in list functions.
-- Later we could include things like lookup,insert,delete,etc.
-- >>> prRuleC (ListCat (Cat "A")) ("(:)", [Cat "A", Cat "B", Cat "B"])
-- /******************** ListA ********************/
-- ListA make_ListA(A p1, ListA p2)
-- {
-- ListA tmp = (ListA) malloc(sizeof(*tmp));
-- if (!tmp)
-- {
-- fprintf(stderr, "Error: out of memory when allocating ListA!\n");
-- exit(1);
-- }
-- tmp->a_ = p1;
-- tmp->lista_ = p2;
-- return tmp;
-- }
--
-- * Standard rule
-- >>> prRuleC (Cat "A") ("funa", [Cat "A", Cat "B", Cat "B"])
-- /******************** funa ********************/
-- A make_funa(A p1, B p2, B p3)
-- {
-- A tmp = (A) malloc(sizeof(*tmp));
-- if (!tmp)
-- {
-- fprintf(stderr, "Error: out of memory when allocating funa!\n");
-- exit(1);
-- }
-- tmp->kind = is_funa;
-- tmp->u.funa_.a_ = p1;
-- tmp->u.funa_.b_1 = p2;
-- tmp->u.funa_.b_2 = p3;
-- return tmp;
-- }
prRuleC :: Cat -> (String, [Cat]) -> Doc
prRuleC _ (fun, _) | isNilFun fun || isOneFun fun = empty
prRuleC cat (fun, _) | isConsFun fun = vsep
[ "/******************** " <> c <> " ********************/"
, c <+> "make_" <> c <> parens (text m <+> "p1" <> "," <+> c <+> "p2")
, lbrace
, nest 4 $ vsep
[ c <+> "tmp = (" <> c <> ") malloc(sizeof(*tmp));"
, "if (!tmp)"
, lbrace
, nest 4 $ vsep
[ "fprintf(stderr, \"Error: out of memory when allocating " <> c <> "!\\n\");"
, "exit(1);" ]
, rbrace
, text $ "tmp->" ++ m' ++ " = " ++ "p1;"
, "tmp->" <> v <+> "=" <+> "p2;"
, "return tmp;" ]
, rbrace ]
where
icat = identCat (normCat cat)
c = text icat
v = text (map toLower icat ++ "_")
ListCat c' = cat -- We're making a list constructor, so we
-- expect a list category
m = identCat (normCat c')
m' = map toLower m ++ "_"
prRuleC c (fun, cats) = vsep
[ text $ "/******************** " ++ fun ++ " ********************/"
, prConstructorC c fun vs cats ]
where
vs = getVars cats
-- | The constructor just assigns the parameters to the corresponding instance
-- variables.
-- >>> prConstructorC (Cat "A") "funa" [("A",1),("B",2)] [Cat "O", Cat "E"]
-- A make_funa(O p1, E p2)
-- {
-- A tmp = (A) malloc(sizeof(*tmp));
-- if (!tmp)
-- {
-- fprintf(stderr, "Error: out of memory when allocating funa!\n");
-- exit(1);
-- }
-- tmp->kind = is_funa;
-- tmp->u.funa_.a_ = p1;
-- tmp->u.funa_.b_2 = p2;
-- return tmp;
-- }
prConstructorC :: Cat -> String -> [IVar] -> [Cat] -> Doc
prConstructorC cat c vs cats = vsep
[ text (cat' ++ " make_" ++ c) <> parens args
, lbrace
, nest 4 $ vsep
[ text $ cat' ++ " tmp = (" ++ cat' ++ ") malloc(sizeof(*tmp));"
, text "if (!tmp)"
, lbrace
, nest 4 $ vsep
[ text ("fprintf(stderr, \"Error: out of memory when allocating " ++ c ++ "!\\n\");")
, text "exit(1);" ]
, rbrace
, text $ "tmp->kind = is_" ++ c ++ ";"
, prAssigns c vs params
, text "return tmp;" ]
, rbrace ]
where
cat' = identCat (normCat cat)
(types, params) = unzip (prParams cats)
args = hsep $ punctuate comma $ zipWith (<+>) types params
-- | Prints the constructor's parameters. Returns pairs of type * name
-- >>> prParams [Cat "O", Cat "E"]
-- [(O,p1),(E,p2)]
prParams :: [Cat] -> [(Doc, Doc)]
prParams = zipWith prParam [1..]
where
prParam n c = (text (identCat c), text ("p" ++ show n))
-- | Prints the assignments of parameters to instance variables.
-- >>> prAssigns "A" [("A",1),("B",2)] [text "abc", text "def"]
-- tmp->u.a_.a_ = abc;
-- tmp->u.a_.b_2 = def;
prAssigns :: String -> [IVar] -> [Doc] -> Doc
prAssigns c vars params = vcat $ zipWith prAssign vars params
where
prAssign (t,n) p =
text ("tmp->u." ++ c' ++ "_." ++ vname t n) <+> char '=' <+> p <> semi
vname t n | n == 1 =
case findIndices ((== t).fst) vars of
[_] -> varName t
_ -> varName t ++ showNum n
vname t n = varName t ++ showNum n
c' = map toLower c
{- **** Helper Functions **** -}
memName s = map toLower s ++ "_"
BNFC-2.8.1/src/BNFC/Backend/C/CFtoCSkel.hs0000644000000000000000000001604512654616013015553 0ustar0000000000000000{-
BNF Converter: C Skeleton generator
Copyright (C) 2004 Author: Michael Pellauer
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the C Skeleton functions.
The generated files follow Appel's case method.
Author : Michael Pellauer (pellauer@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 9 August, 2003
Modified : 12 August, 2003
**************************************************************
-}
module BNFC.Backend.C.CFtoCSkel (cf2CSkel) where
import BNFC.CF
import BNFC.Utils ( (+++) )
import BNFC.Backend.Common.NamedVariables
import BNFC.Backend.Utils (isTokenType)
import Data.Char ( toLower, toUpper )
import Data.Either (lefts)
import Text.PrettyPrint
--Produces (.H file, .C file)
cf2CSkel :: CF -> (String, String)
cf2CSkel cf = (mkHFile cf groups, mkCFile cf groups)
where
groups = fixCoercions (ruleGroups cf)
{- **** Header (.H) File Functions **** -}
--Generates the Header File
mkHFile :: CF -> [(Cat,[Rule])] -> String
mkHFile cf groups = unlines
[
header,
concatMap prDataH groups,
concatMap prUserH user,
footer
]
where
user = fst (unzip (tokenPragmas cf))
header = unlines
[
"#ifndef SKELETON_HEADER",
"#define SKELETON_HEADER",
"/* You might want to change the above name. */",
"",
"#include \"Absyn.h\"",
""
]
prUserH user = "void visit" ++ u' ++ "(" ++ show user ++ " p);"
where
u' = let u = show user in toUpper (head u) : map toLower (tail u) --this is a hack to fix a potential capitalization problem.
footer = unlines
[
"void visitIdent(Ident i);",
"void visitInteger(Integer i);",
"void visitDouble(Double d);",
"void visitChar(Char c);",
"void visitString(String s);",
"",
"#endif"
]
--Prints out visit functions for a category
prDataH :: (Cat, [Rule]) -> String
prDataH (cat, _rules) =
if isList cat
then concat ["void visit", cl, "(", cl, " p);\n"]
else "void visit" ++ cl ++ "(" ++ cl ++ " p);\n"
where cl = identCat $ normCat cat
{- **** Implementation (.C) File Functions **** -}
-- | Makes the skeleton's .c File
mkCFile :: CF -> [(Cat,[Rule])] -> String
mkCFile cf groups = concat
[
header,
concatMap (prData user) groups,
concatMap (prUser.show) user,
footer
]
where
user = fst (unzip (tokenPragmas cf))
header = unlines [
"/*** BNFC-Generated Visitor Traversal Skeleton. ***/",
"/* This traverses the abstract syntax tree.",
" To use, copy Skeleton.h and Skeleton.c to",
" new files. */",
"",
"#include ",
"#include ",
"",
"#include \"Skeleton.h\"",
""
]
prUser u = unlines
[
"void visit" ++ u' ++ "(" ++ u ++ " p)",
"{",
" /* Code for " ++ u ++ " Goes Here */",
"}"
]
where
u' = toUpper (head u) : map toLower (tail u) --this is a hack to fix a potential capitalization problem.
footer = unlines
[
"void visitIdent(Ident i)",
"{",
" /* Code for Ident Goes Here */",
"}",
"void visitInteger(Integer i)",
"{",
" /* Code for Integer Goes Here */",
"}",
"void visitDouble(Double d)",
"{",
" /* Code for Double Goes Here */",
"}",
"void visitChar(Char c)",
"{",
" /* Code for Char Goes Here */",
"}",
"void visitString(String s)",
"{",
" /* Code for String Goes Here */",
"}",
""
]
--Visit functions for a category.
prData :: [UserDef] -> (Cat, [Rule]) -> String
prData user (cat, rules)
| isList cat = unlines
[
"void visit" ++ cl ++ "("++ cl +++ vname ++ ")",
"{",
" while(" ++ vname ++ " != 0)",
" {",
" /* Code For " ++ cl ++ " Goes Here */",
" visit" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_);",
" " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;",
" }",
"}",
""
]
-- Not a list:
| otherwise = unlines
[
"void visit" ++ cl ++ "(" ++ cl ++ " _p_)",
"{",
" switch(_p_->kind)",
" {",
concatMap (render . prPrintRule user) rules,
" default:",
" fprintf(stderr, \"Error: bad kind field when printing " ++ cl ++ "!\\n\");",
" exit(1);",
" }",
"}\n"
]
where cl = identCat $ normCat cat
ecl = identCat $ normCatOfList cat
vname = map toLower cl
member = map toLower ecl
-- | Visits all the instance variables of a category.
-- >>> let ab = Cat "ab"
-- >>> prPrintRule [] (Rule "abc" undefined [Left ab, Left ab])
-- case is_abc:
-- /* Code for abc Goes Here */
-- visitab(_p_->u.abc_.ab_1);
-- visitab(_p_->u.abc_.ab_2);
-- break;
-- >>> prPrintRule [ab] (Rule "abc" undefined [Left ab])
-- case is_abc:
-- /* Code for abc Goes Here */
-- visitAb(_p_->u.abc_.ab_);
-- break;
-- >>> prPrintRule [ab] (Rule "abc" undefined [Left ab, Left ab])
-- case is_abc:
-- /* Code for abc Goes Here */
-- visitAb(_p_->u.abc_.ab_1);
-- visitAb(_p_->u.abc_.ab_2);
-- break;
prPrintRule :: [UserDef] -> Rule -> Doc
prPrintRule user (Rule fun _c cats) | not (isCoercion fun) = nest 2 $ vcat
[ text $ "case is_" ++ fun ++ ":"
, nest 2 (vcat
[ "/* Code for " <> text fun <> " Goes Here */"
, cats'
, "break;" ])
]
where
cats' = vcat $ map (prCat user fun) (lefts (numVars cats))
prPrintRule _user (Rule _fun _ _) = ""
-- Prints the actual instance-variable visiting.
prCat :: [UserDef] -> Fun -> (Cat, Doc) -> Doc
prCat user fnm (cat, vname) =
let visitf = "visit" <> if isTokenType user cat
then basicFunName cat
else text (identCat (normCat cat))
in visitf <> parens ("_p_->u." <> text v <> "_." <> vname ) <> ";"
where v = map toLower $ normFun fnm
--The visit-function name of a basic type
basicFunName :: Cat -> Doc
basicFunName c = text (toUpper (head (show c)): tail (show c))
BNFC-2.8.1/src/BNFC/Backend/C/CFtoBisonC.hs0000644000000000000000000002236312654616013015727 0ustar0000000000000000{-
BNF Converter: C Bison generator
Copyright (C) 2004 Author: Michael Pellauer
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the Bison input file.
Note that because of the way bison stores results
the programmer can increase performance by limiting
the number of entry points in their grammar.
Author : Michael Pellauer (pellauer@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 6 August, 2003
Modified : 6 August, 2003
**************************************************************
-}
module BNFC.Backend.C.CFtoBisonC (cf2Bison, startSymbol) where
import BNFC.CF
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import BNFC.Backend.Common.NamedVariables hiding (varName)
import Data.Char (toLower)
import BNFC.Utils ((+++))
--This follows the basic structure of CFtoHappy.
-- Type declarations
type Rules = [(NonTerminal,[(Pattern,Action)])]
type Pattern = String
type Action = String
type MetaVar = String
--The environment comes from the CFtoFlex
cf2Bison :: String -> CF -> SymEnv -> String
cf2Bison name cf env
= unlines
[header name cf,
union (allCatsNorm cf),
"%token _ERROR_",
tokens user env,
declarations cf,
specialToks cf,
startSymbol cf,
"%%",
prRules (rulesForBison cf env)
]
where
user = fst (unzip (tokenPragmas cf))
header :: String -> CF -> String
header name cf = unlines
["/* This Bison file was machine-generated by BNFC */",
"%{",
"#include ",
"#include ",
"#include ",
"#include \"Absyn.h\"",
"#define initialize_lexer " ++ name ++ "_initialize_lexer",
"extern int yyparse(void);",
"extern int yylex(void);",
"int yy_mylinenumber;",
"extern int initialize_lexer(FILE * inp);",
"void yyerror(const char *str)",
"{",
" extern char *" ++ name ++ "text;",
" fprintf(stderr,\"error: line %d: %s at %s\\n\",",
" yy_mylinenumber + 1, str, " ++ name ++ "text);",
"}",
"",
-- M.F. 2004-09-17 changed allEntryPoints to allCatsIdNorm. Seems to fix the [Ty2] bug.
unlines $ map parseMethod (allCatsNorm cf), -- (allEntryPoints cf),
concatMap reverseList (filter isList (allCatsNorm cf)),
"%}"
]
--This generates a parser method for each entry point.
parseMethod :: Cat -> String
parseMethod cat =
-- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm
-- then ""
-- else
unlines
[
cat' +++ resultName cat' +++ "= 0;",
cat' ++ " p" ++ cat' ++ "(FILE *inp)",
"{",
" initialize_lexer(inp);",
" if (yyparse())",
" { /* Failure */",
" return 0;",
" }",
" else",
" { /* Success */",
" return" +++ resultName cat' ++ ";",
" }",
"}"
]
where
cat' = identCat (normCat cat)
--This method generates list reversal functions for each list type.
reverseList :: Cat -> String
reverseList c = unlines
[
c' ++ " reverse" ++ c' ++ "(" ++ c' +++ "l)",
"{",
" " ++ c' +++"prev = 0;",
" " ++ c' +++"tmp = 0;",
" while (l)",
" {",
" tmp = l->" ++ v ++ ";",
" l->" ++ v +++ "= prev;",
" prev = l;",
" l = tmp;",
" }",
" return prev;",
"}"
]
where
c' = identCat (normCat c)
v = map toLower c' ++ "_"
--The union declaration is special to Bison/Yacc and gives the type of yylval.
--For efficiency, we may want to only include used categories here.
union :: [Cat] -> String
union cats = unlines
[
"%union",
"{",
" int int_;",
" char char_;",
" double double_;",
" char* string_;",
concatMap mkPointer cats,
"}"
]
where --This is a little weird because people can make [Exp2] etc.
mkPointer s | identCat s /= show s = --list. add it even if it refers to a coercion.
" " ++ identCat (normCat s) +++ varName (normCat s) ++ ";\n"
mkPointer s | normCat s == s = --normal cat
" " ++ identCat (normCat s) +++ varName (normCat s) ++ ";\n"
mkPointer _ = ""
--declares non-terminal types.
declarations :: CF -> String
declarations cf = concatMap (typeNT cf) (allCats cf)
where --don't define internal rules
typeNT cf nt | rulesForCat cf nt /= [] = "%type <" ++ varName (normCat nt) ++ "> " ++ identCat nt ++ "\n"
typeNT _ _ = ""
--declares terminal types.
tokens :: [UserDef] -> SymEnv -> String
tokens user = concatMap (declTok user)
where
declTok u (s,r) = if s `elem` map show u
then "%token " ++ r ++ " /* " ++ s ++ " */\n"
else "%token " ++ r ++ " /* " ++ s ++ " */\n"
specialToks :: CF -> String
specialToks cf = concat [
ifC catString "%token _STRING_\n",
ifC catChar "%token _CHAR_\n",
ifC catInteger "%token _INTEGER_\n",
ifC catDouble "%token _DOUBLE_\n",
ifC catIdent "%token _IDENT_\n"
]
where
ifC cat s = if isUsedCat cf cat then s else ""
startSymbol :: CF -> String
startSymbol cf = "%start" +++ identCat (firstEntry cf)
--The following functions are a (relatively) straightforward translation
--of the ones in CFtoHappy.hs
rulesForBison :: CF -> SymEnv -> Rules
rulesForBison cf env = map mkOne $ ruleGroups cf where
mkOne (cat,rules) = constructRule cf env rules cat
-- For every non-terminal, we construct a set of rules.
constructRule :: CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])
constructRule cf env rules nt = (nt,[(p, generateAction (identCat (normCat nt)) (funRule r) b m +++ result) |
r0 <- rules,
let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs
then (True,revSepListRule r0)
else (False,r0),
let (p,m) = generatePatterns cf env r])
where
revs = reversibleCats cf
eps = allEntryPoints cf
isEntry nt = nt `elem` eps
result = if isEntry nt then resultName (identCat (normCat nt)) ++ "= $$;" else ""
-- | Generates a string containing the semantic action.
-- >>> generateAction "Foo" "Bar" False ["$1"]
-- "make_Bar($1);"
-- >>> generateAction "Foo" "_" False ["$1"]
-- "$1;"
-- >>> generateAction "ListFoo" "[]" False []
-- "0;"
-- >>> generateAction "ListFoo" "(:[])" False ["$1"]
-- "make_ListFoo($1, 0);"
-- >>> generateAction "ListFoo" "(:)" False ["$1","$2"]
-- "make_ListFoo($1, $2);"
-- >>> generateAction "ListFoo" "(:)" True ["$1","$2"]
-- "make_ListFoo($2, $1);"
generateAction :: String -> Fun -> Bool -> [MetaVar] -> Action
generateAction nt f b ms
| isCoercion f = unwords ms ++ ";"
| isNilFun f = "0;"
| isOneFun f = concat ["make_", nt, "(", intercalate ", " ms', ", 0);"]
| isConsFun f = concat ["make_", nt, "(", intercalate ", " ms', ");"]
| otherwise = concat ["make_", f, "(", intercalate ", " ms', ");"]
where
ms' = if b then reverse ms else ms
-- Generate patterns and a set of metavariables indicating
-- where in the pattern the non-terminal
generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar])
generatePatterns cf env r = case rhsRule r of
[] -> ("/* empty */",[])
its -> (unwords (map mkIt its), metas its)
where
mkIt i = case i of
Left c -> fromMaybe (typeName (identCat c)) (lookup (show c) env)
Right s -> fromMaybe s (lookup s env)
metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 :: Int ..] its]
revIf c m = if not (isConsFun (funRule r)) && elem c revs
then "reverse" ++ identCat (normCat c) ++ "(" ++ m ++ ")"
else m -- no reversal in the left-recursive Cons rule itself
revs = reversibleCats cf
-- We have now constructed the patterns and actions,
-- so the only thing left is to merge them into one string.
prRules :: Rules -> String
prRules [] = []
prRules ((_, []):rs) = prRules rs --internal rule
prRules ((nt, (p,a) : ls):rs) =
unwords [nt', ":" , p, "{ $$ =", a, "}", '\n' : pr ls] ++ ";\n" ++ prRules rs
where
nt' = identCat nt
pr [] = []
pr ((p,a):ls) = unlines [unwords [" |", p, "{ $$ =", a , "}"]] ++ pr ls
--Some helper functions.
resultName :: String -> String
resultName s = "YY_RESULT_" ++ s ++ "_"
-- | slightly stronger than the NamedVariable version.
-- >>> varName (Cat "Abc")
-- "abc_"
varName :: Cat -> String
varName = (++ "_") . map toLower . identCat . normCat
typeName :: String -> String
typeName "Ident" = "_IDENT_"
typeName "String" = "_STRING_"
typeName "Char" = "_CHAR_"
typeName "Integer" = "_INTEGER_"
typeName "Double" = "_DOUBLE_"
typeName x = x
BNFC-2.8.1/src/BNFC/Backend/C/CFtoCPrinter.hs0000644000000000000000000004077412654616013016306 0ustar0000000000000000{-
BNF Converter: C Pretty Printer printer
Copyright (C) 2004 Author: Michael Pellauer
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the C Pretty Printer.
It also generates the "show" method for
printing an abstract syntax tree.
The generated files use the Visitor design pattern.
Author : Michael Pellauer (pellauer@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 10 August, 2003
Modified : 3 September, 2003
* Added resizable buffers
**************************************************************
-}
module BNFC.Backend.C.CFtoCPrinter (cf2CPrinter) where
import BNFC.CF
import BNFC.Utils ((+++))
import BNFC.Backend.Common (renderListSepByPrecedence)
import BNFC.Backend.Common.NamedVariables
import BNFC.Backend.Common.StrUtils (renderCharOrString)
import BNFC.Backend.Utils (isTokenType)
import Data.List
import Data.Char(toLower)
import Data.Either (lefts)
import BNFC.PrettyPrint
--Produces (.h file, .c file)
cf2CPrinter :: CF -> (String, String)
cf2CPrinter cf = (mkHFile cf groups, mkCFile cf groups)
where
groups = fixCoercions (ruleGroupsInternals cf)
{- **** Header (.h) File Methods **** -}
--An extremely large function to make the Header File
mkHFile :: CF -> [(Cat,[Rule])] -> String
mkHFile cf groups = unlines
[
header,
concatMap prPrints eps,
concatMap prPrintDataH groups,
concatMap prShows eps,
concatMap prShowDataH groups,
footer
]
where
eps = allEntryPoints cf
prPrints s | normCat s == s = "char* print" ++ s' ++ "(" ++ s' ++ " p);\n"
where
s' = identCat s
prPrints _ = ""
prShows s | normCat s == s = "char* show" ++ s' ++ "(" ++ s' ++ " p);\n"
where
s' = identCat s
prShows _ = ""
header = unlines
[
"#ifndef PRINTER_HEADER",
"#define PRINTER_HEADER",
"",
"#include \"Absyn.h\"",
"",
"/* Certain applications may improve performance by changing the buffer size */",
"#define BUFFER_INITIAL 2000",
"/* You may wish to change _L_PAREN or _R_PAREN */",
"#define _L_PAREN '('",
"#define _R_PAREN ')'",
"",
"/* The following are simple heuristics for rendering terminals */",
"/* You may wish to change them */",
"void renderCC(Char c);",
"void renderCS(String s);",
"void indent(void);",
"void backup(void);",
""
]
footer = unlines $
["void pp" ++ t ++ "(String s, int i);" | t <- tokenNames cf]
++
["void sh" ++ t ++ "(String s);" | t <- tokenNames cf]
++
[
"void ppInteger(Integer n, int i);",
"void ppDouble(Double d, int i);",
"void ppChar(Char c, int i);",
"void ppString(String s, int i);",
"void ppIdent(String s, int i);",
"void shInteger(Integer n);",
"void shDouble(Double d);",
"void shChar(Char c);",
"void shString(String s);",
"void shIdent(String s);",
"void bufAppendS(const char* s);",
"void bufAppendC(const char c);",
"void bufReset(void);",
"void resizeBuffer(void);",
"",
"#endif"
]
--Prints all the required method names and their parameters.
prPrintDataH :: (Cat, [Rule]) -> String
prPrintDataH (cat, _) = concat ["void pp", cl, "(", cl, " p, int i);\n"]
where
cl = identCat (normCat cat)
--Prints all the required method names and their parameters.
prShowDataH :: (Cat, [Rule]) -> String
prShowDataH (cat, _) = concat ["void sh", cl, "(", cl, " p);\n"]
where
cl = identCat (normCat cat)
{- **** Implementation (.C) File Methods **** -}
--This makes the .C file by a similar method.
mkCFile :: CF -> [(Cat,[Rule])] -> String
mkCFile cf groups = concat
[
header,
prRender,
concatMap prPrintFun eps,
concatMap prShowFun eps,
concatMap (prPrintData user) groups,
printBasics,
printTokens,
concatMap (prShowData user) groups,
showBasics,
showTokens,
footer
]
where
eps = allEntryPoints cf
user = fst (unzip (tokenPragmas cf))
header = unlines
[
"/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/",
"",
"#include \"Printer.h\"",
"#include ",
"#include ",
"#include ",
"",
"#define INDENT_WIDTH 2",
"",
"int _n_;",
"char* buf_;",
"int cur_;",
"int buf_size;",
""
]
printBasics = unlines
[
"void ppInteger(Integer n, int i)",
"{",
" char tmp[16];",
" sprintf(tmp, \"%d\", n);",
" bufAppendS(tmp);",
"}",
"void ppDouble(Double d, int i)",
"{",
" char tmp[16];",
" sprintf(tmp, \"%g\", d);",
" bufAppendS(tmp);",
"}",
"void ppChar(Char c, int i)",
"{",
" bufAppendC('\\'');",
" bufAppendC(c);",
" bufAppendC('\\'');",
"}",
"void ppString(String s, int i)",
"{",
" bufAppendC('\\\"');",
" bufAppendS(s);",
" bufAppendC('\\\"');",
"}",
"void ppIdent(String s, int i)",
"{",
" renderS(s);",
"}",
""
]
printTokens = unlines
[unlines [
"void pp" ++ t ++ "(String s, int i)",
"{",
" renderS(s);",
"}",
""
] | t <- tokenNames cf
]
showBasics = unlines
[
"void shInteger(Integer i)",
"{",
" char tmp[16];",
" sprintf(tmp, \"%d\", i);",
" bufAppendS(tmp);",
"}",
"void shDouble(Double d)",
"{",
" char tmp[16];",
" sprintf(tmp, \"%g\", d);",
" bufAppendS(tmp);",
"}",
"void shChar(Char c)",
"{",
" bufAppendC('\\'');",
" bufAppendC(c);",
" bufAppendC('\\'');",
"}",
"void shString(String s)",
"{",
" bufAppendC('\\\"');",
" bufAppendS(s);",
" bufAppendC('\\\"');",
"}",
"void shIdent(String s)",
"{",
" bufAppendC('\\\"');",
" bufAppendS(s);",
" bufAppendC('\\\"');",
"}",
""
]
showTokens = unlines
[unlines [
"void sh" ++ t ++ "(String s)",
"{",
" bufAppendC('\\\"');",
" bufAppendS(s);",
" bufAppendC('\\\"');",
"}",
""
] | t <- tokenNames cf
]
footer = unlines
[
"void bufAppendS(const char* s)",
"{",
" int len = strlen(s);",
" int n;",
" while (cur_ + len > buf_size)",
" {",
" buf_size *= 2; /* Double the buffer size */",
" resizeBuffer();",
" }",
" for(n = 0; n < len; n++)",
" {",
" buf_[cur_ + n] = s[n];",
" }",
" cur_ += len;",
" buf_[cur_] = 0;",
"}",
"void bufAppendC(const char c)",
"{",
" if (cur_ == buf_size)",
" {",
" buf_size *= 2; /* Double the buffer size */",
" resizeBuffer();",
" }",
" buf_[cur_] = c;",
" cur_++;",
" buf_[cur_] = 0;",
"}",
"void bufReset(void)",
"{",
" cur_ = 0;",
" buf_size = BUFFER_INITIAL;",
" resizeBuffer();",
" memset(buf_, 0, buf_size);",
"}",
"void resizeBuffer(void)",
"{",
" char* temp = (char*) malloc(buf_size);",
" if (!temp)",
" {",
" fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");",
" exit(1);",
" }",
" if (buf_)",
" {",
" strncpy(temp, buf_, buf_size); /* peteg: strlcpy is safer, but not POSIX/ISO C. */",
" free(buf_);",
" }",
" buf_ = temp;",
"}",
"char *buf_;",
"int cur_, buf_size;",
""
]
{- **** Pretty Printer Methods **** -}
--An entry point to begin printing
prPrintFun :: Cat -> String
prPrintFun ep | normCat ep == ep = unlines
[
"char* print" ++ ep' ++ "(" ++ ep' ++ " p)",
"{",
" _n_ = 0;",
" bufReset();",
" pp" ++ ep' ++ "(p, 0);",
" return buf_;",
"}"
]
where
ep' = identCat ep
prPrintFun _ = ""
--Generates methods for the Pretty Printer
prPrintData :: [UserDef] -> (Cat, [Rule]) -> String
prPrintData user (cat, rules) = unlines $
if isList cat
then
[
"void pp" ++ cl ++ "("++ cl +++ vname ++ ", int i)",
"{",
" while(" ++ vname ++ "!= 0)",
" {",
" if (" ++ vname ++ "->" ++ vname ++ "_ == 0)",
" {",
visitMember,
optsep,
" " ++ vname +++ "= 0;",
" }",
" else",
" {",
visitMember,
render (nest 6 (renderListSepByPrecedence "i" renderX
(getSeparatorByPrecedence rules))),
" " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;",
" }",
" }",
"}",
""
] --Not a list:
else
[
"void pp" ++ cl ++ "(" ++ cl ++ " _p_, int _i_)",
"{",
" switch(_p_->kind)",
" {",
concatMap (prPrintRule user) rules,
" default:",
" fprintf(stderr, \"Error: bad kind field when printing " ++ show cat ++ "!\\n\");",
" exit(1);",
" }",
"}\n"
]
where
cl = identCat (normCat cat)
ecl = identCat (normCatOfList cat)
vname = map toLower cl
member = map toLower ecl
visitMember = " pp" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_, i);"
sep' = getCons rules
optsep = if hasOneFunc rules then "" else " " ++ render (renderX sep') ++ ";"
-- | Helper function that call the right c function (renderC or renderS) to
-- render a literal string.
--
-- >>> renderX ","
-- renderC(',')
--
-- >>> renderX "---"
-- renderS("---")
renderX :: String -> Doc
renderX sep' = "render" <> char sc <> parens (text sep)
where (sc, sep) = renderCharOrString sep'
--Pretty Printer methods for a rule.
prPrintRule :: [UserDef] -> Rule -> String
prPrintRule user r@(Rule fun _ cats) | not (isCoercion fun) = unlines
[
" case is_" ++ fun ++ ":",
lparen,
cats',
rparen,
" break;\n"
]
where
p = precRule r
(lparen, rparen) =
(" if (_i_ > " ++ show p ++ ") renderC(_L_PAREN);",
" if (_i_ > " ++ show p ++ ") renderC(_R_PAREN);")
cats' = concatMap (prPrintCat user fun) (numVars cats)
prPrintRule _ _ = ""
--This goes on to recurse to the instance variables.
prPrintCat :: [UserDef] -> String -> Either (Cat, Doc) String -> String
prPrintCat user fnm (c) = case c of
Right t -> " " ++ render (renderX t) ++ ";\n"
Left (cat, nt) | isTokenType user cat -> " pp" ++ basicFunName (render nt) ++ "(_p_->u." ++ v ++ "_." ++ render nt ++ ", " ++ show (precCat cat) ++ ");\n"
Left (InternalCat, _) -> " /* Internal Category */\n"
Left (cat, nt) -> " pp" ++ identCat (normCat cat) ++ "(_p_->u." ++ v ++ "_." ++ render nt ++ ", " ++ show (precCat cat) ++ ");\n"
where
v = map toLower (normFun fnm)
{- **** Abstract Syntax Tree Printer **** -}
--An entry point to begin printing
prShowFun :: Cat -> String
prShowFun ep | normCat ep == ep = unlines
[
"char* show" ++ ep' ++ "(" ++ ep' ++ " p)",
"{",
" _n_ = 0;",
" bufReset();",
" sh" ++ ep' ++ "(p);",
" return buf_;",
"}"
]
where
ep' = identCat ep
prShowFun _ = ""
--This prints the functions for Abstract Syntax tree printing.
prShowData :: [UserDef] -> (Cat, [Rule]) -> String
prShowData user (cat, rules) = unlines $
if isList cat
then
[
"void sh" ++ cl ++ "("++ cl +++ vname ++ ")",
"{",
" while(" ++ vname ++ "!= 0)",
" {",
" if (" ++ vname ++ "->" ++ vname ++ "_)",
" {",
visitMember,
" bufAppendS(\", \");",
" " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;",
" }",
" else",
" {",
visitMember,
" " ++ vname ++ " = 0;",
" }",
" }",
"}",
""
] --Not a list:
else
[
"void sh" ++ cl ++ "(" ++ cl ++ " _p_)",
"{",
" switch(_p_->kind)",
" {",
concatMap (prShowRule user) rules,
" default:",
" fprintf(stderr, \"Error: bad kind field when showing " ++ show cat ++ "!\\n\");",
" exit(1);",
" }",
"}\n"
]
where
cl = identCat (normCat cat)
ecl = identCat (normCatOfList cat)
vname = map toLower cl
member = map toLower ecl
visitMember = " sh" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_);"
--Pretty Printer methods for a rule.
prShowRule :: [UserDef] -> Rule -> String
prShowRule user (Rule fun _ cats) | not (isCoercion fun) = unlines
[
" case is_" ++ fun ++ ":",
lparen,
" bufAppendS(\"" ++ fun ++ "\");\n",
optspace,
cats',
rparen,
" break;\n"
]
where
(optspace, lparen, rparen) = if allTerms cats
then ("","","")
else (" bufAppendC(' ');\n", " bufAppendC('(');\n"," bufAppendC(')');\n")
cats' = if allTerms cats
then ""
else concat (insertSpaces (map (prShowCat user fun) (lefts $ numVars cats)))
insertSpaces [] = []
insertSpaces (x:[]) = [x]
insertSpaces (x:xs) = if x == ""
then insertSpaces xs
else x : " bufAppendC(' ');\n" : insertSpaces xs
allTerms [] = True
allTerms (Left _:_) = False
allTerms (_:zs) = allTerms zs
prShowRule _ _ = ""
--This goes on to recurse to the instance variables.
prShowCat :: [UserDef] -> Fun -> (Cat, Doc) -> String
prShowCat user fnm c = case c of
(cat,nt) | isTokenType user cat ->
" sh" ++ basicFunName (render nt) ++ "(_p_->u." ++ v ++ "_." ++ render nt ++ ");\n"
(InternalCat, _) -> " /* Internal Category */\n"
(cat,nt) | show (normCat $ strToCat$ render nt) /= render nt ->
" sh" ++ identCat (normCat cat) ++ "(_p_->u." ++ v ++ "_." ++ render nt ++ ");\n"
(cat,nt) -> concat
[
" bufAppendC('[');\n",
" sh" ++ identCat (normCat cat) ++ "(_p_->u." ++ v ++ "_." ++ render nt ++ ");\n",
" bufAppendC(']');\n"
]
where v = map toLower (normFun fnm)
{- **** Helper Functions Section **** -}
--The visit-function name of a basic type
basicFunName :: String -> String
basicFunName v
| "integer_" `isPrefixOf` v = "Integer"
| "char_" `isPrefixOf` v = "Char"
| "string_" `isPrefixOf` v = "String"
| "double_" `isPrefixOf` v = "Double"
| "ident_" `isPrefixOf` v = "Ident"
| otherwise = "Ident" --User-defined type
--An extremely simple renderCer for terminals.
prRender :: String
prRender = unlines
[
"/* You may wish to change the renderC functions */",
"void renderC(Char c)",
"{",
" if (c == '{')",
" {",
" bufAppendC('\\n');",
" indent();",
" bufAppendC(c);",
" _n_ = _n_ + INDENT_WIDTH;",
" bufAppendC('\\n');",
" indent();",
" }",
" else if (c == '(' || c == '[')",
" bufAppendC(c);",
" else if (c == ')' || c == ']')",
" {",
" backup();",
" bufAppendC(c);",
" }",
" else if (c == '}')",
" {",
" int t;",
" _n_ = _n_ - INDENT_WIDTH;",
" for(t=0; t 0)",
" {",
" bufAppendS(s);",
" bufAppendC(' ');",
" }",
"}",
"void indent(void)",
"{",
" int n = _n_;",
" while (n > 0)",
" {",
" bufAppendC(' ');",
" n--;",
" }",
"}",
"void backup(void)",
"{",
" if (buf_[cur_ - 1] == ' ')",
" {",
" buf_[cur_ - 1] = 0;",
" cur_--;",
" }",
"}"
]
BNFC-2.8.1/src/BNFC/Backend/Java/0000755000000000000000000000000012654616013014133 5ustar0000000000000000BNFC-2.8.1/src/BNFC/Backend/Java/CFtoJavaAbs15.hs0000644000000000000000000002427412654616013016731 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-}
{-
BNF Converter: Java 1.5 Abstract Syntax
Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the Java Abstract Syntax
It uses the BNFC.Backend.Common.NamedVariables module for variable
naming. It returns a list of file names, and the
contents to be written into that file. (In Java
public classes must go in their own file.)
The generated classes also support the Visitor
Design Pattern.
Author : Michael Pellauer (pellauer@cs.chalmers.se),
Bjorn Bringert (bringert@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 24 April, 2003
Modified : 16 June, 2004
**************************************************************
-}
module BNFC.Backend.Java.CFtoJavaAbs15 (cf2JavaAbs, typename) where
import BNFC.CF
import BNFC.Utils((+++),(++++))
import BNFC.Backend.Common.NamedVariables hiding (IVar, getVars, varName)
import Data.Function (on)
import Data.List
import Data.Char(toLower)
import Data.Maybe (mapMaybe)
import Text.PrettyPrint
--Produces abstract data types in Java.
--These follow Appel's "non-object oriented" version.
--They also allow users to use the Visitor design pattern.
type IVar = (String, Int, String)
--The type of an instance variable
--a # unique to that type
--and an optional name (handles typedefs).
--The result is a list of files which must be written to disk.
--The tuple is (FileName, FileContents)
cf2JavaAbs :: String -> String -> CF -> [(FilePath, String)]
cf2JavaAbs _ packageAbsyn cf =
concatMap (prData header packageAbsyn user) rules
where
header = "package " ++ packageAbsyn ++ "; // Java Package generated by the BNF Converter.\n"
user = [n | (n,_) <- tokenPragmas cf]
rules = getAbstractSyntax cf
--Generates a (possibly abstract) category class, and classes for all its rules.
prData :: String -> String -> [UserDef] -> Data ->[(String, String)]
prData header packageAbsyn user (cat, rules) =
categoryClass ++ mapMaybe (prRule header packageAbsyn funs user cat) rules
where
funs = map fst rules
categoryClass
| show cat `elem` funs = [] -- the catgory is also a function, skip abstract class
| otherwise = [(identCat cat, header ++++
unlines [
"public abstract class" +++ cls
+++ "implements java.io.Serializable {",
" public abstract R accept("
++ cls ++ ".Visitor v, A arg);",
prVisitor packageAbsyn funs,
"}"
])]
where cls = identCat cat
prVisitor :: String -> [String] -> String
prVisitor packageAbsyn funs =
unlines [
" public interface Visitor {",
unlines (map prVisitFun funs),
" }"
]
where
prVisitFun f = " public R visit(" ++ packageAbsyn ++ "." ++ f ++ " p, A arg);"
--Generates classes for a rule, depending on what type of rule it is.
prRule :: String -- ^ Header
-> String -- ^ Abstract syntax package name
-> [String] -- ^ Names of all constructors in the category
-> [UserDef] -> Cat -> (Fun, [Cat]) -> Maybe (String, String)
prRule h packageAbsyn funs user c (fun, cats)
| isNilFun fun || isOneFun fun = Nothing --these are not represented in the AbSyn
| isConsFun fun =Just (fun', --this is the linked list case.
unlines
[
h,
"public class" +++ fun' +++ "extends java.util.LinkedList<"++ et ++"> {",
"}"
])
| otherwise = Just (fun, --a standard rule
unlines
[
h,
"public class" +++ fun ++ ext +++ "{",
render $ nest 2 $ vcat
[ prInstVars vs
, prConstructor fun user vs cats],
prAccept packageAbsyn c fun,
prEquals packageAbsyn fun vs,
prHashCode packageAbsyn fun vs,
if isAlsoCategory then prVisitor packageAbsyn funs else "",
"}"
])
where
vs = getVars cats user
fun' = identCat (normCat c)
isAlsoCategory = fun == show c
--This handles the case where a LBNF label is the same as the category.
ext = if isAlsoCategory then "" else " extends" +++ identCat c
et = typename (show $ normCatOfList c) user
--The standard accept function for the Visitor pattern
prAccept :: String -> Cat -> String -> String
prAccept pack cat _ = "\n public R accept(" ++ pack ++ "." ++ show cat
++ ".Visitor v, A arg) { return v.visit(this, arg); }\n"
-- Creates the equals() method.
prEquals :: String -> String -> [IVar] -> String
prEquals pack fun vs =
unlines $ map (" "++) $ ["public boolean equals(Object o) {",
" if (this == o) return true;",
" if (o instanceof " ++ fqn ++ ") {"]
++ (if null vs
then [" return true;"]
else [" " ++ fqn +++ "x = ("++fqn++")o;",
" return " ++ checkKids ++ ";"]) ++
[" }",
" return false;",
"}"]
where
fqn = pack++"."++fun
checkKids = intercalate " && " $ map checkKid vs
checkKid iv = "this." ++ v ++ ".equals(x." ++ v ++ ")"
where v = render (iVarName iv)
-- Creates the equals() method.
prHashCode :: String -> String -> [IVar] -> String
prHashCode _ _ vs =
unlines $ map (" "++) ["public int hashCode() {",
" return " ++ hashKids vs ++ ";",
"}"
]
where
aPrime = 37
hashKids [] = show aPrime
hashKids (v:vs) = hashKids_ (hashKid v) vs
hashKids_ = foldl (\r v -> show aPrime ++ "*" ++ "(" ++ r ++ ")+" ++ hashKid v)
hashKid iv = "this." ++ render (iVarName iv) ++ ".hashCode()"
-- | A class's instance variables.
-- >>> prInstVars [("A",1,""), ("B",1,""), ("A",2,"abc")]
-- public final A _1, abc_2;
-- public final B _1;
prInstVars :: [IVar] -> Doc
prInstVars [] = empty
prInstVars vars@((t,_,_):_) =
"public" <+> "final" <+> text t <+> uniques <> ";" $$ prInstVars vs'
where
(uniques, vs') = prUniques t vars
--these functions group the types together nicely
prUniques :: String -> [IVar] -> (Doc, [IVar])
prUniques t vs = (prVars vs (findIndices (\(y,_,_) -> y == t) vs), remType t vs)
prVars vs = hsep . punctuate comma . map (iVarName . (vs!!))
remType :: String -> [IVar] -> [IVar]
remType _ [] = []
remType t ((t2,n,nm):ts)
| t == t2 = remType t ts
| otherwise = (t2,n,nm) : remType t ts
-- | Convert IVar to java name
-- >>> iVarName ("A",1,"abc")
-- abc_1
-- >>> iVarName ("C", 2, "")
-- _2
-- >>> iVarName ("Integer", 0, "integer")
-- integer_
iVarName :: IVar -> Doc
iVarName (_,n,nm) = text (varName nm) <> text (showNum n)
-- | The constructor just assigns the parameters to the corresponding instance
-- variables.
-- >>> prConstructor "bla" [] [("A",1,"a"),("B",1,""),("A",2,"")] [Cat "A",Cat "B", Cat "C"]
-- public bla(A p1, B p2, C p3) { a_1 = p1; _ = p2; _2 = p3; }
-- >>> prConstructor "EInt" [] [("Integer",0,"integer")] [Cat "Integer"]
-- public EInt(Integer p1) { integer_ = p1; }
prConstructor :: String -> [UserDef] -> [IVar] -> [Cat] -> Doc
prConstructor c u vs cats =
"public" <+> text c <> parens (interleave types params)
<+> "{" <+> text (prAssigns vs params) <> "}"
where
(types, params) = unzip (prParams cats u (length cats) (length cats+1))
interleave xs ys = hsep $ punctuate "," $ zipWith ((<+>) `on` text) xs ys
--Prints the parameters to the constructors.
prParams :: [Cat] -> [UserDef] -> Int -> Int -> [(String,String)]
prParams [] _ _ _ = []
prParams (c:cs) u n m = (typename (identCat c) u, 'p' : show (m-n))
: prParams cs u (n-1) m
--This algorithm peeks ahead in the list so we don't use map or fold
prAssigns :: [IVar] -> [String] -> String
prAssigns [] _ = []
prAssigns _ [] = []
prAssigns ((t,n,nm):vs) (p:ps) =
if n == 1 then
case findIndices (\x -> case x of (l,_,_) -> l == t) vs of
[] -> varName nm +++ "=" +++ p ++ ";" +++ prAssigns vs ps
_ -> varName nm ++ showNum n +++ "=" +++ p ++ ";" +++ prAssigns vs ps
else varName nm ++ showNum n +++ "=" +++ p ++ ";" +++ prAssigns vs ps
-- Different than the standard BNFC.Backend.Common.NamedVariables version
-- because of the user-defined types.
getVars :: [Cat] -> [UserDef] -> [IVar]
getVars cs user = reverse $ singleToZero $ foldl addVar [] (map identCat cs)
where
addVar is c = (c', n, c):is
where c' = typename c user
n = maximum (1:[n'+1 | (_,n',c'') <- is, c'' == c])
singleToZero is = [(t,n',nm) | (t,n,nm) <- is,
let n' = if length [n | (_,_,n) <- is, n == nm] == 1
then 0 else n]
varName :: String -- ^ category name
-> String -- ^ Variable name
varName c = map toLower c ++ "_"
--This makes up for the fact that there's no typedef in Java
typename :: String -> [UserDef] -> String
typename t user | t == "Ident" = "String"
| t == "Char" = "Character"
| t `elem` map show user = "String"
| otherwise = t
BNFC-2.8.1/src/BNFC/Backend/Java/CFtoJavaPrinter15.hs0000644000000000000000000003143412654616013017643 0ustar0000000000000000{-
BNF Converter: Java Pretty Printer generator
Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the Java Pretty Printer
class. In addition, since there's no good way
to display a class heirarchy (toString() doesn't
count) in Java, it generates a method that
displays the Abstract Syntax in a way similar
to Haskell.
This uses Appel's method and may serve as a
useful example to those who wish to use it.
Author : Michael Pellauer (pellauer@cs.chalmers.se),
Bjorn Bringert (bringert@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 24 April, 2003
Modified : 9 Aug, 2004
Added string buffer for efficiency (Michael, August 03)
**************************************************************
-}
module BNFC.Backend.Java.CFtoJavaPrinter15 ( cf2JavaPrinter ) where
import BNFC.Backend.Java.CFtoJavaAbs15
import BNFC.CF
import BNFC.Backend.Common (renderListSepByPrecedence)
import BNFC.Backend.Common.NamedVariables
import BNFC.Utils ( (+++) )
import Data.List
import Data.Char ( toLower, isSpace )
import Data.Either (lefts)
import BNFC.PrettyPrint
--Produces the PrettyPrinter class.
--It will generate two methods "print" and "show"
--print is the actual pretty printer for linearization.
--show produces a Haskell-style syntax that can be extremely useful
--especially for testing parser correctness.
cf2JavaPrinter :: String -> String -> CF -> String
cf2JavaPrinter packageBase packageAbsyn cf =
unlines
[
header,
prEntryPoints packageAbsyn cf,
unlines (map (prData packageAbsyn user) groups),
unlines (map (shData packageAbsyn user) groups),
footer
]
where
user = [n | (n,_) <- tokenPragmas cf]
groups = fixCoercions (ruleGroupsInternals cf)
header = unlines [
"package" +++ packageBase ++ ";",
"import" +++ packageAbsyn ++ ".*;",
"",
"public class PrettyPrinter",
"{",
" //For certain applications increasing the initial size of the buffer may improve performance.",
" private static final int INITIAL_BUFFER_SIZE = 128;",
" private static final int INDENT_WIDTH = 2;",
" //You may wish to change the parentheses used in precedence.",
" private static final String _L_PAREN = new String(\"(\");",
" private static final String _R_PAREN = new String(\")\");",
prRender
]
footer = unlines [ --later only include used categories
" private static void pp(Integer n, int _i_) { buf_.append(n); buf_.append(\" \"); }",
" private static void pp(Double d, int _i_) { buf_.append(d); buf_.append(\" \"); }",
" private static void pp(String s, int _i_) { buf_.append(s); buf_.append(\" \"); }",
" private static void pp(Character c, int _i_) { buf_.append(\"'\" + c.toString() + \"'\"); buf_.append(\" \"); }",
" private static void sh(Integer n) { render(n.toString()); }",
" private static void sh(Double d) { render(d.toString()); }",
" private static void sh(Character c) { render(c.toString()); }",
" private static void sh(String s) { printQuoted(s); }",
" private static void printQuoted(String s) { render(\"\\\"\" + s + \"\\\"\"); }",
" private static void indent()",
" {",
" int n = _n_;",
" while (n > 0)",
" {",
" buf_.append(\" \");",
" n--;",
" }",
" }",
" private static void backup()",
" {",
" if (buf_.charAt(buf_.length() - 1) == ' ') {",
" buf_.setLength(buf_.length() - 1);",
" }",
" }",
" private static void trim()",
" {",
" while (buf_.length() > 0 && buf_.charAt(0) == ' ')",
" buf_.deleteCharAt(0); ",
" while (buf_.length() > 0 && buf_.charAt(buf_.length()-1) == ' ')",
" buf_.deleteCharAt(buf_.length()-1);",
" }",
" private static int _n_ = 0;",
" private static StringBuilder buf_ = new StringBuilder(INITIAL_BUFFER_SIZE);",
"}"
]
--An extremely simple renderer for terminals.
prRender :: String
prRender = unlines
[
" //You may wish to change render",
" private static void render(String s)",
" {",
" if (s.equals(\"{\"))",
" {",
" buf_.append(\"\\n\");",
" indent();",
" buf_.append(s);",
" _n_ = _n_ + INDENT_WIDTH;",
" buf_.append(\"\\n\");",
" indent();",
" }",
" else if (s.equals(\"(\") || s.equals(\"[\"))",
" buf_.append(s);",
" else if (s.equals(\")\") || s.equals(\"]\"))",
" {",
" backup();",
" buf_.append(s);",
" buf_.append(\" \");",
" }",
" else if (s.equals(\"}\"))",
" {",
" int t;",
" _n_ = _n_ - INDENT_WIDTH;",
" for(t=0; t CF -> String
prEntryPoints packageAbsyn cf =
msg ++ concat (map prEntryPoint (allCats cf)) ++ msg2
where
msg = " // print and show methods are defined for each category.\n"
msg2 = " /*** You shouldn't need to change anything beyond this point. ***/\n"
prEntryPoint cat | (normCat cat) == cat = unlines
[
" public static String print(" ++ packageAbsyn ++ "." ++ cat' ++ " foo)",
" {",
" pp(foo, 0);",
" trim();",
" String temp = buf_.toString();",
" buf_.delete(0,buf_.length());",
" return temp;",
" }",
" public static String show(" ++ packageAbsyn ++ "." ++ cat' ++ " foo)",
" {",
" sh(foo);",
" String temp = buf_.toString();",
" buf_.delete(0,buf_.length());",
" return temp;",
" }"
]
where
cat' = identCat cat
prEntryPoint _ = ""
prData :: String -> [UserDef] -> (Cat, [Rule]) -> String
prData packageAbsyn user (cat, rules) =
if isList cat
then unlines
[
" private static void pp(" ++ packageAbsyn ++ "."
++ identCat (normCat cat) +++ "foo, int _i_)",
" {",
render $ nest 5 $ prList user cat rules <> " }"
]
else unlines --not a list
[
" private static void pp(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo, int _i_)",
" {",
(concat (addElse $ map (prRule packageAbsyn) rules)) ++ " }"
]
where addElse = map (" "++). intersperse "else " . filter (not . null) . map (dropWhile isSpace)
prRule :: String -> Rule -> String
prRule packageAbsyn r@(Rule fun _c cats) | not (isCoercion fun || isDefinedRule fun) = concat
[
" if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")\n",
" {\n",
" " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= ("
++ packageAbsyn ++ "." ++ fun ++ ") foo;\n",
lparen,
cats',
rparen,
" }\n"
]
where
p = precRule r
(lparen, rparen) =
(" if (_i_ > " ++ (show p) ++ ") render(_L_PAREN);\n",
" if (_i_ > " ++ (show p) ++ ") render(_R_PAREN);\n")
cats' = case cats of
[] -> ""
_ -> concatMap (render . prCat (text fnm)) (numVars cats)
fnm = '_' : map toLower fun
prRule _nm _ = ""
-- |
--
-- >>> let lfoo = ListCat (Cat "Foo")
-- >>> prList [] lfoo [Rule "[]" lfoo [], Rule "(:)" lfoo [Left (Cat "Foo"), Right ".", Left lfoo]]
-- for (java.util.Iterator it = foo.iterator(); it.hasNext();)
-- {
-- pp(it.next(), _i_);
-- if (it.hasNext()) {
-- render(".");
-- } else {
-- render(".");
-- }
-- }
prList :: [UserDef] -> Cat -> [Rule] -> Doc
prList user c rules =
"for (java.util.Iterator<" <> et <> "> it = foo.iterator(); it.hasNext();)"
$$ codeblock 2
[ "pp(it.next(), _i_);"
, "if (it.hasNext()) {"
, nest 2 (renderListSepByPrecedence "_i_" renderSep
(getSeparatorByPrecedence rules))
, "} else {"
, nest 2 (renderSep optsep <> ";")
, "}"
]
where
et = text (typename (show $ normCatOfList c) user)
sep = escapeChars $ getCons rules
optsep = if hasOneFunc rules then "" else sep
renderSep x = "render(\"" <> text x <>"\")"
-- |
-- >>> prCat "F" (Right "++")
-- render("++");
--
-- >>> prCat "F" (Left (Cat "String", "string_"))
-- printQuoted(F.string_);
--
-- >>> prCat "F" (Left (InternalCat, "#_"))
--
-- >>> prCat "F" (Left (Cat "Abc", "abc_"))
-- pp(F.abc_, 0);
--
prCat :: Doc -> Either (Cat, Doc) String -> Doc
prCat _ (Right t) = nest 7 ("render(\"" <> text(escapeChars t) <> "\");\n")
prCat fnm (Left (Cat "String", nt))
= nest 7 ("printQuoted(" <> fnm <> "." <> nt <> ");\n")
prCat _ (Left (InternalCat, _)) = empty
prCat fnm (Left (cat, nt))
= nest 7 ("pp(" <> fnm <> "." <> nt <> ", " <> integer (precCat cat) <> ");\n")
--The following methods generate the Show function.
shData :: String -> [UserDef] -> (Cat, [Rule]) -> String
shData packageAbsyn user (cat, rules) =
if isList cat
then unlines
[
" private static void sh(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)",
" {",
(shList user cat rules) ++ " }"
]
else unlines
[
" private static void sh(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)",
" {",
(concat (map (shRule packageAbsyn) rules)) ++ " }"
]
shRule :: String -> Rule -> String
shRule packageAbsyn (Rule fun _c cats) | not (isCoercion fun || isDefinedRule fun) = unlines
[
" if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")",
" {",
" " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= ("
++ packageAbsyn ++ "." ++ fun ++ ") foo;",
members ++ " }"
]
where
members = concat
[
lparen,
" render(\"" ++ (escapeChars fun) ++ "\");\n",
cats',
rparen
]
cats' = if allTerms cats
then ""
else concatMap (render . shCat (text fnm)) (lefts (numVars cats))
(lparen, rparen) =
if allTerms cats
then ("","")
else (" render(\"(\");\n"," render(\")\");\n")
allTerms [] = True
allTerms ((Left {}):_) = False
allTerms (_:zs) = allTerms zs
fnm = '_' : map toLower fun
shRule _nm _ = ""
shList :: [UserDef] -> Cat -> [Rule] -> String
shList user c _rules = unlines
[
" for (java.util.Iterator<" ++ et
++ "> it = foo.iterator(); it.hasNext();)",
" {",
" sh(it.next());",
" if (it.hasNext())",
" render(\",\");",
" }"
]
where
et = typename (show $ normCatOfList c) user
-- |
-- >>> shCat "F" (ListCat (Cat "A"), "lista_")
-- render("[");
-- sh(F.lista_);
-- render("]");
--
-- >>> shCat "F" (InternalCat, "#_")
--
-- >>> shCat "F" (Cat "A", "a_")
-- sh(F.a_);
--
shCat :: Doc -> (Cat, Doc) -> Doc
shCat fnm (ListCat _, vname) = vcat
[ " render(\"[\");"
, " sh(" <> fnm <> "." <> vname <> ");"
, " render(\"]\");\n" ]
shCat _ (InternalCat, _) = empty
shCat fname (_, vname) = " sh(" <> fname <> "." <> vname <> ");\n"
--Helper function that escapes characters in strings
escapeChars :: String -> String
escapeChars [] = []
escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))
escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))
escapeChars (x:xs) = x : (escapeChars xs)
BNFC-2.8.1/src/BNFC/Backend/Java/CFtoJLex15.hs0000644000000000000000000001525312654616013016261 0ustar0000000000000000{-
BNF Converter: Java JLex generator
Copyright (C) 2004 Author: Michael Pellauer
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the JLex input file. This
file is quite different than Alex or Flex.
Author : Michael Pellauer (pellauer@cs.chalmers.se),
Bjorn Bringert (bringert@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 25 April, 2003
Modified : 4 Nov, 2004
**************************************************************
-}
module BNFC.Backend.Java.CFtoJLex15 ( cf2jlex ) where
import BNFC.CF
import BNFC.Backend.Java.RegToJLex
import BNFC.Utils ( (+++) )
import BNFC.Backend.Common.NamedVariables
import Text.PrettyPrint
--The environment must be returned for the parser to use.
cf2jlex :: String -> CF -> Bool -> (Doc, SymEnv)
cf2jlex packageBase cf jflex = (vcat
[
prelude jflex packageBase,
cMacros,
lexSymbols jflex env,
text $ unlines $ restOfJLex cf
], env)
where
env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int)
makeSymEnv [] _ = []
makeSymEnv (s:symbs) n = (s, "_SYMB_" ++ show n) : makeSymEnv symbs (n+1)
-- | File prelude
prelude :: Bool -> String -> Doc
prelude jflex packageBase = vcat
[ "// This JLex file was machine-generated by the BNF converter"
, "package" <+> text packageBase <> ";"
, ""
, "import java_cup.runtime.*;"
, "%%"
, "%cup"
, "%unicode"
, "%line"
, "%public"
, "%{"
, nest 2 $ vcat
[ "String pstring = new String();"
, "public int line_num() { return (yyline+1); }"
, "public String buff()" <+> braces
(if jflex
then "return new String(zzBuffer,zzCurrentPos,10).trim();"
else "return new String(yy_buffer,yy_buffer_index,10).trim();")
]
, "%}"
]
--For now all categories are included.
--Optimally only the ones that are used should be generated.
cMacros :: Doc
cMacros = vcat [
"LETTER = ({CAPITAL}|{SMALL})",
"CAPITAL = [A-Z\\xC0-\\xD6\\xD8-\\xDE]",
"SMALL = [a-z\\xDF-\\xF6\\xF8-\\xFF]",
"DIGIT = [0-9]",
"IDENT = ({LETTER}|{DIGIT}|['_])",
"%state COMMENT",
"%state CHAR",
"%state CHARESC",
"%state CHAREND",
"%state STRING",
"%state ESCAPED",
"%%"
]
-- |
-- >>> lexSymbols False [("foo","bar")]
-- foo { return new Symbol(sym.bar); }
-- >>> lexSymbols False [("\\","bar")]
-- \\ { return new Symbol(sym.bar); }
-- >>> lexSymbols False [("/","bar")]
-- / { return new Symbol(sym.bar); }
-- >>> lexSymbols True [("/","bar")]
-- \/ { return new Symbol(sym.bar); }
-- >>> lexSymbols True [("~","bar")]
-- \~ { return new Symbol(sym.bar); }
lexSymbols :: Bool -> SymEnv -> Doc
lexSymbols jflex ss = vcat $ map transSym ss
where
transSym (s,r) =
"" <> text (escapeChars s) <> " { return new Symbol(sym."
<> text r <> "); }"
--Helper function that escapes characters in strings
escapeChars :: String -> String
escapeChars = concatMap (escapeChar jflex)
restOfJLex :: CF -> [String]
restOfJLex cf =
[
lexComments (comments cf),
userDefTokens,
ifC catString strStates,
ifC catChar chStates,
ifC catDouble "{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? { return new Symbol(sym._DOUBLE_, new Double(yytext())); }",
ifC catInteger "{DIGIT}+ { return new Symbol(sym._INTEGER_, new Integer(yytext())); }",
ifC catIdent "{LETTER}{IDENT}* { return new Symbol(sym._IDENT_, yytext().intern()); }"
, "[ \\t\\r\\n\\f] { /* ignore white space. */ }"
]
where
ifC cat s = if isUsedCat cf cat then s else ""
userDefTokens = unlines $
["" ++ printRegJLex exp +++
"{ return new Symbol(sym." ++ show name ++ ", yytext().intern()); }"
| (name, exp) <- tokenPragmas cf]
strStates = unlines --These handle escaped characters in Strings.
[
"\"\\\"\" { yybegin(STRING); }",
"\\\\ { yybegin(ESCAPED); }",
"\\\" { String foo = pstring; pstring = new String(); yybegin(YYINITIAL); return new Symbol(sym._STRING_, foo.intern()); }",
". { pstring += yytext(); }",
"n { pstring += \"\\n\"; yybegin(STRING); }",
"\\\" { pstring += \"\\\"\"; yybegin(STRING); }",
"\\\\ { pstring += \"\\\\\"; yybegin(STRING); }",
"t { pstring += \"\\t\"; yybegin(STRING); }",
". { pstring += yytext(); yybegin(STRING); }"
]
chStates = unlines --These handle escaped characters in Chars.
[
"\"'\" { yybegin(CHAR); }",
"\\\\ { yybegin(CHARESC); }",
"[^'] { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }",
"n { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\n')); }",
"t { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\t')); }",
". { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }",
"\"'\" {yybegin(YYINITIAL);}"
]
lexComments :: ([(String, String)], [String]) -> String
lexComments (m,s) =
(unlines (map lexSingleComment s))
++ (unlines (map lexMultiComment m))
lexSingleComment :: String -> String
lexSingleComment c =
"\"" ++ c ++ "\"[^\\n]*\\n { /* BNFC single-line comment */ }"
--There might be a possible bug here if a language includes 2 multi-line comments.
--They could possibly start a comment with one character and end it with another.
--However this seems rare.
lexMultiComment :: (String, String) -> String
lexMultiComment (b,e) = unlines [
"\"" ++ b ++ "\" { yybegin(COMMENT); }",
"