SyntaxMacros (empty) → 0.1
raw patch · 20 files changed
+2504/−0 lines, 20 filesdep +AspectAGdep +TTTASdep +basesetup-changed
Dependencies added: AspectAG, TTTAS, base, containers, haskell98, template-haskell, uulib
Files
- COPYRIGHT +29/−0
- LICENSE-LGPL +507/−0
- README +38/−0
- Setup.hs +3/−0
- SyntaxMacros.cabal +32/−0
- examples/Expr.hs +189/−0
- examples/Main.hs +109/−0
- examples/prog.src +1/−0
- examples/prog2.src +1/−0
- src/Language/Grammars/Grammar.hs +135/−0
- src/Language/Grammars/SyntaxMacros.hs +185/−0
- src/Language/Grammars/SyntaxMacros/Machine.hs +330/−0
- src/Language/Grammars/SyntaxMacros/ScanUtils.hs +179/−0
- src/Language/Grammars/SyntaxMacros/Scanner.hs +17/−0
- src/Language/Grammars/SyntaxMacros/Token.hs +95/−0
- src/Language/Grammars/SyntaxMacros/TokenParser.hs +112/−0
- src/Language/Grammars/SyntaxMacros/Utils.hs +191/−0
- src/Language/Grammars/Transformations/GramTrafo.hs +64/−0
- src/Language/Grammars/Transformations/LeftCorner.hs +129/−0
- src/Language/Grammars/Transformations/LeftFact.hs +158/−0
+ COPYRIGHT view
@@ -0,0 +1,29 @@+The SyntaxMacros package is (c) copyright 2010+to the original authors and other contributors listed here. If you add+or modify code, please add your name here.++Original authors:+ Marcos Viera+ Doaitse Swierstra+ Atze Dijkstra+ Arthur Baars ++----+The SyntaxMacros package is licensed under the terms of the GNU Lesser General Public+Licence (LGPL), which can be found in the file called LICENCE-LGPL, with+the following special exception:++ As a relaxation of clause 6 of the LGPL, the copyright holders of this+ library give permission to use, copy, link, modify, and distribute,+ binary-only object-code versions of an executable linked with the+ original unmodified Library, without requiring the supply of any+ mechanism to modify or replace the Library and relink (clauses 6a,+ 6b, 6c, 6d, 6e), provided that all the other terms of clause 6 are+ complied with.++This software 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+License for more details.++
+ LICENSE-LGPL view
@@ -0,0 +1,507 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 2.1, February 1999++ Copyright (C) 1991, 1999 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.++[This is the first released version of the Lesser GPL. It also counts+ as the successor of the GNU Library Public License, version 2, hence+ the version number 2.1.]++ Preamble++ The licenses for most software are designed to take away your+freedom to share and change it. By contrast, the GNU General Public+Licenses are intended to guarantee your freedom to share and change+free software--to make sure the software is free for all its users.++ This license, the Lesser General Public License, applies to some+specially designated software packages--typically libraries--of the+Free Software Foundation and other authors who decide to use it. You+can use it too, but we suggest you first think carefully about whether+this license or the ordinary General Public License is the better+strategy to use in any particular case, based on the explanations+below.++ When we speak of free software, we are referring to freedom of use,+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 and use pieces of+it in new free programs; and that you are informed that you can do+these things.++ To protect your rights, we need to make restrictions that forbid+distributors to deny you these rights or to ask you to surrender these+rights. These restrictions translate to certain responsibilities for+you if you distribute copies of the library or if you modify it.++ For example, if you distribute copies of the library, whether gratis+or for a fee, you must give the recipients all the rights that we gave+you. You must make sure that they, too, receive or can get the source+code. If you link other code with the library, you must provide+complete object files to the recipients, so that they can relink them+with the library after making changes to the library and recompiling+it. And you must show them these terms so they know their rights.++ We protect your rights with a two-step method: (1) we copyright the+library, and (2) we offer you this license, which gives you legal+permission to copy, distribute and/or modify the library.++ To protect each distributor, we want to make it very clear that+there is no warranty for the free library. Also, if the library is+modified by someone else and passed on, the recipients should know+that what they have is not the original version, so that the original+author's reputation will not be affected by problems that might be+introduced by others.++ Finally, software patents pose a constant threat to the existence of+any free program. We wish to make sure that a company cannot+effectively restrict the users of a free program by obtaining a+restrictive license from a patent holder. Therefore, we insist that+any patent license obtained for a version of the library must be+consistent with the full freedom of use specified in this license.++ Most GNU software, including some libraries, is covered by the+ordinary GNU General Public License. This license, the GNU Lesser+General Public License, applies to certain designated libraries, and+is quite different from the ordinary General Public License. We use+this license for certain libraries in order to permit linking those+libraries into non-free programs.++ When a program is linked with a library, whether statically or using+a shared library, the combination of the two is legally speaking a+combined work, a derivative of the original library. The ordinary+General Public License therefore permits such linking only if the+entire combination fits its criteria of freedom. The Lesser General+Public License permits more lax criteria for linking other code with+the library.++ We call this license the "Lesser" General Public License because it+does Less to protect the user's freedom than the ordinary General+Public License. It also provides other free software developers Less+of an advantage over competing non-free programs. These disadvantages+are the reason we use the ordinary General Public License for many+libraries. However, the Lesser license provides advantages in certain+special circumstances.++ For example, on rare occasions, there may be a special need to+encourage the widest possible use of a certain library, so that it+becomes a de-facto standard. To achieve this, non-free programs must+be allowed to use the library. A more frequent case is that a free+library does the same job as widely used non-free libraries. In this+case, there is little to gain by limiting the free library to free+software only, so we use the Lesser General Public License.++ In other cases, permission to use a particular library in non-free+programs enables a greater number of people to use a large body of+free software. For example, permission to use the GNU C Library in+non-free programs enables many more people to use the whole GNU+operating system, as well as its variant, the GNU/Linux operating+system.++ Although the Lesser General Public License is Less protective of the+users' freedom, it does ensure that the user of a program that is+linked with the Library has the freedom and the wherewithal to run+that program using a modified version of the Library.++ The precise terms and conditions for copying, distribution and+modification follow. Pay close attention to the difference between a+"work based on the library" and a "work that uses the library". The+former contains code derived from the library, whereas the latter must+be combined with the library in order to run.+++ GNU LESSER GENERAL PUBLIC LICENSE+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++ 0. This License Agreement applies to any software library or other+program which contains a notice placed by the copyright holder or+other authorized party saying it may be distributed under the terms of+this Lesser General Public License (also called "this License").+Each licensee is addressed as "you".++ A "library" means a collection of software functions and/or data+prepared so as to be conveniently linked with application programs+(which use some of those functions and data) to form executables.++ The "Library", below, refers to any such software library or work+which has been distributed under these terms. A "work based on the+Library" means either the Library or any derivative work under+copyright law: that is to say, a work containing the Library or a+portion of it, either verbatim or with modifications and/or translated+straightforwardly into another language. (Hereinafter, translation is+included without limitation in the term "modification".)++ "Source code" for a work means the preferred form of the work for+making modifications to it. For a library, 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 library.++ Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope. The act of+running a program using the Library is not restricted, and output from+such a program is covered only if its contents constitute a work based+on the Library (independent of the use of the Library in a tool for+writing it). Whether that is true depends on what the Library does+and what the program that uses the Library does.++ 1. You may copy and distribute verbatim copies of the Library's+complete 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 distribute a copy of this License along with the+Library.++ 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 Library or any portion+of it, thus forming a work based on the Library, 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) The modified work must itself be a software library.++ b) You must cause the files modified to carry prominent notices+ stating that you changed the files and the date of any change.++ c) You must cause the whole of the work to be licensed at no+ charge to all third parties under the terms of this License.++ d) If a facility in the modified Library refers to a function or a+ table of data to be supplied by an application program that uses+ the facility, other than as an argument passed when the facility+ is invoked, then you must make a good faith effort to ensure that,+ in the event an application does not supply such function or+ table, the facility still operates, and performs whatever part of+ its purpose remains meaningful.++ (For example, a function in a library to compute square roots has+ a purpose that is entirely well-defined independent of the+ application. Therefore, Subsection 2d requires that any+ application-supplied function or table used by this function must+ be optional: if the application does not supply it, the square+ root function must still compute square roots.)++These requirements apply to the modified work as a whole. If+identifiable sections of that work are not derived from the Library,+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 Library, 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 Library.++In addition, mere aggregation of another work not based on the Library+with the Library (or with a work based on the Library) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++ 3. You may opt to apply the terms of the ordinary GNU General Public+License instead of this License to a given copy of the Library. To do+this, you must alter all the notices that refer to this License, so+that they refer to the ordinary GNU General Public License, version 2,+instead of to this License. (If a newer version than version 2 of the+ordinary GNU General Public License has appeared, then you can specify+that version instead if you wish.) Do not make any other change in+these notices.++ Once this change is made in a given copy, it is irreversible for+that copy, so the ordinary GNU General Public License applies to all+subsequent copies and derivative works made from that copy.++ This option is useful when you wish to copy part of the code of+the Library into a program that is not a library.++ 4. You may copy and distribute the Library (or a portion or+derivative of it, under Section 2) in object code or executable form+under the terms of Sections 1 and 2 above provided that you 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.++ If distribution of 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 satisfies the requirement to+distribute the source code, even though third parties are not+compelled to copy the source along with the object code.++ 5. A program that contains no derivative of any portion of the+Library, but is designed to work with the Library by being compiled or+linked with it, is called a "work that uses the Library". Such a+work, in isolation, is not a derivative work of the Library, and+therefore falls outside the scope of this License.++ However, linking a "work that uses the Library" with the Library+creates an executable that is a derivative of the Library (because it+contains portions of the Library), rather than a "work that uses the+library". The executable is therefore covered by this License.+Section 6 states terms for distribution of such executables.++ When a "work that uses the Library" uses material from a header file+that is part of the Library, the object code for the work may be a+derivative work of the Library even though the source code is not.+Whether this is true is especially significant if the work can be+linked without the Library, or if the work is itself a library. The+threshold for this to be true is not precisely defined by law.++ If such an object file uses only numerical parameters, data+structure layouts and accessors, and small macros and small inline+functions (ten lines or less in length), then the use of the object+file is unrestricted, regardless of whether it is legally a derivative+work. (Executables containing this object code plus portions of the+Library will still fall under Section 6.)++ Otherwise, if the work is a derivative of the Library, you may+distribute the object code for the work under the terms of Section 6.+Any executables containing that work also fall under Section 6,+whether or not they are linked directly with the Library itself.++ 6. As an exception to the Sections above, you may also combine or+link a "work that uses the Library" with the Library to produce a+work containing portions of the Library, and distribute that work+under terms of your choice, provided that the terms permit+modification of the work for the customer's own use and reverse+engineering for debugging such modifications.++ You must give prominent notice with each copy of the work that the+Library is used in it and that the Library and its use are covered by+this License. You must supply a copy of this License. If the work+during execution displays copyright notices, you must include the+copyright notice for the Library among them, as well as a reference+directing the user to the copy of this License. Also, you must do one+of these things:++ a) Accompany the work with the complete corresponding+ machine-readable source code for the Library including whatever+ changes were used in the work (which must be distributed under+ Sections 1 and 2 above); and, if the work is an executable linked+ with the Library, with the complete machine-readable "work that+ uses the Library", as object code and/or source code, so that the+ user can modify the Library and then relink to produce a modified+ executable containing the modified Library. (It is understood+ that the user who changes the contents of definitions files in the+ Library will not necessarily be able to recompile the application+ to use the modified definitions.)++ b) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (1) uses at run time a+ copy of the library already present on the user's computer system,+ rather than copying library functions into the executable, and (2)+ will operate properly with a modified version of the library, if+ the user installs one, as long as the modified version is+ interface-compatible with the version that the work was made with.++ c) Accompany the work with a written offer, valid for at least+ three years, to give the same user the materials specified in+ Subsection 6a, above, for a charge no more than the cost of+ performing this distribution.++ d) If distribution of the work is made by offering access to copy+ from a designated place, offer equivalent access to copy the above+ specified materials from the same place.++ e) Verify that the user has already received a copy of these+ materials or that you have already sent this user a copy.++ For an executable, the required form of the "work that uses the+Library" must include any data and utility programs needed for+reproducing the executable from it. However, as a special exception,+the materials to be 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.++ It may happen that this requirement contradicts the license+restrictions of other proprietary libraries that do not normally+accompany the operating system. Such a contradiction means you cannot+use both them and the Library together in an executable that you+distribute.++ 7. You may place library facilities that are a work based on the+Library side-by-side in a single library together with other library+facilities not covered by this License, and distribute such a combined+library, provided that the separate distribution of the work based on+the Library and of the other library facilities is otherwise+permitted, and provided that you do these two things:++ a) Accompany the combined library with a copy of the same work+ based on the Library, uncombined with any other library+ facilities. This must be distributed under the terms of the+ Sections above.++ b) Give prominent notice with the combined library of the fact+ that part of it is a work based on the Library, and explaining+ where to find the accompanying uncombined form of the same work.++ 8. You may not copy, modify, sublicense, link with, or distribute+the Library except as expressly provided under this License. Any+attempt otherwise to copy, modify, sublicense, link with, or+distribute the Library 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.++ 9. 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 Library or its derivative works. These actions are+prohibited by law if you do not accept this License. Therefore, by+modifying or distributing the Library (or any work based on the+Library), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Library or works based on it.++ 10. Each time you redistribute the Library (or any work based on the+Library), the recipient automatically receives a license from the+original licensor to copy, distribute, link with or modify the Library+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 with+this License.++ 11. 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 Library at all. For example, if a patent+license would not permit royalty-free redistribution of the Library 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 Library.++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.++ 12. If the distribution and/or use of the Library is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Library 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.++ 13. The Free Software Foundation may publish revised and/or new+versions of the Lesser 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 Library+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 Library does not specify a+license version number, you may choose any version ever published by+the Free Software Foundation.++ 14. If you wish to incorporate parts of the Library into other free+programs whose distribution conditions are incompatible with these,+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++ 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR+OTHER PARTIES PROVIDE THE LIBRARY "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+LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. 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 LIBRARY 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+LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), 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 Libraries++ If you develop a new library, and you want it to be of the greatest+possible use to the public, we recommend making it free software that+everyone can redistribute and change. You can do so by permitting+redistribution under these terms (or, alternatively, under the terms of the+ordinary General Public License).++ To apply these terms, attach the following notices to the library. 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.++ <one line to give the library's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This library is free software; you can redistribute it and/or+ modify it under the terms of the GNU Lesser General Public+ License as published by the Free Software Foundation; either+ version 2.1 of the License, or (at your option) any later version.++ This library 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+ Lesser General Public License for more details.++ You should have received a copy of the GNU Lesser General Public+ License along with this library; 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.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the library, if+necessary. Here is a sample; alter the names:++ Yoyodyne, Inc., hereby disclaims all copyright interest in the+ library `Frob' (a library for tweaking knobs) written by James Random Hacker.++ <signature of Ty Coon>, 1 April 1990+ Ty Coon, President of Vice++That's all there is to it!+
+ README view
@@ -0,0 +1,38 @@+Please check the right section in this file for instructions depending on how you obtained the source files.+++Installing SyntaxMacros from a source distribution+-------------------------------------------++ System wide installation (assumming GHC is the+ Haskell compiler) can be done like this:++ ghc --make Setup.hs -o setup -package Cabal+ ./setup configure+ ./setup build+ ./setup install+++Installing uulib to a non-standard location+-------------------------------------------++ This is useful if you don't want (or can't)+ modify system wide settings.++ ghc --make Setup.hs -o setup -package Cabal+ ./setup configure --prefix=/foo+ ./setup build+ ./setup install --user++ The last command registers the package only for+ the user.++++Optionally generating Haddock Documentation+-------------------------------------------++ Output generated in dist/doc/html++ ./setup haddock+
+ Setup.hs view
@@ -0,0 +1,3 @@++import Distribution.Simple+main = defaultMain
+ SyntaxMacros.cabal view
@@ -0,0 +1,32 @@+name: SyntaxMacros +version: 0.1+license: LGPL+license-file: COPYRIGHT+maintainer: Marcos Viera <mviera@fing.edu.uy>+homepage: http://www.cs.uu.nl/wiki/Center/SyntaxMacrosForFree +description: Library of first-class Syntax Macros+synopsis: Syntax Macros in the form of an EDSL+build-type: Simple+category: Development +stability: Experimental+copyright: Universiteit Utrecht+build-depends: base>=4 && <5, haskell98, template-haskell>=2.4.0.1, TTTAS>=0.4.0, AspectAG>=0.2,+ uulib>=0.9.12, containers>=0.3+cabal-version: >= 1.2.3 +exposed-modules: Language.Grammars.Grammar, + Language.Grammars.SyntaxMacros, + Language.Grammars.SyntaxMacros.Scanner+other-modules: Language.Grammars.SyntaxMacros.Machine, + Language.Grammars.SyntaxMacros.Token, + Language.Grammars.SyntaxMacros.TokenParser, + Language.Grammars.SyntaxMacros.ScanUtils, + Language.Grammars.SyntaxMacros.Utils, + Language.Grammars.Transformations.GramTrafo,+ Language.Grammars.Transformations.LeftCorner,+ Language.Grammars.Transformations.LeftFact+extensions: EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies,+ MultiParamTypeClasses, RankNTypes, ScopedTypeVariables,+ TypeSynonymInstances, UndecidableInstances, GADTs+hs-source-dirs: src+extra-source-files: README, LICENSE-LGPL +ghc-options: -Wall
+ examples/Expr.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction + , GADTs #-}++module Expr where++import Language.Grammars.AspectAG+import Language.Grammars.AspectAG.Derive++import Data.HList.Label4+import Data.HList.TypeEqGeneric1+import Data.HList.TypeCastGeneric1++import Data.Maybe++import UU.Pretty++import Control.Monad ++data AGItf = AGItf { expr :: T_Expr}+ deriving Show++data T_Expr = Cst {cv :: Int}+ | Var {vnm :: String}+ | Mul {me1 :: T_Expr, me2 :: T_Expr}+ | Add {ae1 :: T_Expr, ae2 :: T_Expr}+ | Let {lnm :: String, val :: T_Expr, body :: T_Expr}+ deriving Show++++-- syn att d f = syndef att (def d f)+-- inh att nts d f = inhdef att nts (def d f)+syn = syndefM+inh = inhdefM++$(deriveAG ''AGItf)++exprNT = nt_T_Expr .*. hNil+allNT = nt_AGItf .*. exprNT+ +++$(attLabels ["spp"])++sppAGItf = syn spp $ liftM (# spp) (at ch_expr)+sppCst = syn spp $ liftM pp (at ch_cv)+sppVar = syn spp $ liftM pp (at ch_vnm)+sppMul = syn spp $ do e1 <- at ch_me1 + e2 <- at ch_me2+ return $ e1 # spp >|< " * " >|< e2 # spp +sppAdd = syn spp $ do e1 <- at ch_ae1 + e2 <- at ch_ae2+ return $ e1 # spp >|< " + " >|< e2 # spp ++sppLet = syn spp $ do lnm <- at ch_lnm+ val <- at ch_val+ body <- at ch_body+ return $ "let " >|< pp lnm >|< " = " >|< val # spp >|< " in " >|< body # spp +++$(attLabels ["ienv","sval"])+++ienvRule = copy ienv exprNT +ienvAGItf = inh ienv exprNT $ do return (ch_expr .=. ([] :: [(String,Int)]) .*. emptyRecord)+ienvCst = ienvRule+ienvVar = ienvRule+ienvMul = ienvRule+ienvAdd = ienvRule+ienvLet = inh ienv exprNT $ do lnm <- at ch_lnm+ val <- at ch_val+ lhs <- at lhs+ return $ ch_val .=. lhs # ienv .*.+ ch_body .=. (lnm, val # sval) : lhs # ienv .*. + emptyRecord+++svalRule f = use sval allNT f (0::Int) +svalAGItf = svalRule ((*)::Int->Int->Int)+svalCst = syn sval $ liftM id (at ch_cv)+svalVar = syn sval $ do vnm <- at ch_vnm + lhs <- at lhs+ return $ fromJust (lookup vnm (lhs # ienv)) +svalMul = svalRule ((*)::Int->Int->Int)+svalAdd = svalRule ((+)::Int->Int->Int)+svalLet = syn sval $ liftM (# sval) (at ch_body)+++aspAGItf = sppAGItf `ext` ienvAGItf `ext` svalAGItf+aspCst = sppCst `ext` ienvCst `ext` svalCst +aspVar = sppVar `ext` ienvVar `ext` svalVar +aspMul = sppMul `ext` ienvMul `ext` svalMul +aspAdd = sppAdd `ext` ienvAdd `ext` svalAdd +aspLet = sppLet `ext` ienvLet `ext` svalLet++{-+semAGItf e = knit aspAGItf (ch_expr .=. e .*. emptyRecord)++semCst e = knit aspCst (ch_cv .=. (\(Record HNil) -> e) .*. emptyRecord)++semVar e = knit aspVar (ch_vnm .=. (\(Record HNil) -> e) .*. emptyRecord)++semMul e1 e2 = knit aspMul (ch_me1 .=. e1 .*. ch_me2 .=. e2 .*. emptyRecord)++semAdd e1 e2 = knit aspAdd (ch_ae1 .=. e1 .*. ch_ae2 .=. e2 .*. emptyRecord)++semLet l e1 e2 = knit aspLet (ch_lnm .=. (\(Record HNil) -> l) .*. ch_val .=. e1 .*. ch_body .=. e2 .*. emptyRecord)+-}++semAGItf r = knit aspAGItf r +semCst r = knit aspCst r+semVar r = knit aspVar r+semMul r = knit aspMul r+semAdd r = knit aspAdd r+semLet = knit aspLet ++-- modifications+-- syn att d f = syndef att (def d f)+-- inh att nts d f = inhdef att nts (def d f)+-- synmod att v (Fam ic sp) = Fam ic (sp .@. att .=. v)+-- synM att v f = synmod att (def v f)+synM = synmodM+inhM = inhmodM++$(chLabel "se" ''T_Expr)++sppSq = synM spp $ do me1 <- at ch_me1 + return $ "square " >|< (me1 # spp) ++semSq r = knit (sppSq `ext` aspMul) + (ch_me1 .=. (r # ch_se) .*. ch_me2 .=. (r # ch_se) .*. emptyRecord)++{-+sppSq = synM spp $ do me1 <- at ch_me1 + return $ "square " >|< (me1 # spp) ++semSq r = knit (sppSq `ext` aspMul) (ch_me2 .=. (r # ch_me1) .*. r)+-}++$(chLabels ["pe1","pe2"] ''T_Expr)++sppPyth = synM spp $ do ae1 <- at ch_ae1+ ae2 <- at ch_ae2 + return $ "pyth " >|< (ae1 # spp) >|< " "+ >|< (ae2 # spp) +svalPyth = synM sval $ do ae1 <- at ch_ae1+ ae2 <- at ch_ae2+ return $ (\p1 p2 -> p1 * p1 + p2 * p2 )(ae1 # sval) (ae2 # sval) +semPyth r = knit (sppPyth `ext` svalPyth `ext` aspAdd) + (ch_ae1 .=. (r # ch_pe1) .*. ch_ae2 .=. (r # ch_pe2) .*. emptyRecord)+++++-- identity stuff+$(chLabel "pe" ''T_Expr)+{-+synId att = syn att $ liftM (# att) (at ch_id)+inhId att nts = inh att nts $ do lhs <- at lhs+ return $ ch_id .=. (lhs # att) .*. emptyRecord++attsId = (synId spp) `ext`(inhId ienv exprNT) `ext`(synId sval)+-}++sppPar = syn spp $ do pe <- at ch_pe+ return $ "(" >|< pe # spp >|< ")" +svalPar = syn sval $ do liftM (# sval) (at ch_pe)+ienvPar = copy ienv exprNT++ +semPar = knit (sppPar `ext` ienvPar `ext` svalPar)+++sppSubst = synM spp $ do lnm <- at ch_lnm+ val <- at ch_val+ body <- at ch_body+ return $ (body # spp) >|< "[" >|< (pp lnm) >|< " | " >|< (val # spp) >|< "]" +{-+ienvSubst = inhM ienv exprNT $ do lnm <- at ch_lnm+ val <- at ch_val+ lhs <- at lhs+ return $ ch_val .=. (lhs # ienv) .*.+ ch_body .=. ((lnm, val # sval) : (lhs # ienv)) .*. + emptyRecord+-}+semSubst r = knit (sppSubst `ext` {-ienvSubst `ext`-} aspLet) r+++
+ examples/Main.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE Arrows, DoRec, EmptyDataDecls, FlexibleContexts #-}+++import qualified Data.Set as Set++import Control.Arrow++import UU.Pretty++import Expr+import Language.Grammars.AspectAG+import qualified Language.Grammars.AspectAG as AG++import Language.Grammars.SyntaxMacros+import Language.Grammars.Grammar++import Language.Grammars.SyntaxMacros.Scanner+++gramOpts :: ScanOpts+gramOpts+ = defaultScanOpts+ { scoKeywordsTxt = Set.fromList ["let", "in"]+ , scoSpecChars = Set.fromList "=+*"+ , scoDollarIdent = True+ }+++extKeywordsTxt :: ScanOpts -> [String] -> ScanOpts+extKeywordsTxt opts kws = opts { scoKeywordsTxt = scoKeywordsTxt opts `Set.union` Set.fromList kws }++extSpecChars :: ScanOpts -> [Char] -> ScanOpts+extSpecChars opts kws = opts { scoSpecChars = scoSpecChars opts `Set.union` Set.fromList kws }++data NTRoot+ntRoot = undefined :: NTRoot+++data NTExp+ntExp = undefined :: NTExp++data NTTerm+ntTerm = undefined :: NTTerm++data NTFactor+ntFactor = undefined :: NTFactor+++prds = proc () -> do+ rec root <- addNT -< [ prd $ (ch_expr,exp) <#> \e -> semAGItf e () ] ++ exp <- addNT -< [ prd $ "let" .> (ch_lnm,var) -.> "=" .> (ch_val,exp) <.> "in" .> (ch_body,exp) <#> semLet+ , prd $ (ch_ae1,term) <.> "+" .> (ch_ae2,exp) <#> semAdd+ , prdId term ]+ + term <- addNT -< [ prd $ (ch_me1,term) <.> "*" .> (ch_me2,factor) <#> semMul + , prdId factor ]++ factor <- addNT -< [ prd $ (ch_cv,int) -#> semCst+ , prd $ (ch_vnm,var) -#> semVar ]++ exportNTs -< Export root $ ntExp ^= exp ^| + ntTerm ^= term ^|+ ntFactor ^= factor ^| + ntNil ++gram = closeGram prds++test1 = do+ tokens <- scanFile gramOpts "prog.src"+ let (Ok res) = (parse . compile ) gram tokens+ print $ res # spp+ print $ res # sval+++type AttExpr = Record (HCons (LVPair (Proxy Att_ienv) [(String,Int)]) HNil)+ -> Record (HCons (LVPair (Proxy Att_spp) PP_Doc)+ (HCons (LVPair (Proxy Att_sval) Int) HNil))++--extended grammar (syntax macro) +prds' :: ( NTRecord (nts env) + , GetNT NTExp (nts env) (Symbol AttExpr env)+ , GetNT NTFactor (nts env) (Symbol AttExpr env)) + => SyntaxMacro env (Export start nts) (Export start nts)+prds' = proc (Export root nts) -> do+ let exp = getNT ntExp nts+ addProds -< (exp, [ prd $ "square" .> (ch_se,exp) <#> semSq + , prd $ "pyth" .> (ch_pe1,exp) <.> (ch_pe2,exp) <#> semPyth+ , prd $ (ch_body,exp) <.> "[" .> (ch_lnm,var) -.> "|" .> (ch_val,exp) <.> "]" #> semSubst ])+ ++ let factor = getNT ntFactor nts+ addProds -< (factor, [ prd $ "(" .> (ch_pe,exp) <.> ")" #> semPar ])+ + exportNTs -< (Export root nts)++gram' = closeGram (extendGram prds prds') ++test2 = do+ tokens <- scanFile (gramOpts `extKeywordsTxt` [ "square", "pyth" ] `extSpecChars` "()[|]") "prog2.src"+ case ( parse . compile ) gram' tokens of+ (Ok res) -> do print $ res # spp+ print $ res # sval+ (Rep _ err) -> print err+++main = test1 >> test2 ++
+ examples/prog.src view
@@ -0,0 +1,1 @@+let letter= 2 + 10 in 3 * letter + 104
+ examples/prog2.src view
@@ -0,0 +1,1 @@+let letter= pyth ( 2 + 1) 3 in ( (x + 1) [x | 10]) * (letter + square 4)
+ src/Language/Grammars/Grammar.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE ExistentialQuantification, GADTs #-}++module Language.Grammars.Grammar where++import Language.AbstractSyntax.TTTAS+import Language.Grammars.AspectAG hiding (append)+++data Grammar a + = forall env . Grammar (Ref a env) + (Env Productions env env)++newtype Productions a env + = PS {unPS :: [Prod a env]}++data Prod a env where+ Seq :: Symbol b env -> Prod (b -> a) env + -> Prod a env+ End :: a -> Prod a env++data DTerm = DTerm++data Symbol a env where+ Term :: String -> Symbol DTerm env++ Nont :: Ref a env -> Symbol a env+ -- attributed terminals+ NontInt :: Symbol Int env+ NontChar :: Symbol Char env+ NontVarid :: Symbol String env+ NontConid :: Symbol String env+ NontOp :: Symbol String env + --- TODO: the rest of EnumValToken++infixl 5 `ext`+ext :: Env Productions env def' -> [Prod a env]+ -> Env Productions env (def', a)+ext g = Ext g . PS ++++matchSym :: Symbol a env -> Symbol b env + -> Maybe (Equal a b)+matchSym (Nont x) (Nont y) = match x y+matchSym (Term x) (Term y) | x == y = Just Eq+matchSym NontInt NontInt = Just Eq+matchSym NontVarid NontVarid = Just Eq+matchSym NontConid NontConid = Just Eq+matchSym NontOp NontOp = Just Eq+matchSym _ _ = Nothing+++append :: (a -> b -> c) -> Prod a env -> Symbol b env + -> Prod c env+append g (End f ) s = Seq s (End (g f))+append g (Seq t ts ) s + = Seq t (append (\b c d -> g (b d) c) ts s)+++data Lit a env = Lit (a env)++int :: Lit (Symbol Int) env+char :: Lit (Symbol Char) env+var :: Lit (Symbol String) env+con :: Lit (Symbol String) env+op :: Lit (Symbol String) env++int = Lit NontInt+char = Lit NontChar+var = Lit NontVarid+con = Lit NontConid+op = Lit NontOp++infixr 6 -:-+(-:-) = (,)++infixr 5 <.>, -.>, .>, <#>, -#>, #>++prd a = a ($)+prdId nt = Seq nt $ End id++((chn,s) <.> ps) f = Seq s $ ps f'+ where f' sem r = \x -> f sem (chn .=. x .*. r) ++(pn,Lit s) -.> pp = \r -> Seq s $ pp (f r)+ where f r ff p = \x -> r ff (pn .=. (\(Record HNil) -> x) .*. p) ++s .> pp = \r -> Seq (Term s) $ pp (f r)+ where f r ff p = \DTerm -> r ff p +++((chn,s) <#> sem) f = Seq s (End $ f')+ where f' = \x -> f sem + (chn .=. x .*. emptyRecord)++(pn,Lit s) -#> ff = \r -> Seq s (End $ f r)+ where f r = \x -> r ff (pn .=. (\(Record HNil) -> x) .*. emptyRecord)++s #> ff = \r -> Seq (Term s) (End $ f r)+ where f r = \DTerm -> r ff emptyRecord ++{-+-- DOESN'T WORK++class ProdSeq a b c v v' | a -> b, b -> c where+ (<.>) :: (HExtend (LVPair t v) l l') =>+ (t, a env)-> + ((t1 -> l -> v' -> t2) -> Prod b env)-> + (t1 -> l' -> t2)-> + Prod c env++instance ProdSeq (Symbol b) (b->a) a v v where+ (pn,s) <.> pp = \r -> Seq s $ pp (f r)+ where f r ff p = \x -> r ff (pn .=. x .*. p) +++instance ProdSeq (Lit (Symbol b)) (b->a) a (Record HNil -> v) v where+ (pn,Lit s) <..> pp = \r -> Seq s $ pp (f r)+ where f r ff p = \x -> r ff (pn .=. (\(Record HNil) -> x) .*. p) ++-- WORKS++class ProdEnd a b | a -> b where+ (<#>) :: (t, a env) -> t1-> (t1 -> Record (HCons (LVPair t b) HNil) -> t2) -> Prod t2 env++instance ProdEnd (Symbol v) v where+ (pn,s) <#> ff = \r -> Seq s (End $ f r)+ where f r = \x -> r ff (pn .=. x .*. emptyRecord)++instance ProdEnd (Lit (Symbol v)) (Record HNil -> v) where+ (pn,Lit s) <#> ff = \r -> Seq s (End $ f r)+ where f r = \x -> r ff (pn .=. (\(Record HNil) -> x) .*. emptyRecord)+-}++
+ src/Language/Grammars/SyntaxMacros.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE Arrows, ExistentialQuantification, GADTs, Rank2Types, FlexibleContexts, ScopedTypeVariables+ , EmptyDataDecls, MultiParamTypeClasses, FlexibleInstances, OverlappingInstances, FunctionalDependencies, UndecidableInstances+ , TypeFamilies #-}++module Language.Grammars.SyntaxMacros where++import Language.AbstractSyntax.TTTAS+import Control.Arrow++import UU.Parsing hiding (Symbol,parse,Ok)+import qualified UU.Parsing as UU+import Language.Grammars.SyntaxMacros.Scanner++import Language.Grammars.Grammar+import Language.Grammars.Transformations.LeftCorner+import Language.Grammars.Transformations.LeftFact++type GramTrafo = Trafo Unit Productions+type ExtGram env nts + = GramTrafo env () (nts env)+type SyntaxMacro env nts nts' + = GramTrafo env (nts env) (nts' env)++data Export start nts env = Export (Symbol start env) (nts env)++-- add a new non-terminal to the grammar+addNT :: GramTrafo env [Prod a env] (Symbol a env)+addNT = proc p -> do + r <- newSRef -< PS p+ returnA -< Nont r+++-- add productions to an existing non-terminal+addProds :: GramTrafo env + (Symbol a env, [Prod a env]) ()+addProds = proc (Nont nt, prds) -> do+ updateFinalEnv -< + updateEnv (\(PS ps) -> PS $ prds ++ ps) nt++-- close the grammar+closeGram :: (forall env. ExtGram env (Export a nts)) + -> Grammar a +closeGram prds = case runTrafo prds Unit () of+ Result _ (Export (Nont r) _) gram + -> (leftfactoring . leftcorner) $ Grammar r gram+++extendGram :: (NTRecord (nts env), NTRecord (nts' env)) + => ExtGram env (Export start nts) + -> SyntaxMacro env (Export start nts) (Export start' nts') + -> ExtGram env (Export start' nts')+extendGram g sm = g >>> sm++exportNTs :: NTRecord (nts env) => GramTrafo env (Export start nts env) (Export start nts env)+exportNTs = returnA+++-- extensible record++newtype NTField nt a env = NTField { symbolNTField :: (Symbol a env) } ++labelNTField :: NTField nt a env -> nt+labelNTField _ = undefined++data NTCons nt v l env = NTCons (NTField nt v env) (l env)+data NTNil env = NTNil++class NTRecord r +instance NTRecord (NTNil env)+instance (NTRecord (l env), NotDuplicated nt (l env)) => NTRecord (NTCons nt v l env)+++class Fail err++data Duplicated nt++class NotDuplicated nt r+instance NotDuplicated nt (NTNil env)+instance Fail (Duplicated nt) => NotDuplicated nt (NTCons nt v l env) -- using overlapping+instance NotDuplicated nt1 (l env) => NotDuplicated nt1 (NTCons nt2 v l env)+++ntNil = NTNil++infixr 4 ^= +(^=) :: nt -> (Symbol a env) -> NTField nt a env+(^=) _ = NTField+++infixr 2 ^| +(^|) :: NTRecord (NTCons nt a l env) => NTField nt a env -> l env -> NTCons nt a l env+(^|) = NTCons+++class GetNT nt r v | nt r -> v where+ getNT :: nt -> r -> v++data NotFound nt++instance Fail (NotFound nt) => GetNT nt (NTNil env) r where+ getNT = undefined+instance GetNT nt (NTCons nt v l env) (Symbol v env) where -- using overlapping+ getNT _ (NTCons f _) = symbolNTField f+instance GetNT nt1 (l env) r => GetNT nt1 (NTCons nt2 v l env) r where+ getNT nt (NTCons _ l) = getNT nt l+++-- COMPILE --------------------------------------------------------------------++pInt :: Parser Token Int+pChr :: Parser Token Char+pCon :: Parser Token String+pVar :: Parser Token String+pOp :: Parser Token String++pChr = head <$> pChar+pInt = read <$> pInteger+pCon = id <$> pConid+pVar = id <$> pVarid+pOp = id <$> pVarsym++pTerm t = const DTerm <$> (pKey t)++newtype Const f a s = C {unC :: f a}+++compile :: Grammar a -> Parser Token a+compile (Grammar (start :: Ref a env) rules) + = unC (lookupEnv start result)+ where result = + mapEnv + (\ (PS ps) -> C (foldr1 (<|>) [ comp p | p <- ps]))+ rules+ comp :: forall t . Prod t env -> Parser Token t+ comp (End x) = pLow x + comp (Seq (Term t) ss) + = flip ($) <$> pTerm t <*> comp ss + comp (Seq (Nont n) ss) + = flip ($) <$> unC (lookupEnv n result)+ <*> comp ss+ comp (Seq (NontInt) ss) + = flip ($) <$> pInt <*> comp ss + comp (Seq (NontChar) ss) + = flip ($) <$> pChr <*> comp ss + comp (Seq (NontVarid) ss) + = flip ($) <$> pVar <*> comp ss + comp (Seq (NontConid) ss) + = flip ($) <$> pCon <*> comp ss + comp (Seq (NontOp) ss) + = flip ($) <$> pOp <*> comp ss +++mapEnv :: (forall a . f a s -> g a s) + -> Env f s env -> Env g s env+mapEnv _ Empty = Empty+mapEnv f (Ext r v) = Ext (mapEnv f r) (f v)+++-- PARSE ----------------------------------------------------------------------++type ParseMsg = Message Token (Maybe Token)++data ParseResult a = Ok a+ | Rep a [ParseMsg] + deriving Show++parse :: Parser Token a -> [Token] -> ParseResult a+parse p input = case rparse p input of+ (a,[] ) -> Ok a+ (a,msgs) -> Rep a msgs+++rparse :: Parser Token a -> [Token] -> (a, [ParseMsg])+rparse p input = let ((Pair a _),msgs) = eval (UU.parse p input)+ in (a,msgs)+ where eval :: Steps a Token (Maybe Token) -> (a, [ParseMsg])+ eval (OkVal v r) = let (a,msgs) = v `seq` eval r + in (v a,msgs)+ eval (UU.Ok r) = eval r+ eval (Cost _ r) = eval r+ eval (StRepair _ msg r) = let (v,msgs) = eval r + in (v,msg:msgs)+ eval (Best _ r _) = eval r+ eval (NoMoreSteps v ) = (v,[]) +
+ src/Language/Grammars/SyntaxMacros/Machine.hs view
@@ -0,0 +1,330 @@+module Language.Grammars.SyntaxMacros.Machine (scanHandle,scanFile,scan,getRational,getBaseNumber) where++import Data.Char+import Data.List+import Data.Maybe+import IO+import UU.Scanner.Position+import qualified Data.Set as Set++import Language.Grammars.SyntaxMacros.Utils+import Language.Grammars.SyntaxMacros.ScanUtils+import Language.Grammars.SyntaxMacros.Token++++scanHandle :: ScanOpts -> FilePath -> Handle -> IO [Token]+scanHandle opts fn fh+ = do { txt <- hGetContents fh+ ; return (scan opts (initPos fn) txt) + }++scanFile :: ScanOpts -> FilePath -> IO [Token]+scanFile opts fn = + do txt <- readFile fn+ return (scan opts (initPos fn) txt) ++scan :: ScanOpts -> Pos -> String -> [Token]+scan opts pos input+ = if scoLitmode opts+ then scanLitText pos input+ else doScan pos input++ where+ -- locatein :: Ord a => [a] -> a -> Bool+ -- locatein es = isJust . btLocateIn compare (tab2tree (sort es))+ iskw = (`Set.member` scoKeywordsTxt opts) -- locatein (scoKeywordsTxt opts)+ isop = (`Set.member` scoKeywordsOps opts) -- locatein (scoKeywordsOps opts)+ isSymbol = (`Set.member` scoSpecChars opts) -- locatein (scoSpecChars opts)+ isOpsym = (`Set.member` scoOpChars opts) -- locatein (scoOpChars opts)+ isPairSym= (`Set.member` scoSpecPairs opts) -- locatein (scoSpecPairs opts)++ isIdStart c = isLower c || c == '_'+ isIdChar c = isAlphaNum c || c == '\'' || c == '_'+ isQIdChar c = isIdChar c || c == '.'++ allowQual = scoAllowQualified opts++ scanIdent isId p s+ = (name,advc (length name) p,rest)+ where (name,rest) = span isId s++ scanDollarIdent :: String -> (String,Int,String)+ scanDollarIdent [] = ("",0,[])+ scanDollarIdent ('$':c:s) | not (isSpace c)+ = let (str,w,s') = scanDollarIdent s+ in (c:str,w+2,s')+ scanDollarIdent cs@(c:s) | isSpace c || isSymbol c || isOpsym c+ = ("",0,cs)+ scanDollarIdent (c:s) = let (str,w,s') = scanDollarIdent s+ in (c:str,w+1,s')++ scanQualified :: String -> (String,String)+ scanQualified s+ = qual "" s+ where split isX s = span (\c -> isX c && c /= '.') s+ validQuald c = isId c || isOpsym c+ isId c = isIdStart c || isUpper c+ qual q s+ = case s of+ (c:s') | isUpper c -- possibly a module qualifier+ -> case split isIdChar s' of+ (s'',('.':srest@(c':_))) | validQuald c' -- something validly qualifiable follows+ -> qual (q ++ [c] ++ s'' ++ ".") srest+ _ -> dflt+ (c:_) | isOpsym c || isIdChar c -- not a qualifier, an operator or lowercase identifier+ -> dflt+ where dflt = (q,s)++ scanLitText p ('\\':'b':'e':'g':'i':'n':'{':'c':'o':'d':'e':'}':s)+ | posIs1stColumn p+ = doScan (advc 12 p) s+ scanLitText p (c:s)+ = scanLitText (adv p c) s+ scanLitText p []+ = []++ doScan p [] = []+ doScan p (c:s) | isSpace c = let (sp,next) = span isSpace s+ in doScan (foldl adv p (c:sp)) next++ doScan p ('-':'-':s) = doScan p (dropWhile (/= '\n') s)+ doScan p ('{':'-':s) = lexNest doScan (advc 2 p) s+ doScan p ('"':ss)+ = let (s,p',rest) = scanString (advc 1 p) ss+ in if null rest || head rest /= '"'+ then errToken "Unterminated string literal" p : doScan p' rest+ else valueToken TkString s p : doScan (advc 1 p') (tail rest)++ doScan p ('$':ss)+ | scoDollarIdent opts = tok : doScan (advc (w+1) p) ss'+ where (ident,w,ss') = scanDollarIdent ss+ tok = if null ident+ then errToken "Zero length $identifier" p+ else valueToken TkVarid ident p++ doScan p ('\\':'e':'n':'d':'{':'c':'o':'d':'e':'}':s)+ | scoLitmode opts && posIs1stColumn p+ = scanLitText (advc 10 p) s++ -- this is experimental, for now, not foolproof, only to be used for the Prelude+ doScan p ('\'':'\'':ss)+ = let (s,w,r) = scanDQuoteIdent ss+ in if null r+ then errToken "Unterminated double quote ident" p : doScan (advc (w+1) p) r+ else valueToken TkConid s p : doScan (advc (w+4) p) r++ doScan p ('\'':ss)+ = let (mc,cwidth,rest) = scanChar ss+ in case mc of+ Nothing -> errToken "Error in character literal" p : doScan (advc cwidth p) rest+ Just c -> if null rest || head rest /= '\''+ then errToken "Unterminated character literal" p : doScan (advc (cwidth+1) p) rest+ else valueToken TkChar [c] p : doScan (advc (cwidth+2) p) (tail rest)++ doScan p cs@(c:c2:s)+ | isPairSym sym = reserved sym p : doScan(advc 2 p) s+ where sym = [c,c2]+ doScan p cs@(c:s)+ | isSymbol c = reserved [c] p+ : doScan (advc 1 p) s+ | isIdStart c || isUpper c+ =+ let (qualPrefix,qualTail) = scanQualified cs+ in if null qualPrefix || not allowQual+ then+ let (name', p', s') = scanIdent isIdChar (advc 1 p) s+ name = c:name'+ tok = if iskw name+ then reserved name p+ else valueToken (varKind name) name p+ in tok : doScan p' s'+ else case doScan (advc (length qualPrefix) p) qualTail of+ (tok@(ValToken tp val _):toks)+ -> ValToken (tokTpQual tp) (qualPrefix ++ val) p : toks+ ts -> ts+ | isOpsym c = let (name, s') = span isOpsym cs+ tok n p (c:_)+ | length suf' == 2 && isPairSym suf'+ = (fst (tok pre p []) ++ [reserved suf' (advc (length pre) p)],1)+ where (pre,suf) = splitAt (length n - 1) n+ suf' = suf ++ [c]+ tok n p s+ | isop n = ([reserved n p],0)+ | length suf == 2 && isPairSym suf+ = (fst (tok pre p []) ++ [reserved suf (advc (length pre) p)],0)+ | c==':' = ([valueToken TkConOp n p],0)+ | otherwise = ([valueToken TkOp n p],0)+ where (pre,suf) = splitAt (length n - 2) n+ (toks,drops) = tok name p s'+ in toks ++ doScan (advc drops $ foldl adv p name) (drop drops s')+ | isDigit c = let (tktype,number,width,s') = getNumber cs+ in valueToken tktype number p : doScan (advc width p) s'+ | isDigit c+ = let (tktype,(number,mantissa,exp),w,cs') = getRational' cs+ m = maybe "" (\mant -> "." ++ mant)+ e = maybe "" (\(sign,exp) -> "E" ++ maybe "" id sign ++ exp)+ in valueToken tktype (number ++ m mantissa ++ e exp) p+ : doScan (advc w p) cs'+ | otherwise = errToken ("Unexpected character " ++ show c) p+ : doScan (adv p c) s++varKind :: String -> EnumValToken+varKind ('_':s) = varKind s+varKind (c :s) | isUpper c = TkConid+ | otherwise = TkVarid+varKind [] = TkVarid++lexNest :: (Pos -> String -> [Token]) + -> Pos + -> String + -> [Token]+lexNest cont pos inp = lexNest' cont pos inp+ where lexNest' c p ('-':'}':s) = c (advc 2 p) s+ lexNest' c p ('{':'-':s) = lexNest' (lexNest' c) (advc 2 p) s+ lexNest' c p (x:s) = lexNest' c (adv p x) s+ lexNest' _ _ [] = [ errToken "Unterminated nested comment" pos]+++scanString :: Pos -> String -> (String,Pos,String)+scanString p [] = ("",p,[])+scanString p ('\\':'&':xs) = scanString (advc 2 p) xs+scanString p ('\'':xs) = let (str,p',r) = scanString (advc 1 p) xs+ in ('\'': str,p',r)+scanString p ('\\':x:xs) | isSpace x+ = let (white,rest) = span isSpace xs+ in case rest of+ ('\\':rest') -> scanString (advc 1 $ foldl adv (advc 2 p) white) rest'+ _ -> ("",advc 2 p,xs)+scanString p xs = let (ch,cw,cr) = getchar xs+ (str,p',r) = scanString (advc cw p) cr+ in maybe ("",p,xs) (\c -> (c:str,p',r)) ch++scanChar :: [Char] -> (Maybe Char,Int,[Char])+scanChar ('"' :xs) = (Just '"',1,xs)+scanChar xs = getchar xs++getchar :: [Char] -> (Maybe Char,Int,[Char])+getchar [] = (Nothing,0,[])+getchar s@('\n':_ ) = (Nothing,0,s )+getchar s@('\t':_ ) = (Nothing,0,s)+getchar s@('\'':_ ) = (Nothing,0,s)+getchar s@('\"':_ ) = (Nothing,0,s)+getchar ('\\':xs) = let (c,l,r) = getEscChar xs+ in (c,l+1,r)+getchar (x:xs) = (Just x,1,xs)++scanDQuoteIdent :: String -> (String,Int,String)+scanDQuoteIdent [] = ("",0,[])+scanDQuoteIdent ('\'':'\'':xs) = ("",0,xs)+scanDQuoteIdent (x:xs) = let (s,w,r) = scanDQuoteIdent xs -- should check similar to getchar+ in (x:s,w+1,r)++getEscChar :: [Char] -> (Maybe Char,Int,[Char])+getEscChar [] = (Nothing,0,[])+getEscChar s@('x':xs) = let (tp,n,len,rest) = getNumber ('0' : s)+ in (Just $ chr $ fromInteger $ getBaseNumber 16 n, len-1, rest)+getEscChar s@('o':xs) = let (tp,n,len,rest) = getNumber ('0' : s)+ in (Just $ chr $ fromInteger $ getBaseNumber 8 n, len-1, rest)+getEscChar s@('^':x:xs) = case x `lookup` cntrCntrs of+ Just c -> (Just c,2,xs)+ _ -> (Nothing,0,s)+ where cntrCntrs = [ ('@','\^@'), ('[','\^['), ('\\','\^\'), (']','\^]'), ('^','\^^'), ('_','\^_') ]+ ++ zip ['A' .. 'Z'] ['\^A' .. '\^Z']+getEscChar s@(x:xs) | isDigit x = let (tp,n,len,rest) = getNumber s+ val = case tp of+ TkInteger8 -> getBaseNumber 8 n+ TkInteger16 -> getBaseNumber 16 n+ TkInteger10 -> getBaseNumber 10 n+ in if val >= 0 && val <= 255+ then (Just (chr $ fromInteger val),len, rest)+ else (Nothing,1,rest)+ | otherwise = case x `lookup` cntrChars of+ Just c -> (Just c,1,xs)+ Nothing+ -> case filter (flip isPrefixOf s . fst) cntrStrs of+ [] -> (Nothing,0,s)+ ((m,mr):_)+ -> (Just mr,ml,drop ml s)+ where ml = length m+ where cntrChars = [('a','\a'),('b','\b'),('f','\f'),('n','\n'),('r','\r'),('t','\t')+ ,('v','\v'),('\\','\\'),('\"','\"'),('\'','\'')]+ cntrStrs = [ ("NUL",'\NUL'), ("SOH",'\SOH'), ("STX",'\STX'), ("ETX",'\ETX')+ , ("EOT",'\EOT'), ("ENQ",'\ENQ'), ("ACK",'\ACK'), ("BEL",'\BEL')+ , ("BS" ,'\BS' ), ("HT" ,'\HT' ), ("LF" ,'\LF' ), ("VT" ,'\VT' )+ , ("FF" ,'\FF' ), ("CR" ,'\CR' ), ("SO" ,'\SO' ), ("SI" ,'\SI' )+ , ("DLE",'\DLE'), ("DC1",'\DC1'), ("DC2",'\DC2'), ("DC3",'\DC3')+ , ("DC4",'\DC4'), ("NAK",'\NAK'), ("SYN",'\SYN'), ("ETB",'\ETB')+ , ("CAN",'\CAN'), ("EM" ,'\EM' ), ("SUB",'\SUB'), ("ESC",'\ESC')+ , ("FS" ,'\FS' ), ("GS" ,'\GS' ), ("RS" ,'\RS' ), ("US" ,'\US' )+ , ("SP" ,'\SP' ), ("DEL",'\DEL')+ ]++getBaseNumber :: Integer -> [Char] -> Integer+getBaseNumber base n = foldl (\r x -> toInteger (value x) + base * r) 0 n++getNumber :: [Char] -> (EnumValToken,[Char],Int,[Char])+getNumber cs@(c:s)+ | c /= '0' = num10+ | null s = const0+ | hs == 'x' || hs == 'X' = num16+ | hs == 'o' || hs == 'O' = num8+ | otherwise = num10+ where (hs:ts) = s+ const0 = (TkInteger10, "0",1,s)+ num10 = let (n,r) = span isDigit cs+ in (TkInteger10,n,length n,r)+ num16 = readNum isHexaDigit ts TkInteger16+ num8 = readNum isOctalDigit ts TkInteger8+ readNum p ts tk+ = let nrs@(n,rs) = span p ts+ in if null n then const0+ else (tk , n, 2+length n,rs)++getRational' :: String -> (EnumValToken,(String,Maybe String,Maybe (Maybe String,String)),Int,String)+getRational' s+ = case s2 of+ ('.':s3@(c:_)) | isDigit c && tktype == TkInteger10 && tktype2 == TkInteger10+ -> case scanExp s4 of+ Just (sign,number3,width3,s5)+ -> (TkFraction,(number,Just number2,Just (sign,number3)),width + width2 + width3 + 1,s5)+ _ -> (TkFraction,(number,Just number2,Nothing),width + width2 + 1,s4)+ where (tktype2,number2,width2,s4) = getNumber s3+ _ -> case scanExp s2 of+ Just (sign,number3,width3,s5)+ -> (TkFraction,(number,Nothing,Just (sign,number3)),width + width3,s5)+ _ -> (tktype,(number,Nothing,Nothing),width,s2)+ where (tktype,number,width,s2) = getNumber s+ scanExp s+ = case s of+ (c:s5) | c == 'e' || c == 'E'+ -> case s5 of+ (csign:s6)+ | csign == '+' || csign == '-'+ -> case s6 of+ (c:_) | isDigit c && tktype3 == TkInteger10+ -> Just (Just [csign],number3,width3+2,s7)+ where (tktype3,number3,width3,s7) = getNumber s6+ _ -> Nothing+ | isDigit csign && tktype3 == TkInteger10+ -> Just (Nothing,number3,width3+1,s7)+ where (tktype3,number3,width3,s7) = getNumber s5+ _ -> Nothing+ _ -> Nothing++getRational :: String -> (String,Maybe String,Maybe (Maybe String,String))+getRational s+ = n+ where (_,n,_,_) = getRational' s++isHexaDigit :: Char -> Bool+isHexaDigit d = isDigit d || (d >= 'A' && d <= 'F') || (d >= 'a' && d <= 'f')++isOctalDigit :: Char -> Bool+isOctalDigit d = d >= '0' && d <= '7'++value :: Char -> Int+value c | isDigit c = ord c - ord '0'+ | isUpper c = ord c - ord 'A' + 10+ | isLower c = ord c - ord 'a' + 10+
+ src/Language/Grammars/SyntaxMacros/ScanUtils.hs view
@@ -0,0 +1,179 @@+module Language.Grammars.SyntaxMacros.ScanUtils + ( ScanOpts(..), defaultScanOpts+ + , isNoPos, posIs1stColumn+ + , InFilePos(..), infpStart, infpNone+ , infpAdvCol, infpAdvLine, infpAdv1Line, infpAdvStr+ + , genTokVal, genTokTp, genTokMap+ + , isLF, isStr, isStrQuote+ , isWhite, isBlack+ , isVarStart, isVarRest+ )+ where++import IO+import Data.Char+import Data.List+import qualified Data.Set as Set++-- import EH.Util.Pretty++import UU.Parsing+import UU.Scanner.Position( noPos, Pos(..), Position(..) )+import UU.Scanner.GenToken++-------------------------------------------------------------------------+-- Utils for GenToken+-------------------------------------------------------------------------++genTokVal :: GenToken v t v -> v+genTokVal (ValToken _ v _) = v+genTokVal (Reserved v _) = v++genTokTp :: GenToken k t v -> Maybe t+genTokTp (ValToken t _ _) = Just t+genTokTp _ = Nothing++genTokMap :: (a->b) -> GenToken a t a -> GenToken b t b+genTokMap f (ValToken t v p) = ValToken t (f v) p+genTokMap f (Reserved k p) = Reserved (f k) p++-------------------------------------------------------------------------+-- Utils for Pos+-------------------------------------------------------------------------++isNoPos :: Pos -> Bool+isNoPos (Pos l c f) = l < 0 || c < 0++posIs1stColumn :: Pos -> Bool+posIs1stColumn p = column p == 1++-------------------------------------------------------------------------+-- InFilePos: Simplified Pos for inside a file only+-------------------------------------------------------------------------++data InFilePos+ = InFilePos { infpLine, infpColumn :: Int }+ deriving (Eq,Ord)++instance Show InFilePos where+ show (InFilePos l c) = if l < 0 || c < 0 then "" else "(" ++ show l ++ ":" ++ show c ++ ")"++infpStart :: InFilePos+infpStart = InFilePos 1 1++infpNone :: InFilePos+infpNone = InFilePos (-1) (-1)++infpAdvCol :: Int -> InFilePos -> InFilePos+infpAdvCol i p = p {infpColumn = i + infpColumn p}++infpAdvStr :: String -> InFilePos -> InFilePos+infpAdvStr s p = infpAdvCol (length s) p++infpAdvLine :: Int -> InFilePos -> InFilePos+infpAdvLine i p = p {infpLine = i + infpLine p, infpColumn = 1}++infpAdv1Line :: InFilePos -> InFilePos+infpAdv1Line = infpAdvLine 1++-------------------------------------------------------------------------+-- PP of parse errors+-------------------------------------------------------------------------++instance Position p => Position (Maybe p) where+ line = maybe (line noPos) line+ column = maybe (column noPos) column+ file = maybe (file noPos) file++instance Position (GenToken k t v) where+ line = line . position+ column = column . position+ file = file . position++{------------------------------------------------------------------------+instance PP Pos where+ pp (Pos l c f) = ppParens $ (if null f then empty else pp f >|< ":" ) >|< l >|< "," >|< c++------------------------------------------------------------------------}+++-------------------------------------------------------------------------+-- ScanOpts+-------------------------------------------------------------------------++{-+ScanOpts encode all possible options we ever might want to pass to a scanner used inside the EHC project.+Hence not all options are used by all scanners.+-}++data ScanOpts+ = ScanOpts+ { scoKeywordsTxt :: !(Set.Set String) -- identifiers which are keywords+ , scoCommandsTxt :: !(Set.Set String) -- identifiers which are commands+ , scoKeywordsOps :: !(Set.Set String) -- operators which are keywords+ , scoSpecChars :: !(Set.Set Char) -- 1 char keywords+ , scoOpChars :: !(Set.Set Char) -- chars used for operators+ , scoSpecPairs :: !(Set.Set String) -- pairs of chars which form keywords+ , scoDollarIdent :: !Bool -- allow $ encoded identifiers+ , scoOffsideTrigs :: ![String] -- offside triggers+ , scoOffsideModule :: !String -- offside start of module+ , scoOffsideOpen :: !String -- offside open symbol+ , scoOffsideClose :: !String -- offside close symbol+ , scoLitmode :: !Bool -- do literal scanning+ , scoVerbOpenClose :: ![(String,String)] -- open/close pairs used for verbatim text+ , scoAllowQualified :: !Bool -- allow qualified variations, i.e. prefixing with "XXX."+ }++defaultScanOpts :: ScanOpts+defaultScanOpts+ = ScanOpts+ { scoKeywordsTxt = Set.empty+ , scoCommandsTxt = Set.empty+ , scoKeywordsOps = Set.empty+ , scoSpecChars = Set.empty+ , scoOpChars = Set.empty+ , scoSpecPairs = Set.empty+ , scoDollarIdent = False+ , scoOffsideTrigs = []+ , scoOffsideModule = ""+ , scoOffsideOpen = ""+ , scoOffsideClose = ""+ , scoLitmode = False+ , scoVerbOpenClose = []+ , scoAllowQualified = True+ }++-------------------------------------------------------------------------+-- Char predicates+-------------------------------------------------------------------------++isLF :: Char -> Bool+isLF = (`elem` "\n\r")++isStrQuote :: Char -> Bool+isStrQuote c = c == '"'++isStr :: Char -> Bool+isStr c = not (isStrQuote c || isLF c)++isVarStart :: Char -> Bool+isVarStart c = c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z'++isVarRest :: Char -> Bool+isVarRest c = isVarStart c || isDigit c || c `elem` "'_"++isWhite :: Char -> Bool+isWhite = (`elem` " \t")++{-+isDig :: Char -> Bool+isDig c = c >= '0' && c <= '9'+-}++isBlack :: Char -> Bool+isBlack c = not (isWhite c || isLF c)+
+ src/Language/Grammars/SyntaxMacros/Scanner.hs view
@@ -0,0 +1,17 @@+module Language.Grammars.SyntaxMacros.Scanner + (module Language.Grammars.SyntaxMacros.Machine, + module Language.Grammars.SyntaxMacros.Token, + module Language.Grammars.SyntaxMacros.TokenParser, + module Language.Grammars.SyntaxMacros.ScanUtils, + module UU.Scanner.Position) where++import Language.Grammars.SyntaxMacros.Machine+import Language.Grammars.SyntaxMacros.Token+import Language.Grammars.SyntaxMacros.TokenParser+import Language.Grammars.SyntaxMacros.ScanUtils+import UU.Scanner.Position+import UU.Scanner.GenTokenOrd()+import UU.Scanner.GenTokenSymbol()+++
+ src/Language/Grammars/SyntaxMacros/Token.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE TypeSynonymInstances #-}+module Language.Grammars.SyntaxMacros.Token ( Token,EnumValToken(..)+ , module UU.Scanner.GenToken+ , reserved,valueToken,errToken,tokTpIsInt,tokTpIsId, tokTpQual) where ++import UU.Scanner.Position+import UU.Scanner.GenToken++import Data.Set +++type Token = GenToken String EnumValToken String+++data EnumValToken+ = TkVarid+ | TkConid+ | TkOp+ | TkConOp+ | TkQVarid+ | TkQConid+ | TkQOp+ | TkQConOp+ | TkString+ | TkChar+ | TkInteger8+ | TkInteger10+ | TkInteger16+ | TkFraction+ | TkTextnm+ | TkTextln + | TkError+ deriving (Eq, Ord)++instance Show Token where+ showsPrec _ token+ = showString+ (case token of+ Reserved key pos -> "symbol " ++ key ++ maybeshow pos+ ValToken tp val pos -> show tp ++ " " ++ val ++ maybeshow pos+ )++instance Show EnumValToken where+ show tp = case tp of + TkVarid -> "lower case identifier" + TkConid -> "upper case identifier" + TkOp -> "operator" + TkConOp -> "con operator" + TkQOp -> "qualified operator" + TkQVarid -> "lower case qualified identifier" + TkQConid -> "upper case qualified identifier" + TkQConOp -> "qualified con operator" + TkString -> "string" + TkChar -> "character" + TkInteger8 -> "octal integer" + TkInteger10 -> "decimal Integer" + TkInteger16 -> "hexadecimal integer" + TkFraction -> "fraction (float,...)" + TkTextnm -> "text name" + TkTextln -> "text lines" + TkError -> "error in scanner:" ++maybeshow :: Pos -> String+maybeshow (Pos l c fn) | l <= 0 || c <= 0 = ""+ | otherwise = " at line " ++ show l+ ++ ", column " ++ show c+ ++ " of file " ++ show fn++reserved :: String -> Pos -> Token+reserved = Reserved ++valueToken :: EnumValToken -> String -> Pos -> Token+valueToken = ValToken ++errToken :: String -> Pos -> Token+errToken = valueToken TkError ++tokTpIsInt :: EnumValToken -> Bool+tokTpIsInt tp = tp == TkInteger8 || tp == TkInteger10 || tp == TkInteger16++tokTpIsId :: EnumValToken -> Bool+tokTpIsId+ = (`member` ts)+ where ts = fromList+ [TkVarid,TkConid,TkOp,TkConOp+ ,TkQVarid,TkQConid,TkQOp,TkQConOp+ ]++tokTpQual :: EnumValToken -> EnumValToken+tokTpQual TkVarid = TkQVarid+tokTpQual TkConid = TkQConid+tokTpQual TkOp = TkQOp+tokTpQual TkConOp = TkQConOp+tokTpQual t = t+
+ src/Language/Grammars/SyntaxMacros/TokenParser.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE FlexibleContexts #-}++module Language.Grammars.SyntaxMacros.TokenParser where ++import UU.Parsing.Interface(IsParser(..))+import UU.Parsing.Derived(pListSep, pPacked)+import UU.Scanner.Position(Pos)+import UU.Scanner.GenTokenParser(pReserved, pValToken)++import Language.Grammars.SyntaxMacros.Token++++-------------------------------------------------------------------------+-- IsParsers for Symbols+-------------------------------------------------------------------------++pKeyPos :: IsParser p Token => String -> p Pos+pKeyPos keyword = pReserved keyword+++pSpecPos :: IsParser p Token => Char -> p Pos+pSpecPos s = pReserved [s]++pKey :: IsParser p Token => String -> p String+pKey key = key <$ pKeyPos key++pSpec :: IsParser p Token => Char -> p String +pSpec c = [c] <$ pSpecPos c+ +pStringPos, pCharPos,+ pInteger8Pos, pInteger10Pos, pInteger16Pos, pFractionPos,+ pVaridPos, pConidPos,+ pTextnmPos, pTextlnPos, pIntegerPos, pVarsymPos, pConsymPos :: IsParser p Token => p (String,Pos)++pStringPos = pValToken TkString "" +pCharPos = pValToken TkChar "\NUL" +pInteger8Pos = pValToken TkInteger8 "0" +pInteger10Pos = pValToken TkInteger10 "0" +pInteger16Pos = pValToken TkInteger16 "0"+pFractionPos = pValToken TkFraction "0.0"+pVaridPos = pValToken TkVarid "<identifier>" +pConidPos = pValToken TkConid "<Identifier>" +pConsymPos = pValToken TkConOp "<conoperator>"+pVarsymPos = pValToken TkOp "<operator>" +pTextnmPos = pValToken TkTextnm "<name>" +pTextlnPos = pValToken TkTextln "<line>" +pIntegerPos = pInteger10Pos++pString, pChar,+ pInteger8, pInteger10, pInteger16, pFraction,+ pVarid, pConid,+ pTextnm, pTextln, pInteger, pVarsym, pConsym :: IsParser p Token => p String++pString = fst <$> pStringPos +pChar = fst <$> pCharPos +pInteger8 = fst <$> pInteger8Pos +pInteger10 = fst <$> pInteger10Pos +pInteger16 = fst <$> pInteger16Pos +pFraction = fst <$> pFractionPos +pVarid = fst <$> pVaridPos +pConid = fst <$> pConidPos +pVarsym = fst <$> pVarsymPos +pConsym = fst <$> pConsymPos +pTextnm = fst <$> pTextnmPos +pTextln = fst <$> pTextlnPos +pInteger = fst <$> pIntegerPos + +pComma, pSemi, pOParen, pCParen, pOBrack, pCBrack, pOCurly, pCCurly+ :: IsParser p Token => p String++pComma = pSpec ','+pSemi = pSpec ';'+pOParen = pSpec '('+pCParen = pSpec ')'+pOBrack = pSpec '['+pCBrack = pSpec ']'+pOCurly = pSpec '{'+pCCurly = pSpec '}'++pCommaPos, pSemiPos, pOParenPos, pCParenPos, pOBrackPos, pCBrackPos, pOCurlyPos, pCCurlyPos+ :: IsParser p Token => p Pos++pCommaPos = pSpecPos ','+pSemiPos = pSpecPos ';'+pOParenPos = pSpecPos '('+pCParenPos = pSpecPos ')'+pOBrackPos = pSpecPos '['+pCBrackPos = pSpecPos ']'+pOCurlyPos = pSpecPos '{'+pCCurlyPos = pSpecPos '}'++pCommas :: IsParser p Token => p a -> p [a]+pSemics :: IsParser p Token => p a -> p [a]+pParens :: IsParser p Token => p a -> p a+pBracks :: IsParser p Token => p a -> p a+pCurly :: IsParser p Token => p a -> p a++pCommas = pListSep pComma+pSemics = pListSep pSemi+pParens = pPacked pOParen pCParen+pBracks = pPacked pOBrack pCBrack+pCurly = pPacked pOCurly pCCurly++pParens_pCommas :: IsParser p Token => p a -> p [a]+pBracks_pCommas :: IsParser p Token => p a -> p [a]+pCurly_pSemics :: IsParser p Token => p a -> p [a]++pParens_pCommas = pParens.pCommas+pBracks_pCommas = pBracks.pCommas+pCurly_pSemics = pCurly .pSemics+
+ src/Language/Grammars/SyntaxMacros/Utils.hs view
@@ -0,0 +1,191 @@+module Language.Grammars.SyntaxMacros.Utils where++-- import EH.Util.Pretty+import Data.Char+import Data.List+import qualified Data.Set as Set+import qualified Data.Map as Map++-------------------------------------------------------------------------+-- Set+-------------------------------------------------------------------------++unionMapSet :: Ord b => (a -> Set.Set b) -> (Set.Set a -> Set.Set b)+unionMapSet f = Set.unions . map f . Set.toList++-------------------------------------------------------------------------+-- Map+-------------------------------------------------------------------------++inverseMap :: (Ord k, Ord v') => (k -> v -> (v',k')) -> Map.Map k v -> Map.Map v' k'+inverseMap mk = Map.fromList . map (uncurry mk) . Map.toList++-------------------------------------------------------------------------+-- List+-------------------------------------------------------------------------++hdAndTl' :: a -> [a] -> (a,[a])+hdAndTl' _ (a:as) = (a,as)+hdAndTl' n [] = (n,[])++hdAndTl :: [a] -> (a,[a])+hdAndTl = hdAndTl' undefined++maybeNull :: r -> ([a] -> r) -> [a] -> r+maybeNull n f l = if null l then n else f l++maybeHd :: r -> (a -> r) -> [a] -> r+maybeHd n f = maybeNull n (f . head)++wordsBy :: (a -> Bool) -> [a] -> [[a]]+wordsBy p l+ = w l+ where w [] = []+ w l = let (l',ls') = break p l+ in l' : case ls' of [] -> []+ (_:[]) -> [[]]+ (_:ls'') -> w ls''++initlast :: [a] -> Maybe ([a],a)+initlast as+ = il [] as+ where il acc [a] = Just (reverse acc,a)+ il acc (a:as) = il (a:acc) as+ il _ _ = Nothing++initlast2 :: [a] -> Maybe ([a],a,a)+initlast2 as+ = il [] as+ where il acc [a,b] = Just (reverse acc,a,b)+ il acc (a:as) = il (a:acc) as+ il _ _ = Nothing++firstNotEmpty :: [[x]] -> [x]+firstNotEmpty = maybeHd [] id . filter (not . null)++-- saturate a list, that is:+-- for all indices i between min and max,+-- if there is no listelement x for which get x returns i,+-- add an element mk i to the list++listSaturate :: (Enum a,Ord a) => a -> a -> (x -> a) -> (a -> x) -> [x] -> [x]+listSaturate min max get mk xs+ = [ Map.findWithDefault (mk i) i mp | i <- [min..max] ]+ where mp = Map.fromList [ (get x,x) | x <- xs ]++-- saturate a list with values from assoc list, that is:+-- for all indices i between min and max,+-- if there is no listelement x for which get x returns i,+-- add a candidate from the associationlist (which must be present) to the list++listSaturateWith :: (Enum a,Ord a) => a -> a -> (x -> a) -> [(a,x)] -> [x] -> [x]+listSaturateWith min max get missing l+ = listSaturate min max get mk l+ where mp = Map.fromList missing+ mk a = panicJust "listSaturateWith" $ Map.lookup a mp++-- variant on span, predicate on full list+spanOnRest :: ([a] -> Bool) -> [a] -> ([a],[a])+spanOnRest p [] = ([],[])+spanOnRest p xs@(x:xs')+ | p xs = (x:ys, zs)+ | otherwise = ([],xs)+ where (ys,zs) = spanOnRest p xs'++-------------------------------------------------------------------------+-- String+-------------------------------------------------------------------------++strWhite :: Int -> String+strWhite sz = replicate sz ' '++strPad :: String -> Int -> String+strPad s sz = s ++ strWhite (sz - length s)++strCapitalize :: String -> String+strCapitalize s+ = case s of+ (c:cs) -> toUpper c : cs+ _ -> s++strToInt :: String -> Int+strToInt = foldl (\i c -> i * 10 + ord c - ord '0') 0++-------------------------------------------------------------------------+-- Split for qualified name+-------------------------------------------------------------------------++splitForQualified :: String -> [String]+splitForQualified s+ = ws''+ where ws = wordsBy (=='.') s+ ws' = case initlast2 ws of+ Just (ns,n,"") -> ns ++ [n ++ "."]+ _ -> ws+ ws''= case break (=="") ws' of+ (nq,(_:ns)) -> nq ++ [concatMap ("."++) ns]+ _ -> ws'++-------------------------------------------------------------------------+-- Misc+-------------------------------------------------------------------------++panic m = error ("panic: " ++ m)++-------------------------------------------------------------------------+-- group/sort/nub combi's+-------------------------------------------------------------------------++isSortedByOn :: (b -> b -> Ordering) -> (a -> b) -> [a] -> Bool+isSortedByOn cmp sel l+ = isSrt l+ where isSrt (x1:tl@(x2:_)) = cmp (sel x1) (sel x2) /= GT && isSrt tl+ isSrt _ = True++sortOn :: Ord b => (a -> b) -> [a] -> [a]+sortOn = sortByOn compare++sortByOn :: (b -> b -> Ordering) -> (a -> b) -> [a] -> [a]+sortByOn cmp sel = sortBy (\e1 e2 -> sel e1 `cmp` sel e2)++groupOn :: Eq b => (a -> b) -> [a] -> [[a]]+groupOn sel = groupBy (\e1 e2 -> sel e1 == sel e2)++groupSortOn :: Ord b => (a -> b) -> [a] -> [[a]]+groupSortOn sel = groupOn sel . sortOn sel++groupByOn :: (b -> b -> Bool) -> (a -> b) -> [a] -> [[a]]+groupByOn eq sel = groupBy (\e1 e2 -> sel e1 `eq` sel e2)++groupSortByOn :: (b -> b -> Ordering) -> (a -> b) -> [a] -> [[a]]+groupSortByOn cmp sel = groupByOn (\e1 e2 -> cmp e1 e2 == EQ) sel . sortByOn cmp sel++nubOn :: Eq b => (a->b) -> [a] -> [a]+nubOn sel = nubBy (\a1 a2 -> sel a1 == sel a2)++-------------------------------------------------------------------------+-- Ordering+-------------------------------------------------------------------------++orderingLexic :: [Ordering] -> Ordering+orderingLexic = foldr1 (\o1 o2 -> if o1 == EQ then o2 else o1)++-------------------------------------------------------------------------+-- Maybe+-------------------------------------------------------------------------++panicJust :: String -> Maybe a -> a+panicJust m = maybe (panic m) id++infixr 0 $?++($?) :: (a -> Maybe b) -> Maybe a -> Maybe b+f $? mx = do x <- mx+ f x++orMb :: Maybe a -> Maybe a -> Maybe a+orMb m1 m2 = maybe m2 (const m1) m1++++
+ src/Language/Grammars/Transformations/GramTrafo.hs view
@@ -0,0 +1,64 @@+{-# OPTIONS -fglasgow-exts #-}++module Language.Grammars.Transformations.GramTrafo where++import Language.AbstractSyntax.TTTAS+import Language.Grammars.Grammar++newtype MapA_X env a env'+ = MapA_X (forall x. Symbol x env -> Maybe (Ref (x -> a) env'))++emptyMap :: MapA_X env a env'+emptyMap = MapA_X (const Nothing)++extendMap :: Symbol x env -> MapA_X env a env'+ -> MapA_X env a (env',x->a)+extendMap x (MapA_X m) + = MapA_X (\s -> case matchSym s x of+ Just Eq -> Just Zero+ Nothing -> fmap Suc (m s)+ )+++type GramTrafo env a = Trafo (MapA_X env a) Productions+++initMap :: GramTrafo env a s c d+ -> Trafo Unit Productions s c d+initMap (Trafo st) + = Trafo (\_ -> case st emptyMap of+ TrafoE _ f -> TrafoE Unit f+ )++newNontR :: forall x env s a + . Symbol x env + -> GramTrafo env a s (Productions (x->a) s) (Ref (x->a) s)+newNontR x = Trafo $ \m -> extEnv (extendMap x m)+++newtype Mapping old new + = Mapping (Env Ref new old) ++map2trans :: Mapping env s -> T env s+map2trans (Mapping env) + = T (\r -> (lookupEnv r env))++mapProd :: T env1 env2 -> Prod a env1 -> Prod a env2+mapProd _ (End x) = End x+mapProd t (Seq (Term x) r) = Seq (Term x) + (mapProd t r)++mapProd t (Seq (Nont x) r) = Seq (Nont (unT t x)) + (mapProd t r)+mapProd t (Seq NontInt r) = Seq NontInt + (mapProd t r)+mapProd t (Seq NontChar r) = Seq NontChar + (mapProd t r)+mapProd t (Seq NontVarid r) = Seq NontVarid + (mapProd t r)+mapProd t (Seq NontConid r) = Seq NontConid + (mapProd t r)+mapProd t (Seq NontOp r) = Seq NontOp + (mapProd t r)++
+ src/Language/Grammars/Transformations/LeftCorner.hs view
@@ -0,0 +1,129 @@+{-# OPTIONS -XExistentialQuantification -XArrows -XDoRec -XGADTs #-}++module Language.Grammars.Transformations.LeftCorner (leftcorner) where++import Language.AbstractSyntax.TTTAS+import Language.Grammars.Grammar+import Language.Grammars.Transformations.GramTrafo+import Control.Arrow+++leftcorner :: forall a . Grammar a -> Grammar a+leftcorner (Grammar start productions)+ = case runTrafo (lctrafo productions) Unit () of+ Result _ (T tt) gram -> + Grammar (tt start) gram++lctrafo :: Env Productions env env + -> Trafo Unit Productions s () (T env s)+lctrafo productions = proc _ ->+ do rec let tenv_s = map2trans menv_s+ menv_s <- (rules1 productions productions) -< tenv_s+ returnA -< tenv_s+++rules1 :: Env Productions env env+ -> Env Productions env env' + -> Trafo Unit Productions s (T env s) + (Mapping env' s)+rules1 _ Empty + = proc _ ->+ returnA -< Mapping Empty ++rules1 productions (Ext ps (PS prods)) + = proc tenv_s ->+ do p <- app_rule1 productions prods -< tenv_s+ r <- newSRef -< p + Mapping e <- rules1 productions ps -< tenv_s+ returnA -< Mapping (Ext e r)+ +app_rule1 :: forall env a s. Env Productions env env+ -> [Prod a env]+ -> Trafo Unit Productions s (T env s) (Productions a s)+app_rule1 productions prods = initMap + ( proc tenv_s -> + do pss <- sequenceA (map (rule1 productions) prods) -< tenv_s + returnA -< PS (concatMap unPS pss)+ )++rule1 :: Env Productions env env -> Prod a env + -> GramTrafo env a s (T env s) (Productions a s)+rule1 gram (Seq x beta) + = proc tenv_s ->+ do insert gram x -< (tenv_s, mapProd tenv_s beta)+ ++rule2 :: Env Productions env env + -> Symbol x env + -> GramTrafo env a s (T env s, Ref (x -> a) s) + (Productions a s)+rule2 _ (Term a) + = proc (_, a_x) ->+ do returnA -< PS [rule2a a a_x]+rule2 gram (Nont b) + = case lookupEnv b gram of+ PS ps -> proc (tenv_s, a_x) ->+ do pss <- sequenceA + (map (rule2b gram) ps) -< (tenv_s, a_x)+ returnA -< PS (concatMap unPS pss)+rule2 _ NontInt + = proc (_, a_x) ->+ do returnA -< PS [rule2a' NontInt a_x]+rule2 _ NontChar + = proc (_, a_x) ->+ do returnA -< PS [rule2a' NontChar a_x]+rule2 _ NontVarid + = proc (_, a_x) ->+ do returnA -< PS [rule2a' NontVarid a_x]+rule2 _ NontConid + = proc (_, a_x) ->+ do returnA -< PS [rule2a' NontConid a_x]+rule2 _ NontOp + = proc (_, a_x) ->+ do returnA -< PS [rule2a' NontOp a_x]+++rule2a' :: Symbol a s-> Ref (a -> b) s -> Prod b s+rule2a' s refA_a+ = Seq s $ Seq (Nont refA_a) $ End ($) +++rule2a :: String -> Ref (DTerm -> a) s -> Prod a s+rule2a a refA_a+ = Seq (Term a) $ Seq (Nont refA_a) $ End ($) ++rule2b :: Env Productions env env + -> Prod b env + -> GramTrafo env a s (T env s, Ref (b -> a) s) + (Productions a s)+rule2b gram (Seq x beta) + = proc (tenv_s, a_b) ->+ do insert gram x -< (tenv_s, append (flip (.)) + (mapProd tenv_s beta) + (Nont a_b))++insert :: forall env s a x+ . Env Productions env env + -> Symbol x env+ -> GramTrafo env a s (T env s, Prod (x->a) s)+ (Productions a s)+insert gram x = + Trafo (+ \(MapA_X m) -> case m x of+ Just r -> extendA_X (MapA_X m) r+ Nothing -> let Trafo step = insertNewA_X + in step (MapA_X m)+ )+ where+ insertNewA_X = proc (tenv_s,p) ->+ do r <- newNontR x -< PS [p]+ rule2 gram x -< (tenv_s,r)+++extendA_X :: m env2-> Ref (x->a) env2-> TrafoE m Productions s env2 (t, Prod (x->a) s) (Productions a env)+extendA_X m r = fmap (const $ PS []) $ + updateSRef m r (\(_,p) (PS ps) -> PS (p:ps))++++
+ src/Language/Grammars/Transformations/LeftFact.hs view
@@ -0,0 +1,158 @@+{-# OPTIONS -XExistentialQuantification -XArrows -XDoRec #-}++module Language.Grammars.Transformations.LeftFact (leftfactoring) where++import Language.AbstractSyntax.TTTAS+import Language.Grammars.Grammar+import Language.Grammars.Transformations.GramTrafo+import Control.Arrow+import Data.Maybe++++--list of repeated symbols (with hidden type)+data AnySym env = forall x. AnySym (Symbol x env)++newtype BT env s = BT (Bool, T env s)++-- The 'leftfactoring' function makes a feed-back loop to apply the +-- transformation to the Grammar.+-- If the transformation has produced new nonterminals (repeated initial+-- symbols have been found) the 'leftfactoring' function is called again.+leftfactoring :: forall a. Grammar a -> Grammar a+leftfactoring (Grammar start productions)+ = case runTrafo (lftrafo productions) Unit () of+ Result _ (BT (b,T tt)) gram -> + let g = Grammar (tt start) gram+ in if b then leftfactoring g+ else g ++lftrafo :: Env Productions env env + -> Trafo Unit Productions s () (BT env s)+lftrafo productions = proc _ ->+ do rec let tenv_s = map2trans menv_s+ (b,menv_s) <- (rules productions) -< tenv_s+ returnA -< BT (b,tenv_s)+++-- The function 'rules' is defined by induction over the original Grammar. +-- Applies the "transformation rule" for each nonterminal (and+-- its corresponding productions) of the Grammar.+-- First of all, the list of "repeated initial symbols" in the productions+-- of a nonterminal is found.+-- Having this list, the rule is applied to the productions.+-- The nonterminal is added to the new Grammar, with the productions+-- generated by the rule.+-- The output of the Trafo is compound by a boolean indicating if repeated+-- symbols were found, and the Mapping from the positions in the new Grammar+-- for each nonterminal of the old Grammar.+rules :: Env Productions env env' + -> Trafo Unit Productions s (T env s) (Bool,(Mapping env' s))+rules Empty + = proc _ ->+ returnA -< (False, Mapping Empty)++rules (Ext ps (PS prods)) = + let rep = getrepeated prods+ in proc tenv_s ->+ do p <- app_rule rep prods -< tenv_s+ r <- newSRef -< p + (bs,Mapping e) <- rules ps -< tenv_s+ returnA -< ((length rep > 0) || bs, Mapping (Ext e r))+ +app_rule :: forall env a s. [AnySym env]+ -> [Prod a env]+ -> Trafo Unit Productions s (T env s) (Productions a s)+app_rule rep prods = initMap + ( proc tenv_s -> + do pss <- sequenceA (map (rule rep) prods) -< tenv_s + returnA -< PS (concatMap unPS pss)+ )++-- If the first symbol of the production is in the list of "repeated+-- initial symbols", the transformation generated by 'rinstert'+-- is called with input the rest of the production. So, a new nonterminal+-- A_Rest_X is generated (if necessary) and the rest (beta) of the production+-- is stored as a production of it.+-- In other case the production (with its references mapped to the+-- to the new Grammar) is returned. +rule :: [AnySym env] -> Prod a env+ -> GramTrafo env a s (T env s) (Productions a s)+rule _ (End a) = proc env2s ->+ do returnA -< PS [ mapProd env2s (End a) ]+ +rule rep (Seq x beta) + | x `iselem` rep = proc env2s ->+ do rinsert x -< (env2s, mapProd env2s beta)+ | otherwise = proc env2s ->+ do returnA -< PS [ mapProd env2s (Seq x beta) ]+++-- Insertion of a new production into one "rest" nonterminal.+-- If the symbol 'x' is in the MapA_X the nonterminal was already+-- added, so we obtain the reference of the nonterminal and add the new+-- production.+-- Otherwise, we have to create the new nonterminal (newNontR x).+rinsert :: forall env s a x. Symbol x env+ -> GramTrafo env a s (T env s, Prod (x->a) s) (Productions a s)+rinsert x = + Trafo (+ \(MapA_X m) -> case m x of+ Nothing -> case proc (env2s,p) ->+ do r <- newNontR x -< PS [p]+ addprod x -< (env2s,r) + of Trafo step -> step (MapA_X m)+ Just r -> TrafoE (MapA_X m)+ (\(_,p) t e f ->+ ( PS []+ , t+ , updateEnv (\(PS ps) + -> PS (p:ps))+ r e+ , f+ )+ )+ )+++addprod :: Symbol x env -> GramTrafo env a s (T env s, Ref (x -> a) s) + (Productions a s) +addprod (Term x) = proc (_, a__x) -> + do returnA -< PS [ Seq (Term x) $ Seq (Nont a__x) $ End ($)]+addprod (Nont r) = proc (env2s, a__x) -> + do returnA -< PS [ Seq (Nont (unT env2s r)) $ Seq (Nont a__x) + $ End ($)]+addprod (NontInt) = proc (_, a__x) -> + do returnA -< PS [ Seq NontInt $ Seq (Nont a__x) $ End ($)]+addprod (NontChar) = proc (_, a__x) -> + do returnA -< PS [ Seq NontChar $ Seq (Nont a__x) $ End ($)]+addprod (NontVarid) = proc (_, a__x) -> + do returnA -< PS [ Seq NontVarid $ Seq (Nont a__x) $ End ($)]+addprod (NontConid) = proc (_, a__x) -> + do returnA -< PS [ Seq NontConid $ Seq (Nont a__x) $ End ($)]+addprod (NontOp) = proc (_, a__x) -> + do returnA -< PS [ Seq NontOp $ Seq (Nont a__x) $ End ($)]++-- Get the list of symbols that are repeated as "first symbol" in the list+-- of productions.+getrepeated :: [Prod a env] -> [AnySym env]+getrepeated prods = repeated $ mapMaybe head' prods+ where head' (End _ ) = Nothing+ head' (Seq x _) = Just (AnySym x)+ repeated [] = []+ repeated (ax@(AnySym x):xs) + | x `iselem` xs = ax : repeated (filter (noteqAny ax) xs)+ | otherwise = repeated xs++ noteqAny (AnySym x) (AnySym y) = (aux $ matchSym x y)+ +aux :: Maybe (Equal a b) -> Bool+aux (Just Eq) = False+aux Nothing = True ++iselem :: Symbol t env -> [AnySym env] -> Bool+iselem _ [] = False+iselem x ((AnySym y):ys) = case (matchSym x y) of+ (Just Eq) -> True+ Nothing -> iselem x ys +