murder (empty) → 1.0
raw patch · 27 files changed
+3270/−0 lines, 27 filesdep +AspectAGdep +HListdep +ListLikesetup-changed
Dependencies added: AspectAG, HList, ListLike, TTTAS, base, containers, template-haskell, uu-parsinglib, uulib
Files
- COPYRIGHT +28/−0
- LICENSE-LGPL +507/−0
- README +38/−0
- Setup.hs +3/−0
- examples/LangDef.hs +98/−0
- examples/LangExt.hs +254/−0
- examples/LangSem.hs +107/−0
- examples/Main.hs +63/−0
- examples/Utils.hs +33/−0
- examples/prog.src +1/−0
- examples/prog2.src +1/−0
- examples/prog3.src +1/−0
- murder.cabal +37/−0
- src/Language/Grammars/Grammar.hs +324/−0
- src/Language/Grammars/Murder.hs +144/−0
- src/Language/Grammars/Murder/Machine.hs +330/−0
- src/Language/Grammars/Murder/ScanUtils.hs +179/−0
- src/Language/Grammars/Murder/Scanner.hs +17/−0
- src/Language/Grammars/Murder/Token.hs +95/−0
- src/Language/Grammars/Murder/TokenParser.hs +112/−0
- src/Language/Grammars/Murder/UULib.hs +90/−0
- src/Language/Grammars/Murder/UUParsing.hs +84/−0
- src/Language/Grammars/Murder/Utils.hs +191/−0
- src/Language/Grammars/Transformations/GramTrafo.hs +73/−0
- src/Language/Grammars/Transformations/LeftCorner.hs +222/−0
- src/Language/Grammars/Transformations/RemoveEmpties.hs +152/−0
- src/Language/Grammars/Transformations/RemoveFix.hs +86/−0
+ COPYRIGHT view
@@ -0,0 +1,28 @@+The murder package is (c) copyright 2012+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++----+The murder 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
+ examples/LangDef.hs view
@@ -0,0 +1,98 @@+{-# OPTIONS -fcontext-stack=100 #-}++{-# LANGUAGE Arrows, DoRec #-}++module LangDef where++import qualified Data.Set as Set++import Control.Arrow++import Language.Grammars.Murder+import Language.Grammars.Grammar++import Language.Grammars.Murder.Scanner++import LangSem+import Utils++import Control.Applicative++import Data.HList++import UU.Pretty.Basic++prds = proc () -> do++ rec root <- addNT -< (iI semAGItf exp Ii)+ exp <- addNT -< (iI semLet "let" var "=" exp "in" exp Ii) + <|> + (iI semAdd exp "+" term Ii)+ <|> + iI id term Ii + term <- addNT -< (iI semMul term "*" factor Ii)+ <|>+ iI id factor Ii+ factor <- addNT -< (iI semCst int Ii)+ <|> + (iI semVar var Ii)++ exportNTs -< exportList root $ export ntExp exp + . export ntTerm term + . export ntFactor factor ++{-+prds = proc () -> do++ rec root <- addNT -< (iI (`semAGItf` emptyRecord) (ch_expr <=> exp) Ii)+ exp <- addNT -< (iI semLet "let" (ch_lnm <=> var) "=" (ch_val <=> exp) "in" (ch_body <=> exp) Ii)+ <|>+ (iI semAdd (ch_ae1 <=> exp) "+" (ch_ae2 <=> term) Ii)+ <|>+ ntPrd term+ term <- addNT -< (iI semMul (ch_me1 <=> term) "*" (ch_me2 <=> factor) Ii)+ <|>+ ntPrd factor++ factor <- addNT -< (iI semCst (ch_cv <=> int) Ii)+ <|> + (iI semVar (ch_vnm <=> var) Ii)++ exportNTs -< exportList root $ export ntExp exp + . export ntTerm term + . export ntFactor factor +-} +{-+-- another possible version+prds = proc () -> do++ rec root <- addNT -< (`semAGItf` emptyRecord) <$> ch_expr <=> exp+ exp <- addNT -< semLet <$ tr "let" <*> ch_lnm <=> var <* tr "=" <*> ch_val <=> exp <* tr "in" <*> ch_body <=> exp+ <|>+ semAdd <$> ch_ae1 <=> exp <* tr "+" <*> ch_ae2 <=> term+ <|>+ ntPrd term+ term <- addNT -< semMul <$> ch_me1 <=> term <* tr "*" <*> ch_me2 <=> factor+ <|>+ ntPrd factor++ factor <- addNT -< semCst <$> ch_cv <=> int+ <|> + semVar <$> ch_vnm <=> var++ exportNTs -< exportList root $ export ntExp exp + . export ntTerm term + . export ntFactor factor ++-}++{-+gramOpts :: ScanOpts+gramOpts+ = defaultScanOpts+ { scoKeywordsTxt = Set.fromList ["let", "in"]+ , scoSpecChars = Set.fromList "=+*"+ , scoDollarIdent = True+ }+-} +
+ examples/LangExt.hs view
@@ -0,0 +1,254 @@+{-# OPTIONS -fcontext-stack=100 #-}+{-# LANGUAGE Arrows, DoRec, EmptyDataDecls, FlexibleContexts, TemplateHaskell, NoMonomorphismRestriction,+ RankNTypes #-}++module LangExt where+++import Control.Arrow++import UU.Pretty++import Language.Grammars.AspectAG+import Language.Grammars.AspectAG.Derive++import Language.Grammars.Murder+import Language.Grammars.Grammar hiding ((<=>))+++import LangSem+import Utils++import Control.Applicative++import Data.HList.Label4+import Data.HList.TypeEqGeneric1+import Data.HList.TypeCastGeneric1++++-- modifications of the semantics+synM = synmodM+inhM = inhmodM+++--Syntax Macro 1 -------------------------------------------------------------- ++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))+++++--Square+-- $(chLabel "se" ''T_Expr)+$(addProd "Sq" [ ("se",''T_Expr) ])++sppSq = synM spp $ do me1 <- at ch_se + return $ "square" >#< (me1 # spp) ++se2m r = (ch_me1 .=. (r # ch_se) .*. ch_me2 .=. (r # ch_se) .*. emptyRecord)+m2se r = (ch_se .=. (r # ch_me1) .*. emptyRecord)+++-- aspSq = sppSq `ext` (adapt aspMul se2m se2m m2se)+aspSq = sppSq `ext` (mapChildren aspMul (ch_me1 .=. ch_se .*. ch_me2 .=. ch_se .*. emptyRecord))++-- semSq = \s -> knit aspSq (s .*. emptyRecord) +semSq = semP_Sq aspSq++--Pyth+-- $(chLabels ["pe1","pe2"] ''T_Expr)+$(addProd "Pyth" [ ("pe1",''T_Expr), ("pe2",''T_Expr) ])++sppSq' = synM spp $ do liftM (# spp) (at ch_se) +aspSq' = sppSq' `ext` aspSq ++sppPyth = synM spp $ do pe1 <- at ch_pe1+ pe2 <- at ch_pe2 + return $ "pyth" >#< (pe1 # spp) >#< (pe2 # spp) +{-+aspAdd' = graft (graft aspAdd+ (ch_ae2 .=. ch_ae2 .*. emptyRecord)+ ch_ae1 + aspSq' + (ch_se .=. ch_pe1 .*. emptyRecord))+ (ch_pe1 .=. ch_pe1 .*. emptyRecord)+ ch_ae2+ aspSq' + (ch_se .=. ch_pe2 .*. emptyRecord)+-}++aspAdd' = agMacro (aspAdd, ch_ae1 ==> (aspSq', ch_se --> ch_pe1)+ <.> + ch_ae2 ==> (aspSq', ch_se --> ch_pe2))+++aspPyth = sppPyth `ext` aspAdd'+-- semPyth = \p1 p2 -> knit aspPyth (p1 .*. p2 .*. emptyRecord) +semPyth = semP_Pyth aspPyth+++--AddSq+$(addProd "AddSq" [ ("as1",''T_Expr), ("as2",''T_Expr) ])+++sppAddSq = synM spp $ do as1 <- at ch_as1+ as2 <- at ch_as2 + return $ "addsq" >#< (as1 # spp) >#< (as2 # spp) ++++{-+aspAddSq = sppAddSq `ext`+ (graft (graft aspMul+ (ch_me2 .=. ch_me2 .*. emptyRecord)+ ch_me1 + aspAdd + (ch_ae1 .=. ch_as1 .*. ch_ae2 .=. ch_as2 .*. emptyRecord))+ (ch_as1 .=. ch_as1 .*. ch_as2 .=. ch_as2 .*. emptyRecord)+ ch_me2+ aspAdd + (ch_ae1 .=. ch_as1 .*. ch_ae2 .=. ch_as2 .*. emptyRecord))+-}++aspAddSq = sppAddSq `ext`+ agMacro (aspMul , ch_me1 ==> (aspAdd, ch_ae1 --> ch_as1 <.> ch_ae2 --> ch_as2)+ <.> ch_me2 ==> (aspAdd, ch_ae1 --> ch_as1 <.> ch_ae2 --> ch_as2))+++semAddSq = semP_AddSq aspAddSq+++--Parenthesis+-- $(chLabel "pe" ''T_Expr)+$(addProd "Par" [ ("pe",''T_Expr) ])++sppPar = syn spp $ do pe <- at ch_pe+ return $ "(" >|< pe # spp >|< ")" +svalPar = syn sval $ do liftM (# sval) (at ch_pe)+ienvPar = copy ienv exprNT++aspPar = sppPar `ext` ienvPar `ext` svalPar+-- semPar = \e -> knit aspPar (e .*. emptyRecord)+semPar = semP_Par aspPar+++--Substitution+sppSubst = synM spp $ do lnm <- valAt ch_lnm+ val <- at ch_val+ body <- at ch_body+ return $ (body # spp) >|< "[" >|< (pp lnm) >|< " | " >|< (val # spp) >|< "]" ++semSubst = \b l v -> semP_Let (sppSubst `ext` aspLet) l v b+++++--Grammar Extension+prds' :: ( NTRecord (nts env) + , GetNT NTExp (nts env) (Symbol AttExpr TNonT env)+ , GetNT NTTerm (nts env) (Symbol AttExpr TNonT env)+ , GetNT NTFactor (nts env) (Symbol AttExpr TNonT env)) + => GramExt env start nts start nts+prds' = proc imported -> do+ let exp = getNT ntExp imported+ let term = getNT ntTerm imported+ let factor = getNT ntFactor imported++ addProds -< (exp, ( iI semSubst exp "[" var "|" exp "]" Ii))++ addProds -< (term, ( iI semSq "square" factor Ii) <|>+ ( iI semPyth "pyth" factor factor Ii) <|>+ ( iI semAddSq "addsq" factor factor Ii))+ + addProds -< (factor, ( iI semPar "(" exp ")" Ii ) )+ + exportNTs -< imported++++--gramOpts' gramOpts = gramOpts `extKeywordsTxt` [ "square", "pyth" ] `extSpecChars` "()[|]"++++--Syntax Macro 2 --------------------------------------------------------------++--Double+-- $(chLabel "de" ''T_Expr)+$(addProd "Db" [ ("de",''T_Expr) ])++--aspTwo = fixCst aspCst ch_cv 2+{-+aspMul' = graft aspMul+ (ch_me2 .=. ch_de .*. emptyRecord) + ch_me1+ aspTwo+ emptyRecord +-}++aspMul' = agMacro (aspMul , ch_me1 ==> (aspCst, ch_cv ~~> (DTerm undefined 2))+ <.> ch_me2 --> ch_de)+ ++sppDb = synM spp $ do de <- at ch_de + return $ "double" >#< (de # spp) ++aspDb = sppDb `ext` aspMul'+ +--semDb = \d -> knit aspDb (d .*. emptyRecord)+semDb = semP_Db aspDb+ +++--AddMul+-- $(chLabels ["am1","am2","am3"] ''T_Expr)+$(addProd "AddMul" [ ("am1",''T_Expr), ("am2",''T_Expr), ("am3",''T_Expr) ])+++sppAddMul = synM spp $ do am1 <- at ch_am1 + am2 <- at ch_am2 + am3 <- at ch_am3 + return $ "addmul" >#< (am1 # spp) >#< (am2 # spp) >#< (am3 # spp) +{-+aspAddMul = ext sppAddMul $ graft aspAdd+ (ch_ae1 .=. ch_am1 .*. emptyRecord)+ ch_ae2 + aspMul+ (ch_me1 .=. ch_am2 .*. ch_me2 .=. ch_am3 .*. emptyRecord)+-}+aspAddMul = sppAddMul `ext`+ agMacro (aspAdd , ch_ae1 --> ch_am1+ <.> ch_ae2 ==> (aspMul, ch_me1 --> ch_am2 <.> ch_me2 --> ch_am3))++ +-- semAddMul = \p1 p2 p3 -> knit aspAddMul (p1 .*. p2 .*. p3 .*. emptyRecord)+semAddMul = semP_AddMul aspAddMul +++--Grammar Extension++prds'' :: ( NTRecord (nts env) + , GetNT NTTerm (nts env) (Symbol AttExpr TNonT env)+ , GetNT NTFactor (nts env) (Symbol AttExpr TNonT env)) + => GramExt env start nts start nts+prds'' = proc imported -> do+ let term = getNT ntTerm imported+ let factor = getNT ntFactor imported+++ addProds -< (term, (iI semDb "double" factor Ii) <|>+ (iI semAddMul "addmul" factor factor factor Ii))++ + exportNTs -< imported++++--gramOpts'' gramOpts = gramOpts `extKeywordsTxt` [ "double", "addmul" ] `extSpecChars` "()[|]"+++++
+ examples/LangSem.hs view
@@ -0,0 +1,107 @@+{-# OPTIONS -fcontext-stack=100 #-}+{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction #-}++module LangSem 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 ++import Language.Grammars.Grammar (DTerm(..))++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 = syndefM+inh = inhdefM+valAt = liftM value . at+posAt = liftM pos . at+++$(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 (valAt ch_cv)+sppVar = syn spp $ liftM pp (valAt 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 <- valAt 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 <- valAt 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 (valAt ch_cv)+svalVar = syn sval $ do vnm <- valAt 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 = semP_AGItf aspAGItf +semCst = semP_Cst aspCst +semVar = semP_Var aspVar +semMul = semP_Mul aspMul+semAdd = semP_Add aspAdd+semLet = semP_Let aspLet ++
+ examples/Main.hs view
@@ -0,0 +1,63 @@+import qualified Data.Set as Set++import Control.Arrow++import UU.Pretty++import LangDef+import LangSem++import LangExt++import Language.Grammars.Murder+import Language.Grammars.Murder.UUParsing++import Language.Grammars.AspectAG+++gram = closeGram prds+test1 = lang1 "prog.src"+lang1 s = do+-- tokens <- scanFile gramOpts "prog.src"+ tokens <- readFile s++ let r = (parse . compile ) gram tokens++ case ( parse . compile ) gram tokens of+ (Ok fres) -> do + let res = fres emptyRecord+ print $ res # spp+ print $ res # sval+ (Rep _ err) -> print err+++++gram' = closeGram (prds +>> prds') +test2 = lang2 "prog2.src"+lang2 s = do+-- tokens <- scanFile (gramOpts' gramOpts) "prog2.src"+ tokens <- readFile s+ case ( parse . compile ) gram' tokens of+ (Ok fres) -> do + let res = fres emptyRecord+ print $ res # spp+ print $ res # sval+ (Rep _ err) -> print err++gram'' = closeGram (prds +>> prds' +>> prds'') +test3 = lang3 "prog3.src"+lang3 s = do+-- tokens <- scanFile ((gramOpts'' . gramOpts') gramOpts) "prog3.src"+ tokens <- readFile s+ case ( parse . compile ) gram'' tokens of+ (Ok fres) -> do + let res = fres emptyRecord+ print $ res # spp+ print $ res # sval+ (Rep _ err) -> print err+++main = test1 >> test2 >> test3++
+ examples/Utils.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE EmptyDataDecls #-}++module Utils where++import qualified Data.Set as Set++import UU.Pretty++import Language.Grammars.Murder+import Language.Grammars.Grammar++import Language.Grammars.Murder.Scanner++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++trm = Term+
+ examples/prog.src view
@@ -0,0 +1,1 @@+let letter = 2 + 10 in letter * 104
+ examples/prog2.src view
@@ -0,0 +1,1 @@+let letter = pyth ( 2 + 1) 3 in ( (x + 1) [x | 10]) * (letter + square 2)
+ examples/prog3.src view
@@ -0,0 +1,1 @@+let letter = pyth ( 2 + 1) 3 in ( (x + 1) [x | 10]) * (letter + addmul 2 3 4 + square ( double 3 ))
+ murder.cabal view
@@ -0,0 +1,37 @@+name: murder +version: 1.0+cabal-version: >= 1.2.3 +license: LGPL+license-file: COPYRIGHT+maintainer: Marcos Viera <mviera@fing.edu.uy>+homepage: http://www.cs.uu.nl/wiki/Center/MurderForFree +synopsis: MUtually Recursive Definitions Explicitly Represented +description: The murder library is an EDSL for grammar fragments as first-class values. It provides combinators to define and extend grammars, and produce compilers out of them.+build-type: Simple+category: Development +stability: Experimental+copyright: Universiteit Utrecht+extra-source-files: README, LICENSE-LGPL +library+ build-depends: base>=4 && <5, template-haskell>=2.4.0.1, TTTAS>=0.4.1, AspectAG>=0.3.4.1,+ uulib>=0.9.12, uu-parsinglib >= 2.7.1, ListLike >= 3.1.0, containers>=0.3, HList>=0.2+ exposed-modules: Language.Grammars.Grammar, + Language.Grammars.Murder, + Language.Grammars.Murder.Scanner,+ Language.Grammars.Murder.UUParsing,+ Language.Grammars.Murder.UULib+ other-modules: Language.Grammars.Murder.Machine, + Language.Grammars.Murder.Token, + Language.Grammars.Murder.TokenParser, + Language.Grammars.Murder.ScanUtils, + Language.Grammars.Murder.Utils, + Language.Grammars.Transformations.GramTrafo,+ Language.Grammars.Transformations.RemoveEmpties,+ Language.Grammars.Transformations.RemoveFix,+ Language.Grammars.Transformations.LeftCorner+ extensions: EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies,+ MultiParamTypeClasses, RankNTypes, ScopedTypeVariables,+ TypeSynonymInstances, UndecidableInstances, GADTs+ hs-source-dirs: src+ ghc-options: -Wall+
+ src/Language/Grammars/Grammar.hs view
@@ -0,0 +1,324 @@+{-# LANGUAGE ExistentialQuantification, GADTs, EmptyDataDecls,+ MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}++module Language.Grammars.Grammar where++import Language.AbstractSyntax.TTTAS+import Data.HList++import Control.Applicative+++-------------------------------------------+-- GRAMMAR REPRESENTATION+-------------------------------------------++data TL+data FL a+data NF+++data Grammar a + = forall env . Grammar (Ref a env) + (FinalEnv (Productions NF) env)+++newtype Productions l a env + = PS {unPS :: [Prod l a env]}++data Prod l a env where+ Star :: Prod l (a->b) env -> Prod l a env + -> Prod l b env+ FlipStar :: Prod NF a env -> Prod NF (a->b) env + -> Prod NF b env+ Sym :: Symbol a t env + -> Prod l a env+ Pure :: a + -> Prod l a env++ Fix :: Productions (FL a) a env + -> Prod TL a env+ Var :: Prod (FL a) a env ++-- I tried with HOAS, but it is more restrictive+-- Fix :: (forall s. Prod a s -> Productions a s) -> Prod a env +++type GramEnv = Env (Productions NF)+type PreGramEnv = Env (Productions TL)+++newtype PreProductions l env a + = PP {unPP :: [Prod l a env]}+++type Line = Int+type Column = Int+type Filename = String++data Pos = Pos !Line !Column + | PosFile !Line !Column Filename+ deriving Show++data DTerm a = DTerm {pos :: Pos, value :: a}++data TTerm+data TNonT+data TAttT++data Symbol a t env where+ Term :: String -> Symbol (DTerm String) TTerm env++ Nont :: Ref a env -> Symbol a TNonT env+ -- attributed terminals+ TermInt :: Symbol (DTerm Int) TAttT env+ TermChar :: Symbol (DTerm Char) TAttT env+ TermVarid :: Symbol (DTerm String) TAttT env+ TermConid :: Symbol (DTerm String) TAttT env+ TermOp :: Symbol (DTerm String) TAttT env + --- TODO: the rest of EnumValToken+++getRefNT :: Symbol a TNonT env -> Ref a env+getRefNT (Nont ref) = ref+++pairEq :: Maybe (Equal a b) -> Maybe (Equal (a,t) (b,t))+pairEq (Just Eq) = Just Eq+pairEq Nothing = Nothing++matchSym :: Symbol a t1 env -> Symbol b t2 env + -> Maybe (Equal (a,t1) (b,t2))+matchSym (Nont x) (Nont y) = pairEq $ match x y+matchSym (Term x) (Term y) | x == y = Just Eq+matchSym TermInt TermInt = Just Eq+matchSym TermVarid TermVarid = Just Eq+matchSym TermConid TermConid = Just Eq+matchSym TermOp TermOp = Just Eq+matchSym _ _ = Nothing+++int :: Symbol (DTerm Int) TAttT env+char :: Symbol (DTerm Char) TAttT env+var :: Symbol (DTerm String) TAttT env+con :: Symbol (DTerm String) TAttT env+op :: Symbol (DTerm String) TAttT env++int = TermInt+char = TermChar+var = TermVarid+con = TermConid+op = TermOp+++------------------------+-- APPLICATIVE INTERFACE+++sym :: Symbol a t env -> PreProductions l env a+sym s = PP [ Sym $ s ]++nt :: Symbol a TNonT env -> PreProductions l env a+nt s = sym s++ntPrd :: Symbol a TNonT env -> PreProductions l env a+ntPrd s = id <$> nt s+ ++tr :: String -> PreProductions l env (DTerm String)+tr s = PP [ Sym $ Term s ]+++prod :: PreProductions l env a -> Productions l a env+prod (PP ps) = PS ps++varPrd :: PreProductions (FL a) env a+varPrd = PP [ Var ]+fixPrd :: PreProductions (FL a) env a -> PreProductions TL env a+fixPrd p = PP [ (Fix . prod) p ]+++instance Functor (PreProductions l env) where+ fmap f (PP p) = PP [ Star (Pure f) p' | p' <- p ]++instance Applicative (PreProductions l env) where+ pure f = PP [ Pure f ]+ + (PP f) <*> (PP g) = PP [ Star f' g' | f' <- f, g' <- g ]++instance Alternative (PreProductions l env) where+ empty = PP []+ + (PP f) <|> (PP g) = PP (f ++ g)+{-+ some p = fixPrd (one <|> more)+ where one = (:[]) <$> toFL p + more = (:) <$> toFL p <*> varPrd+++ many p = fixPrd (none <|> more) + where none = pure [] + more = (:) <$> toFL p <*> varPrd++toFL :: PreProductions l env a -> PreProductions (FL b) env a+toFL (PP p) = PP $ map prodToFL p++prodToFL :: Prod l a env -> Prod (FL b) a env+prodToFL (Star f g) = Star (prodToFL f) (prodToFL g)+prodToFL (FlipStar f g) = FlipStar (prodToFL f) (prodToFL g)+prodToFL (Sym s) = Sym s+prodToFL (Pure a) = Pure a+prodToFL (Fix f) = Fix f+prodToFL Var = error "ERROR: Language.Grammars.Grammar:1"+-}++pSome :: PreProductions (FL [a]) env a -> PreProductions TL env [a]+pSome p = fixPrd (one <|> more)+ where one = (:[]) <$> p + more = (:) <$> p <*> varPrd++pMany :: PreProductions (FL [a]) env a -> PreProductions TL env [a]+pMany p = fixPrd (none <|> more)+ where none = pure [] + more = (:) <$> p <*> varPrd+{-+pMaybe :: PreProductions l env a -> PreProductions l env (Maybe a)+pMaybe p = (nothing <|> just)+ where nothing = pure Nothing + just = Just <$> p +++pEither :: PreProductions l env a -> PreProductions l env b -> PreProductions l env (Either a b)+pEither p q = (left <|> right)+ where left = Left <$> p+ right = Right <$> q +-}++opt :: PreProductions l env a -> a -> PreProductions l env a+opt p a = p <|> pure a++pMaybe :: (b, (a -> b)) -> PreProductions TL env a -> PreProductions TL env b+pMaybe (n, j) p = (nothing <|> just)+ where nothing = pure n + just = j <$> p +++pFoldr :: (a -> b -> b, b) -> PreProductions (FL b) env a -> PreProductions TL env b+pFoldr (c, e) p = fixPrd (none <|> more)+ where none = pure e + more = c <$> p <*> varPrd++------------------------+-- IDIOMS++-- | The 'Ii' is to be pronounced as @stop@+data Ii = Ii ++-- | The function 'iI' is to be pronounced as @start@+iI ::Idiomatic l env (a -> a) g => g+iI = idiomatic (pure id)++class Idiomatic l env f g | g -> f l env where+ idiomatic :: PreProductions l env f -> g++instance Idiomatic l env x (Ii -> PreProductions l env x) where+ idiomatic ix Ii = ix+++instance Idiomatic l env f g => Idiomatic l env (a -> f) (PreProductions l env a -> g) where+ idiomatic isf is = idiomatic (isf <*> is)++instance Idiomatic l env f g => Idiomatic l env (a -> f) (Symbol a TNonT env -> g) where+ idiomatic isf is = idiomatic (isf <*> (sym is))++instance Idiomatic l env f g => Idiomatic l env ((Record HNil -> a) -> f) (Symbol a TAttT env -> g) where+ idiomatic isf is = idiomatic (isf <*> ((\x (Record HNil) -> x) <$> (sym is :: PreProductions l env a)))+++instance Idiomatic l env f g => Idiomatic l env ((a -> b) -> f) ((a -> b) -> g) where+ idiomatic isf f = idiomatic (isf <*> (pure f :: PreProductions l env (a->b)))++instance (Idiomatic l env f g) + => Idiomatic l env f (String -> g) where+ idiomatic isf str = idiomatic (isf <* (tr str))++{-+data Pos = Pos String++pt :: String -> Pos+pt = Pos++instance Idiomatic l env f g => Idiomatic l env ((Record HNil -> DTerm String) -> f) (Pos -> g) where+ idiomatic isf (Pos is) = idiomatic (isf <*> ((\x (Record HNil) -> x) <$> (tr is)))+-}++-------------------------------------------------------------------------------+++newtype LSPair nt a t env = LSPair { symLSPair :: (Symbol a t env) } ++labelLSPair :: LSPair nt a t env -> nt+labelLSPair _ = undefined++infixr 6 ^= +(^=) :: nt -> Symbol a t env -> LSPair nt a t env+(^=) _ = LSPair++infixr 6 <=>++class LabelSymbol t v v' | t v -> v' where + (<=>) :: label -> Symbol v t env -> PreProductions l env (LVPair label v')+++instance LabelSymbol TAttT v (Record HNil -> v) where+ l <=> v = (\x -> l .=. (\(Record HNil) -> x)) <$> (sym v)++instance LabelSymbol TNonT v v where+ l <=> v = (l .=.) <$> (sym v)++instance LabelSymbol TTerm v v where -- only to have all the instances+ l <=> v = (l .=.) <$> (sym v)+++{-+-------------------------------------------------------------------------------+-- Show instances for the Grammars+-- Just for debugging purposes++instance Show (Grammar a) where+ show (Grammar r prods) = show r ++ "\n" ++ show prods++instance ShowEnv (Env (Productions l) env env') => Show (Env (Productions l) env env') where+ show env = showEnv 0 env++class ShowEnv a where+ showEnv :: Int -> a -> String++instance ShowEnv (Env (Productions l) env env') where+ showEnv _ (Empty) = "\n"+ showEnv n (Ext nts nont) = show n ++ "->" ++ show nont ++ "\n" ++ showEnv (n+1) nts+ +instance Show (Productions l a env) where+ show (PS prods) = show prods++instance Show (Prod l a env) where+ show (Star pf pa) = "(" ++ show pf ++ "<*>" ++ show pa ++ ")"+ show (FlipStar pa pf) = "(" ++ show pa ++ "<**>" ++ show pf ++ ")"+ show (Sym s) = show s + show (Pure _) = "pure"+ show (Fix f) = "fix " ++ show f+ show Var = "var"++instance Show (Symbol a t env) where+ show (Term s) = show s+ show (Nont r) = show r+ show (TermInt) = "int"+ show (TermChar) = "char"+ show (TermVarid) = "var"+ show (TermConid) = "con"+ show (TermOp) = "op"++instance Show (Ref a env) where+ show Zero = "0"+ show (Suc r) = show $ (1::Int) + ((read . show) r)+-}
+ src/Language/Grammars/Murder.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE Arrows, ExistentialQuantification, GADTs, Rank2Types, FlexibleContexts, ScopedTypeVariables+ , EmptyDataDecls, MultiParamTypeClasses, FlexibleInstances, OverlappingInstances, FunctionalDependencies, UndecidableInstances+ , NoMonomorphismRestriction+ #-}++module Language.Grammars.Murder where++import Language.AbstractSyntax.TTTAS+import Control.Arrow++import Language.Grammars.Grammar +import Language.Grammars.Transformations.RemoveFix+import Language.Grammars.Transformations.RemoveEmpties+import Language.Grammars.Transformations.LeftCorner+++type GramTrafo = Trafo Unit (Productions NF)+type PreGramTrafo = Trafo Unit (Productions TL)++type ExtGram env start nts + = PreGramTrafo env () (Export start nts env)+type GramExt env start nts start' nts' + = PreGramTrafo env (Export start nts env) (Export start' nts' env)++data Export start nts env = Export (Symbol start TNonT env) (nts env)++-- add a new non-terminal to the grammar+addNT :: PreGramTrafo env (PreProductions TL env a) (Symbol a TNonT env)+addNT = proc p -> do + r <- newSRef -< prod p+ returnA -< Nont r+++-- add productions to an existing non-terminal+addProds :: PreGramTrafo env + (Symbol a TNonT env, PreProductions TL env a) ()+addProds = proc (nont, prds) -> do+ updateFinalEnv -< + updateEnv (\ps -> PS $ (unPP prds) ++ (unPS ps)) (getRefNT nont)++ +-- close the grammar+closeGram :: (forall env. ExtGram env a nts) + -> Grammar a +closeGram prds = case runTrafo prds Unit () of+ Result _ (Export (Nont r) _) gram + -> (leftCorner . removeEmpties) (removeFix r gram)++-- extend a grammar+extendGram :: (NTRecord (nts env), NTRecord (nts' env)) + => ExtGram env start nts + -> GramExt env start nts start' nts' + -> ExtGram env start' nts'+extendGram g sm = g >>> sm+++(+>>) :: (NTRecord (nts env), NTRecord (nts' env)) + => ExtGram env start nts + -> GramExt env start nts start' nts' + -> ExtGram env start' nts'++(+>>) = extendGram+++-- export+exportNTs :: NTRecord (nts env) => PreGramTrafo env (Export start nts env) (Export start nts env)+exportNTs = returnA++-- compose grammars+{-+compG :: (NTUnion nts1 nts2 nts)+ => ExtGram env start nts1+ -> ExtGram env start nts2+ -> ExtGram env start nts++compG g1 g2 = proc () -> do+ (Export s1 ns1) <- g1 -< ()+ (Export s2 ns2) <- g2 -< ()+ + s <- addNT -< iI s1 Ii <|> iI s2 Ii++ returnA -< Export s (ntUnion ns1 ns2)+-}++-- extensible record+++data NTCons nt v l env = NTCons (LSPair nt v TNonT 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 env+ntNil = NTNil++++infixr 4 ^| +(^|) :: NTRecord (NTCons nt a l env) => LSPair nt a TNonT 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 TNonT env) where -- using overlapping+ getNT _ (NTCons f _) = symLSPair f+instance GetNT nt1 (l env) r => GetNT nt1 (NTCons nt2 v l env) r where+ getNT nont (NTCons _ l) = getNT nont l++instance GetNT nt (nts env) r => GetNT nt (Export start nts env) r where+ getNT nont (Export _ nts) = getNT nont nts++getStart :: Export start nts env -> (Symbol start TNonT env)+getStart (Export start _) = start++exportList :: Symbol start TNonT env -> (NTNil env -> nts env) -> Export start nts env+exportList r l = Export r $ l ntNil++export :: (NTRecord (l env), NotDuplicated nt (l env))+ => nt -> Symbol a TNonT env + -> l env -> NTCons nt a l env+export l nont = (^|) (l ^= nont) +++extendExport :: Export start t env -> (t env -> nts env) -> Export start nts env+extendExport (Export r nts) ext = Export r (ext nts)+
+ src/Language/Grammars/Murder/Machine.hs view
@@ -0,0 +1,330 @@+module Language.Grammars.Murder.Machine (scanHandle,scanFile,scan,getRational,getBaseNumber) where++import Data.Char+import Data.List+import Data.Maybe+import System.IO+import UU.Scanner.Position+import qualified Data.Set as Set++import Language.Grammars.Murder.Utils+import Language.Grammars.Murder.ScanUtils+import Language.Grammars.Murder.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/Murder/ScanUtils.hs view
@@ -0,0 +1,179 @@+module Language.Grammars.Murder.ScanUtils + ( ScanOpts(..), defaultScanOpts+ + , isNoPos, posIs1stColumn+ + , InFilePos(..), infpStart, infpNone+ , infpAdvCol, infpAdvLine, infpAdv1Line, infpAdvStr+ + , genTokVal, genTokTp, genTokMap+ + , isLF, isStr, isStrQuote+ , isWhite, isBlack+ , isVarStart, isVarRest+ )+ where++import System.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/Murder/Scanner.hs view
@@ -0,0 +1,17 @@+module Language.Grammars.Murder.Scanner + (module Language.Grammars.Murder.Machine, + module Language.Grammars.Murder.Token, + module Language.Grammars.Murder.TokenParser, + module Language.Grammars.Murder.ScanUtils, + module UU.Scanner.Position) where++import Language.Grammars.Murder.Machine+import Language.Grammars.Murder.Token+import Language.Grammars.Murder.TokenParser+import Language.Grammars.Murder.ScanUtils+import UU.Scanner.Position+import UU.Scanner.GenTokenOrd()+import UU.Scanner.GenTokenSymbol()+++
+ src/Language/Grammars/Murder/Token.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE TypeSynonymInstances #-}+module Language.Grammars.Murder.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/Murder/TokenParser.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE FlexibleContexts #-}++module Language.Grammars.Murder.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.Murder.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/Murder/UULib.hs view
@@ -0,0 +1,90 @@+module Language.Grammars.Murder.UULib where++import qualified UU.Parsing as UU+import Language.Grammars.Murder.Scanner hiding (Pos)+import qualified Language.Grammars.Murder.Scanner as S++import Language.Grammars.Grammar+import Language.AbstractSyntax.TTTAS++toPos :: S.Pos -> Pos+toPos (S.Pos l c f) = PosFile l c f++toDTerm :: (a -> b) -> (a, S.Pos) -> DTerm b+toDTerm f p = DTerm ((toPos . snd) p) ((f . fst) p)++pChr :: UU.Parser Token (DTerm Char)+pChr = (toDTerm head) UU.<$> pCharPos+pInt :: UU.Parser Token (DTerm Int)+pInt = (toDTerm read) UU.<$> pIntegerPos+pCon :: UU.Parser Token (DTerm String)+pCon = (toDTerm id) UU.<$> pConidPos+pVar :: UU.Parser Token (DTerm String)+pVar = (toDTerm id) UU.<$> pVaridPos+pOp :: UU.Parser Token (DTerm String)+pOp = (toDTerm id) UU.<$> pVarsymPos++pTerm :: (UU.IsParser p Token) + => String -> p (DTerm String)+pTerm t = (toDTerm id . (\loc -> (t,loc))) UU.<$> pKeyPos t++newtype Const f a s = C {unC :: f a}+++compile :: Grammar a -> UU.Parser Token a+compile (Grammar (start :: Ref a env) rules) + = unC (lookupEnv start result)+ where result = + mapEnv + (\ (PS ps) -> C (foldr1 (UU.<|>) [ comp p | p <- ps]))+ rules++ comp :: forall t . Prod NF t env -> UU.Parser Token t++ comp (Star x y) = comp x UU.<*> comp y+ comp (FlipStar x y) = comp x UU.<**> comp y+ comp (Pure x) = UU.pLow x++ comp (Sym (Term t)) = pTerm t+ comp (Sym (Nont n)) = unC (lookupEnv n result)++ comp (Sym TermInt) = pInt+ comp (Sym TermChar) = pChr+ comp (Sym TermVarid) = pVar+ comp (Sym TermConid) = pCon+ comp (Sym TermOp) = pOp+++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 = UU.Message Token (Maybe Token)++data ParseResult a = Ok a+ | Rep a [ParseMsg] + deriving Show++parse :: UU.Parser Token a -> [Token] -> ParseResult a+parse p input = case rparse p input of+ (a,[] ) -> Ok a+ (a,msgs) -> Rep a msgs+++rparse :: UU.Parser Token a -> [Token] -> (a, [ParseMsg])+rparse p input = let (UU.Pair a _,msgs) = eval (UU.parse p input)+ in (a,msgs)+ where eval :: UU.Steps a Token (Maybe Token) -> (a, [ParseMsg])+ eval (UU.OkVal v r) = let (a,msgs) = v `seq` eval r + in (v a,msgs)+ eval (UU.Ok r) = eval r+ eval (UU.Cost _ r) = eval r+ eval (UU.StRepair _ msg r) = let (v,msgs) = eval r + in (v,msg:msgs)+ eval (UU.Best _ r _) = eval r+ eval (UU.NoMoreSteps v ) = (v,[]) +
+ src/Language/Grammars/Murder/UUParsing.hs view
@@ -0,0 +1,84 @@+module Language.Grammars.Murder.UUParsing where+++import qualified Text.ParserCombinators.UU.Core as UU+import Text.ParserCombinators.UU+import Text.ParserCombinators.UU.Utils+import Text.ParserCombinators.UU.BasicInstances hiding (Parser,input,msgs)++import Language.Grammars.Grammar+import Language.AbstractSyntax.TTTAS+++type Parser a = P (Str Char String LineCol) a++pInt :: Parser Int+pInt = pInteger+pChr :: Parser Char+pChr = pAscii++pVar :: Parser String+pVar = ((:) <$> pLower <*> pList pIdChar `micro` 2) <* spaces ++pCon :: Parser String+pCon = ((:) <$> pUpper <*> pList pIdChar `micro` 2) <* spaces++pIdChar :: Parser Char+pIdChar = pLower <|> pUpper <|> pDigit <|> pAnySym "='"++pOp :: Parser String+pOp = (pList1 $ pAnySym ('|':"!#$%&*+./<=>?@\\^-~:") `micro` 2) <* spaces++pTerm :: String -> Parser String+pTerm keyw = pToken keyw `micro` 1 <* spaces+spaces :: Parser String+spaces = pMunch (`elem` " \n")++lc2Pos :: LineCol -> Pos+lc2Pos (LineCol l c) = Pos l c++newtype Const f a s = C {unC :: f a}++-- | The function 'compile' generates a parser out of a closed grammar +compile :: Grammar a -> Parser 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 NF t env -> Parser t++ comp (Star x y) = comp x <*> comp y+ comp (FlipStar x y) = comp x <**> comp y+ comp (Pure x) = pure x++ comp (Sym (Term t)) = (DTerm . lc2Pos) <$> pPos <*> pTerm t+ comp (Sym (Nont n)) = unC (lookupEnv n result)++ comp (Sym TermInt) = (DTerm . lc2Pos) <$> pPos <*> pInt+ comp (Sym TermChar) = (DTerm . lc2Pos) <$> pPos <*> pChr+ comp (Sym TermVarid) = (DTerm . lc2Pos) <$> pPos <*> pVar+ comp (Sym TermConid) = (DTerm . lc2Pos) <$> pPos <*> pCon+ comp (Sym TermOp) = (DTerm . lc2Pos) <$> pPos <*> pOp+++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)++++data ParseResult a = Ok a+ | Rep a [Error LineCol] + deriving Show++-- | The function 'parse' runs the parser for an input.+parse :: Parser a -> String -> ParseResult a+parse p input = case UU.parse ( (,) <$> p <*> pEnd) (createStr (LineCol 0 0) input) of+ (a,[] ) -> Ok a+ (a,msgs) -> Rep a msgs++
+ src/Language/Grammars/Murder/Utils.hs view
@@ -0,0 +1,191 @@+module Language.Grammars.Murder.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,73 @@+{-# LANGUAGE RankNTypes, GADTs #-}+module Language.Grammars.Transformations.GramTrafo where++import Language.AbstractSyntax.TTTAS+import Language.Grammars.Grammar++data MapA_X env a env'+ = MapA_X (forall x t. Symbol (x->a) t env -> Maybe (Ref x env')) -- Star+ (forall x t. Symbol x t env -> Maybe (Ref (x->a) env')) -- Flip+++emptyMap :: MapA_X env a env'+emptyMap = MapA_X (const Nothing) (const Nothing)++extendMapS :: Symbol (x->a) t env -> MapA_X env a env'+ -> MapA_X env a (env',x)+extendMapS x (MapA_X ms mf) + = MapA_X (\s -> case matchSym s x of+ Just Eq -> Just Zero+ Nothing -> fmap Suc (ms s))+ (\s -> fmap Suc (mf s))++extendMapF :: Symbol x t env -> MapA_X env a env'+ -> MapA_X env a (env',x->a)+extendMapF x (MapA_X ms mf) + = MapA_X (\s -> fmap Suc (ms s))+ (\s -> case matchSym s x of+ Just Eq -> Just Zero+ Nothing -> fmap Suc (mf s))+ +++type GramTrafo env a = Trafo (MapA_X env a) (Productions NF)+++initMap :: GramTrafo env a s c d+ -> Trafo Unit (Productions NF) s c d+initMap (Trafo st) + = Trafo (\_ -> case st emptyMap of+ TrafoE _ f -> TrafoE Unit f+ )++newNontRS :: forall x t env s a + . Symbol (x->a) t env + -> GramTrafo env a s (Productions NF x s) (Ref x s)+newNontRS x = Trafo $ \m -> extEnv (extendMapS x m)++newNontRF :: forall x t env s a + . Symbol x t env + -> GramTrafo env a s (Productions NF (x->a) s) (Ref (x->a) s)+newNontRF x = Trafo $ \m -> extEnv (extendMapF x m)+++newtype Mapping old new + = Mapping (Env Ref new old) ++map2trans :: Mapping env s -> T env s+map2trans (Mapping env) + = T (flip lookupEnv env)+++mapProd :: T env1 env2 -> Prod NF a env1 -> Prod NF a env2+mapProd t (Sym (Nont x)) = Sym (Nont (unT t x)) +mapProd _ (Sym (Term x)) = Sym (Term x) +mapProd _ (Sym TermInt) = Sym TermInt +mapProd _ (Sym TermChar) = Sym TermChar +mapProd _ (Sym TermVarid) = Sym TermVarid +mapProd _ (Sym TermConid) = Sym TermConid +mapProd _ (Sym TermOp) = Sym TermOp +mapProd _ (Pure x) = Pure x+mapProd t (Star r l) = Star (mapProd t r) (mapProd t l)+mapProd t (FlipStar r l) = FlipStar (mapProd t r) (mapProd t l)+
+ src/Language/Grammars/Transformations/LeftCorner.hs view
@@ -0,0 +1,222 @@+{-# 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 :: GramEnv env env + -> Trafo Unit (Productions NF) 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 :: GramEnv env env+ -> GramEnv env env' + -> Trafo Unit (Productions NF) 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. GramEnv env env+ -> [Prod NF a env]+ -> Trafo Unit (Productions NF) s (T env s) (Productions NF a s)+app_rule1 productions prods = initMap + ( proc tenv_s -> + do pss <- sequenceA (map (rule1 productions . accessLeftMost) prods) -< tenv_s + returnA -< PS (concatMap unPS pss)+ )++rule1 :: GramEnv env env -> Prod NF a env + -> GramTrafo env a s (T env s) (Productions NF a s)++rule1 gram (Star (Sym x) beta) + = proc tenv_s ->+ do insertS gram x -< (tenv_s, mapProd tenv_s beta)++rule1 gram (FlipStar (Sym x) beta) + = proc tenv_s ->+ do insertF gram x -< (tenv_s, mapProd tenv_s beta)++rule1 gram (Sym x) + = rule1 gram $ FlipStar (Sym x) (Pure id)++rule1 _ (Pure _) + = error "Left-Corner(1): The grammar has empty productions."+rule1 _ _+ = error "Left-Corner(2): error in the transformation!!!"+++accessLeftMost :: Prod NF a env -> Prod NF a env+accessLeftMost (Star (Star f g) h) + = accessLeftMost $ FlipStar f (Star (Star (Pure (\g' h' f' -> f' g' h')) g) h)+accessLeftMost (Star (FlipStar f g) h) + = accessLeftMost $ FlipStar f (Star (Star (Pure flip) g) h)+accessLeftMost (FlipStar (Star f g) h) + = accessLeftMost $ FlipStar f (Star (Star (Pure (\g' h' f' -> h' (f' g'))) g) h)+accessLeftMost (FlipStar (FlipStar f g) h) + = accessLeftMost $ FlipStar f (Star (Star (Pure (\g' h' f' -> h' (g' f'))) g) h)+accessLeftMost p = p ++rule2S :: GramEnv env env + -> Symbol (x->a) t env + -> GramTrafo env a s (T env s, Ref x s) + (Productions NF a s)+rule2S gram (Nont b) + = case lookupEnv b gram of+ PS ps -> proc (tenv_s, a_x) ->+ do pss <- sequenceA + (map (rule2bS gram . accessLeftMost) ps) -< (tenv_s, a_x)+ returnA -< PS (concatMap unPS pss)++++rule2bS :: GramEnv env env + -> Prod NF (b->a) env + -> GramTrafo env a s (T env s, Ref b s) + (Productions NF a s)++rule2bS gram (Star (Sym x) beta) + = proc (tenv_s, a_b) ->+ do insertF gram x -< (tenv_s, Star (Star (Pure (\b y bya -> bya b y)) (mapProd tenv_s beta)) (Sym $ Nont a_b) )++rule2bS gram (FlipStar (Sym x) beta) + = proc (tenv_s, a_b) ->+ do insertF gram x -< (tenv_s, Star (Star (Pure (\bya y b -> bya b y)) (mapProd tenv_s beta)) (Sym $ Nont a_b) )++rule2bS gram (Sym x) + = rule2bS gram $ FlipStar (Sym x) (Pure id)++rule2bS _ (Pure _)+ = error "Left-Corner(3): The grammar has empty productions."++rule2bS _ _+ = error "Left-Corner(4): error in the transformation!!!"++--++rule2F :: GramEnv env env + -> Symbol x t env + -> GramTrafo env a s (T env s, Ref (x->a) s) + (Productions NF a s)+rule2F _ (Term a) + = proc (_, a_x) ->+ do returnA -< PS [rule2aF a a_x]+rule2F gram (Nont b) + = case lookupEnv b gram of+ PS ps -> proc (tenv_s, a_x) ->+ do pss <- sequenceA + (map (rule2bF gram . accessLeftMost) ps) -< (tenv_s, a_x)+ returnA -< PS (concatMap unPS pss)+rule2F _ TermInt + = proc (_, a_x) ->+ do returnA -< PS [rule2a'F TermInt a_x]+rule2F _ TermChar + = proc (_, a_x) ->+ do returnA -< PS [rule2a'F TermChar a_x]+rule2F _ TermVarid + = proc (_, a_x) ->+ do returnA -< PS [rule2a'F TermVarid a_x]+rule2F _ TermConid + = proc (_, a_x) ->+ do returnA -< PS [rule2a'F TermConid a_x]+rule2F _ TermOp + = proc (_, a_x) ->+ do returnA -< PS [rule2a'F TermOp a_x]+++rule2a'F :: Symbol a t s -> Ref (a->b) s -> Prod NF b s+rule2a'F s refA_a+ = FlipStar (Sym s) (Sym $ Nont refA_a) -- (flip ($)) <$> (Sym s) <*> nont refA_a+++rule2aF :: String -> Ref (DTerm String -> a) s -> Prod NF a s+rule2aF a refA_a+ = FlipStar (Sym $ Term a) (Sym $ Nont refA_a) -- (flip ($)) <$> term a <*> nont refA_a+++rule2bF :: GramEnv env env + -> Prod NF b env + -> GramTrafo env a s (T env s, Ref (b -> a) s) + (Productions NF a s)++rule2bF gram (Star (Sym x) beta) + = proc (tenv_s, a_b) ->+ do insertF gram x -< (tenv_s, Star (Star (Pure (\b xa bx -> xa (bx b))) (mapProd tenv_s beta)) (Sym $ Nont a_b) )++rule2bF gram (FlipStar (Sym x) beta) + = proc (tenv_s, a_b) ->+ do insertF gram x -< (tenv_s, Star (Star (Pure (flip (.))) (mapProd tenv_s beta)) (Sym $ Nont a_b) )++rule2bF gram (Sym x) + = rule2bF gram $ FlipStar (Sym x) (Pure id)++rule2bF _ (Pure _)+ = error "Left-Corner(5): The grammar has empty productions."++rule2bF _ _+ = error "Left-Corner(6): error in the transformation!!!"++insertS :: forall x t env s a+ . GramEnv env env + -> Symbol (x->a) t env+ -> GramTrafo env a s (T env s, Prod NF x s)+ (Productions NF a s)+insertS gram x = + Trafo (+ \(MapA_X ms mf) -> case ms x of+ Just r -> extendA_X (MapA_X ms mf) r+ + Nothing -> let Trafo step = insertNewA_X + in step (MapA_X ms mf)+ )+ where+ insertNewA_X = proc (tenv_s,p) ->+ do r <- newNontRS x -< PS [p]+ rule2S gram x -< (tenv_s,r)+++insertF :: forall x t env s a+ . GramEnv env env + -> Symbol x t env+ -> GramTrafo env a s (T env s, Prod NF (x->a) s)+ (Productions NF a s)+insertF gram x = + Trafo (+ \(MapA_X ms mf) -> case mf x of+ Just r -> extendA_X (MapA_X ms mf) r+ + Nothing -> let Trafo step = insertNewA_X + in step (MapA_X ms mf)+ )+ where+ insertNewA_X = proc (tenv_s,p) ->+ do r <- newNontRF x -< PS [p]+ rule2F gram x -< (tenv_s,r)+++extendA_X :: m env2 -> Ref x env2 + -> TrafoE m (Productions NF) s env2 (t, Prod NF x s) (Productions NF a env)+extendA_X m r = fmap (const $ PS []) $ + updateSRef m r (\(_,p) (PS ps) -> PS (p:ps))+
+ src/Language/Grammars/Transformations/RemoveEmpties.hs view
@@ -0,0 +1,152 @@++module Language.Grammars.Transformations.RemoveEmpties (removeEmpties) where+++import Language.Grammars.Grammar+import Language.AbstractSyntax.TTTAS+++data HasEmpty a env = Unknown | HasEmpty (Prod NF a env) | HasNotEmpty+-- deriving (Show)+++removeEmpties :: Grammar a -> Grammar a+removeEmpties (Grammar start prods) + = Grammar start $ removeEmptiesEnv (findEmpties prods) prods ++++findEmpties :: GramEnv env env -> Env HasEmpty env env +findEmpties prods = findEmpties' prods (initEmpties prods)+ where+ findEmpties' prds empties = + case stepFindEmpties empties prds empties of+ (empties', True, _) -> findEmpties' prds empties'+ (empties', False, False) -> empties'+ (_, False, True) -> error "Remove Empties(1): Incorrect Grammar!!"++initEmpties :: GramEnv use def -> Env HasEmpty use def +initEmpties Empty = Empty+initEmpties (Ext nts _) = Ext (initEmpties nts) Unknown++stepFindEmpties :: Env HasEmpty use use -> GramEnv use def -> Env HasEmpty use def + -> (Env HasEmpty use def, Bool, Bool) +stepFindEmpties _ Empty Empty + = (Empty, False, False)+stepFindEmpties empties (Ext rprd prd) (Ext re e) + = let (re',rchanged,rhasUnk) = stepFindEmpties empties rprd re+ (e', changed, hasUnk) = updateEmpty empties prd e+ in (Ext re' e', changed || rchanged, hasUnk || rhasUnk)+stepFindEmpties _ _ _ + = error "RemoveEmpties(2): Error in the transformation!!!" +++updateEmpty :: Env HasEmpty use use -> Productions NF a use -> HasEmpty a use + -> (HasEmpty a use, Bool, Bool) +updateEmpty _ _ (HasEmpty p) = (HasEmpty p, False, False)+updateEmpty _ _ HasNotEmpty = (HasNotEmpty, False, False)+updateEmpty empties prd Unknown = case hasEmpty empties prd of+ Unknown -> (Unknown, False, True)+ e -> (e, True, False)++hasEmpty :: Env HasEmpty env env -> Productions NF a env -> HasEmpty a env+hasEmpty empties (PS ps)= foldr (\p re -> combHasEmpty (isEmpty p empties) re) HasNotEmpty ps+++combHasEmpty :: HasEmpty a env -> HasEmpty a env -> HasEmpty a env+combHasEmpty (HasEmpty _) (HasEmpty _) = error "Remove Empties(3): Ambiguous Grammar!!!"+combHasEmpty _ (HasEmpty p) = HasEmpty p+combHasEmpty (HasEmpty p) _ = HasEmpty p+combHasEmpty HasNotEmpty HasNotEmpty = HasNotEmpty+combHasEmpty _ Unknown = Unknown+combHasEmpty Unknown _ = Unknown+++isEmpty :: Prod NF a env -> Env HasEmpty env env -> HasEmpty a env+isEmpty (Pure a) _ = HasEmpty (Pure a)+isEmpty (Sym (Term _)) _ = HasNotEmpty+isEmpty (Sym (TermInt)) _ = HasNotEmpty+isEmpty (Sym (TermChar)) _ = HasNotEmpty+isEmpty (Sym (TermVarid)) _ = HasNotEmpty+isEmpty (Sym (TermConid)) _ = HasNotEmpty+isEmpty (Sym (TermOp)) _ = HasNotEmpty+isEmpty (Sym (Nont r)) empties = lookupEnv r empties+isEmpty (Star pl pr) empties = case isEmpty pl empties of+ HasEmpty (Pure f) -> case isEmpty pr empties of+ HasEmpty (Pure x) -> HasEmpty $ Pure (f x)+ HasEmpty _ -> error "RemoveEmpties(4): Error in the transformation!!!"+ HasNotEmpty -> HasNotEmpty+ Unknown -> Unknown+ HasEmpty _ -> error "RemoveEmpties(5): Error in the transformation!!!"+ HasNotEmpty -> HasNotEmpty+ Unknown -> case isEmpty pr empties of+ HasNotEmpty -> HasNotEmpty+ _ -> Unknown+isEmpty (FlipStar pl pr) empties = case isEmpty pl empties of+ HasEmpty (Pure x) -> case isEmpty pr empties of+ HasEmpty (Pure f) -> HasEmpty $ Pure (f x)+ HasEmpty _ -> error "RemoveEmpties(6): Error in the transformation!!!"+ HasNotEmpty -> HasNotEmpty+ Unknown -> Unknown+ HasEmpty _ -> error "RemoveEmpties(7): Error in the transformation!!!"+ HasNotEmpty -> HasNotEmpty+ Unknown -> case isEmpty pr empties of+ HasNotEmpty -> HasNotEmpty+ _ -> Unknown+++++removeEmptiesEnv :: Env HasEmpty use use -> GramEnv use def -> GramEnv use def+removeEmptiesEnv _ Empty + = Empty+removeEmptiesEnv empties (Ext rprds prds) + = Ext (removeEmptiesEnv empties rprds) (removeEmpty empties prds)+++removeEmpty :: Env HasEmpty env env -> Productions NF a env -> Productions NF a env+removeEmpty empties (PS prds) = PS $ foldr ((++) . remEmptyProd) [] prds + where + -- if we don't allow the starting point to be empty, + -- then we can ignore the empty part+ remEmptyProd prd = let (prd',_) = splitEmpty empties prd+ in prd'+++splitEmpty :: Env HasEmpty env env -> Prod NF a env -> ([Prod NF a env], Maybe (Prod NF a env))++splitEmpty empties (Star f g) + = let (fne, fe) = splitEmpty empties f + (gne, ge) = splitEmpty empties g ++ fne_gne = [ Star fv gv | fv <- fne, gv <- gne ] + fne_ge = case ge of+ Nothing -> []+ Just gv -> [ Star fv gv | fv <- fne] ++ fe_gne = case fe of+ Nothing -> []+ Just fv -> [ FlipStar gv fv | gv <- gne] + fe_ge = do + (Pure fv) <- fe+ (Pure gv) <- ge+ return $ Pure (fv gv)++ in (fne_gne ++ fne_ge ++ fe_gne , fe_ge)+++splitEmpty empties (Sym (Nont r)) + = case lookupEnv r empties of+ HasEmpty (Pure f) -> ([Sym $ Nont r], Just (Pure f))+ HasEmpty _ -> error "RemoveEmpties(9): Error in the transformation!!!"+ _ -> ([Sym $ Nont r], Nothing)+-- HasNotEmpty -> ([Sym $ Nont r], Nothing)+-- Unknown -> error "RemoveEmpties(10): Error in the transformation!!!"++splitEmpty _ (Sym s) = ([Sym s], Nothing)+splitEmpty _ (Pure a) = ([],Just $ Pure a)++splitEmpty _ (FlipStar _ _) + = error "RemoveEmpties(11): FlipStar cannot be used to define grammars."++
+ src/Language/Grammars/Transformations/RemoveFix.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE RankNTypes, Arrows, DoRec #-} ++module Language.Grammars.Transformations.RemoveFix (removeFix) where+++import Language.AbstractSyntax.TTTAS+import Language.Grammars.Grammar+import Language.Grammars.Transformations.GramTrafo++import Control.Arrow+++removeFix :: forall env a. Ref a env -> PreGramEnv env env -> Grammar a+removeFix start productions+ = case runTrafo (remfixtrafo productions) Unit () of+ Result _ (T tt) gram -> + Grammar (tt start) gram++remfixtrafo :: PreGramEnv env env + -> Trafo Unit (Productions NF) s () (T env s)+remfixtrafo productions = proc _ ->+ do rec let tenv_s = map2trans menv_s+ menv_s <- (remfixProds productions) -< tenv_s+ returnA -< tenv_s+++remfixProds :: PreGramEnv env env' + -> Trafo Unit (Productions NF) s (T env s) + (Mapping env' s)+remfixProds Empty + = proc _ ->+ returnA -< Mapping Empty ++remfixProds (Ext p (PS prods)) + = proc tenv_s ->+ do ps <- sequenceA (map remfixProd prods) -< tenv_s + r <- newSRef -< PS ps + Mapping e <- remfixProds p -< tenv_s+ returnA -< Mapping (Ext e r)++++remfixProd :: Prod TL a env + -> Trafo Unit (Productions NF) s (T env s) (Prod NF a s)++remfixProd (Fix (PS ps)) + = proc tenv_s ->+ do rec r <- newSRef -< PS (map (remVar r tenv_s) ps) + returnA -< (Sym $ Nont r)++remfixProd (Star f g) + = proc tenv_s ->+ do f' <- remfixProd f -< tenv_s+ g' <- remfixProd g -< tenv_s+ returnA -< Star f' g'+{-+remfixProd (FlipStar f g) + = proc tenv_s ->+ do f' <- remfixProd f -< tenv_s+ g' <- remfixProd g -< tenv_s+ returnA -< FlipStar f' g'+-}+remfixProd (Sym s) + = proc tenv_s ->+ do returnA -< Sym $ mapSym tenv_s s++remfixProd (Pure x) + = proc _ ->+ do returnA -< Pure x+++mapSym :: T env1 env2 -> Symbol a t env1 -> Symbol a t env2+mapSym t (Nont x) = Nont (unT t x)+mapSym _ (Term x) = Term x+mapSym _ TermInt = TermInt +mapSym _ TermChar = TermChar +mapSym _ TermVarid = TermVarid +mapSym _ TermConid = TermConid +mapSym _ TermOp = TermOp ++remVar :: Ref b s -> T env s -> Prod (FL b) a env -> Prod NF a s+remVar _ t (Sym s) = Sym $ mapSym t s +remVar _ _ (Pure x) = Pure x+remVar r t (Star f g) = Star (remVar r t f) (remVar r t g)+remVar r _ Var = Sym (Nont r) +