diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,29 @@ +The SyntaxMacros package is (c) copyright 2010 +to the original authors and other contributors listed here. If you add +or modify code, please add your name here. + +Original authors: + Marcos Viera + Doaitse Swierstra + Atze Dijkstra + Arthur Baars + +---- +The SyntaxMacros package is licensed under the terms of the GNU Lesser General Public +Licence (LGPL), which can be found in the file called LICENCE-LGPL, with +the following special exception: + + As a relaxation of clause 6 of the LGPL, the copyright holders of this + library give permission to use, copy, link, modify, and distribute, + binary-only object-code versions of an executable linked with the + original unmodified Library, without requiring the supply of any + mechanism to modify or replace the Library and relink (clauses 6a, + 6b, 6c, 6d, 6e), provided that all the other terms of clause 6 are + complied with. + +This software is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +License for more details. + + diff --git a/LICENSE-LGPL b/LICENSE-LGPL new file mode 100644 --- /dev/null +++ b/LICENSE-LGPL @@ -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. + + + Copyright (C) + + 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. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ + +import Distribution.Simple +main = defaultMain diff --git a/SyntaxMacros.cabal b/SyntaxMacros.cabal new file mode 100644 --- /dev/null +++ b/SyntaxMacros.cabal @@ -0,0 +1,32 @@ +name: SyntaxMacros +version: 0.1 +license: LGPL +license-file: COPYRIGHT +maintainer: Marcos Viera +homepage: http://www.cs.uu.nl/wiki/Center/SyntaxMacrosForFree +description: Library of first-class Syntax Macros +synopsis: Syntax Macros in the form of an EDSL +build-type: Simple +category: Development +stability: Experimental +copyright: Universiteit Utrecht +build-depends: base>=4 && <5, haskell98, template-haskell>=2.4.0.1, TTTAS>=0.4.0, AspectAG>=0.2, + uulib>=0.9.12, containers>=0.3 +cabal-version: >= 1.2.3 +exposed-modules: Language.Grammars.Grammar, + Language.Grammars.SyntaxMacros, + Language.Grammars.SyntaxMacros.Scanner +other-modules: Language.Grammars.SyntaxMacros.Machine, + Language.Grammars.SyntaxMacros.Token, + Language.Grammars.SyntaxMacros.TokenParser, + Language.Grammars.SyntaxMacros.ScanUtils, + Language.Grammars.SyntaxMacros.Utils, + Language.Grammars.Transformations.GramTrafo, + Language.Grammars.Transformations.LeftCorner, + Language.Grammars.Transformations.LeftFact +extensions: EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, + MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, + TypeSynonymInstances, UndecidableInstances, GADTs +hs-source-dirs: src +extra-source-files: README, LICENSE-LGPL +ghc-options: -Wall diff --git a/examples/Expr.hs b/examples/Expr.hs new file mode 100644 --- /dev/null +++ b/examples/Expr.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction + , GADTs #-} + +module Expr where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 +import Data.HList.TypeCastGeneric1 + +import Data.Maybe + +import UU.Pretty + +import Control.Monad + +data AGItf = AGItf { expr :: T_Expr} + deriving Show + +data T_Expr = Cst {cv :: Int} + | Var {vnm :: String} + | Mul {me1 :: T_Expr, me2 :: T_Expr} + | Add {ae1 :: T_Expr, ae2 :: T_Expr} + | Let {lnm :: String, val :: T_Expr, body :: T_Expr} + deriving Show + + + +-- syn att d f = syndef att (def d f) +-- inh att nts d f = inhdef att nts (def d f) +syn = syndefM +inh = inhdefM + +$(deriveAG ''AGItf) + +exprNT = nt_T_Expr .*. hNil +allNT = nt_AGItf .*. exprNT + + + +$(attLabels ["spp"]) + +sppAGItf = syn spp $ liftM (# spp) (at ch_expr) +sppCst = syn spp $ liftM pp (at ch_cv) +sppVar = syn spp $ liftM pp (at ch_vnm) +sppMul = syn spp $ do e1 <- at ch_me1 + e2 <- at ch_me2 + return $ e1 # spp >|< " * " >|< e2 # spp +sppAdd = syn spp $ do e1 <- at ch_ae1 + e2 <- at ch_ae2 + return $ e1 # spp >|< " + " >|< e2 # spp + +sppLet = syn spp $ do lnm <- at ch_lnm + val <- at ch_val + body <- at ch_body + return $ "let " >|< pp lnm >|< " = " >|< val # spp >|< " in " >|< body # spp + + +$(attLabels ["ienv","sval"]) + + +ienvRule = copy ienv exprNT +ienvAGItf = inh ienv exprNT $ do return (ch_expr .=. ([] :: [(String,Int)]) .*. emptyRecord) +ienvCst = ienvRule +ienvVar = ienvRule +ienvMul = ienvRule +ienvAdd = ienvRule +ienvLet = inh ienv exprNT $ do lnm <- at ch_lnm + val <- at ch_val + lhs <- at lhs + return $ ch_val .=. lhs # ienv .*. + ch_body .=. (lnm, val # sval) : lhs # ienv .*. + emptyRecord + + +svalRule f = use sval allNT f (0::Int) +svalAGItf = svalRule ((*)::Int->Int->Int) +svalCst = syn sval $ liftM id (at ch_cv) +svalVar = syn sval $ do vnm <- at ch_vnm + lhs <- at lhs + return $ fromJust (lookup vnm (lhs # ienv)) +svalMul = svalRule ((*)::Int->Int->Int) +svalAdd = svalRule ((+)::Int->Int->Int) +svalLet = syn sval $ liftM (# sval) (at ch_body) + + +aspAGItf = sppAGItf `ext` ienvAGItf `ext` svalAGItf +aspCst = sppCst `ext` ienvCst `ext` svalCst +aspVar = sppVar `ext` ienvVar `ext` svalVar +aspMul = sppMul `ext` ienvMul `ext` svalMul +aspAdd = sppAdd `ext` ienvAdd `ext` svalAdd +aspLet = sppLet `ext` ienvLet `ext` svalLet + +{- +semAGItf e = knit aspAGItf (ch_expr .=. e .*. emptyRecord) + +semCst e = knit aspCst (ch_cv .=. (\(Record HNil) -> e) .*. emptyRecord) + +semVar e = knit aspVar (ch_vnm .=. (\(Record HNil) -> e) .*. emptyRecord) + +semMul e1 e2 = knit aspMul (ch_me1 .=. e1 .*. ch_me2 .=. e2 .*. emptyRecord) + +semAdd e1 e2 = knit aspAdd (ch_ae1 .=. e1 .*. ch_ae2 .=. e2 .*. emptyRecord) + +semLet l e1 e2 = knit aspLet (ch_lnm .=. (\(Record HNil) -> l) .*. ch_val .=. e1 .*. ch_body .=. e2 .*. emptyRecord) +-} + +semAGItf r = knit aspAGItf r +semCst r = knit aspCst r +semVar r = knit aspVar r +semMul r = knit aspMul r +semAdd r = knit aspAdd r +semLet = knit aspLet + +-- modifications +-- syn att d f = syndef att (def d f) +-- inh att nts d f = inhdef att nts (def d f) +-- synmod att v (Fam ic sp) = Fam ic (sp .@. att .=. v) +-- synM att v f = synmod att (def v f) +synM = synmodM +inhM = inhmodM + +$(chLabel "se" ''T_Expr) + +sppSq = synM spp $ do me1 <- at ch_me1 + return $ "square " >|< (me1 # spp) + +semSq r = knit (sppSq `ext` aspMul) + (ch_me1 .=. (r # ch_se) .*. ch_me2 .=. (r # ch_se) .*. emptyRecord) + +{- +sppSq = synM spp $ do me1 <- at ch_me1 + return $ "square " >|< (me1 # spp) + +semSq r = knit (sppSq `ext` aspMul) (ch_me2 .=. (r # ch_me1) .*. r) +-} + +$(chLabels ["pe1","pe2"] ''T_Expr) + +sppPyth = synM spp $ do ae1 <- at ch_ae1 + ae2 <- at ch_ae2 + return $ "pyth " >|< (ae1 # spp) >|< " " + >|< (ae2 # spp) +svalPyth = synM sval $ do ae1 <- at ch_ae1 + ae2 <- at ch_ae2 + return $ (\p1 p2 -> p1 * p1 + p2 * p2 )(ae1 # sval) (ae2 # sval) +semPyth r = knit (sppPyth `ext` svalPyth `ext` aspAdd) + (ch_ae1 .=. (r # ch_pe1) .*. ch_ae2 .=. (r # ch_pe2) .*. emptyRecord) + + + + +-- identity stuff +$(chLabel "pe" ''T_Expr) +{- +synId att = syn att $ liftM (# att) (at ch_id) +inhId att nts = inh att nts $ do lhs <- at lhs + return $ ch_id .=. (lhs # att) .*. emptyRecord + +attsId = (synId spp) `ext`(inhId ienv exprNT) `ext`(synId sval) +-} + +sppPar = syn spp $ do pe <- at ch_pe + return $ "(" >|< pe # spp >|< ")" +svalPar = syn sval $ do liftM (# sval) (at ch_pe) +ienvPar = copy ienv exprNT + + +semPar = knit (sppPar `ext` ienvPar `ext` svalPar) + + +sppSubst = synM spp $ do lnm <- at ch_lnm + val <- at ch_val + body <- at ch_body + return $ (body # spp) >|< "[" >|< (pp lnm) >|< " | " >|< (val # spp) >|< "]" +{- +ienvSubst = inhM ienv exprNT $ do lnm <- at ch_lnm + val <- at ch_val + lhs <- at lhs + return $ ch_val .=. (lhs # ienv) .*. + ch_body .=. ((lnm, val # sval) : (lhs # ienv)) .*. + emptyRecord +-} +semSubst r = knit (sppSubst `ext` {-ienvSubst `ext`-} aspLet) r + + + diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE Arrows, DoRec, EmptyDataDecls, FlexibleContexts #-} + + +import qualified Data.Set as Set + +import Control.Arrow + +import UU.Pretty + +import Expr +import Language.Grammars.AspectAG +import qualified Language.Grammars.AspectAG as AG + +import Language.Grammars.SyntaxMacros +import Language.Grammars.Grammar + +import Language.Grammars.SyntaxMacros.Scanner + + +gramOpts :: ScanOpts +gramOpts + = defaultScanOpts + { scoKeywordsTxt = Set.fromList ["let", "in"] + , scoSpecChars = Set.fromList "=+*" + , scoDollarIdent = True + } + + +extKeywordsTxt :: ScanOpts -> [String] -> ScanOpts +extKeywordsTxt opts kws = opts { scoKeywordsTxt = scoKeywordsTxt opts `Set.union` Set.fromList kws } + +extSpecChars :: ScanOpts -> [Char] -> ScanOpts +extSpecChars opts kws = opts { scoSpecChars = scoSpecChars opts `Set.union` Set.fromList kws } + +data NTRoot +ntRoot = undefined :: NTRoot + + +data NTExp +ntExp = undefined :: NTExp + +data NTTerm +ntTerm = undefined :: NTTerm + +data NTFactor +ntFactor = undefined :: NTFactor + + +prds = proc () -> do + rec root <- addNT -< [ prd $ (ch_expr,exp) <#> \e -> semAGItf e () ] + + exp <- addNT -< [ prd $ "let" .> (ch_lnm,var) -.> "=" .> (ch_val,exp) <.> "in" .> (ch_body,exp) <#> semLet + , prd $ (ch_ae1,term) <.> "+" .> (ch_ae2,exp) <#> semAdd + , prdId term ] + + term <- addNT -< [ prd $ (ch_me1,term) <.> "*" .> (ch_me2,factor) <#> semMul + , prdId factor ] + + factor <- addNT -< [ prd $ (ch_cv,int) -#> semCst + , prd $ (ch_vnm,var) -#> semVar ] + + exportNTs -< Export root $ ntExp ^= exp ^| + ntTerm ^= term ^| + ntFactor ^= factor ^| + ntNil + +gram = closeGram prds + +test1 = do + tokens <- scanFile gramOpts "prog.src" + let (Ok res) = (parse . compile ) gram tokens + print $ res # spp + print $ res # sval + + +type AttExpr = Record (HCons (LVPair (Proxy Att_ienv) [(String,Int)]) HNil) + -> Record (HCons (LVPair (Proxy Att_spp) PP_Doc) + (HCons (LVPair (Proxy Att_sval) Int) HNil)) + +--extended grammar (syntax macro) +prds' :: ( NTRecord (nts env) + , GetNT NTExp (nts env) (Symbol AttExpr env) + , GetNT NTFactor (nts env) (Symbol AttExpr env)) + => SyntaxMacro env (Export start nts) (Export start nts) +prds' = proc (Export root nts) -> do + let exp = getNT ntExp nts + addProds -< (exp, [ prd $ "square" .> (ch_se,exp) <#> semSq + , prd $ "pyth" .> (ch_pe1,exp) <.> (ch_pe2,exp) <#> semPyth + , prd $ (ch_body,exp) <.> "[" .> (ch_lnm,var) -.> "|" .> (ch_val,exp) <.> "]" #> semSubst ]) + + + let factor = getNT ntFactor nts + addProds -< (factor, [ prd $ "(" .> (ch_pe,exp) <.> ")" #> semPar ]) + + exportNTs -< (Export root nts) + +gram' = closeGram (extendGram prds prds') + +test2 = do + tokens <- scanFile (gramOpts `extKeywordsTxt` [ "square", "pyth" ] `extSpecChars` "()[|]") "prog2.src" + case ( parse . compile ) gram' tokens of + (Ok res) -> do print $ res # spp + print $ res # sval + (Rep _ err) -> print err + + +main = test1 >> test2 + + diff --git a/examples/prog.src b/examples/prog.src new file mode 100644 --- /dev/null +++ b/examples/prog.src @@ -0,0 +1,1 @@ +let letter= 2 + 10 in 3 * letter + 104 diff --git a/examples/prog2.src b/examples/prog2.src new file mode 100644 --- /dev/null +++ b/examples/prog2.src @@ -0,0 +1,1 @@ +let letter= pyth ( 2 + 1) 3 in ( (x + 1) [x | 10]) * (letter + square 4) diff --git a/src/Language/Grammars/Grammar.hs b/src/Language/Grammars/Grammar.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/Grammar.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE ExistentialQuantification, GADTs #-} + +module Language.Grammars.Grammar where + +import Language.AbstractSyntax.TTTAS +import Language.Grammars.AspectAG hiding (append) + + +data Grammar a + = forall env . Grammar (Ref a env) + (Env Productions env env) + +newtype Productions a env + = PS {unPS :: [Prod a env]} + +data Prod a env where + Seq :: Symbol b env -> Prod (b -> a) env + -> Prod a env + End :: a -> Prod a env + +data DTerm = DTerm + +data Symbol a env where + Term :: String -> Symbol DTerm env + + Nont :: Ref a env -> Symbol a env + -- attributed terminals + NontInt :: Symbol Int env + NontChar :: Symbol Char env + NontVarid :: Symbol String env + NontConid :: Symbol String env + NontOp :: Symbol String env + --- TODO: the rest of EnumValToken + +infixl 5 `ext` +ext :: Env Productions env def' -> [Prod a env] + -> Env Productions env (def', a) +ext g = Ext g . PS + + + +matchSym :: Symbol a env -> Symbol b env + -> Maybe (Equal a b) +matchSym (Nont x) (Nont y) = match x y +matchSym (Term x) (Term y) | x == y = Just Eq +matchSym NontInt NontInt = Just Eq +matchSym NontVarid NontVarid = Just Eq +matchSym NontConid NontConid = Just Eq +matchSym NontOp NontOp = Just Eq +matchSym _ _ = Nothing + + +append :: (a -> b -> c) -> Prod a env -> Symbol b env + -> Prod c env +append g (End f ) s = Seq s (End (g f)) +append g (Seq t ts ) s + = Seq t (append (\b c d -> g (b d) c) ts s) + + +data Lit a env = Lit (a env) + +int :: Lit (Symbol Int) env +char :: Lit (Symbol Char) env +var :: Lit (Symbol String) env +con :: Lit (Symbol String) env +op :: Lit (Symbol String) env + +int = Lit NontInt +char = Lit NontChar +var = Lit NontVarid +con = Lit NontConid +op = Lit NontOp + +infixr 6 -:- +(-:-) = (,) + +infixr 5 <.>, -.>, .>, <#>, -#>, #> + +prd a = a ($) +prdId nt = Seq nt $ End id + +((chn,s) <.> ps) f = Seq s $ ps f' + where f' sem r = \x -> f sem (chn .=. x .*. r) + +(pn,Lit s) -.> pp = \r -> Seq s $ pp (f r) + where f r ff p = \x -> r ff (pn .=. (\(Record HNil) -> x) .*. p) + +s .> pp = \r -> Seq (Term s) $ pp (f r) + where f r ff p = \DTerm -> r ff p + + +((chn,s) <#> sem) f = Seq s (End $ f') + where f' = \x -> f sem + (chn .=. x .*. emptyRecord) + +(pn,Lit s) -#> ff = \r -> Seq s (End $ f r) + where f r = \x -> r ff (pn .=. (\(Record HNil) -> x) .*. emptyRecord) + +s #> ff = \r -> Seq (Term s) (End $ f r) + where f r = \DTerm -> r ff emptyRecord + +{- +-- DOESN'T WORK + +class ProdSeq a b c v v' | a -> b, b -> c where + (<.>) :: (HExtend (LVPair t v) l l') => + (t, a env)-> + ((t1 -> l -> v' -> t2) -> Prod b env)-> + (t1 -> l' -> t2)-> + Prod c env + +instance ProdSeq (Symbol b) (b->a) a v v where + (pn,s) <.> pp = \r -> Seq s $ pp (f r) + where f r ff p = \x -> r ff (pn .=. x .*. p) + + +instance ProdSeq (Lit (Symbol b)) (b->a) a (Record HNil -> v) v where + (pn,Lit s) <..> pp = \r -> Seq s $ pp (f r) + where f r ff p = \x -> r ff (pn .=. (\(Record HNil) -> x) .*. p) + +-- WORKS + +class ProdEnd a b | a -> b where + (<#>) :: (t, a env) -> t1-> (t1 -> Record (HCons (LVPair t b) HNil) -> t2) -> Prod t2 env + +instance ProdEnd (Symbol v) v where + (pn,s) <#> ff = \r -> Seq s (End $ f r) + where f r = \x -> r ff (pn .=. x .*. emptyRecord) + +instance ProdEnd (Lit (Symbol v)) (Record HNil -> v) where + (pn,Lit s) <#> ff = \r -> Seq s (End $ f r) + where f r = \x -> r ff (pn .=. (\(Record HNil) -> x) .*. emptyRecord) +-} + + diff --git a/src/Language/Grammars/SyntaxMacros.hs b/src/Language/Grammars/SyntaxMacros.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/SyntaxMacros.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE Arrows, ExistentialQuantification, GADTs, Rank2Types, FlexibleContexts, ScopedTypeVariables + , EmptyDataDecls, MultiParamTypeClasses, FlexibleInstances, OverlappingInstances, FunctionalDependencies, UndecidableInstances + , TypeFamilies #-} + +module Language.Grammars.SyntaxMacros where + +import Language.AbstractSyntax.TTTAS +import Control.Arrow + +import UU.Parsing hiding (Symbol,parse,Ok) +import qualified UU.Parsing as UU +import Language.Grammars.SyntaxMacros.Scanner + +import Language.Grammars.Grammar +import Language.Grammars.Transformations.LeftCorner +import Language.Grammars.Transformations.LeftFact + +type GramTrafo = Trafo Unit Productions +type ExtGram env nts + = GramTrafo env () (nts env) +type SyntaxMacro env nts nts' + = GramTrafo env (nts env) (nts' env) + +data Export start nts env = Export (Symbol start env) (nts env) + +-- add a new non-terminal to the grammar +addNT :: GramTrafo env [Prod a env] (Symbol a env) +addNT = proc p -> do + r <- newSRef -< PS p + returnA -< Nont r + + +-- add productions to an existing non-terminal +addProds :: GramTrafo env + (Symbol a env, [Prod a env]) () +addProds = proc (Nont nt, prds) -> do + updateFinalEnv -< + updateEnv (\(PS ps) -> PS $ prds ++ ps) nt + +-- close the grammar +closeGram :: (forall env. ExtGram env (Export a nts)) + -> Grammar a +closeGram prds = case runTrafo prds Unit () of + Result _ (Export (Nont r) _) gram + -> (leftfactoring . leftcorner) $ Grammar r gram + + +extendGram :: (NTRecord (nts env), NTRecord (nts' env)) + => ExtGram env (Export start nts) + -> SyntaxMacro env (Export start nts) (Export start' nts') + -> ExtGram env (Export start' nts') +extendGram g sm = g >>> sm + +exportNTs :: NTRecord (nts env) => GramTrafo env (Export start nts env) (Export start nts env) +exportNTs = returnA + + +-- extensible record + +newtype NTField nt a env = NTField { symbolNTField :: (Symbol a env) } + +labelNTField :: NTField nt a env -> nt +labelNTField _ = undefined + +data NTCons nt v l env = NTCons (NTField nt v env) (l env) +data NTNil env = NTNil + +class NTRecord r +instance NTRecord (NTNil env) +instance (NTRecord (l env), NotDuplicated nt (l env)) => NTRecord (NTCons nt v l env) + + +class Fail err + +data Duplicated nt + +class NotDuplicated nt r +instance NotDuplicated nt (NTNil env) +instance Fail (Duplicated nt) => NotDuplicated nt (NTCons nt v l env) -- using overlapping +instance NotDuplicated nt1 (l env) => NotDuplicated nt1 (NTCons nt2 v l env) + + +ntNil = NTNil + +infixr 4 ^= +(^=) :: nt -> (Symbol a env) -> NTField nt a env +(^=) _ = NTField + + +infixr 2 ^| +(^|) :: NTRecord (NTCons nt a l env) => NTField nt a env -> l env -> NTCons nt a l env +(^|) = NTCons + + +class GetNT nt r v | nt r -> v where + getNT :: nt -> r -> v + +data NotFound nt + +instance Fail (NotFound nt) => GetNT nt (NTNil env) r where + getNT = undefined +instance GetNT nt (NTCons nt v l env) (Symbol v env) where -- using overlapping + getNT _ (NTCons f _) = symbolNTField f +instance GetNT nt1 (l env) r => GetNT nt1 (NTCons nt2 v l env) r where + getNT nt (NTCons _ l) = getNT nt l + + +-- COMPILE -------------------------------------------------------------------- + +pInt :: Parser Token Int +pChr :: Parser Token Char +pCon :: Parser Token String +pVar :: Parser Token String +pOp :: Parser Token String + +pChr = head <$> pChar +pInt = read <$> pInteger +pCon = id <$> pConid +pVar = id <$> pVarid +pOp = id <$> pVarsym + +pTerm t = const DTerm <$> (pKey t) + +newtype Const f a s = C {unC :: f a} + + +compile :: Grammar a -> Parser Token a +compile (Grammar (start :: Ref a env) rules) + = unC (lookupEnv start result) + where result = + mapEnv + (\ (PS ps) -> C (foldr1 (<|>) [ comp p | p <- ps])) + rules + comp :: forall t . Prod t env -> Parser Token t + comp (End x) = pLow x + comp (Seq (Term t) ss) + = flip ($) <$> pTerm t <*> comp ss + comp (Seq (Nont n) ss) + = flip ($) <$> unC (lookupEnv n result) + <*> comp ss + comp (Seq (NontInt) ss) + = flip ($) <$> pInt <*> comp ss + comp (Seq (NontChar) ss) + = flip ($) <$> pChr <*> comp ss + comp (Seq (NontVarid) ss) + = flip ($) <$> pVar <*> comp ss + comp (Seq (NontConid) ss) + = flip ($) <$> pCon <*> comp ss + comp (Seq (NontOp) ss) + = flip ($) <$> pOp <*> comp ss + + +mapEnv :: (forall a . f a s -> g a s) + -> Env f s env -> Env g s env +mapEnv _ Empty = Empty +mapEnv f (Ext r v) = Ext (mapEnv f r) (f v) + + +-- PARSE ---------------------------------------------------------------------- + +type ParseMsg = Message Token (Maybe Token) + +data ParseResult a = Ok a + | Rep a [ParseMsg] + deriving Show + +parse :: Parser Token a -> [Token] -> ParseResult a +parse p input = case rparse p input of + (a,[] ) -> Ok a + (a,msgs) -> Rep a msgs + + +rparse :: Parser Token a -> [Token] -> (a, [ParseMsg]) +rparse p input = let ((Pair a _),msgs) = eval (UU.parse p input) + in (a,msgs) + where eval :: Steps a Token (Maybe Token) -> (a, [ParseMsg]) + eval (OkVal v r) = let (a,msgs) = v `seq` eval r + in (v a,msgs) + eval (UU.Ok r) = eval r + eval (Cost _ r) = eval r + eval (StRepair _ msg r) = let (v,msgs) = eval r + in (v,msg:msgs) + eval (Best _ r _) = eval r + eval (NoMoreSteps v ) = (v,[]) + diff --git a/src/Language/Grammars/SyntaxMacros/Machine.hs b/src/Language/Grammars/SyntaxMacros/Machine.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/SyntaxMacros/Machine.hs @@ -0,0 +1,330 @@ +module Language.Grammars.SyntaxMacros.Machine (scanHandle,scanFile,scan,getRational,getBaseNumber) where + +import Data.Char +import Data.List +import Data.Maybe +import IO +import UU.Scanner.Position +import qualified Data.Set as Set + +import Language.Grammars.SyntaxMacros.Utils +import Language.Grammars.SyntaxMacros.ScanUtils +import Language.Grammars.SyntaxMacros.Token + + + +scanHandle :: ScanOpts -> FilePath -> Handle -> IO [Token] +scanHandle opts fn fh + = do { txt <- hGetContents fh + ; return (scan opts (initPos fn) txt) + } + +scanFile :: ScanOpts -> FilePath -> IO [Token] +scanFile opts fn = + do txt <- readFile fn + return (scan opts (initPos fn) txt) + +scan :: ScanOpts -> Pos -> String -> [Token] +scan opts pos input + = if scoLitmode opts + then scanLitText pos input + else doScan pos input + + where + -- locatein :: Ord a => [a] -> a -> Bool + -- locatein es = isJust . btLocateIn compare (tab2tree (sort es)) + iskw = (`Set.member` scoKeywordsTxt opts) -- locatein (scoKeywordsTxt opts) + isop = (`Set.member` scoKeywordsOps opts) -- locatein (scoKeywordsOps opts) + isSymbol = (`Set.member` scoSpecChars opts) -- locatein (scoSpecChars opts) + isOpsym = (`Set.member` scoOpChars opts) -- locatein (scoOpChars opts) + isPairSym= (`Set.member` scoSpecPairs opts) -- locatein (scoSpecPairs opts) + + isIdStart c = isLower c || c == '_' + isIdChar c = isAlphaNum c || c == '\'' || c == '_' + isQIdChar c = isIdChar c || c == '.' + + allowQual = scoAllowQualified opts + + scanIdent isId p s + = (name,advc (length name) p,rest) + where (name,rest) = span isId s + + scanDollarIdent :: String -> (String,Int,String) + scanDollarIdent [] = ("",0,[]) + scanDollarIdent ('$':c:s) | not (isSpace c) + = let (str,w,s') = scanDollarIdent s + in (c:str,w+2,s') + scanDollarIdent cs@(c:s) | isSpace c || isSymbol c || isOpsym c + = ("",0,cs) + scanDollarIdent (c:s) = let (str,w,s') = scanDollarIdent s + in (c:str,w+1,s') + + scanQualified :: String -> (String,String) + scanQualified s + = qual "" s + where split isX s = span (\c -> isX c && c /= '.') s + validQuald c = isId c || isOpsym c + isId c = isIdStart c || isUpper c + qual q s + = case s of + (c:s') | isUpper c -- possibly a module qualifier + -> case split isIdChar s' of + (s'',('.':srest@(c':_))) | validQuald c' -- something validly qualifiable follows + -> qual (q ++ [c] ++ s'' ++ ".") srest + _ -> dflt + (c:_) | isOpsym c || isIdChar c -- not a qualifier, an operator or lowercase identifier + -> dflt + where dflt = (q,s) + + scanLitText p ('\\':'b':'e':'g':'i':'n':'{':'c':'o':'d':'e':'}':s) + | posIs1stColumn p + = doScan (advc 12 p) s + scanLitText p (c:s) + = scanLitText (adv p c) s + scanLitText p [] + = [] + + doScan p [] = [] + doScan p (c:s) | isSpace c = let (sp,next) = span isSpace s + in doScan (foldl adv p (c:sp)) next + + doScan p ('-':'-':s) = doScan p (dropWhile (/= '\n') s) + doScan p ('{':'-':s) = lexNest doScan (advc 2 p) s + doScan p ('"':ss) + = let (s,p',rest) = scanString (advc 1 p) ss + in if null rest || head rest /= '"' + then errToken "Unterminated string literal" p : doScan p' rest + else valueToken TkString s p : doScan (advc 1 p') (tail rest) + + doScan p ('$':ss) + | scoDollarIdent opts = tok : doScan (advc (w+1) p) ss' + where (ident,w,ss') = scanDollarIdent ss + tok = if null ident + then errToken "Zero length $identifier" p + else valueToken TkVarid ident p + + doScan p ('\\':'e':'n':'d':'{':'c':'o':'d':'e':'}':s) + | scoLitmode opts && posIs1stColumn p + = scanLitText (advc 10 p) s + + -- this is experimental, for now, not foolproof, only to be used for the Prelude + doScan p ('\'':'\'':ss) + = let (s,w,r) = scanDQuoteIdent ss + in if null r + then errToken "Unterminated double quote ident" p : doScan (advc (w+1) p) r + else valueToken TkConid s p : doScan (advc (w+4) p) r + + doScan p ('\'':ss) + = let (mc,cwidth,rest) = scanChar ss + in case mc of + Nothing -> errToken "Error in character literal" p : doScan (advc cwidth p) rest + Just c -> if null rest || head rest /= '\'' + then errToken "Unterminated character literal" p : doScan (advc (cwidth+1) p) rest + else valueToken TkChar [c] p : doScan (advc (cwidth+2) p) (tail rest) + + doScan p cs@(c:c2:s) + | isPairSym sym = reserved sym p : doScan(advc 2 p) s + where sym = [c,c2] + doScan p cs@(c:s) + | isSymbol c = reserved [c] p + : doScan (advc 1 p) s + | isIdStart c || isUpper c + = + let (qualPrefix,qualTail) = scanQualified cs + in if null qualPrefix || not allowQual + then + let (name', p', s') = scanIdent isIdChar (advc 1 p) s + name = c:name' + tok = if iskw name + then reserved name p + else valueToken (varKind name) name p + in tok : doScan p' s' + else case doScan (advc (length qualPrefix) p) qualTail of + (tok@(ValToken tp val _):toks) + -> ValToken (tokTpQual tp) (qualPrefix ++ val) p : toks + ts -> ts + | isOpsym c = let (name, s') = span isOpsym cs + tok n p (c:_) + | length suf' == 2 && isPairSym suf' + = (fst (tok pre p []) ++ [reserved suf' (advc (length pre) p)],1) + where (pre,suf) = splitAt (length n - 1) n + suf' = suf ++ [c] + tok n p s + | isop n = ([reserved n p],0) + | length suf == 2 && isPairSym suf + = (fst (tok pre p []) ++ [reserved suf (advc (length pre) p)],0) + | c==':' = ([valueToken TkConOp n p],0) + | otherwise = ([valueToken TkOp n p],0) + where (pre,suf) = splitAt (length n - 2) n + (toks,drops) = tok name p s' + in toks ++ doScan (advc drops $ foldl adv p name) (drop drops s') + | isDigit c = let (tktype,number,width,s') = getNumber cs + in valueToken tktype number p : doScan (advc width p) s' + | isDigit c + = let (tktype,(number,mantissa,exp),w,cs') = getRational' cs + m = maybe "" (\mant -> "." ++ mant) + e = maybe "" (\(sign,exp) -> "E" ++ maybe "" id sign ++ exp) + in valueToken tktype (number ++ m mantissa ++ e exp) p + : doScan (advc w p) cs' + | otherwise = errToken ("Unexpected character " ++ show c) p + : doScan (adv p c) s + +varKind :: String -> EnumValToken +varKind ('_':s) = varKind s +varKind (c :s) | isUpper c = TkConid + | otherwise = TkVarid +varKind [] = TkVarid + +lexNest :: (Pos -> String -> [Token]) + -> Pos + -> String + -> [Token] +lexNest cont pos inp = lexNest' cont pos inp + where lexNest' c p ('-':'}':s) = c (advc 2 p) s + lexNest' c p ('{':'-':s) = lexNest' (lexNest' c) (advc 2 p) s + lexNest' c p (x:s) = lexNest' c (adv p x) s + lexNest' _ _ [] = [ errToken "Unterminated nested comment" pos] + + +scanString :: Pos -> String -> (String,Pos,String) +scanString p [] = ("",p,[]) +scanString p ('\\':'&':xs) = scanString (advc 2 p) xs +scanString p ('\'':xs) = let (str,p',r) = scanString (advc 1 p) xs + in ('\'': str,p',r) +scanString p ('\\':x:xs) | isSpace x + = let (white,rest) = span isSpace xs + in case rest of + ('\\':rest') -> scanString (advc 1 $ foldl adv (advc 2 p) white) rest' + _ -> ("",advc 2 p,xs) +scanString p xs = let (ch,cw,cr) = getchar xs + (str,p',r) = scanString (advc cw p) cr + in maybe ("",p,xs) (\c -> (c:str,p',r)) ch + +scanChar :: [Char] -> (Maybe Char,Int,[Char]) +scanChar ('"' :xs) = (Just '"',1,xs) +scanChar xs = getchar xs + +getchar :: [Char] -> (Maybe Char,Int,[Char]) +getchar [] = (Nothing,0,[]) +getchar s@('\n':_ ) = (Nothing,0,s ) +getchar s@('\t':_ ) = (Nothing,0,s) +getchar s@('\'':_ ) = (Nothing,0,s) +getchar s@('\"':_ ) = (Nothing,0,s) +getchar ('\\':xs) = let (c,l,r) = getEscChar xs + in (c,l+1,r) +getchar (x:xs) = (Just x,1,xs) + +scanDQuoteIdent :: String -> (String,Int,String) +scanDQuoteIdent [] = ("",0,[]) +scanDQuoteIdent ('\'':'\'':xs) = ("",0,xs) +scanDQuoteIdent (x:xs) = let (s,w,r) = scanDQuoteIdent xs -- should check similar to getchar + in (x:s,w+1,r) + +getEscChar :: [Char] -> (Maybe Char,Int,[Char]) +getEscChar [] = (Nothing,0,[]) +getEscChar s@('x':xs) = let (tp,n,len,rest) = getNumber ('0' : s) + in (Just $ chr $ fromInteger $ getBaseNumber 16 n, len-1, rest) +getEscChar s@('o':xs) = let (tp,n,len,rest) = getNumber ('0' : s) + in (Just $ chr $ fromInteger $ getBaseNumber 8 n, len-1, rest) +getEscChar s@('^':x:xs) = case x `lookup` cntrCntrs of + Just c -> (Just c,2,xs) + _ -> (Nothing,0,s) + where cntrCntrs = [ ('@','\^@'), ('[','\^['), ('\\','\^\'), (']','\^]'), ('^','\^^'), ('_','\^_') ] + ++ zip ['A' .. 'Z'] ['\^A' .. '\^Z'] +getEscChar s@(x:xs) | isDigit x = let (tp,n,len,rest) = getNumber s + val = case tp of + TkInteger8 -> getBaseNumber 8 n + TkInteger16 -> getBaseNumber 16 n + TkInteger10 -> getBaseNumber 10 n + in if val >= 0 && val <= 255 + then (Just (chr $ fromInteger val),len, rest) + else (Nothing,1,rest) + | otherwise = case x `lookup` cntrChars of + Just c -> (Just c,1,xs) + Nothing + -> case filter (flip isPrefixOf s . fst) cntrStrs of + [] -> (Nothing,0,s) + ((m,mr):_) + -> (Just mr,ml,drop ml s) + where ml = length m + where cntrChars = [('a','\a'),('b','\b'),('f','\f'),('n','\n'),('r','\r'),('t','\t') + ,('v','\v'),('\\','\\'),('\"','\"'),('\'','\'')] + cntrStrs = [ ("NUL",'\NUL'), ("SOH",'\SOH'), ("STX",'\STX'), ("ETX",'\ETX') + , ("EOT",'\EOT'), ("ENQ",'\ENQ'), ("ACK",'\ACK'), ("BEL",'\BEL') + , ("BS" ,'\BS' ), ("HT" ,'\HT' ), ("LF" ,'\LF' ), ("VT" ,'\VT' ) + , ("FF" ,'\FF' ), ("CR" ,'\CR' ), ("SO" ,'\SO' ), ("SI" ,'\SI' ) + , ("DLE",'\DLE'), ("DC1",'\DC1'), ("DC2",'\DC2'), ("DC3",'\DC3') + , ("DC4",'\DC4'), ("NAK",'\NAK'), ("SYN",'\SYN'), ("ETB",'\ETB') + , ("CAN",'\CAN'), ("EM" ,'\EM' ), ("SUB",'\SUB'), ("ESC",'\ESC') + , ("FS" ,'\FS' ), ("GS" ,'\GS' ), ("RS" ,'\RS' ), ("US" ,'\US' ) + , ("SP" ,'\SP' ), ("DEL",'\DEL') + ] + +getBaseNumber :: Integer -> [Char] -> Integer +getBaseNumber base n = foldl (\r x -> toInteger (value x) + base * r) 0 n + +getNumber :: [Char] -> (EnumValToken,[Char],Int,[Char]) +getNumber cs@(c:s) + | c /= '0' = num10 + | null s = const0 + | hs == 'x' || hs == 'X' = num16 + | hs == 'o' || hs == 'O' = num8 + | otherwise = num10 + where (hs:ts) = s + const0 = (TkInteger10, "0",1,s) + num10 = let (n,r) = span isDigit cs + in (TkInteger10,n,length n,r) + num16 = readNum isHexaDigit ts TkInteger16 + num8 = readNum isOctalDigit ts TkInteger8 + readNum p ts tk + = let nrs@(n,rs) = span p ts + in if null n then const0 + else (tk , n, 2+length n,rs) + +getRational' :: String -> (EnumValToken,(String,Maybe String,Maybe (Maybe String,String)),Int,String) +getRational' s + = case s2 of + ('.':s3@(c:_)) | isDigit c && tktype == TkInteger10 && tktype2 == TkInteger10 + -> case scanExp s4 of + Just (sign,number3,width3,s5) + -> (TkFraction,(number,Just number2,Just (sign,number3)),width + width2 + width3 + 1,s5) + _ -> (TkFraction,(number,Just number2,Nothing),width + width2 + 1,s4) + where (tktype2,number2,width2,s4) = getNumber s3 + _ -> case scanExp s2 of + Just (sign,number3,width3,s5) + -> (TkFraction,(number,Nothing,Just (sign,number3)),width + width3,s5) + _ -> (tktype,(number,Nothing,Nothing),width,s2) + where (tktype,number,width,s2) = getNumber s + scanExp s + = case s of + (c:s5) | c == 'e' || c == 'E' + -> case s5 of + (csign:s6) + | csign == '+' || csign == '-' + -> case s6 of + (c:_) | isDigit c && tktype3 == TkInteger10 + -> Just (Just [csign],number3,width3+2,s7) + where (tktype3,number3,width3,s7) = getNumber s6 + _ -> Nothing + | isDigit csign && tktype3 == TkInteger10 + -> Just (Nothing,number3,width3+1,s7) + where (tktype3,number3,width3,s7) = getNumber s5 + _ -> Nothing + _ -> Nothing + +getRational :: String -> (String,Maybe String,Maybe (Maybe String,String)) +getRational s + = n + where (_,n,_,_) = getRational' s + +isHexaDigit :: Char -> Bool +isHexaDigit d = isDigit d || (d >= 'A' && d <= 'F') || (d >= 'a' && d <= 'f') + +isOctalDigit :: Char -> Bool +isOctalDigit d = d >= '0' && d <= '7' + +value :: Char -> Int +value c | isDigit c = ord c - ord '0' + | isUpper c = ord c - ord 'A' + 10 + | isLower c = ord c - ord 'a' + 10 + diff --git a/src/Language/Grammars/SyntaxMacros/ScanUtils.hs b/src/Language/Grammars/SyntaxMacros/ScanUtils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/SyntaxMacros/ScanUtils.hs @@ -0,0 +1,179 @@ +module Language.Grammars.SyntaxMacros.ScanUtils + ( ScanOpts(..), defaultScanOpts + + , isNoPos, posIs1stColumn + + , InFilePos(..), infpStart, infpNone + , infpAdvCol, infpAdvLine, infpAdv1Line, infpAdvStr + + , genTokVal, genTokTp, genTokMap + + , isLF, isStr, isStrQuote + , isWhite, isBlack + , isVarStart, isVarRest + ) + where + +import IO +import Data.Char +import Data.List +import qualified Data.Set as Set + +-- import EH.Util.Pretty + +import UU.Parsing +import UU.Scanner.Position( noPos, Pos(..), Position(..) ) +import UU.Scanner.GenToken + +------------------------------------------------------------------------- +-- Utils for GenToken +------------------------------------------------------------------------- + +genTokVal :: GenToken v t v -> v +genTokVal (ValToken _ v _) = v +genTokVal (Reserved v _) = v + +genTokTp :: GenToken k t v -> Maybe t +genTokTp (ValToken t _ _) = Just t +genTokTp _ = Nothing + +genTokMap :: (a->b) -> GenToken a t a -> GenToken b t b +genTokMap f (ValToken t v p) = ValToken t (f v) p +genTokMap f (Reserved k p) = Reserved (f k) p + +------------------------------------------------------------------------- +-- Utils for Pos +------------------------------------------------------------------------- + +isNoPos :: Pos -> Bool +isNoPos (Pos l c f) = l < 0 || c < 0 + +posIs1stColumn :: Pos -> Bool +posIs1stColumn p = column p == 1 + +------------------------------------------------------------------------- +-- InFilePos: Simplified Pos for inside a file only +------------------------------------------------------------------------- + +data InFilePos + = InFilePos { infpLine, infpColumn :: Int } + deriving (Eq,Ord) + +instance Show InFilePos where + show (InFilePos l c) = if l < 0 || c < 0 then "" else "(" ++ show l ++ ":" ++ show c ++ ")" + +infpStart :: InFilePos +infpStart = InFilePos 1 1 + +infpNone :: InFilePos +infpNone = InFilePos (-1) (-1) + +infpAdvCol :: Int -> InFilePos -> InFilePos +infpAdvCol i p = p {infpColumn = i + infpColumn p} + +infpAdvStr :: String -> InFilePos -> InFilePos +infpAdvStr s p = infpAdvCol (length s) p + +infpAdvLine :: Int -> InFilePos -> InFilePos +infpAdvLine i p = p {infpLine = i + infpLine p, infpColumn = 1} + +infpAdv1Line :: InFilePos -> InFilePos +infpAdv1Line = infpAdvLine 1 + +------------------------------------------------------------------------- +-- PP of parse errors +------------------------------------------------------------------------- + +instance Position p => Position (Maybe p) where + line = maybe (line noPos) line + column = maybe (column noPos) column + file = maybe (file noPos) file + +instance Position (GenToken k t v) where + line = line . position + column = column . position + file = file . position + +{------------------------------------------------------------------------ +instance PP Pos where + pp (Pos l c f) = ppParens $ (if null f then empty else pp f >|< ":" ) >|< l >|< "," >|< c + +------------------------------------------------------------------------} + + +------------------------------------------------------------------------- +-- ScanOpts +------------------------------------------------------------------------- + +{- +ScanOpts encode all possible options we ever might want to pass to a scanner used inside the EHC project. +Hence not all options are used by all scanners. +-} + +data ScanOpts + = ScanOpts + { scoKeywordsTxt :: !(Set.Set String) -- identifiers which are keywords + , scoCommandsTxt :: !(Set.Set String) -- identifiers which are commands + , scoKeywordsOps :: !(Set.Set String) -- operators which are keywords + , scoSpecChars :: !(Set.Set Char) -- 1 char keywords + , scoOpChars :: !(Set.Set Char) -- chars used for operators + , scoSpecPairs :: !(Set.Set String) -- pairs of chars which form keywords + , scoDollarIdent :: !Bool -- allow $ encoded identifiers + , scoOffsideTrigs :: ![String] -- offside triggers + , scoOffsideModule :: !String -- offside start of module + , scoOffsideOpen :: !String -- offside open symbol + , scoOffsideClose :: !String -- offside close symbol + , scoLitmode :: !Bool -- do literal scanning + , scoVerbOpenClose :: ![(String,String)] -- open/close pairs used for verbatim text + , scoAllowQualified :: !Bool -- allow qualified variations, i.e. prefixing with "XXX." + } + +defaultScanOpts :: ScanOpts +defaultScanOpts + = ScanOpts + { scoKeywordsTxt = Set.empty + , scoCommandsTxt = Set.empty + , scoKeywordsOps = Set.empty + , scoSpecChars = Set.empty + , scoOpChars = Set.empty + , scoSpecPairs = Set.empty + , scoDollarIdent = False + , scoOffsideTrigs = [] + , scoOffsideModule = "" + , scoOffsideOpen = "" + , scoOffsideClose = "" + , scoLitmode = False + , scoVerbOpenClose = [] + , scoAllowQualified = True + } + +------------------------------------------------------------------------- +-- Char predicates +------------------------------------------------------------------------- + +isLF :: Char -> Bool +isLF = (`elem` "\n\r") + +isStrQuote :: Char -> Bool +isStrQuote c = c == '"' + +isStr :: Char -> Bool +isStr c = not (isStrQuote c || isLF c) + +isVarStart :: Char -> Bool +isVarStart c = c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z' + +isVarRest :: Char -> Bool +isVarRest c = isVarStart c || isDigit c || c `elem` "'_" + +isWhite :: Char -> Bool +isWhite = (`elem` " \t") + +{- +isDig :: Char -> Bool +isDig c = c >= '0' && c <= '9' +-} + +isBlack :: Char -> Bool +isBlack c = not (isWhite c || isLF c) + diff --git a/src/Language/Grammars/SyntaxMacros/Scanner.hs b/src/Language/Grammars/SyntaxMacros/Scanner.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/SyntaxMacros/Scanner.hs @@ -0,0 +1,17 @@ +module Language.Grammars.SyntaxMacros.Scanner + (module Language.Grammars.SyntaxMacros.Machine, + module Language.Grammars.SyntaxMacros.Token, + module Language.Grammars.SyntaxMacros.TokenParser, + module Language.Grammars.SyntaxMacros.ScanUtils, + module UU.Scanner.Position) where + +import Language.Grammars.SyntaxMacros.Machine +import Language.Grammars.SyntaxMacros.Token +import Language.Grammars.SyntaxMacros.TokenParser +import Language.Grammars.SyntaxMacros.ScanUtils +import UU.Scanner.Position +import UU.Scanner.GenTokenOrd() +import UU.Scanner.GenTokenSymbol() + + + diff --git a/src/Language/Grammars/SyntaxMacros/Token.hs b/src/Language/Grammars/SyntaxMacros/Token.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/SyntaxMacros/Token.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE TypeSynonymInstances #-} +module Language.Grammars.SyntaxMacros.Token ( Token,EnumValToken(..) + , module UU.Scanner.GenToken + , reserved,valueToken,errToken,tokTpIsInt,tokTpIsId, tokTpQual) where + +import UU.Scanner.Position +import UU.Scanner.GenToken + +import Data.Set + + +type Token = GenToken String EnumValToken String + + +data EnumValToken + = TkVarid + | TkConid + | TkOp + | TkConOp + | TkQVarid + | TkQConid + | TkQOp + | TkQConOp + | TkString + | TkChar + | TkInteger8 + | TkInteger10 + | TkInteger16 + | TkFraction + | TkTextnm + | TkTextln + | TkError + deriving (Eq, Ord) + +instance Show Token where + showsPrec _ token + = showString + (case token of + Reserved key pos -> "symbol " ++ key ++ maybeshow pos + ValToken tp val pos -> show tp ++ " " ++ val ++ maybeshow pos + ) + +instance Show EnumValToken where + show tp = case tp of + TkVarid -> "lower case identifier" + TkConid -> "upper case identifier" + TkOp -> "operator" + TkConOp -> "con operator" + TkQOp -> "qualified operator" + TkQVarid -> "lower case qualified identifier" + TkQConid -> "upper case qualified identifier" + TkQConOp -> "qualified con operator" + TkString -> "string" + TkChar -> "character" + TkInteger8 -> "octal integer" + TkInteger10 -> "decimal Integer" + TkInteger16 -> "hexadecimal integer" + TkFraction -> "fraction (float,...)" + TkTextnm -> "text name" + TkTextln -> "text lines" + TkError -> "error in scanner:" + +maybeshow :: Pos -> String +maybeshow (Pos l c fn) | l <= 0 || c <= 0 = "" + | otherwise = " at line " ++ show l + ++ ", column " ++ show c + ++ " of file " ++ show fn + +reserved :: String -> Pos -> Token +reserved = Reserved + +valueToken :: EnumValToken -> String -> Pos -> Token +valueToken = ValToken + +errToken :: String -> Pos -> Token +errToken = valueToken TkError + +tokTpIsInt :: EnumValToken -> Bool +tokTpIsInt tp = tp == TkInteger8 || tp == TkInteger10 || tp == TkInteger16 + +tokTpIsId :: EnumValToken -> Bool +tokTpIsId + = (`member` ts) + where ts = fromList + [TkVarid,TkConid,TkOp,TkConOp + ,TkQVarid,TkQConid,TkQOp,TkQConOp + ] + +tokTpQual :: EnumValToken -> EnumValToken +tokTpQual TkVarid = TkQVarid +tokTpQual TkConid = TkQConid +tokTpQual TkOp = TkQOp +tokTpQual TkConOp = TkQConOp +tokTpQual t = t + diff --git a/src/Language/Grammars/SyntaxMacros/TokenParser.hs b/src/Language/Grammars/SyntaxMacros/TokenParser.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/SyntaxMacros/TokenParser.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Language.Grammars.SyntaxMacros.TokenParser where + +import UU.Parsing.Interface(IsParser(..)) +import UU.Parsing.Derived(pListSep, pPacked) +import UU.Scanner.Position(Pos) +import UU.Scanner.GenTokenParser(pReserved, pValToken) + +import Language.Grammars.SyntaxMacros.Token + + + +------------------------------------------------------------------------- +-- IsParsers for Symbols +------------------------------------------------------------------------- + +pKeyPos :: IsParser p Token => String -> p Pos +pKeyPos keyword = pReserved keyword + + +pSpecPos :: IsParser p Token => Char -> p Pos +pSpecPos s = pReserved [s] + +pKey :: IsParser p Token => String -> p String +pKey key = key <$ pKeyPos key + +pSpec :: IsParser p Token => Char -> p String +pSpec c = [c] <$ pSpecPos c + +pStringPos, pCharPos, + pInteger8Pos, pInteger10Pos, pInteger16Pos, pFractionPos, + pVaridPos, pConidPos, + pTextnmPos, pTextlnPos, pIntegerPos, pVarsymPos, pConsymPos :: IsParser p Token => p (String,Pos) + +pStringPos = pValToken TkString "" +pCharPos = pValToken TkChar "\NUL" +pInteger8Pos = pValToken TkInteger8 "0" +pInteger10Pos = pValToken TkInteger10 "0" +pInteger16Pos = pValToken TkInteger16 "0" +pFractionPos = pValToken TkFraction "0.0" +pVaridPos = pValToken TkVarid "" +pConidPos = pValToken TkConid "" +pConsymPos = pValToken TkConOp "" +pVarsymPos = pValToken TkOp "" +pTextnmPos = pValToken TkTextnm "" +pTextlnPos = pValToken TkTextln "" +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 + diff --git a/src/Language/Grammars/SyntaxMacros/Utils.hs b/src/Language/Grammars/SyntaxMacros/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/SyntaxMacros/Utils.hs @@ -0,0 +1,191 @@ +module Language.Grammars.SyntaxMacros.Utils where + +-- import EH.Util.Pretty +import Data.Char +import Data.List +import qualified Data.Set as Set +import qualified Data.Map as Map + +------------------------------------------------------------------------- +-- Set +------------------------------------------------------------------------- + +unionMapSet :: Ord b => (a -> Set.Set b) -> (Set.Set a -> Set.Set b) +unionMapSet f = Set.unions . map f . Set.toList + +------------------------------------------------------------------------- +-- Map +------------------------------------------------------------------------- + +inverseMap :: (Ord k, Ord v') => (k -> v -> (v',k')) -> Map.Map k v -> Map.Map v' k' +inverseMap mk = Map.fromList . map (uncurry mk) . Map.toList + +------------------------------------------------------------------------- +-- List +------------------------------------------------------------------------- + +hdAndTl' :: a -> [a] -> (a,[a]) +hdAndTl' _ (a:as) = (a,as) +hdAndTl' n [] = (n,[]) + +hdAndTl :: [a] -> (a,[a]) +hdAndTl = hdAndTl' undefined + +maybeNull :: r -> ([a] -> r) -> [a] -> r +maybeNull n f l = if null l then n else f l + +maybeHd :: r -> (a -> r) -> [a] -> r +maybeHd n f = maybeNull n (f . head) + +wordsBy :: (a -> Bool) -> [a] -> [[a]] +wordsBy p l + = w l + where w [] = [] + w l = let (l',ls') = break p l + in l' : case ls' of [] -> [] + (_:[]) -> [[]] + (_:ls'') -> w ls'' + +initlast :: [a] -> Maybe ([a],a) +initlast as + = il [] as + where il acc [a] = Just (reverse acc,a) + il acc (a:as) = il (a:acc) as + il _ _ = Nothing + +initlast2 :: [a] -> Maybe ([a],a,a) +initlast2 as + = il [] as + where il acc [a,b] = Just (reverse acc,a,b) + il acc (a:as) = il (a:acc) as + il _ _ = Nothing + +firstNotEmpty :: [[x]] -> [x] +firstNotEmpty = maybeHd [] id . filter (not . null) + +-- saturate a list, that is: +-- for all indices i between min and max, +-- if there is no listelement x for which get x returns i, +-- add an element mk i to the list + +listSaturate :: (Enum a,Ord a) => a -> a -> (x -> a) -> (a -> x) -> [x] -> [x] +listSaturate min max get mk xs + = [ Map.findWithDefault (mk i) i mp | i <- [min..max] ] + where mp = Map.fromList [ (get x,x) | x <- xs ] + +-- saturate a list with values from assoc list, that is: +-- for all indices i between min and max, +-- if there is no listelement x for which get x returns i, +-- add a candidate from the associationlist (which must be present) to the list + +listSaturateWith :: (Enum a,Ord a) => a -> a -> (x -> a) -> [(a,x)] -> [x] -> [x] +listSaturateWith min max get missing l + = listSaturate min max get mk l + where mp = Map.fromList missing + mk a = panicJust "listSaturateWith" $ Map.lookup a mp + +-- variant on span, predicate on full list +spanOnRest :: ([a] -> Bool) -> [a] -> ([a],[a]) +spanOnRest p [] = ([],[]) +spanOnRest p xs@(x:xs') + | p xs = (x:ys, zs) + | otherwise = ([],xs) + where (ys,zs) = spanOnRest p xs' + +------------------------------------------------------------------------- +-- String +------------------------------------------------------------------------- + +strWhite :: Int -> String +strWhite sz = replicate sz ' ' + +strPad :: String -> Int -> String +strPad s sz = s ++ strWhite (sz - length s) + +strCapitalize :: String -> String +strCapitalize s + = case s of + (c:cs) -> toUpper c : cs + _ -> s + +strToInt :: String -> Int +strToInt = foldl (\i c -> i * 10 + ord c - ord '0') 0 + +------------------------------------------------------------------------- +-- Split for qualified name +------------------------------------------------------------------------- + +splitForQualified :: String -> [String] +splitForQualified s + = ws'' + where ws = wordsBy (=='.') s + ws' = case initlast2 ws of + Just (ns,n,"") -> ns ++ [n ++ "."] + _ -> ws + ws''= case break (=="") ws' of + (nq,(_:ns)) -> nq ++ [concatMap ("."++) ns] + _ -> ws' + +------------------------------------------------------------------------- +-- Misc +------------------------------------------------------------------------- + +panic m = error ("panic: " ++ m) + +------------------------------------------------------------------------- +-- group/sort/nub combi's +------------------------------------------------------------------------- + +isSortedByOn :: (b -> b -> Ordering) -> (a -> b) -> [a] -> Bool +isSortedByOn cmp sel l + = isSrt l + where isSrt (x1:tl@(x2:_)) = cmp (sel x1) (sel x2) /= GT && isSrt tl + isSrt _ = True + +sortOn :: Ord b => (a -> b) -> [a] -> [a] +sortOn = sortByOn compare + +sortByOn :: (b -> b -> Ordering) -> (a -> b) -> [a] -> [a] +sortByOn cmp sel = sortBy (\e1 e2 -> sel e1 `cmp` sel e2) + +groupOn :: Eq b => (a -> b) -> [a] -> [[a]] +groupOn sel = groupBy (\e1 e2 -> sel e1 == sel e2) + +groupSortOn :: Ord b => (a -> b) -> [a] -> [[a]] +groupSortOn sel = groupOn sel . sortOn sel + +groupByOn :: (b -> b -> Bool) -> (a -> b) -> [a] -> [[a]] +groupByOn eq sel = groupBy (\e1 e2 -> sel e1 `eq` sel e2) + +groupSortByOn :: (b -> b -> Ordering) -> (a -> b) -> [a] -> [[a]] +groupSortByOn cmp sel = groupByOn (\e1 e2 -> cmp e1 e2 == EQ) sel . sortByOn cmp sel + +nubOn :: Eq b => (a->b) -> [a] -> [a] +nubOn sel = nubBy (\a1 a2 -> sel a1 == sel a2) + +------------------------------------------------------------------------- +-- Ordering +------------------------------------------------------------------------- + +orderingLexic :: [Ordering] -> Ordering +orderingLexic = foldr1 (\o1 o2 -> if o1 == EQ then o2 else o1) + +------------------------------------------------------------------------- +-- Maybe +------------------------------------------------------------------------- + +panicJust :: String -> Maybe a -> a +panicJust m = maybe (panic m) id + +infixr 0 $? + +($?) :: (a -> Maybe b) -> Maybe a -> Maybe b +f $? mx = do x <- mx + f x + +orMb :: Maybe a -> Maybe a -> Maybe a +orMb m1 m2 = maybe m2 (const m1) m1 + + + + diff --git a/src/Language/Grammars/Transformations/GramTrafo.hs b/src/Language/Grammars/Transformations/GramTrafo.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/Transformations/GramTrafo.hs @@ -0,0 +1,64 @@ +{-# OPTIONS -fglasgow-exts #-} + +module Language.Grammars.Transformations.GramTrafo where + +import Language.AbstractSyntax.TTTAS +import Language.Grammars.Grammar + +newtype MapA_X env a env' + = MapA_X (forall x. Symbol x env -> Maybe (Ref (x -> a) env')) + +emptyMap :: MapA_X env a env' +emptyMap = MapA_X (const Nothing) + +extendMap :: Symbol x env -> MapA_X env a env' + -> MapA_X env a (env',x->a) +extendMap x (MapA_X m) + = MapA_X (\s -> case matchSym s x of + Just Eq -> Just Zero + Nothing -> fmap Suc (m s) + ) + + +type GramTrafo env a = Trafo (MapA_X env a) Productions + + +initMap :: GramTrafo env a s c d + -> Trafo Unit Productions s c d +initMap (Trafo st) + = Trafo (\_ -> case st emptyMap of + TrafoE _ f -> TrafoE Unit f + ) + +newNontR :: forall x env s a + . Symbol x env + -> GramTrafo env a s (Productions (x->a) s) (Ref (x->a) s) +newNontR x = Trafo $ \m -> extEnv (extendMap x m) + + +newtype Mapping old new + = Mapping (Env Ref new old) + +map2trans :: Mapping env s -> T env s +map2trans (Mapping env) + = T (\r -> (lookupEnv r env)) + +mapProd :: T env1 env2 -> Prod a env1 -> Prod a env2 +mapProd _ (End x) = End x +mapProd t (Seq (Term x) r) = Seq (Term x) + (mapProd t r) + +mapProd t (Seq (Nont x) r) = Seq (Nont (unT t x)) + (mapProd t r) +mapProd t (Seq NontInt r) = Seq NontInt + (mapProd t r) +mapProd t (Seq NontChar r) = Seq NontChar + (mapProd t r) +mapProd t (Seq NontVarid r) = Seq NontVarid + (mapProd t r) +mapProd t (Seq NontConid r) = Seq NontConid + (mapProd t r) +mapProd t (Seq NontOp r) = Seq NontOp + (mapProd t r) + + diff --git a/src/Language/Grammars/Transformations/LeftCorner.hs b/src/Language/Grammars/Transformations/LeftCorner.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/Transformations/LeftCorner.hs @@ -0,0 +1,129 @@ +{-# OPTIONS -XExistentialQuantification -XArrows -XDoRec -XGADTs #-} + +module Language.Grammars.Transformations.LeftCorner (leftcorner) where + +import Language.AbstractSyntax.TTTAS +import Language.Grammars.Grammar +import Language.Grammars.Transformations.GramTrafo +import Control.Arrow + + +leftcorner :: forall a . Grammar a -> Grammar a +leftcorner (Grammar start productions) + = case runTrafo (lctrafo productions) Unit () of + Result _ (T tt) gram -> + Grammar (tt start) gram + +lctrafo :: Env Productions env env + -> Trafo Unit Productions s () (T env s) +lctrafo productions = proc _ -> + do rec let tenv_s = map2trans menv_s + menv_s <- (rules1 productions productions) -< tenv_s + returnA -< tenv_s + + +rules1 :: Env Productions env env + -> Env Productions env env' + -> Trafo Unit Productions s (T env s) + (Mapping env' s) +rules1 _ Empty + = proc _ -> + returnA -< Mapping Empty + +rules1 productions (Ext ps (PS prods)) + = proc tenv_s -> + do p <- app_rule1 productions prods -< tenv_s + r <- newSRef -< p + Mapping e <- rules1 productions ps -< tenv_s + returnA -< Mapping (Ext e r) + +app_rule1 :: forall env a s. Env Productions env env + -> [Prod a env] + -> Trafo Unit Productions s (T env s) (Productions a s) +app_rule1 productions prods = initMap + ( proc tenv_s -> + do pss <- sequenceA (map (rule1 productions) prods) -< tenv_s + returnA -< PS (concatMap unPS pss) + ) + +rule1 :: Env Productions env env -> Prod a env + -> GramTrafo env a s (T env s) (Productions a s) +rule1 gram (Seq x beta) + = proc tenv_s -> + do insert gram x -< (tenv_s, mapProd tenv_s beta) + + +rule2 :: Env Productions env env + -> Symbol x env + -> GramTrafo env a s (T env s, Ref (x -> a) s) + (Productions a s) +rule2 _ (Term a) + = proc (_, a_x) -> + do returnA -< PS [rule2a a a_x] +rule2 gram (Nont b) + = case lookupEnv b gram of + PS ps -> proc (tenv_s, a_x) -> + do pss <- sequenceA + (map (rule2b gram) ps) -< (tenv_s, a_x) + returnA -< PS (concatMap unPS pss) +rule2 _ NontInt + = proc (_, a_x) -> + do returnA -< PS [rule2a' NontInt a_x] +rule2 _ NontChar + = proc (_, a_x) -> + do returnA -< PS [rule2a' NontChar a_x] +rule2 _ NontVarid + = proc (_, a_x) -> + do returnA -< PS [rule2a' NontVarid a_x] +rule2 _ NontConid + = proc (_, a_x) -> + do returnA -< PS [rule2a' NontConid a_x] +rule2 _ NontOp + = proc (_, a_x) -> + do returnA -< PS [rule2a' NontOp a_x] + + +rule2a' :: Symbol a s-> Ref (a -> b) s -> Prod b s +rule2a' s refA_a + = Seq s $ Seq (Nont refA_a) $ End ($) + + +rule2a :: String -> Ref (DTerm -> a) s -> Prod a s +rule2a a refA_a + = Seq (Term a) $ Seq (Nont refA_a) $ End ($) + +rule2b :: Env Productions env env + -> Prod b env + -> GramTrafo env a s (T env s, Ref (b -> a) s) + (Productions a s) +rule2b gram (Seq x beta) + = proc (tenv_s, a_b) -> + do insert gram x -< (tenv_s, append (flip (.)) + (mapProd tenv_s beta) + (Nont a_b)) + +insert :: forall env s a x + . Env Productions env env + -> Symbol x env + -> GramTrafo env a s (T env s, Prod (x->a) s) + (Productions a s) +insert gram x = + Trafo ( + \(MapA_X m) -> case m x of + Just r -> extendA_X (MapA_X m) r + Nothing -> let Trafo step = insertNewA_X + in step (MapA_X m) + ) + where + insertNewA_X = proc (tenv_s,p) -> + do r <- newNontR x -< PS [p] + rule2 gram x -< (tenv_s,r) + + +extendA_X :: m env2-> Ref (x->a) env2-> TrafoE m Productions s env2 (t, Prod (x->a) s) (Productions a env) +extendA_X m r = fmap (const $ PS []) $ + updateSRef m r (\(_,p) (PS ps) -> PS (p:ps)) + + + + diff --git a/src/Language/Grammars/Transformations/LeftFact.hs b/src/Language/Grammars/Transformations/LeftFact.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/Transformations/LeftFact.hs @@ -0,0 +1,158 @@ +{-# OPTIONS -XExistentialQuantification -XArrows -XDoRec #-} + +module Language.Grammars.Transformations.LeftFact (leftfactoring) where + +import Language.AbstractSyntax.TTTAS +import Language.Grammars.Grammar +import Language.Grammars.Transformations.GramTrafo +import Control.Arrow +import Data.Maybe + + + +--list of repeated symbols (with hidden type) +data AnySym env = forall x. AnySym (Symbol x env) + +newtype BT env s = BT (Bool, T env s) + +-- The 'leftfactoring' function makes a feed-back loop to apply the +-- transformation to the Grammar. +-- If the transformation has produced new nonterminals (repeated initial +-- symbols have been found) the 'leftfactoring' function is called again. +leftfactoring :: forall a. Grammar a -> Grammar a +leftfactoring (Grammar start productions) + = case runTrafo (lftrafo productions) Unit () of + Result _ (BT (b,T tt)) gram -> + let g = Grammar (tt start) gram + in if b then leftfactoring g + else g + +lftrafo :: Env Productions env env + -> Trafo Unit Productions s () (BT env s) +lftrafo productions = proc _ -> + do rec let tenv_s = map2trans menv_s + (b,menv_s) <- (rules productions) -< tenv_s + returnA -< BT (b,tenv_s) + + +-- The function 'rules' is defined by induction over the original Grammar. +-- Applies the "transformation rule" for each nonterminal (and +-- its corresponding productions) of the Grammar. +-- First of all, the list of "repeated initial symbols" in the productions +-- of a nonterminal is found. +-- Having this list, the rule is applied to the productions. +-- The nonterminal is added to the new Grammar, with the productions +-- generated by the rule. +-- The output of the Trafo is compound by a boolean indicating if repeated +-- symbols were found, and the Mapping from the positions in the new Grammar +-- for each nonterminal of the old Grammar. +rules :: Env Productions env env' + -> Trafo Unit Productions s (T env s) (Bool,(Mapping env' s)) +rules Empty + = proc _ -> + returnA -< (False, Mapping Empty) + +rules (Ext ps (PS prods)) = + let rep = getrepeated prods + in proc tenv_s -> + do p <- app_rule rep prods -< tenv_s + r <- newSRef -< p + (bs,Mapping e) <- rules ps -< tenv_s + returnA -< ((length rep > 0) || bs, Mapping (Ext e r)) + +app_rule :: forall env a s. [AnySym env] + -> [Prod a env] + -> Trafo Unit Productions s (T env s) (Productions a s) +app_rule rep prods = initMap + ( proc tenv_s -> + do pss <- sequenceA (map (rule rep) prods) -< tenv_s + returnA -< PS (concatMap unPS pss) + ) + +-- If the first symbol of the production is in the list of "repeated +-- initial symbols", the transformation generated by 'rinstert' +-- is called with input the rest of the production. So, a new nonterminal +-- A_Rest_X is generated (if necessary) and the rest (beta) of the production +-- is stored as a production of it. +-- In other case the production (with its references mapped to the +-- to the new Grammar) is returned. +rule :: [AnySym env] -> Prod a env + -> GramTrafo env a s (T env s) (Productions a s) +rule _ (End a) = proc env2s -> + do returnA -< PS [ mapProd env2s (End a) ] + +rule rep (Seq x beta) + | x `iselem` rep = proc env2s -> + do rinsert x -< (env2s, mapProd env2s beta) + | otherwise = proc env2s -> + do returnA -< PS [ mapProd env2s (Seq x beta) ] + + +-- Insertion of a new production into one "rest" nonterminal. +-- If the symbol 'x' is in the MapA_X the nonterminal was already +-- added, so we obtain the reference of the nonterminal and add the new +-- production. +-- Otherwise, we have to create the new nonterminal (newNontR x). +rinsert :: forall env s a x. Symbol x env + -> GramTrafo env a s (T env s, Prod (x->a) s) (Productions a s) +rinsert x = + Trafo ( + \(MapA_X m) -> case m x of + Nothing -> case proc (env2s,p) -> + do r <- newNontR x -< PS [p] + addprod x -< (env2s,r) + of Trafo step -> step (MapA_X m) + Just r -> TrafoE (MapA_X m) + (\(_,p) t e f -> + ( PS [] + , t + , updateEnv (\(PS ps) + -> PS (p:ps)) + r e + , f + ) + ) + ) + + +addprod :: Symbol x env -> GramTrafo env a s (T env s, Ref (x -> a) s) + (Productions a s) +addprod (Term x) = proc (_, a__x) -> + do returnA -< PS [ Seq (Term x) $ Seq (Nont a__x) $ End ($)] +addprod (Nont r) = proc (env2s, a__x) -> + do returnA -< PS [ Seq (Nont (unT env2s r)) $ Seq (Nont a__x) + $ End ($)] +addprod (NontInt) = proc (_, a__x) -> + do returnA -< PS [ Seq NontInt $ Seq (Nont a__x) $ End ($)] +addprod (NontChar) = proc (_, a__x) -> + do returnA -< PS [ Seq NontChar $ Seq (Nont a__x) $ End ($)] +addprod (NontVarid) = proc (_, a__x) -> + do returnA -< PS [ Seq NontVarid $ Seq (Nont a__x) $ End ($)] +addprod (NontConid) = proc (_, a__x) -> + do returnA -< PS [ Seq NontConid $ Seq (Nont a__x) $ End ($)] +addprod (NontOp) = proc (_, a__x) -> + do returnA -< PS [ Seq NontOp $ Seq (Nont a__x) $ End ($)] + +-- Get the list of symbols that are repeated as "first symbol" in the list +-- of productions. +getrepeated :: [Prod a env] -> [AnySym env] +getrepeated prods = repeated $ mapMaybe head' prods + where head' (End _ ) = Nothing + head' (Seq x _) = Just (AnySym x) + repeated [] = [] + repeated (ax@(AnySym x):xs) + | x `iselem` xs = ax : repeated (filter (noteqAny ax) xs) + | otherwise = repeated xs + + noteqAny (AnySym x) (AnySym y) = (aux $ matchSym x y) + +aux :: Maybe (Equal a b) -> Bool +aux (Just Eq) = False +aux Nothing = True + +iselem :: Symbol t env -> [AnySym env] -> Bool +iselem _ [] = False +iselem x ((AnySym y):ys) = case (matchSym x y) of + (Just Eq) -> True + Nothing -> iselem x ys +