diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 --- /dev/null +++ b/COPYRIGHT @@ -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. + + 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/examples/LangDef.hs b/examples/LangDef.hs new file mode 100644 --- /dev/null +++ b/examples/LangDef.hs @@ -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 + } +-} + diff --git a/examples/LangExt.hs b/examples/LangExt.hs new file mode 100644 --- /dev/null +++ b/examples/LangExt.hs @@ -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` "()[|]" + + + + + diff --git a/examples/LangSem.hs b/examples/LangSem.hs new file mode 100644 --- /dev/null +++ b/examples/LangSem.hs @@ -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 + + diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -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 + + diff --git a/examples/Utils.hs b/examples/Utils.hs new file mode 100644 --- /dev/null +++ b/examples/Utils.hs @@ -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 + 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 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 2) diff --git a/examples/prog3.src b/examples/prog3.src new file mode 100644 --- /dev/null +++ b/examples/prog3.src @@ -0,0 +1,1 @@ +let letter = pyth ( 2 + 1) 3 in ( (x + 1) [x | 10]) * (letter + addmul 2 3 4 + square ( double 3 )) diff --git a/murder.cabal b/murder.cabal new file mode 100644 --- /dev/null +++ b/murder.cabal @@ -0,0 +1,37 @@ +name: murder +version: 1.0 +cabal-version: >= 1.2.3 +license: LGPL +license-file: COPYRIGHT +maintainer: Marcos Viera +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 + 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,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) +-} diff --git a/src/Language/Grammars/Murder.hs b/src/Language/Grammars/Murder.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/Murder.hs @@ -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) + diff --git a/src/Language/Grammars/Murder/Machine.hs b/src/Language/Grammars/Murder/Machine.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/Murder/Machine.hs @@ -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 + diff --git a/src/Language/Grammars/Murder/ScanUtils.hs b/src/Language/Grammars/Murder/ScanUtils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/Murder/ScanUtils.hs @@ -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) + diff --git a/src/Language/Grammars/Murder/Scanner.hs b/src/Language/Grammars/Murder/Scanner.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/Murder/Scanner.hs @@ -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() + + + diff --git a/src/Language/Grammars/Murder/Token.hs b/src/Language/Grammars/Murder/Token.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/Murder/Token.hs @@ -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 + diff --git a/src/Language/Grammars/Murder/TokenParser.hs b/src/Language/Grammars/Murder/TokenParser.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/Murder/TokenParser.hs @@ -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 "" +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/Murder/UULib.hs b/src/Language/Grammars/Murder/UULib.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/Murder/UULib.hs @@ -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,[]) + diff --git a/src/Language/Grammars/Murder/UUParsing.hs b/src/Language/Grammars/Murder/UUParsing.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/Murder/UUParsing.hs @@ -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 + + diff --git a/src/Language/Grammars/Murder/Utils.hs b/src/Language/Grammars/Murder/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/Murder/Utils.hs @@ -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 + + + + 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,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) + 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,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)) + diff --git a/src/Language/Grammars/Transformations/RemoveEmpties.hs b/src/Language/Grammars/Transformations/RemoveEmpties.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/Transformations/RemoveEmpties.hs @@ -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." + + diff --git a/src/Language/Grammars/Transformations/RemoveFix.hs b/src/Language/Grammars/Transformations/RemoveFix.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/Transformations/RemoveFix.hs @@ -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) +