packages feed

uulib (empty) → 0.9.5

raw patch · 41 files changed

+10441/−0 lines, 41 filesdep +basedep +haskell98setup-changed

Dependencies added: base, haskell98

Files

@@ -0,0 +1,62 @@+The UUST package is (c) copyright 2005+to the original authors and other contributors listed here.  If you add+or modify code, please add your name here.++Original authors:+	Doaitse Swierstra+	Arthur Baars+Contributors:+	Alexey Rodriguez++----+The UUST 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.++----+This software depends on library code by Daan Leijen, which+is distributed under the following license:++                       The Modified BSD License++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions +are met:++  * Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.++  * Redistributions in binary form must reproduce the above+    copyright notice, this list of conditions and the following+    disclaimer in the documentation and/or other materials provided+    with the distribution.++  * Neither the names of the copyright holders, nor the names of its+    contributors may be used to endorse or promote products derived +    from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ LICENSE-LGPL view
@@ -0,0 +1,507 @@+                  GNU LESSER GENERAL PUBLIC LICENSE+                       Version 2.1, February 1999++ Copyright (C) 1991, 1999 Free Software Foundation, Inc.+     59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++[This is the first released version of the Lesser GPL.  It also counts+ as the successor of the GNU Library Public License, version 2, hence+ the version number 2.1.]++                            Preamble++  The licenses for most software are designed to take away your+freedom to share and change it.  By contrast, the GNU General Public+Licenses are intended to guarantee your freedom to share and change+free software--to make sure the software is free for all its users.++  This license, the Lesser General Public License, applies to some+specially designated software packages--typically libraries--of the+Free Software Foundation and other authors who decide to use it.  You+can use it too, but we suggest you first think carefully about whether+this license or the ordinary General Public License is the better+strategy to use in any particular case, based on the explanations+below.++  When we speak of free software, we are referring to freedom of use,+not price.  Our General Public Licenses are designed to make sure that+you have the freedom to distribute copies of free software (and charge+for this service if you wish); that you receive source code or can get+it if you want it; that you can change the software and use pieces of+it in new free programs; and that you are informed that you can do+these things.++  To protect your rights, we need to make restrictions that forbid+distributors to deny you these rights or to ask you to surrender these+rights.  These restrictions translate to certain responsibilities for+you if you distribute copies of the library or if you modify it.++  For example, if you distribute copies of the library, whether gratis+or for a fee, you must give the recipients all the rights that we gave+you.  You must make sure that they, too, receive or can get the source+code.  If you link other code with the library, you must provide+complete object files to the recipients, so that they can relink them+with the library after making changes to the library and recompiling+it.  And you must show them these terms so they know their rights.++  We protect your rights with a two-step method: (1) we copyright the+library, and (2) we offer you this license, which gives you legal+permission to copy, distribute and/or modify the library.++  To protect each distributor, we want to make it very clear that+there is no warranty for the free library.  Also, if the library is+modified by someone else and passed on, the recipients should know+that what they have is not the original version, so that the original+author's reputation will not be affected by problems that might be+introduced by others.++  Finally, software patents pose a constant threat to the existence of+any free program.  We wish to make sure that a company cannot+effectively restrict the users of a free program by obtaining a+restrictive license from a patent holder.  Therefore, we insist that+any patent license obtained for a version of the library must be+consistent with the full freedom of use specified in this license.++  Most GNU software, including some libraries, is covered by the+ordinary GNU General Public License.  This license, the GNU Lesser+General Public License, applies to certain designated libraries, and+is quite different from the ordinary General Public License.  We use+this license for certain libraries in order to permit linking those+libraries into non-free programs.++  When a program is linked with a library, whether statically or using+a shared library, the combination of the two is legally speaking a+combined work, a derivative of the original library.  The ordinary+General Public License therefore permits such linking only if the+entire combination fits its criteria of freedom.  The Lesser General+Public License permits more lax criteria for linking other code with+the library.++  We call this license the "Lesser" General Public License because it+does Less to protect the user's freedom than the ordinary General+Public License.  It also provides other free software developers Less+of an advantage over competing non-free programs.  These disadvantages+are the reason we use the ordinary General Public License for many+libraries.  However, the Lesser license provides advantages in certain+special circumstances.++  For example, on rare occasions, there may be a special need to+encourage the widest possible use of a certain library, so that it+becomes a de-facto standard.  To achieve this, non-free programs must+be allowed to use the library.  A more frequent case is that a free+library does the same job as widely used non-free libraries.  In this+case, there is little to gain by limiting the free library to free+software only, so we use the Lesser General Public License.++  In other cases, permission to use a particular library in non-free+programs enables a greater number of people to use a large body of+free software.  For example, permission to use the GNU C Library in+non-free programs enables many more people to use the whole GNU+operating system, as well as its variant, the GNU/Linux operating+system.++  Although the Lesser General Public License is Less protective of the+users' freedom, it does ensure that the user of a program that is+linked with the Library has the freedom and the wherewithal to run+that program using a modified version of the Library.++  The precise terms and conditions for copying, distribution and+modification follow.  Pay close attention to the difference between a+"work based on the library" and a "work that uses the library".  The+former contains code derived from the library, whereas the latter must+be combined with the library in order to run.+++                  GNU LESSER GENERAL PUBLIC LICENSE+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++  0. This License Agreement applies to any software library or other+program which contains a notice placed by the copyright holder or+other authorized party saying it may be distributed under the terms of+this Lesser General Public License (also called "this License").+Each licensee is addressed as "you".++  A "library" means a collection of software functions and/or data+prepared so as to be conveniently linked with application programs+(which use some of those functions and data) to form executables.++  The "Library", below, refers to any such software library or work+which has been distributed under these terms.  A "work based on the+Library" means either the Library or any derivative work under+copyright law: that is to say, a work containing the Library or a+portion of it, either verbatim or with modifications and/or translated+straightforwardly into another language.  (Hereinafter, translation is+included without limitation in the term "modification".)++  "Source code" for a work means the preferred form of the work for+making modifications to it.  For a library, complete source code means+all the source code for all modules it contains, plus any associated+interface definition files, plus the scripts used to control+compilation and installation of the library.++  Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope.  The act of+running a program using the Library is not restricted, and output from+such a program is covered only if its contents constitute a work based+on the Library (independent of the use of the Library in a tool for+writing it).  Whether that is true depends on what the Library does+and what the program that uses the Library does.++  1. You may copy and distribute verbatim copies of the Library's+complete source code as you receive it, in any medium, provided that+you conspicuously and appropriately publish on each copy an+appropriate copyright notice and disclaimer of warranty; keep intact+all the notices that refer to this License and to the absence of any+warranty; and distribute a copy of this License along with the+Library.++  You may charge a fee for the physical act of transferring a copy,+and you may at your option offer warranty protection in exchange for a+fee.++  2. You may modify your copy or copies of the Library or any portion+of it, thus forming a work based on the Library, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++    a) The modified work must itself be a software library.++    b) You must cause the files modified to carry prominent notices+    stating that you changed the files and the date of any change.++    c) You must cause the whole of the work to be licensed at no+    charge to all third parties under the terms of this License.++    d) If a facility in the modified Library refers to a function or a+    table of data to be supplied by an application program that uses+    the facility, other than as an argument passed when the facility+    is invoked, then you must make a good faith effort to ensure that,+    in the event an application does not supply such function or+    table, the facility still operates, and performs whatever part of+    its purpose remains meaningful.++    (For example, a function in a library to compute square roots has+    a purpose that is entirely well-defined independent of the+    application.  Therefore, Subsection 2d requires that any+    application-supplied function or table used by this function must+    be optional: if the application does not supply it, the square+    root function must still compute square roots.)++These requirements apply to the modified work as a whole.  If+identifiable sections of that work are not derived from the Library,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works.  But when you+distribute the same sections as part of a whole which is a work based+on the Library, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote+it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Library.++In addition, mere aggregation of another work not based on the Library+with the Library (or with a work based on the Library) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++  3. You may opt to apply the terms of the ordinary GNU General Public+License instead of this License to a given copy of the Library.  To do+this, you must alter all the notices that refer to this License, so+that they refer to the ordinary GNU General Public License, version 2,+instead of to this License.  (If a newer version than version 2 of the+ordinary GNU General Public License has appeared, then you can specify+that version instead if you wish.)  Do not make any other change in+these notices.++  Once this change is made in a given copy, it is irreversible for+that copy, so the ordinary GNU General Public License applies to all+subsequent copies and derivative works made from that copy.++  This option is useful when you wish to copy part of the code of+the Library into a program that is not a library.++  4. You may copy and distribute the Library (or a portion or+derivative of it, under Section 2) in object code or executable form+under the terms of Sections 1 and 2 above provided that you accompany+it with the complete corresponding machine-readable source code, which+must be distributed under the terms of Sections 1 and 2 above on a+medium customarily used for software interchange.++  If distribution of object code is made by offering access to copy+from a designated place, then offering equivalent access to copy the+source code from the same place satisfies the requirement to+distribute the source code, even though third parties are not+compelled to copy the source along with the object code.++  5. A program that contains no derivative of any portion of the+Library, but is designed to work with the Library by being compiled or+linked with it, is called a "work that uses the Library".  Such a+work, in isolation, is not a derivative work of the Library, and+therefore falls outside the scope of this License.++  However, linking a "work that uses the Library" with the Library+creates an executable that is a derivative of the Library (because it+contains portions of the Library), rather than a "work that uses the+library".  The executable is therefore covered by this License.+Section 6 states terms for distribution of such executables.++  When a "work that uses the Library" uses material from a header file+that is part of the Library, the object code for the work may be a+derivative work of the Library even though the source code is not.+Whether this is true is especially significant if the work can be+linked without the Library, or if the work is itself a library.  The+threshold for this to be true is not precisely defined by law.++  If such an object file uses only numerical parameters, data+structure layouts and accessors, and small macros and small inline+functions (ten lines or less in length), then the use of the object+file is unrestricted, regardless of whether it is legally a derivative+work.  (Executables containing this object code plus portions of the+Library will still fall under Section 6.)++  Otherwise, if the work is a derivative of the Library, you may+distribute the object code for the work under the terms of Section 6.+Any executables containing that work also fall under Section 6,+whether or not they are linked directly with the Library itself.++  6. As an exception to the Sections above, you may also combine or+link a "work that uses the Library" with the Library to produce a+work containing portions of the Library, and distribute that work+under terms of your choice, provided that the terms permit+modification of the work for the customer's own use and reverse+engineering for debugging such modifications.++  You must give prominent notice with each copy of the work that the+Library is used in it and that the Library and its use are covered by+this License.  You must supply a copy of this License.  If the work+during execution displays copyright notices, you must include the+copyright notice for the Library among them, as well as a reference+directing the user to the copy of this License.  Also, you must do one+of these things:++    a) Accompany the work with the complete corresponding+    machine-readable source code for the Library including whatever+    changes were used in the work (which must be distributed under+    Sections 1 and 2 above); and, if the work is an executable linked+    with the Library, with the complete machine-readable "work that+    uses the Library", as object code and/or source code, so that the+    user can modify the Library and then relink to produce a modified+    executable containing the modified Library.  (It is understood+    that the user who changes the contents of definitions files in the+    Library will not necessarily be able to recompile the application+    to use the modified definitions.)++    b) Use a suitable shared library mechanism for linking with the+    Library.  A suitable mechanism is one that (1) uses at run time a+    copy of the library already present on the user's computer system,+    rather than copying library functions into the executable, and (2)+    will operate properly with a modified version of the library, if+    the user installs one, as long as the modified version is+    interface-compatible with the version that the work was made with.++    c) Accompany the work with a written offer, valid for at least+    three years, to give the same user the materials specified in+    Subsection 6a, above, for a charge no more than the cost of+    performing this distribution.++    d) If distribution of the work is made by offering access to copy+    from a designated place, offer equivalent access to copy the above+    specified materials from the same place.++    e) Verify that the user has already received a copy of these+    materials or that you have already sent this user a copy.++  For an executable, the required form of the "work that uses the+Library" must include any data and utility programs needed for+reproducing the executable from it.  However, as a special exception,+the materials to be distributed need not include anything that is+normally distributed (in either source or binary form) with the major+components (compiler, kernel, and so on) of the operating system on+which the executable runs, unless that component itself accompanies+the executable.++  It may happen that this requirement contradicts the license+restrictions of other proprietary libraries that do not normally+accompany the operating system.  Such a contradiction means you cannot+use both them and the Library together in an executable that you+distribute.++  7. You may place library facilities that are a work based on the+Library side-by-side in a single library together with other library+facilities not covered by this License, and distribute such a combined+library, provided that the separate distribution of the work based on+the Library and of the other library facilities is otherwise+permitted, and provided that you do these two things:++    a) Accompany the combined library with a copy of the same work+    based on the Library, uncombined with any other library+    facilities.  This must be distributed under the terms of the+    Sections above.++    b) Give prominent notice with the combined library of the fact+    that part of it is a work based on the Library, and explaining+    where to find the accompanying uncombined form of the same work.++  8. You may not copy, modify, sublicense, link with, or distribute+the Library except as expressly provided under this License.  Any+attempt otherwise to copy, modify, sublicense, link with, or+distribute the Library is void, and will automatically terminate your+rights under this License.  However, parties who have received copies,+or rights, from you under this License will not have their licenses+terminated so long as such parties remain in full compliance.++  9. You are not required to accept this License, since you have not+signed it.  However, nothing else grants you permission to modify or+distribute the Library or its derivative works.  These actions are+prohibited by law if you do not accept this License.  Therefore, by+modifying or distributing the Library (or any work based on the+Library), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Library or works based on it.++  10. Each time you redistribute the Library (or any work based on the+Library), the recipient automatically receives a license from the+original licensor to copy, distribute, link with or modify the Library+subject to these terms and conditions.  You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties with+this License.++  11. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Library at all.  For example, if a patent+license would not permit royalty-free redistribution of the Library by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Library.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply, and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system which is+implemented by public license practices.  Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++  12. If the distribution and/or use of the Library is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Library under this License+may add an explicit geographical distribution limitation excluding those+countries, so that distribution is permitted only in or among+countries not thus excluded.  In such case, this License incorporates+the limitation as if written in the body of this License.++  13. The Free Software Foundation may publish revised and/or new+versions of the Lesser General Public License from time to time.+Such new versions will be similar in spirit to the present version,+but may differ in detail to address new problems or concerns.++Each version is given a distinguishing version number.  If the Library+specifies a version number of this License which applies to it and+"any later version", you have the option of following the terms and+conditions either of that version or of any later version published by+the Free Software Foundation.  If the Library does not specify a+license version number, you may choose any version ever published by+the Free Software Foundation.++  14. If you wish to incorporate parts of the Library into other free+programs whose distribution conditions are incompatible with these,+write to the author to ask for permission.  For software which is+copyrighted by the Free Software Foundation, write to the Free+Software Foundation; we sometimes make exceptions for this.  Our+decision will be guided by the two goals of preserving the free status+of all derivatives of our free software and of promoting the sharing+and reuse of software generally.++                            NO WARRANTY++  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR+OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY+KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE+LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN+WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY+AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU+FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR+CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE+LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A+FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH+DAMAGES.++                     END OF TERMS AND CONDITIONS+++           How to Apply These Terms to Your New Libraries++  If you develop a new library, and you want it to be of the greatest+possible use to the public, we recommend making it free software that+everyone can redistribute and change.  You can do so by permitting+redistribution under these terms (or, alternatively, under the terms of the+ordinary General Public License).++  To apply these terms, attach the following notices to the library.  It is+safest to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least the+"copyright" line and a pointer to where the full notice is found.++    <one line to give the library's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This library is free software; you can redistribute it and/or+    modify it under the terms of the GNU Lesser General Public+    License as published by the Free Software Foundation; either+    version 2.1 of the License, or (at your option) any later version.++    This library is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU+    Lesser General Public License for more details.++    You should have received a copy of the GNU Lesser General Public+    License along with this library; if not, write to the Free Software+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA++Also add information on how to contact you by electronic and paper mail.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the library, if+necessary.  Here is a sample; alter the names:++  Yoyodyne, Inc., hereby disclaims all copyright interest in the+  library `Frob' (a library for tweaking knobs) written by James Random Hacker.++  <signature of Ty Coon>, 1 April 1990+  Ty Coon, President of Vice++That's all there is to it!+
+ README view
@@ -0,0 +1,71 @@+Please check the right section in this file for instructions depending on how you obtained the source files.+++Installing uulib from a source distribution+-------------------------------------------++  The source distribution can be unpacked from the+  .tar.gz files distributed in the following page:++    http://www.cs.uu.nl/wiki/HUT/Download++  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.+++Installing uulib from the subversion repository+-----------------------------------------------++  Which can be obtained running the following subversion command:++    svn co https://svn.cs.uu.nl:12443/repos/uust-repo/uulib/trunk/++  Now install following the instructions below:++    autoconf+    ./configure+  +  NOTE: the above instructions are REQUIRED when you install from the+  subversion repository. They are not needed when you download a+  source distribution.++  This generates uulib.cabal which is needed for the cabal commands:++    ghc --make Setup.hs -o setup -package Cabal+    ./setup configure+    ./setup build+    ./setup install++  If you want to install to a non-standard location+  you don't need to pass a path to configure, just follow+  the steps outlined above.+++Optionally generating Haddock Documentation+-------------------------------------------++  Requires cpphs 0.9+  Output generated in dist/doc/html++    ./setup haddock+
+ Setup.hs view
@@ -0,0 +1,3 @@++import Distribution.Simple+main = defaultMain
+ src/UU/DData/IntBag.hs view
@@ -0,0 +1,368 @@+--------------------------------------------------------------------------------+{-| Module      :  IntBag+    Copyright   :  (c) Daan Leijen 2002+    License     :  BSD-style++    Maintainer  :  daan@cs.uu.nl+    Stability   :  provisional+    Portability :  portable++  An efficient implementation of bags of integers on top of the "IntMap" module. ++  Many operations have a worst-case complexity of /O(min(n,W))/. This means that the+  operation can become linear in the number of elements  with a maximum of /W/ +  -- the number of bits in an 'Int' (32 or 64). For more information, see+  the references in the "IntMap" module.+-}+---------------------------------------------------------------------------------}+module UU.DData.IntBag ( +            -- * Bag type+              IntBag          -- instance Eq,Show+            +            -- * Operators+            , (\\)++            -- *Query+            , isEmpty+            , size+            , distinctSize+            , member+            , occur++            , subset+            , properSubset+            +            -- * Construction+            , empty+            , single+            , insert+            , insertMany+            , delete+            , deleteAll+            +            -- * Combine+            , union+            , difference+            , intersection+            , unions+            +            -- * Filter+            , filter+            , partition++            -- * Fold+            , fold+            , foldOccur+           +            -- * Conversion+            , elems++            -- ** List+            , toList+            , fromList++            -- ** Ordered list+            , toAscList+            , fromAscList+            , fromDistinctAscList++            -- ** Occurrence lists+            , toOccurList+            , toAscOccurList+            , fromOccurList+            , fromAscOccurList++            -- ** IntMap+            , toMap+            , fromMap+            , fromOccurMap+            +            -- * Debugging+            , showTree+            , showTreeWith+            ) where++import Prelude   hiding  (map,filter)+import qualified Prelude (map,filter)++import qualified UU.DData.IntMap as M++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+infixl 9 \\ --++-- | /O(n+m)/. See 'difference'.+(\\) ::  IntBag -> IntBag -> IntBag+b1 \\ b2 = difference b1 b2++{--------------------------------------------------------------------+  IntBags are a simple wrapper around Maps, 'Map.Map'+--------------------------------------------------------------------}+-- | A bag of integers.+newtype IntBag  = IntBag (M.IntMap Int)++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | /O(1)/. Is the bag empty?+isEmpty :: IntBag -> Bool+isEmpty (IntBag m)  +  = M.isEmpty m++-- | /O(n)/. Returns the number of distinct elements in the bag, ie. (@distinctSize bag == length (nub (toList bag))@).+distinctSize :: IntBag -> Int+distinctSize (IntBag m)     +  = M.size m++-- | /O(n)/. The number of elements in the bag.+size :: IntBag -> Int+size b+  = foldOccur (\x n m -> n+m) 0 b++-- | /O(min(n,W))/. Is the element in the bag?+member ::  Int -> IntBag -> Bool+member x m+  = (occur x m > 0)++-- | /O(min(n,W))/. The number of occurrences of an element in the bag.+occur ::  Int -> IntBag -> Int+occur x (IntBag m)+  = case M.lookup x m of+      Nothing -> 0+      Just n  -> n++-- | /O(n+m)/. Is this a subset of the bag? +subset ::  IntBag -> IntBag -> Bool+subset (IntBag m1) (IntBag m2)+  = M.subsetBy (<=) m1 m2++-- | /O(n+m)/. Is this a proper subset? (ie. a subset and not equal)+properSubset ::  IntBag -> IntBag -> Bool+properSubset b1 b2+  = subset b1 b2 && (b1 /= b2)++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | /O(1)/. Create an empty bag.+empty :: IntBag+empty+  = IntBag (M.empty)++-- | /O(1)/. Create a singleton bag.+single :: Int -> IntBag+single x +  = IntBag (M.single x 0)+    +{--------------------------------------------------------------------+  Insertion, Deletion+--------------------------------------------------------------------}+-- | /O(min(n,W))/. Insert an element in the bag.+insert ::  Int -> IntBag -> IntBag+insert x (IntBag m)          +  = IntBag (M.insertWith (+) x 1 m)++-- | /O(min(n,W))/. The expression (@insertMany x count bag@)+-- inserts @count@ instances of @x@ in the bag @bag@.+insertMany ::  Int -> Int -> IntBag -> IntBag+insertMany x count (IntBag m)          +  = IntBag (M.insertWith (+) x count m)++-- | /O(min(n,W))/. Delete a single element.+delete ::  Int -> IntBag -> IntBag+delete x (IntBag m)+  = IntBag (M.updateWithKey f x m)+  where+    f x n  | n > 0     = Just (n-1)+           | otherwise = Nothing++-- | /O(min(n,W))/. Delete all occurrences of an element.+deleteAll ::  Int -> IntBag -> IntBag+deleteAll x (IntBag m)+  = IntBag (M.delete x m)++{--------------------------------------------------------------------+  Combine+--------------------------------------------------------------------}+-- | /O(n+m)/. Union of two bags. The union adds the elements together.+--+-- > IntBag\> union (fromList [1,1,2]) (fromList [1,2,2,3])+-- > {1,1,1,2,2,2,3}+union ::  IntBag -> IntBag -> IntBag+union (IntBag t1) (IntBag t2)+  = IntBag (M.unionWith (+) t1 t2)++-- | /O(n+m)/. Intersection of two bags.+--+-- > IntBag\> intersection (fromList [1,1,2]) (fromList [1,2,2,3])+-- > {1,2}+intersection ::  IntBag -> IntBag -> IntBag+intersection (IntBag t1) (IntBag t2)+  = IntBag (M.intersectionWith min t1 t2)++-- | /O(n+m)/. Difference between two bags.+--+-- > IntBag\> difference (fromList [1,1,2]) (fromList [1,2,2,3])+-- > {1}+difference   ::  IntBag -> IntBag -> IntBag+difference (IntBag t1) (IntBag t2)+  = IntBag (M.differenceWithKey f t1 t2)+  where+    f x n m  | n-m > 0   = Just (n-m)+             | otherwise = Nothing++-- | The union of a list of bags.+unions ::  [IntBag] -> IntBag+unions bags+  = IntBag (M.unions [m | IntBag m <- bags])++{--------------------------------------------------------------------+  Filter and partition+--------------------------------------------------------------------}+-- | /O(n)/. Filter all elements that satisfy some predicate.+filter ::  (Int -> Bool) -> IntBag -> IntBag+filter p (IntBag m)+  = IntBag (M.filterWithKey (\x n -> p x) m)++-- | /O(n)/. Partition the bag according to some predicate.+partition ::  (Int -> Bool) -> IntBag -> (IntBag,IntBag)+partition p (IntBag m)+  = (IntBag l,IntBag r)+  where+    (l,r) = M.partitionWithKey (\x n -> p x) m++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | /O(n)/. Fold over each element in the bag.+fold :: (Int -> b -> b) -> b -> IntBag -> b+fold f z (IntBag m)+  = M.foldWithKey apply z m+  where+    apply x n z  | n > 0     = apply x (n-1) (f x z)+                 | otherwise = z++-- | /O(n)/. Fold over all occurrences of an element at once. +-- In a call (@foldOccur f z bag@), the function @f@ takes+-- the element first and than the occur count.+foldOccur :: (Int -> Int -> b -> b) -> b -> IntBag -> b+foldOccur f z (IntBag m)+  = M.foldWithKey f z m++{--------------------------------------------------------------------+  List variations +--------------------------------------------------------------------}+-- | /O(n)/. The list of elements.+elems :: IntBag -> [Int]+elems s+  = toList s++{--------------------------------------------------------------------+  Lists +--------------------------------------------------------------------}+-- | /O(n)/. Create a list with all elements.+toList :: IntBag -> [Int]+toList s+  = toAscList s++-- | /O(n)/. Create an ascending list of all elements.+toAscList :: IntBag -> [Int]+toAscList (IntBag m)+  = [y | (x,n) <- M.toAscList m, y <- replicate n x]+++-- | /O(n*min(n,W))/. Create a bag from a list of elements.+fromList ::  [Int] -> IntBag +fromList xs+  = IntBag (M.fromListWith (+) [(x,1) | x <- xs])++-- | /O(n*min(n,W))/. Create a bag from an ascending list.+fromAscList :: [Int] -> IntBag +fromAscList xs+  = IntBag (M.fromAscListWith (+) [(x,1) | x <- xs])++-- | /O(n*min(n,W))/. Create a bag from an ascending list of distinct elements.+fromDistinctAscList :: [Int] -> IntBag +fromDistinctAscList xs+  = IntBag (M.fromDistinctAscList [(x,1) | x <- xs])++-- | /O(n)/. Create a list of element\/occurrence pairs.+toOccurList :: IntBag -> [(Int,Int)]+toOccurList b+  = toAscOccurList b++-- | /O(n)/. Create an ascending list of element\/occurrence pairs.+toAscOccurList :: IntBag -> [(Int,Int)]+toAscOccurList (IntBag m)+  = M.toAscList m++-- | /O(n*min(n,W))/. Create a bag from a list of element\/occurrence pairs.+fromOccurList ::  [(Int,Int)] -> IntBag+fromOccurList xs+  = IntBag (M.fromListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs))++-- | /O(n*min(n,W))/. Create a bag from an ascending list of element\/occurrence pairs.+fromAscOccurList ::  [(Int,Int)] -> IntBag+fromAscOccurList xs+  = IntBag (M.fromAscListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs))++{--------------------------------------------------------------------+  Maps+--------------------------------------------------------------------}+-- | /O(1)/. Convert to an 'IntMap.IntMap' from elements to number of occurrences.+toMap   :: IntBag -> M.IntMap Int+toMap (IntBag m)+  = m++-- | /O(n)/. Convert a 'IntMap.IntMap' from elements to occurrences into a bag.+fromMap ::  M.IntMap Int -> IntBag+fromMap m+  = IntBag (M.filter (>0) m)++-- | /O(1)/. Convert a 'IntMap.IntMap' from elements to occurrences into a bag.+-- Assumes that the 'IntMap.IntMap' contains only elements that occur at least once.+fromOccurMap :: M.IntMap Int -> IntBag+fromOccurMap m+  = IntBag m++{--------------------------------------------------------------------+  Eq, Ord+--------------------------------------------------------------------}+instance Eq (IntBag) where+  (IntBag m1) == (IntBag m2)  = (m1==m2) +  (IntBag m1) /= (IntBag m2)  = (m1/=m2)++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}+instance Show (IntBag) where+  showsPrec d b  = showSet (toAscList b)++showSet :: Show a => [a] -> ShowS+showSet []     +  = showString "{}" +showSet (x:xs) +  = showChar '{' . shows x . showTail xs+  where+    showTail []     = showChar '}'+    showTail (x:xs) = showChar ',' . shows x . showTail xs+    ++{--------------------------------------------------------------------+  Debugging+--------------------------------------------------------------------}+-- | /O(n)/. Show the tree structure that implements the 'IntBag'. The tree+-- is shown as a compressed and /hanging/.+showTree :: IntBag -> String+showTree bag+  = showTreeWith True False bag++-- | /O(n)/. The expression (@showTreeWith hang wide map@) shows+-- the tree that implements the bag. The tree is shown /hanging/ when @hang@ is @True@ +-- and otherwise as a /rotated/ tree. When @wide@ is @True@ an extra wide version+-- is shown.+showTreeWith :: Bool -> Bool -> IntBag -> String+showTreeWith hang wide (IntBag m)+  = M.showTreeWith hang wide m+
+ src/UU/DData/IntMap.hs view
@@ -0,0 +1,1240 @@+{-# OPTIONS -cpp -fglasgow-exts #-} +-------------------------------------------------------------------------------- +{-| Module      :  IntMap+    Copyright   :  (c) Daan Leijen 2002+    License     :  BSD-style++    Maintainer  :  daan@cs.uu.nl+    Stability   :  provisional+    Portability :  portable++  An efficient implementation of maps from integer keys to values. +  +  1) The module exports some names that clash with the "Prelude" -- 'lookup', 'map', and 'filter'. +      If you want to use "IntMap" unqualified, these functions should be hidden.++      > import Prelude hiding (map,lookup,filter)+      > import IntMap++      Another solution is to use qualified names. ++      > import qualified IntMap+      >+      > ... IntMap.single "Paris" "France"++      Or, if you prefer a terse coding style:++      > import qualified IntMap as M+      >+      > ... M.single "Paris" "France"++  2) The implementation is based on /big-endian patricia trees/. This data structure +  performs especially well on binary operations like 'union' and 'intersection'. However,+  my benchmarks show that it is also (much) faster on insertions and deletions when +  compared to a generic size-balanced map implementation (see "Map" and "Data.FiniteMap").+   +  *  Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+     Workshop on ML, September 1998, pages 77--86, <http://www.cse.ogi.edu/~andy/pub/finite.htm>++  *  D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information+     Coded In Alphanumeric/\", Journal of the ACM, 15(4), October 1968, pages 514--534.++  3) Many operations have a worst-case complexity of /O(min(n,W))/. This means that the+    operation can become linear in the number of elements +    with a maximum of /W/ -- the number of bits in an 'Int' (32 or 64). +-}+--------------------------------------------------------------------------------- +module UU.DData.IntMap  ( +            -- * Map type+              IntMap, Key          -- instance Eq,Show++            -- * Operators+            , (!), (\\)++            -- * Query+            , isEmpty+            , size+            , member+            , lookup+            , find          +            , findWithDefault+            +            -- * Construction+            , empty+            , single++            -- ** Insertion+            , insert+            , insertWith, insertWithKey, insertLookupWithKey+            +            -- ** Delete\/Update+            , delete+            , adjust+            , adjustWithKey+            , update+            , updateWithKey+            , updateLookupWithKey+  +            -- * Combine++            -- ** Union+            , union         +            , unionWith          +            , unionWithKey+            , unions++            -- ** Difference+            , difference+            , differenceWith+            , differenceWithKey+            +            -- ** Intersection+            , intersection           +            , intersectionWith+            , intersectionWithKey++            -- * Traversal+            -- ** Map+            , map+            , mapWithKey+            , mapAccum+            , mapAccumWithKey+            +            -- ** Fold+            , fold+            , foldWithKey++            -- * Conversion+            , elems+            , keys+            , assocs+            +            -- ** Lists+            , toList+            , fromList+            , fromListWith+            , fromListWithKey++            -- ** Ordered lists+            , toAscList+            , fromAscList+            , fromAscListWith+            , fromAscListWithKey+            , fromDistinctAscList++            -- * Filter +            , filter+            , filterWithKey+            , partition+            , partitionWithKey++            , split         +            , splitLookup   ++            -- * Subset+            , subset, subsetBy+            , properSubset, properSubsetBy+            +            -- * Debugging+            , showTree+            , showTreeWith+            ) where+++import Prelude hiding (lookup,map,filter)+import Bits +import Int++{-+-- just for testing+import qualified Prelude+import Debug.QuickCheck +import List (nub,sort)+import qualified List+-}  ++#ifdef __GLASGOW_HASKELL__+{--------------------------------------------------------------------+  GHC: use unboxing to get @shiftRL@ inlined.+--------------------------------------------------------------------}+#if __GLASGOW_HASKELL__ >= 503+import GHC.Word+import GHC.Exts ( Word(..), Int(..), shiftRL# )+#else+import Word+import GlaExts ( Word(..), Int(..), shiftRL# )+#endif++type Nat = Word++natFromInt :: Key -> Nat+natFromInt i = fromIntegral i++intFromNat :: Nat -> Key+intFromNat w = fromIntegral w++shiftRL :: Nat -> Key -> Nat+shiftRL (W# x) (I# i)+  = W# (shiftRL# x i)++#elif __HUGS__+{--------------------------------------------------------------------+ Hugs: + * raises errors on boundary values when using 'fromIntegral'+   but not with the deprecated 'fromInt/toInt'. + * Older Hugs doesn't define 'Word'.+ * Newer Hugs defines 'Word' in the Prelude but no operations.+--------------------------------------------------------------------}+import Word++type Nat = Word32   -- illegal on 64-bit platforms!++natFromInt :: Key -> Nat+natFromInt i = fromInt i++intFromNat :: Nat -> Key+intFromNat w = toInt w++shiftRL :: Nat -> Key -> Nat+shiftRL x i   = shiftR x i++#else+{--------------------------------------------------------------------+  'Standard' Haskell+  * A "Nat" is a natural machine word (an unsigned Int)+--------------------------------------------------------------------}+import Word++type Nat = Word++natFromInt :: Key -> Nat+natFromInt i = fromIntegral i++intFromNat :: Nat -> Key+intFromNat w = fromIntegral w++shiftRL :: Nat -> Key -> Nat+shiftRL w i   = shiftR w i++#endif++infixl 9 \\ --++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}++-- | /O(min(n,W))/. See 'find'.+(!) :: IntMap a -> Key -> a+(!) m k    = find k m++-- | /O(n+m)/. See 'difference'.+(\\) :: IntMap a -> IntMap a -> IntMap a+m1 \\ m2 = difference m1 m2++{--------------------------------------------------------------------+  Types  +--------------------------------------------------------------------}+-- | A map of integers to values @a@.+data IntMap a = Nil+              | Tip !Key a+              | Bin !Prefix !Mask !(IntMap a) !(IntMap a) ++type Prefix = Int+type Mask   = Int+type Key    = Int++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | /O(1)/. Is the map empty?+isEmpty :: IntMap a -> Bool+isEmpty Nil   = True+isEmpty other = False++-- | /O(n)/. Number of elements in the map.+size :: IntMap a -> Int+size t+  = case t of+      Bin p m l r -> size l + size r+      Tip k x -> 1+      Nil     -> 0++-- | /O(min(n,W))/. Is the key a member of the map?+member :: Key -> IntMap a -> Bool+member k m+  = case lookup k m of+      Nothing -> False+      Just x  -> True+    +-- | /O(min(n,W))/. Lookup the value of a key in the map.+lookup :: Key -> IntMap a -> Maybe a+lookup k t+  = case t of+      Bin p m l r +        | nomatch k p m -> Nothing+        | zero k m      -> lookup k l+        | otherwise     -> lookup k r+      Tip kx x +        | (k==kx)   -> Just x+        | otherwise -> Nothing+      Nil -> Nothing++-- | /O(min(n,W))/. Find the value of a key. Calls @error@ when the element can not be found.+find :: Key -> IntMap a -> a+find k m+  = case lookup k m of+      Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map")+      Just x  -> x++-- | /O(min(n,W))/. The expression @(findWithDefault def k map)@ returns the value of key @k@ or returns @def@ when+-- the key is not an element of the map.+findWithDefault :: a -> Key -> IntMap a -> a+findWithDefault def k m+  = case lookup k m of+      Nothing -> def+      Just x  -> x++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | /O(1)/. The empty map.+empty :: IntMap a+empty+  = Nil++-- | /O(1)/. A map of one element.+single :: Key -> a -> IntMap a+single k x+  = Tip k x++{--------------------------------------------------------------------+  Insert+  'insert' is the inlined version of 'insertWith (\k x y -> x)'+--------------------------------------------------------------------}+-- | /O(min(n,W))/. Insert a new key\/value pair in the map. When the key +-- is already an element of the set, it's value is replaced by the new value, +-- ie. 'insert' is left-biased.+insert :: Key -> a -> IntMap a -> IntMap a+insert k x t+  = case t of+      Bin p m l r +        | nomatch k p m -> join k (Tip k x) p t+        | zero k m      -> Bin p m (insert k x l) r+        | otherwise     -> Bin p m l (insert k x r)+      Tip ky y +        | k==ky         -> Tip k x+        | otherwise     -> join k (Tip k x) ky t+      Nil -> Tip k x++-- right-biased insertion, used by 'union'+-- | /O(min(n,W))/. Insert with a combining function.+insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWith f k x t+  = insertWithKey (\k x y -> f x y) k x t++-- | /O(min(n,W))/. Insert with a combining function.+insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWithKey f k x t+  = case t of+      Bin p m l r +        | nomatch k p m -> join k (Tip k x) p t+        | zero k m      -> Bin p m (insertWithKey f k x l) r+        | otherwise     -> Bin p m l (insertWithKey f k x r)+      Tip ky y +        | k==ky         -> Tip k (f k x y)+        | otherwise     -> join k (Tip k x) ky t+      Nil -> Tip k x+++-- | /O(min(n,W))/. The expression (@insertLookupWithKey f k x map@) is a pair where+-- the first element is equal to (@lookup k map@) and the second element+-- equal to (@insertWithKey f k x map@).+insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)+insertLookupWithKey f k x t+  = case t of+      Bin p m l r +        | nomatch k p m -> (Nothing,join k (Tip k x) p t)+        | zero k m      -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r)+        | otherwise     -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')+      Tip ky y +        | k==ky         -> (Just y,Tip k (f k x y))+        | otherwise     -> (Nothing,join k (Tip k x) ky t)+      Nil -> (Nothing,Tip k x)+++{--------------------------------------------------------------------+  Deletion+  [delete] is the inlined version of [deleteWith (\k x -> Nothing)]+--------------------------------------------------------------------}+-- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+delete :: Key -> IntMap a -> IntMap a+delete k t+  = case t of+      Bin p m l r +        | nomatch k p m -> t+        | zero k m      -> bin p m (delete k l) r+        | otherwise     -> bin p m l (delete k r)+      Tip ky y +        | k==ky         -> Nil+        | otherwise     -> t+      Nil -> Nil++-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+adjust ::  (a -> a) -> Key -> IntMap a -> IntMap a+adjust f k m+  = adjustWithKey (\k x -> f x) k m++-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+adjustWithKey ::  (Key -> a -> a) -> Key -> IntMap a -> IntMap a+adjustWithKey f k m+  = updateWithKey (\k x -> Just (f k x)) k m++-- | /O(min(n,W))/. The expression (@update f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is @Nothing@, the element is+-- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.+update ::  (a -> Maybe a) -> Key -> IntMap a -> IntMap a+update f k m+  = updateWithKey (\k x -> f x) k m++-- | /O(min(n,W))/. The expression (@update f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f k x@) is @Nothing@, the element is+-- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.+updateWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a+updateWithKey f k t+  = case t of+      Bin p m l r +        | nomatch k p m -> t+        | zero k m      -> bin p m (updateWithKey f k l) r+        | otherwise     -> bin p m l (updateWithKey f k r)+      Tip ky y +        | k==ky         -> case (f k y) of+                             Just y' -> Tip ky y'+                             Nothing -> Nil+        | otherwise     -> t+      Nil -> Nil++-- | /O(min(n,W))/. Lookup and update.+updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)+updateLookupWithKey f k t+  = case t of+      Bin p m l r +        | nomatch k p m -> (Nothing,t)+        | zero k m      -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r)+        | otherwise     -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r')+      Tip ky y +        | k==ky         -> case (f k y) of+                             Just y' -> (Just y,Tip ky y')+                             Nothing -> (Just y,Nil)+        | otherwise     -> (Nothing,t)+      Nil -> (Nothing,Nil)+++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+-- | The union of a list of maps.+unions :: [IntMap a] -> IntMap a+unions xs+  = foldlStrict union empty xs+++-- | /O(n+m)/. The (left-biased) union of two sets. +union :: IntMap a -> IntMap a -> IntMap a+union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = union1+  | shorter m2 m1  = union2+  | p1 == p2       = Bin p1 m1 (union l1 l2) (union r1 r2)+  | otherwise      = join p1 t1 p2 t2+  where+    union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2+            | zero p2 m1        = Bin p1 m1 (union l1 t2) r1+            | otherwise         = Bin p1 m1 l1 (union r1 t2)++    union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2+            | zero p1 m2        = Bin p2 m2 (union t1 l2) r2+            | otherwise         = Bin p2 m2 l2 (union t1 r2)++union (Tip k x) t = insert k x t+union t (Tip k x) = insertWith (\x y -> y) k x t  -- right bias+union Nil t       = t+union t Nil       = t++-- | /O(n+m)/. The union with a combining function. +unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWith f m1 m2+  = unionWithKey (\k x y -> f x y) m1 m2++-- | /O(n+m)/. The union with a combining function. +unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = union1+  | shorter m2 m1  = union2+  | p1 == p2       = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2)+  | otherwise      = join p1 t1 p2 t2+  where+    union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2+            | zero p2 m1        = Bin p1 m1 (unionWithKey f l1 t2) r1+            | otherwise         = Bin p1 m1 l1 (unionWithKey f r1 t2)++    union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2+            | zero p1 m2        = Bin p2 m2 (unionWithKey f t1 l2) r2+            | otherwise         = Bin p2 m2 l2 (unionWithKey f t1 r2)++unionWithKey f (Tip k x) t = insertWithKey f k x t+unionWithKey f t (Tip k x) = insertWithKey (\k x y -> f k y x) k x t  -- right bias+unionWithKey f Nil t  = t+unionWithKey f t Nil  = t++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | /O(n+m)/. Difference between two maps (based on keys). +difference :: IntMap a -> IntMap a -> IntMap a+difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = difference1+  | shorter m2 m1  = difference2+  | p1 == p2       = bin p1 m1 (difference l1 l2) (difference r1 r2)+  | otherwise      = t1+  where+    difference1 | nomatch p2 p1 m1  = t1+                | zero p2 m1        = bin p1 m1 (difference l1 t2) r1+                | otherwise         = bin p1 m1 l1 (difference r1 t2)++    difference2 | nomatch p1 p2 m2  = t1+                | zero p1 m2        = difference t1 l2+                | otherwise         = difference t1 r2++difference t1@(Tip k x) t2 +  | member k t2  = Nil+  | otherwise    = t1++difference Nil t       = Nil+difference t (Tip k x) = delete k t+difference t Nil       = t++-- | /O(n+m)/. Difference with a combining function. +differenceWith :: (a -> a -> Maybe a) -> IntMap a -> IntMap a -> IntMap a+differenceWith f m1 m2+  = differenceWithKey (\k x y -> f x y) m1 m2++-- | /O(n+m)/. Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns @Nothing@, the element is discarded (proper set difference). If+-- it returns (@Just y@), the element is updated with a new value @y@. +differenceWithKey :: (Key -> a -> a -> Maybe a) -> IntMap a -> IntMap a -> IntMap a+differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = difference1+  | shorter m2 m1  = difference2+  | p1 == p2       = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2)+  | otherwise      = t1+  where+    difference1 | nomatch p2 p1 m1  = t1+                | zero p2 m1        = bin p1 m1 (differenceWithKey f l1 t2) r1+                | otherwise         = bin p1 m1 l1 (differenceWithKey f r1 t2)++    difference2 | nomatch p1 p2 m2  = t1+                | zero p1 m2        = differenceWithKey f t1 l2+                | otherwise         = differenceWithKey f t1 r2++differenceWithKey f t1@(Tip k x) t2 +  = case lookup k t2 of+      Just y  -> case f k x y of+                   Just y' -> Tip k y'+                   Nothing -> Nil+      Nothing -> t1++differenceWithKey f Nil t       = Nil+differenceWithKey f t (Tip k y) = updateWithKey (\k x -> f k x y) k t+differenceWithKey f t Nil       = t+++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys). +intersection :: IntMap a -> IntMap a -> IntMap a+intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = intersection1+  | shorter m2 m1  = intersection2+  | p1 == p2       = bin p1 m1 (intersection l1 l2) (intersection r1 r2)+  | otherwise      = Nil+  where+    intersection1 | nomatch p2 p1 m1  = Nil+                  | zero p2 m1        = intersection l1 t2+                  | otherwise         = intersection r1 t2++    intersection2 | nomatch p1 p2 m2  = Nil+                  | zero p1 m2        = intersection t1 l2+                  | otherwise         = intersection t1 r2++intersection t1@(Tip k x) t2 +  | member k t2  = t1+  | otherwise    = Nil+intersection t (Tip k x) +  = case lookup k t of+      Just y  -> Tip k y+      Nothing -> Nil+intersection Nil t = Nil+intersection t Nil = Nil++-- | /O(n+m)/. The intersection with a combining function. +intersectionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+intersectionWith f m1 m2+  = intersectionWithKey (\k x y -> f x y) m1 m2++-- | /O(n+m)/. The intersection with a combining function. +intersectionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = intersection1+  | shorter m2 m1  = intersection2+  | p1 == p2       = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2)+  | otherwise      = Nil+  where+    intersection1 | nomatch p2 p1 m1  = Nil+                  | zero p2 m1        = intersectionWithKey f l1 t2+                  | otherwise         = intersectionWithKey f r1 t2++    intersection2 | nomatch p1 p2 m2  = Nil+                  | zero p1 m2        = intersectionWithKey f t1 l2+                  | otherwise         = intersectionWithKey f t1 r2++intersectionWithKey f t1@(Tip k x) t2 +  = case lookup k t2 of+      Just y  -> Tip k (f k x y)+      Nothing -> Nil+intersectionWithKey f t1 (Tip k y) +  = case lookup k t1 of+      Just x  -> Tip k (f k x y)+      Nothing -> Nil+intersectionWithKey f Nil t = Nil+intersectionWithKey f t Nil = Nil+++{--------------------------------------------------------------------+  Subset+--------------------------------------------------------------------}+-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). +-- Defined as (@properSubset = properSubsetBy (==)@).+properSubset :: Eq a => IntMap a -> IntMap a -> Bool+properSubset m1 m2+  = properSubsetBy (==) m1 m2++{- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).+ The expression (@properSubsetBy f m1 m2@) returns @True@ when+ @m1@ and @m2@ are not equal,+ all keys in @m1@ are in @m2@, and when @f@ returns @True@ when+ applied to their respective values. For example, the following + expressions are all @True@.+ +  > properSubsetBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > properSubsetBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])++ But the following are all @False@:+ +  > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])+  > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+  > properSubsetBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])+-}+properSubsetBy :: (a -> a -> Bool) -> IntMap a -> IntMap a -> Bool+properSubsetBy pred t1 t2+  = case subsetCmp pred t1 t2 of +      LT -> True+      ge -> False++subsetCmp pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = GT+  | shorter m2 m1  = subsetCmpLt+  | p1 == p2       = subsetCmpEq+  | otherwise      = GT  -- disjoint+  where+    subsetCmpLt | nomatch p1 p2 m2  = GT+                | zero p1 m2        = subsetCmp pred t1 l2+                | otherwise         = subsetCmp pred t1 r2+    subsetCmpEq = case (subsetCmp pred l1 l2, subsetCmp pred r1 r2) of+                    (GT,_ ) -> GT+                    (_ ,GT) -> GT+                    (EQ,EQ) -> EQ+                    other   -> LT++subsetCmp pred (Bin p m l r) t  = GT+subsetCmp pred (Tip kx x) (Tip ky y)  +  | (kx == ky) && pred x y = EQ+  | otherwise              = GT  -- disjoint+subsetCmp pred (Tip k x) t      +  = case lookup k t of+     Just y  | pred x y -> LT+     other   -> GT -- disjoint+subsetCmp pred Nil Nil = EQ+subsetCmp pred Nil t   = LT++-- | /O(n+m)/. Is this a subset? Defined as (@subset = subsetBy (==)@).+subset :: Eq a => IntMap a -> IntMap a -> Bool+subset m1 m2+  = subsetBy (==) m1 m2++{- | /O(n+m)/. + The expression (@subsetBy f m1 m2@) returns @True@ if+ all keys in @m1@ are in @m2@, and when @f@ returns @True@ when+ applied to their respective values. For example, the following + expressions are all @True@.+ +  > subsetBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > subsetBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > subsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])++ But the following are all @False@:+ +  > subsetBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])+  > subsetBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > subsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+-}++subsetBy :: (a -> a -> Bool) -> IntMap a -> IntMap a -> Bool+subsetBy pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = False+  | shorter m2 m1  = match p1 p2 m2 && (if zero p1 m2 then subsetBy pred t1 l2+                                                      else subsetBy pred t1 r2)                     +  | otherwise      = (p1==p2) && subsetBy pred l1 l2 && subsetBy pred r1 r2+subsetBy pred (Bin p m l r) t  = False+subsetBy pred (Tip k x) t      = case lookup k t of+                                   Just y  -> pred x y+                                   Nothing -> False +subsetBy pred Nil t            = True++{--------------------------------------------------------------------+  Mapping+--------------------------------------------------------------------}+-- | /O(n)/. Map a function over all values in the map.+map :: (a -> b) -> IntMap a -> IntMap b+map f m+  = mapWithKey (\k x -> f x) m++-- | /O(n)/. Map a function over all values in the map.+mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b+mapWithKey f t  +  = case t of+      Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)+      Tip k x     -> Tip k (f k x)+      Nil         -> Nil++-- | /O(n)/. The function @mapAccum@ threads an accumulating+-- argument through the map in an unspecified order.+mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccum f a m+  = mapAccumWithKey (\a k x -> f a x) a m++-- | /O(n)/. The function @mapAccumWithKey@ threads an accumulating+-- argument through the map in an unspecified order.+mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumWithKey f a t+  = mapAccumL f a t++-- | /O(n)/. The function @mapAccumL@ threads an accumulating+-- argument through the map in pre-order.+mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumL f a t+  = case t of+      Bin p m l r -> let (a1,l') = mapAccumL f a l+                         (a2,r') = mapAccumL f a1 r+                     in (a2,Bin p m l' r')+      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')+      Nil         -> (a,Nil)+++-- | /O(n)/. The function @mapAccumR@ threads an accumulating+-- argument throught the map in post-order.+mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumR f a t+  = case t of+      Bin p m l r -> let (a1,r') = mapAccumR f a r+                         (a2,l') = mapAccumR f a1 l+                     in (a2,Bin p m l' r')+      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')+      Nil         -> (a,Nil)++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | /O(n)/. Filter all values that satisfy some predicate.+filter :: (a -> Bool) -> IntMap a -> IntMap a+filter p m+  = filterWithKey (\k x -> p x) m++-- | /O(n)/. Filter all keys\/values that satisfy some predicate.+filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a+filterWithKey pred t+  = case t of+      Bin p m l r +        -> bin p m (filterWithKey pred l) (filterWithKey pred r)+      Tip k x +        | pred k x  -> t+        | otherwise -> Nil+      Nil -> Nil++-- | /O(n)/. partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partition p m+  = partitionWithKey (\k x -> p x) m++-- | /O(n)/. partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partitionWithKey pred t+  = case t of+      Bin p m l r +        -> let (l1,l2) = partitionWithKey pred l+               (r1,r2) = partitionWithKey pred r+           in (bin p m l1 r1, bin p m l2 r2)+      Tip k x +        | pred k x  -> (t,Nil)+        | otherwise -> (Nil,t)+      Nil -> (Nil,Nil)+++-- | /O(log n)/. The expression (@split k map@) is a pair @(map1,map2)@+-- where all keys in @map1@ are lower than @k@ and all keys in+-- @map2@ larger than @k@.+split :: Key -> IntMap a -> (IntMap a,IntMap a)+split k t+  = case t of+      Bin p m l r+        | zero k m  -> let (lt,gt) = split k l in (lt,union gt r)+        | otherwise -> let (lt,gt) = split k r in (union l lt,gt)+      Tip ky y +        | k>ky      -> (t,Nil)+        | k<ky      -> (Nil,t)+        | otherwise -> (Nil,Nil)+      Nil -> (Nil,Nil)++-- | /O(log n)/. Performs a 'split' but also returns whether the pivot+-- key was found in the original map.+splitLookup :: Key -> IntMap a -> (Maybe a,IntMap a,IntMap a)+splitLookup k t+  = case t of+      Bin p m l r+        | zero k m  -> let (found,lt,gt) = splitLookup k l in (found,lt,union gt r)+        | otherwise -> let (found,lt,gt) = splitLookup k r in (found,union l lt,gt)+      Tip ky y +        | k>ky      -> (Nothing,t,Nil)+        | k<ky      -> (Nothing,Nil,t)+        | otherwise -> (Just y,Nil,Nil)+      Nil -> (Nothing,Nil,Nil)++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | /O(n)/. Fold over the elements of a map in an unspecified order.+--+-- > sum map   = fold (+) 0 map+-- > elems map = fold (:) [] map+fold :: (a -> b -> b) -> b -> IntMap a -> b+fold f z t+  = foldWithKey (\k x y -> f x y) z t++-- | /O(n)/. Fold over the elements of a map in an unspecified order.+--+-- > keys map = foldWithKey (\k x ks -> k:ks) [] map+foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldWithKey f z t+  = foldR f z t++foldR :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldR f z t+  = case t of+      Bin p m l r -> foldR f (foldR f z r) l+      Tip k x     -> f k x z+      Nil         -> z++{--------------------------------------------------------------------+  List variations +--------------------------------------------------------------------}+-- | /O(n)/. Return all elements of the map.+elems :: IntMap a -> [a]+elems m+  = foldWithKey (\k x xs -> x:xs) [] m  ++-- | /O(n)/. Return all keys of the map.+keys  :: IntMap a -> [Key]+keys m+  = foldWithKey (\k x ks -> k:ks) [] m++-- | /O(n)/. Return all key\/value pairs in the map.+assocs :: IntMap a -> [(Key,a)]+assocs m+  = toList m+++{--------------------------------------------------------------------+  Lists +--------------------------------------------------------------------}+-- | /O(n)/. Convert the map to a list of key\/value pairs.+toList :: IntMap a -> [(Key,a)]+toList t+  = foldWithKey (\k x xs -> (k,x):xs) [] t++-- | /O(n)/. Convert the map to a list of key\/value pairs where the+-- keys are in ascending order.+toAscList :: IntMap a -> [(Key,a)]+toAscList t   +  = -- NOTE: the following algorithm only works for big-endian trees+    let (pos,neg) = span (\(k,x) -> k >=0) (foldR (\k x xs -> (k,x):xs) [] t) in neg ++ pos++-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.+fromList :: [(Key,a)] -> IntMap a+fromList xs+  = foldlStrict ins empty xs+  where+    ins t (k,x)  = insert k x t++-- | /O(n*min(n,W))/.  Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a +fromListWith f xs+  = fromListWithKey (\k x y -> f x y) xs++-- | /O(n*min(n,W))/.  Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.+fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a +fromListWithKey f xs +  = foldlStrict ins empty xs+  where+    ins t (k,x) = insertWithKey f k x t++-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order.+fromAscList :: [(Key,a)] -> IntMap a+fromAscList xs+  = fromList xs++-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWith f xs+  = fromListWith f xs++-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWithKey f xs+  = fromListWithKey f xs++-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order and all distinct.+fromDistinctAscList :: [(Key,a)] -> IntMap a+fromDistinctAscList xs+  = fromList xs+++{--------------------------------------------------------------------+  Eq +--------------------------------------------------------------------}+instance Eq a => Eq (IntMap a) where+  t1 == t2  = equal t1 t2+  t1 /= t2  = nequal t1 t2++equal :: Eq a => IntMap a -> IntMap a -> Bool+equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) +equal (Tip kx x) (Tip ky y)+  = (kx == ky) && (x==y)+equal Nil Nil = True+equal t1 t2   = False++nequal :: Eq a => IntMap a -> IntMap a -> Bool+nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) +nequal (Tip kx x) (Tip ky y)+  = (kx /= ky) || (x/=y)+nequal Nil Nil = False+nequal t1 t2   = True++instance Show a => Show (IntMap a) where+  showsPrec d t   = showMap (toList t)+++showMap :: (Show a) => [(Key,a)] -> ShowS+showMap []     +  = showString "{}" +showMap (x:xs) +  = showChar '{' . showElem x . showTail xs+  where+    showTail []     = showChar '}'+    showTail (x:xs) = showChar ',' . showElem x . showTail xs+    +    showElem (k,x)  = shows k . showString ":=" . shows x+  +{--------------------------------------------------------------------+  Debugging+--------------------------------------------------------------------}+-- | /O(n)/. Show the tree that implements the map. The tree is shown+-- in a compressed, hanging format.+showTree :: Show a => IntMap a -> String+showTree s+  = showTreeWith True False s+++{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows+ the tree that implements the map. If @hang@ is+ @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is true, an extra wide version is shown.+-}+showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String+showTreeWith hang wide t+  | hang      = (showsTreeHang wide [] t) ""+  | otherwise = (showsTree wide [] [] t) ""++showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS+showsTree wide lbars rbars t+  = case t of+      Bin p m l r+          -> showsTree wide (withBar rbars) (withEmpty rbars) r .+             showWide wide rbars .+             showsBars lbars . showString (showBin p m) . showString "\n" .+             showWide wide lbars .+             showsTree wide (withEmpty lbars) (withBar lbars) l+      Tip k x+          -> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n" +      Nil -> showsBars lbars . showString "|\n"++showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS+showsTreeHang wide bars t+  = case t of+      Bin p m l r+          -> showsBars bars . showString (showBin p m) . showString "\n" . +             showWide wide bars .+             showsTreeHang wide (withBar bars) l .+             showWide wide bars .+             showsTreeHang wide (withEmpty bars) r+      Tip k x+          -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n" +      Nil -> showsBars bars . showString "|\n" +      +showBin p m+  = "*" -- ++ show (p,m)++showWide wide bars +  | wide      = showString (concat (reverse bars)) . showString "|\n" +  | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+  = case bars of+      [] -> id+      _  -> showString (concat (reverse (tail bars))) . showString node++node           = "+--"+withBar bars   = "|  ":bars+withEmpty bars = "   ":bars+++{--------------------------------------------------------------------+  Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+  Join+--------------------------------------------------------------------}+join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a+join p1 t1 p2 t2+  | zero p1 m = Bin p m t1 t2+  | otherwise = Bin p m t2 t1+  where+    m = branchMask p1 p2+    p = mask p1 m++{--------------------------------------------------------------------+  @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}+bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a+bin p m l Nil = l+bin p m Nil r = r+bin p m l r   = Bin p m l r++  +{--------------------------------------------------------------------+  Endian independent bit twiddling+--------------------------------------------------------------------}+zero :: Key -> Mask -> Bool+zero i m+  = (natFromInt i) .&. (natFromInt m) == 0++nomatch,match :: Key -> Prefix -> Mask -> Bool+nomatch i p m+  = (mask i m) /= p++match i p m+  = (mask i m) == p++mask :: Key -> Mask -> Prefix+mask i m+  = maskW (natFromInt i) (natFromInt m)+++{--------------------------------------------------------------------+  Big endian operations  +--------------------------------------------------------------------}+maskW :: Nat -> Nat -> Prefix+maskW i m+  = intFromNat (i .&. (complement (m-1) `xor` m))++shorter :: Mask -> Mask -> Bool+shorter m1 m2+  = (natFromInt m1) > (natFromInt m2)++branchMask :: Prefix -> Prefix -> Mask+branchMask p1 p2+  = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))+  +{----------------------------------------------------------------------+  Finding the highest bit (mask) in a word [x] can be done efficiently in+  three ways:+  * convert to a floating point value and the mantissa tells us the +    [log2(x)] that corresponds with the highest bit position. The mantissa +    is retrieved either via the standard C function [frexp] or by some bit +    twiddling on IEEE compatible numbers (float). Note that one needs to +    use at least [double] precision for an accurate mantissa of 32 bit +    numbers.+  * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).+  * use processor specific assembler instruction (asm).++  The most portable way would be [bit], but is it efficient enough?+  I have measured the cycle counts of the different methods on an AMD +  Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:++  highestBitMask: method  cycles+                  --------------+                   frexp   200+                   float    33+                   bit      11+                   asm      12++  highestBit:     method  cycles+                  --------------+                   frexp   195+                   float    33+                   bit      11+                   asm      11++  Wow, the bit twiddling is on today's RISC like machines even faster+  than a single CISC instruction (BSR)!+----------------------------------------------------------------------}++{----------------------------------------------------------------------+  [highestBitMask] returns a word where only the highest bit is set.+  It is found by first setting all bits in lower positions than the +  highest bit and than taking an exclusive or with the original value.+  Allthough the function may look expensive, GHC compiles this into+  excellent C code that subsequently compiled into highly efficient+  machine code. The algorithm is derived from Jorg Arndt's FXT library.+----------------------------------------------------------------------}+highestBitMask :: Nat -> Nat+highestBitMask x+  = case (x .|. shiftRL x 1) of +     x -> case (x .|. shiftRL x 2) of +      x -> case (x .|. shiftRL x 4) of +       x -> case (x .|. shiftRL x 8) of +        x -> case (x .|. shiftRL x 16) of +         x -> case (x .|. shiftRL x 32) of   -- for 64 bit platforms+          x -> (x `xor` (shiftRL x 1))+++{--------------------------------------------------------------------+  Utilities +--------------------------------------------------------------------}+foldlStrict f z xs+  = case xs of+      []     -> z+      (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)++{-+{--------------------------------------------------------------------+  Testing+--------------------------------------------------------------------}+testTree :: [Int] -> IntMap Int+testTree xs   = fromList [(x,x*x*30696 `mod` 65521) | x <- xs]+test1 = testTree [1..20]+test2 = testTree [30,29..10]+test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]++{--------------------------------------------------------------------+  QuickCheck+--------------------------------------------------------------------}+qcheck prop+  = check config prop+  where+    config = Config+      { configMaxTest = 500+      , configMaxFail = 5000+      , configSize    = \n -> (div n 2 + 3)+      , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]+      }+++{--------------------------------------------------------------------+  Arbitrary, reasonably balanced trees+--------------------------------------------------------------------}+instance Arbitrary a => Arbitrary (IntMap a) where+  arbitrary = do{ ks <- arbitrary+                ; xs <- mapM (\k -> do{ x <- arbitrary; return (k,x)}) ks+                ; return (fromList xs)+                }+++{--------------------------------------------------------------------+  Single, Insert, Delete+--------------------------------------------------------------------}+prop_Single :: Key -> Int -> Bool+prop_Single k x+  = (insert k x empty == single k x)++prop_InsertDelete :: Key -> Int -> IntMap Int -> Property+prop_InsertDelete k x t+  = not (member k t) ==> delete k (insert k x t) == t++prop_UpdateDelete :: Key -> IntMap Int -> Bool  +prop_UpdateDelete k t+  = update (const Nothing) k t == delete k t+++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+prop_UnionInsert :: Key -> Int -> IntMap Int -> Bool+prop_UnionInsert k x t+  = union (single k x) t == insert k x t++prop_UnionAssoc :: IntMap Int -> IntMap Int -> IntMap Int -> Bool+prop_UnionAssoc t1 t2 t3+  = union t1 (union t2 t3) == union (union t1 t2) t3++prop_UnionComm :: IntMap Int -> IntMap Int -> Bool+prop_UnionComm t1 t2+  = (union t1 t2 == unionWith (\x y -> y) t2 t1)+++prop_Diff :: [(Key,Int)] -> [(Key,Int)] -> Bool+prop_Diff xs ys+  =  List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys))) +    == List.sort ((List.\\) (nub (Prelude.map fst xs))  (nub (Prelude.map fst ys)))++prop_Int :: [(Key,Int)] -> [(Key,Int)] -> Bool+prop_Int xs ys+  =  List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys))) +    == List.sort (nub ((List.intersect) (Prelude.map fst xs)  (Prelude.map fst ys)))++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}+prop_Ordered+  = forAll (choose (5,100)) $ \n ->+    let xs = [(x,()) | x <- [0..n::Int]] +    in fromAscList xs == fromList xs++prop_List :: [Key] -> Bool+prop_List xs+  = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])])+-}
+ src/UU/DData/IntSet.hs view
@@ -0,0 +1,852 @@+{-# OPTIONS -cpp -fglasgow-exts #-}+--------------------------------------------------------------------------------+{-| Module      :  IntSet+    Copyright   :  (c) Daan Leijen 2002+    License     :  BSD-style++    Maintainer  :  daan@cs.uu.nl+    Stability   :  provisional+    Portability :  portable++  An efficient implementation of integer sets.+  +  1) The 'filter' function clashes with the "Prelude". +      If you want to use "IntSet" unqualified, this function should be hidden.++      > import Prelude hiding (filter)+      > import IntSet++      Another solution is to use qualified names. ++      > import qualified IntSet+      >+      > ... IntSet.fromList [1..5]++      Or, if you prefer a terse coding style:++      > import qualified IntSet as S+      >+      > ... S.fromList [1..5]++  2) The implementation is based on /big-endian patricia trees/. This data structure +  performs especially well on binary operations like 'union' and 'intersection'. However,+  my benchmarks show that it is also (much) faster on insertions and deletions when +  compared to a generic size-balanced set implementation (see "Set").+   +  *  Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+     Workshop on ML, September 1998, pages 77--86, <http://www.cse.ogi.edu/~andy/pub/finite.htm>++  *  D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information+     Coded In Alphanumeric/\", Journal of the ACM, 15(4), October 1968, pages 514--534.++  3) Many operations have a worst-case complexity of /O(min(n,W))/. This means that the+    operation can become linear in the number of elements +    with a maximum of /W/ -- the number of bits in an 'Int' (32 or 64). +-}+---------------------------------------------------------------------------------}+module UU.DData.IntSet  ( +            -- * Set type+              IntSet          -- instance Eq,Show++            -- * Operators+            , (\\)++            -- * Query+            , isEmpty+            , size+            , member+            , subset+            , properSubset+            +            -- * Construction+            , empty+            , single+            , insert+            , delete+            +            -- * Combine+            , union, unions+            , difference+            , intersection+            +            -- * Filter+            , filter+            , partition+            , split+            , splitMember++            -- * Fold+            , fold++            -- * Conversion+            -- ** List+            , elems+            , toList+            , fromList+            +            -- ** Ordered list+            , toAscList+            , fromAscList+            , fromDistinctAscList+                        +            -- * Debugging+            , showTree+            , showTreeWith+            ) where+++import Prelude hiding (lookup,filter)+import Bits +import Int++{-+-- just for testing+import QuickCheck +import List (nub,sort)+import qualified List+-}+++#ifdef __GLASGOW_HASKELL__+{--------------------------------------------------------------------+  GHC: use unboxing to get @shiftRL@ inlined.+--------------------------------------------------------------------}+#if __GLASGOW_HASKELL__ >= 503+import GHC.Word+import GHC.Exts ( Word(..), Int(..), shiftRL# )+#else+import Word+import GlaExts ( Word(..), Int(..), shiftRL# )+#endif+++type Nat = Word++natFromInt :: Int -> Nat+natFromInt i = fromIntegral i++intFromNat :: Nat -> Int+intFromNat w = fromIntegral w++shiftRL :: Nat -> Int -> Nat+shiftRL (W# x) (I# i)+  = W# (shiftRL# x i)++#elif __HUGS__+{--------------------------------------------------------------------+ Hugs: + * raises errors on boundary values when using 'fromIntegral'+   but not with the deprecated 'fromInt/toInt'. + * Older Hugs doesn't define 'Word'.+ * Newer Hugs defines 'Word' in the Prelude but no operations.+--------------------------------------------------------------------}+import Word++type Nat = Word32   -- illegal on 64-bit platforms!++natFromInt :: Int -> Nat+natFromInt i = fromInt i++intFromNat :: Nat -> Int+intFromNat w = toInt w++shiftRL :: Nat -> Int -> Nat+shiftRL x i   = shiftR x i++#else+{--------------------------------------------------------------------+  'Standard' Haskell+  * A "Nat" is a natural machine word (an unsigned Int)+--------------------------------------------------------------------}+import Word++type Nat = Word++natFromInt :: Int -> Nat+natFromInt i = fromIntegral i++intFromNat :: Nat -> Int+intFromNat w = fromIntegral w++shiftRL :: Nat -> Int -> Nat+shiftRL w i   = shiftR w i++#endif++infixl 9 \\ --++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+-- | /O(n+m)/. See 'difference'.+(\\) :: IntSet -> IntSet -> IntSet+m1 \\ m2 = difference m1 m2++{--------------------------------------------------------------------+  Types  +--------------------------------------------------------------------}+-- | A set of integers.+data IntSet = Nil+            | Tip !Int+            | Bin !Prefix !Mask !IntSet !IntSet++type Prefix = Int+type Mask   = Int++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | /O(1)/. Is the set empty?+isEmpty :: IntSet -> Bool+isEmpty Nil   = True+isEmpty other = False++-- | /O(n)/. Cardinality of the set.+size :: IntSet -> Int+size t+  = case t of+      Bin p m l r -> size l + size r+      Tip y -> 1+      Nil   -> 0++-- | /O(min(n,W))/. Is the value a member of the set?+member :: Int -> IntSet -> Bool+member x t+  = case t of+      Bin p m l r +        | nomatch x p m -> False+        | zero x m      -> member x l+        | otherwise     -> member x r+      Tip y -> (x==y)+      Nil   -> False+    +-- 'lookup' is used by 'intersection' for left-biasing+lookup :: Int -> IntSet -> Maybe Int+lookup x t+  = case t of+      Bin p m l r +        | nomatch x p m -> Nothing+        | zero x m      -> lookup x l+        | otherwise     -> lookup x r+      Tip y +        | (x==y)    -> Just y+        | otherwise -> Nothing+      Nil -> Nothing++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | /O(1)/. The empty set.+empty :: IntSet+empty+  = Nil++-- | /O(1)/. A set of one element.+single :: Int -> IntSet+single x+  = Tip x++{--------------------------------------------------------------------+  Insert+--------------------------------------------------------------------}+-- | /O(min(n,W))/. Add a value to the set. When the value is already+-- an element of the set, it is replaced by the new one, ie. 'insert'+-- is left-biased.+insert :: Int -> IntSet -> IntSet+insert x t+  = case t of+      Bin p m l r +        | nomatch x p m -> join x (Tip x) p t+        | zero x m      -> Bin p m (insert x l) r+        | otherwise     -> Bin p m l (insert x r)+      Tip y +        | x==y          -> Tip x+        | otherwise     -> join x (Tip x) y t+      Nil -> Tip x++-- right-biased insertion, used by 'union'+insertR :: Int -> IntSet -> IntSet+insertR x t+  = case t of+      Bin p m l r +        | nomatch x p m -> join x (Tip x) p t+        | zero x m      -> Bin p m (insert x l) r+        | otherwise     -> Bin p m l (insert x r)+      Tip y +        | x==y          -> t+        | otherwise     -> join x (Tip x) y t+      Nil -> Tip x++-- | /O(min(n,W))/. Delete a value in the set. Returns the+-- original set when the value was not present.+delete :: Int -> IntSet -> IntSet+delete x t+  = case t of+      Bin p m l r +        | nomatch x p m -> t+        | zero x m      -> bin p m (delete x l) r+        | otherwise     -> bin p m l (delete x r)+      Tip y +        | x==y          -> Nil+        | otherwise     -> t+      Nil -> Nil+++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+-- | The union of a list of sets.+unions :: [IntSet] -> IntSet+unions xs+  = foldlStrict union empty xs+++-- | /O(n+m)/. The union of two sets. +union :: IntSet -> IntSet -> IntSet+union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = union1+  | shorter m2 m1  = union2+  | p1 == p2       = Bin p1 m1 (union l1 l2) (union r1 r2)+  | otherwise      = join p1 t1 p2 t2+  where+    union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2+            | zero p2 m1        = Bin p1 m1 (union l1 t2) r1+            | otherwise         = Bin p1 m1 l1 (union r1 t2)++    union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2+            | zero p1 m2        = Bin p2 m2 (union t1 l2) r2+            | otherwise         = Bin p2 m2 l2 (union t1 r2)++union (Tip x) t = insert x t+union t (Tip x) = insertR x t  -- right bias+union Nil t     = t+union t Nil     = t+++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | /O(n+m)/. Difference between two sets. +difference :: IntSet -> IntSet -> IntSet+difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = difference1+  | shorter m2 m1  = difference2+  | p1 == p2       = bin p1 m1 (difference l1 l2) (difference r1 r2)+  | otherwise      = t1+  where+    difference1 | nomatch p2 p1 m1  = t1+                | zero p2 m1        = bin p1 m1 (difference l1 t2) r1+                | otherwise         = bin p1 m1 l1 (difference r1 t2)++    difference2 | nomatch p1 p2 m2  = t1+                | zero p1 m2        = difference t1 l2+                | otherwise         = difference t1 r2++difference t1@(Tip x) t2 +  | member x t2  = Nil+  | otherwise    = t1++difference Nil t     = Nil+difference t (Tip x) = delete x t+difference t Nil     = t++++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | /O(n+m)/. The intersection of two sets. +intersection :: IntSet -> IntSet -> IntSet+intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = intersection1+  | shorter m2 m1  = intersection2+  | p1 == p2       = bin p1 m1 (intersection l1 l2) (intersection r1 r2)+  | otherwise      = Nil+  where+    intersection1 | nomatch p2 p1 m1  = Nil+                  | zero p2 m1        = intersection l1 t2+                  | otherwise         = intersection r1 t2++    intersection2 | nomatch p1 p2 m2  = Nil+                  | zero p1 m2        = intersection t1 l2+                  | otherwise         = intersection t1 r2++intersection t1@(Tip x) t2 +  | member x t2  = t1+  | otherwise    = Nil+intersection t (Tip x) +  = case lookup x t of+      Just y  -> Tip y+      Nothing -> Nil+intersection Nil t = Nil+intersection t Nil = Nil++++{--------------------------------------------------------------------+  Subset+--------------------------------------------------------------------}+-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).+properSubset :: IntSet -> IntSet -> Bool+properSubset t1 t2+  = case subsetCmp t1 t2 of +      LT -> True+      ge -> False++subsetCmp t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = GT+  | shorter m2 m1  = subsetCmpLt+  | p1 == p2       = subsetCmpEq+  | otherwise      = GT  -- disjoint+  where+    subsetCmpLt | nomatch p1 p2 m2  = GT+                | zero p1 m2        = subsetCmp t1 l2+                | otherwise         = subsetCmp t1 r2+    subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of+                    (GT,_ ) -> GT+                    (_ ,GT) -> GT+                    (EQ,EQ) -> EQ+                    other   -> LT++subsetCmp (Bin p m l r) t  = GT+subsetCmp (Tip x) (Tip y)  +  | x==y       = EQ+  | otherwise  = GT  -- disjoint+subsetCmp (Tip x) t        +  | member x t = LT+  | otherwise  = GT  -- disjoint+subsetCmp Nil Nil = EQ+subsetCmp Nil t   = LT++-- | /O(n+m)/. Is this a subset?+subset :: IntSet -> IntSet -> Bool+subset t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = False+  | shorter m2 m1  = match p1 p2 m2 && (if zero p1 m2 then subset t1 l2+                                                      else subset t1 r2)                     +  | otherwise      = (p1==p2) && subset l1 l2 && subset r1 r2+subset (Bin p m l r) t  = False+subset (Tip x) t        = member x t+subset Nil t            = True+++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | /O(n)/. Filter all elements that satisfy some predicate.+filter :: (Int -> Bool) -> IntSet -> IntSet+filter pred t+  = case t of+      Bin p m l r +        -> bin p m (filter pred l) (filter pred r)+      Tip x +        | pred x    -> t+        | otherwise -> Nil+      Nil -> Nil++-- | /O(n)/. partition the set according to some predicate.+partition :: (Int -> Bool) -> IntSet -> (IntSet,IntSet)+partition pred t+  = case t of+      Bin p m l r +        -> let (l1,l2) = partition pred l+               (r1,r2) = partition pred r+           in (bin p m l1 r1, bin p m l2 r2)+      Tip x +        | pred x    -> (t,Nil)+        | otherwise -> (Nil,t)+      Nil -> (Nil,Nil)+++-- | /O(log n)/. The expression (@split x set@) is a pair @(set1,set2)@+-- where all elements in @set1@ are lower than @x@ and all elements in+-- @set2@ larger than @x@.+split :: Int -> IntSet -> (IntSet,IntSet)+split x t+  = case t of+      Bin p m l r+        | zero x m  -> let (lt,gt) = split x l in (lt,union gt r)+        | otherwise -> let (lt,gt) = split x r in (union l lt,gt)+      Tip y +        | x>y       -> (t,Nil)+        | x<y       -> (Nil,t)+        | otherwise -> (Nil,Nil)+      Nil -> (Nil,Nil)++-- | /O(log n)/. Performs a 'split' but also returns whether the pivot+-- element was found in the original set.+splitMember :: Int -> IntSet -> (Bool,IntSet,IntSet)+splitMember x t+  = case t of+      Bin p m l r+        | zero x m  -> let (found,lt,gt) = splitMember x l in (found,lt,union gt r)+        | otherwise -> let (found,lt,gt) = splitMember x r in (found,union l lt,gt)+      Tip y +        | x>y       -> (False,t,Nil)+        | x<y       -> (False,Nil,t)+        | otherwise -> (True,Nil,Nil)+      Nil -> (False,Nil,Nil)+++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | /O(n)/. Fold over the elements of a set in an unspecified order.+--+-- > sum set   = fold (+) 0 set+-- > elems set = fold (:) [] set+fold :: (Int -> b -> b) -> b -> IntSet -> b+fold f z t+  = foldR f z t++foldR :: (Int -> b -> b) -> b -> IntSet -> b+foldR f z t+  = case t of+      Bin p m l r -> foldR f (foldR f z r) l+      Tip x       -> f x z+      Nil         -> z+          +{--------------------------------------------------------------------+  List variations +--------------------------------------------------------------------}+-- | /O(n)/. The elements of a set.+elems :: IntSet -> [Int]+elems s+  = toList s++{--------------------------------------------------------------------+  Lists +--------------------------------------------------------------------}+-- | /O(n)/. Convert the set to a list of elements.+toList :: IntSet -> [Int]+toList t+  = fold (:) [] t++-- | /O(n)/. Convert the set to an ascending list of elements.+toAscList :: IntSet -> [Int]+toAscList t   +  = -- NOTE: the following algorithm only works for big-endian trees+    let (pos,neg) = span (>=0) (foldR (:) [] t) in neg ++ pos++-- | /O(n*min(n,W))/. Create a set from a list of integers.+fromList :: [Int] -> IntSet+fromList xs+  = foldlStrict ins empty xs+  where+    ins t x  = insert x t++-- | /O(n*min(n,W))/. Build a set from an ascending list of elements.+fromAscList :: [Int] -> IntSet +fromAscList xs+  = fromList xs++-- | /O(n*min(n,W))/. Build a set from an ascending list of distinct elements.+fromDistinctAscList :: [Int] -> IntSet+fromDistinctAscList xs+  = fromList xs+++{--------------------------------------------------------------------+  Eq +--------------------------------------------------------------------}+instance Eq IntSet where+  t1 == t2  = equal t1 t2+  t1 /= t2  = nequal t1 t2++equal :: IntSet -> IntSet -> Bool+equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) +equal (Tip x) (Tip y)+  = (x==y)+equal Nil Nil = True+equal t1 t2   = False++nequal :: IntSet -> IntSet -> Bool+nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) +nequal (Tip x) (Tip y)+  = (x/=y)+nequal Nil Nil = False+nequal t1 t2   = True++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}+instance Show IntSet where+  showsPrec d s  = showSet (toList s)++showSet :: [Int] -> ShowS+showSet []     +  = showString "{}" +showSet (x:xs) +  = showChar '{' . shows x . showTail xs+  where+    showTail []     = showChar '}'+    showTail (x:xs) = showChar ',' . shows x . showTail xs++{--------------------------------------------------------------------+  Debugging+--------------------------------------------------------------------}+-- | /O(n)/. Show the tree that implements the set. The tree is shown+-- in a compressed, hanging format.+showTree :: IntSet -> String+showTree s+  = showTreeWith True False s+++{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows+ the tree that implements the set. If @hang@ is+ @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is true, an extra wide version is shown.+-}+showTreeWith :: Bool -> Bool -> IntSet -> String+showTreeWith hang wide t+  | hang      = (showsTreeHang wide [] t) ""+  | otherwise = (showsTree wide [] [] t) ""++showsTree :: Bool -> [String] -> [String] -> IntSet -> ShowS+showsTree wide lbars rbars t+  = case t of+      Bin p m l r+          -> showsTree wide (withBar rbars) (withEmpty rbars) r .+             showWide wide rbars .+             showsBars lbars . showString (showBin p m) . showString "\n" .+             showWide wide lbars .+             showsTree wide (withEmpty lbars) (withBar lbars) l+      Tip x+          -> showsBars lbars . showString " " . shows x . showString "\n" +      Nil -> showsBars lbars . showString "|\n"++showsTreeHang :: Bool -> [String] -> IntSet -> ShowS+showsTreeHang wide bars t+  = case t of+      Bin p m l r+          -> showsBars bars . showString (showBin p m) . showString "\n" . +             showWide wide bars .+             showsTreeHang wide (withBar bars) l .+             showWide wide bars .+             showsTreeHang wide (withEmpty bars) r+      Tip x+          -> showsBars bars . showString " " . shows x . showString "\n" +      Nil -> showsBars bars . showString "|\n" +      +showBin p m+  = "*" -- ++ show (p,m)++showWide wide bars +  | wide      = showString (concat (reverse bars)) . showString "|\n" +  | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+  = case bars of+      [] -> id+      _  -> showString (concat (reverse (tail bars))) . showString node++node           = "+--"+withBar bars   = "|  ":bars+withEmpty bars = "   ":bars+++{--------------------------------------------------------------------+  Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+  Join+--------------------------------------------------------------------}+join :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet+join p1 t1 p2 t2+  | zero p1 m = Bin p m t1 t2+  | otherwise = Bin p m t2 t1+  where+    m = branchMask p1 p2+    p = mask p1 m++{--------------------------------------------------------------------+  @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}+bin :: Prefix -> Mask -> IntSet -> IntSet -> IntSet+bin p m l Nil = l+bin p m Nil r = r+bin p m l r   = Bin p m l r++  +{--------------------------------------------------------------------+  Endian independent bit twiddling+--------------------------------------------------------------------}+zero :: Int -> Mask -> Bool+zero i m+  = (natFromInt i) .&. (natFromInt m) == 0++nomatch,match :: Int -> Prefix -> Mask -> Bool+nomatch i p m+  = (mask i m) /= p++match i p m+  = (mask i m) == p++mask :: Int -> Mask -> Prefix+mask i m+  = maskW (natFromInt i) (natFromInt m)+++{--------------------------------------------------------------------+  Big endian operations  +--------------------------------------------------------------------}+maskW :: Nat -> Nat -> Prefix+maskW i m+  = intFromNat (i .&. (complement (m-1) `xor` m))++shorter :: Mask -> Mask -> Bool+shorter m1 m2+  = (natFromInt m1) > (natFromInt m2)++branchMask :: Prefix -> Prefix -> Mask+branchMask p1 p2+  = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))+  +{----------------------------------------------------------------------+  Finding the highest bit (mask) in a word [x] can be done efficiently in+  three ways:+  * convert to a floating point value and the mantissa tells us the +    [log2(x)] that corresponds with the highest bit position. The mantissa +    is retrieved either via the standard C function [frexp] or by some bit +    twiddling on IEEE compatible numbers (float). Note that one needs to +    use at least [double] precision for an accurate mantissa of 32 bit +    numbers.+  * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).+  * use processor specific assembler instruction (asm).++  The most portable way would be [bit], but is it efficient enough?+  I have measured the cycle counts of the different methods on an AMD +  Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:++  highestBitMask: method  cycles+                  --------------+                   frexp   200+                   float    33+                   bit      11+                   asm      12++  highestBit:     method  cycles+                  --------------+                   frexp   195+                   float    33+                   bit      11+                   asm      11++  Wow, the bit twiddling is on today's RISC like machines even faster+  than a single CISC instruction (BSR)!+----------------------------------------------------------------------}++{----------------------------------------------------------------------+  [highestBitMask] returns a word where only the highest bit is set.+  It is found by first setting all bits in lower positions than the +  highest bit and than taking an exclusive or with the original value.+  Allthough the function may look expensive, GHC compiles this into+  excellent C code that subsequently compiled into highly efficient+  machine code. The algorithm is derived from Jorg Arndt's FXT library.+----------------------------------------------------------------------}+highestBitMask :: Nat -> Nat+highestBitMask x+  = case (x .|. shiftRL x 1) of +     x -> case (x .|. shiftRL x 2) of +      x -> case (x .|. shiftRL x 4) of +       x -> case (x .|. shiftRL x 8) of +        x -> case (x .|. shiftRL x 16) of +         x -> case (x .|. shiftRL x 32) of   -- for 64 bit platforms+          x -> (x `xor` (shiftRL x 1))+++{--------------------------------------------------------------------+  Utilities +--------------------------------------------------------------------}+foldlStrict f z xs+  = case xs of+      []     -> z+      (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)+++{-+{--------------------------------------------------------------------+  Testing+--------------------------------------------------------------------}+testTree :: [Int] -> IntSet+testTree xs   = fromList xs+test1 = testTree [1..20]+test2 = testTree [30,29..10]+test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]++{--------------------------------------------------------------------+  QuickCheck+--------------------------------------------------------------------}+qcheck prop+  = check config prop+  where+    config = Config+      { configMaxTest = 500+      , configMaxFail = 5000+      , configSize    = \n -> (div n 2 + 3)+      , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]+      }+++{--------------------------------------------------------------------+  Arbitrary, reasonably balanced trees+--------------------------------------------------------------------}+instance Arbitrary IntSet where+  arbitrary = do{ xs <- arbitrary+                ; return (fromList xs)+                }+++{--------------------------------------------------------------------+  Single, Insert, Delete+--------------------------------------------------------------------}+prop_Single :: Int -> Bool+prop_Single x+  = (insert x empty == single x)++prop_InsertDelete :: Int -> IntSet -> Property+prop_InsertDelete k t+  = not (member k t) ==> delete k (insert k t) == t+++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+prop_UnionInsert :: Int -> IntSet -> Bool+prop_UnionInsert x t+  = union t (single x) == insert x t++prop_UnionAssoc :: IntSet -> IntSet -> IntSet -> Bool+prop_UnionAssoc t1 t2 t3+  = union t1 (union t2 t3) == union (union t1 t2) t3++prop_UnionComm :: IntSet -> IntSet -> Bool+prop_UnionComm t1 t2+  = (union t1 t2 == union t2 t1)++prop_Diff :: [Int] -> [Int] -> Bool+prop_Diff xs ys+  =  toAscList (difference (fromList xs) (fromList ys))+    == List.sort ((List.\\) (nub xs)  (nub ys))++prop_Int :: [Int] -> [Int] -> Bool+prop_Int xs ys+  =  toAscList (intersection (fromList xs) (fromList ys))+    == List.sort (nub ((List.intersect) (xs)  (ys)))++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}+prop_Ordered+  = forAll (choose (5,100)) $ \n ->+    let xs = [0..n::Int]+    in fromAscList xs == fromList xs++prop_List :: [Int] -> Bool+prop_List xs+  = (sort (nub xs) == toAscList (fromList xs))+-}+
+ src/UU/DData/Map.hs view
@@ -0,0 +1,1544 @@+--------------------------------------------------------------------------------+{-| Module      :  Map+    Copyright   :  (c) Daan Leijen 2002+    License     :  BSD-style++    Maintainer  :  daan@cs.uu.nl+    Stability   :  provisional+    Portability :  portable++  An efficient implementation of maps from keys to values (dictionaries). ++  1) The module exports some names that clash with the "Prelude" -- 'lookup', 'map', and 'filter'. +      If you want to use "Map" unqualified, these functions should be hidden.++      > import Prelude hiding (lookup,map,filter)+      > import Map++      Another solution is to use qualified names. This is also the only way how+      a "Map", "Set", and "MultiSet" can be used within one module. ++      > import qualified Map+      >+      > ... Map.single "Paris" "France"++      Or, if you prefer a terse coding style:++      > import qualified Map as M+      >+      > ... M.single "Berlin" "Germany"++  2) The implementation of "Map" is based on /size balanced/ binary trees (or+     trees of /bounded balance/) as described by:++     * Stephen Adams, \"/Efficient sets: a balancing act/\", Journal of Functional+       Programming 3(4):553-562, October 1993, <http://www.swiss.ai.mit.edu/~adams/BB>.++     * J. Nievergelt and E.M. Reingold, \"/Binary search trees of bounded balance/\",+       SIAM journal of computing 2(1), March 1973.+     +  3) Another implementation of finite maps based on size balanced trees+      exists as "Data.FiniteMap" in the Ghc libraries. The good part about this library +      is that it is highly tuned and thorougly tested. However, it is also fairly old, +      uses @#ifdef@'s all  over the place and only supports the basic finite map operations. +      The "Map" module overcomes some of these issues:+        +      * It tries to export a more complete and consistent set of operations, like+        'partition', 'adjust', 'mapAccum', 'elemAt' etc. +      +      * It uses the efficient /hedge/ algorithm for both 'union' and 'difference'+        (a /hedge/ algorithm is not applicable to 'intersection').+      +      * It converts ordered lists in linear time ('fromAscList').  ++      * It takes advantage of the module system with names like 'empty' instead of 'Data.FiniteMap.emptyFM'.+      +      * It sticks to portable Haskell, avoiding @#ifdef@'s and other magic.+-}+----------------------------------------------------------------------------------+module UU.DData.Map  ( +            -- * Map type+              Map          -- instance Eq,Show++            -- * Operators+            , (!), (\\)++            -- * Query+            , isEmpty+            , size+            , member+            , lookup+            , find          +            , findWithDefault+            +            -- * Construction+            , empty+            , single++            -- ** Insertion+            , insert+            , insertWith, insertWithKey, insertLookupWithKey+            +            -- ** Delete\/Update+            , delete+            , adjust+            , adjustWithKey+            , update+            , updateWithKey+            , updateLookupWithKey++            -- * Combine++            -- ** Union+            , union         +            , unionWith          +            , unionWithKey+            , unions++            -- ** Difference+            , difference+            , differenceWith+            , differenceWithKey+            +            -- ** Intersection+            , intersection           +            , intersectionWith+            , intersectionWithKey++            -- * Traversal+            -- ** Map+            , map+            , mapWithKey+            , mapAccum+            , mapAccumWithKey+            +            -- ** Fold+            , fold+            , foldWithKey++            -- * Conversion+            , elems+            , keys+            , assocs+            +            -- ** Lists+            , toList+            , fromList+            , fromListWith+            , fromListWithKey++            -- ** Ordered lists+            , toAscList+            , fromAscList+            , fromAscListWith+            , fromAscListWithKey+            , fromDistinctAscList++            -- * Filter +            , filter+            , filterWithKey+            , partition+            , partitionWithKey++            , split         +            , splitLookup   ++            -- * Subset+            , subset, subsetBy+            , properSubset, properSubsetBy++            -- * Indexed +            , lookupIndex+            , findIndex+            , elemAt+            , updateAt+            , deleteAt++            -- * Min\/Max+            , findMin+            , findMax+            , deleteMin+            , deleteMax+            , deleteFindMin+            , deleteFindMax+            , updateMin+            , updateMax+            , updateMinWithKey+            , updateMaxWithKey+            +            -- * Debugging+            , showTree+            , showTreeWith+            , valid+            ) where++import Prelude hiding (lookup,map,filter)+++{-+-- for quick check+import qualified Prelude+import qualified List+import Debug.QuickCheck       +import List(nub,sort)    +-}++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+infixl 9 !,\\ --++-- | /O(log n)/. See 'find'.+(!) :: Ord k => Map k a -> k -> a+(!) m k    = find k m++-- | /O(n+m)/. See 'difference'.+(\\) :: Ord k => Map k a -> Map k a -> Map k a+m1 \\ m2 = difference m1 m2++{--------------------------------------------------------------------+  Size balanced trees.+--------------------------------------------------------------------}+-- | A Map from keys @k@ and values @a@. +data Map k a  = Tip +              | Bin !Size !k a !(Map k a) !(Map k a) ++type Size     = Int++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | /O(1)/. Is the map empty?+isEmpty :: Map k a -> Bool+isEmpty t+  = case t of+      Tip             -> True+      Bin sz k x l r  -> False++-- | /O(1)/. The number of elements in the map.+size :: Map k a -> Int+size t+  = case t of+      Tip             -> 0+      Bin sz k x l r  -> sz+++-- | /O(log n)/. Lookup the value of key in the map.+lookup :: Ord k => k -> Map k a -> Maybe a+lookup k t+  = case t of+      Tip -> Nothing+      Bin sz kx x l r+          -> case compare k kx of+               LT -> lookup k l+               GT -> lookup k r+               EQ -> Just x       ++-- | /O(log n)/. Is the key a member of the map?+member :: Ord k => k -> Map k a -> Bool+member k m+  = case lookup k m of+      Nothing -> False+      Just x  -> True++-- | /O(log n)/. Find the value of a key. Calls @error@ when the element can not be found.+find :: Ord k => k -> Map k a -> a+find k m+  = case lookup k m of+      Nothing -> error "Map.find: element not in the map"+      Just x  -> x++-- | /O(log n)/. The expression @(findWithDefault def k map)@ returns the value of key @k@ or returns @def@ when+-- the key is not in the map.+findWithDefault :: Ord k => a -> k -> Map k a -> a+findWithDefault def k m+  = case lookup k m of+      Nothing -> def+      Just x  -> x++++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | /O(1)/. Create an empty map.+empty :: Map k a+empty +  = Tip++-- | /O(1)/. Create a map with a single element.+single :: k -> a -> Map k a+single k x  +  = Bin 1 k x Tip Tip++{--------------------------------------------------------------------+  Insertion+  [insert] is the inlined version of [insertWith (\k x y -> x)]+--------------------------------------------------------------------}+-- | /O(log n)/. Insert a new key and value in the map.+insert :: Ord k => k -> a -> Map k a -> Map k a+insert kx x t+  = case t of+      Tip -> single kx x+      Bin sz ky y l r+          -> case compare kx ky of+               LT -> balance ky y (insert kx x l) r+               GT -> balance ky y l (insert kx x r)+               EQ -> Bin sz kx x l r++-- | /O(log n)/. Insert with a combining function.+insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWith f k x m          +  = insertWithKey (\k x y -> f x y) k x m++-- | /O(log n)/. Insert with a combining function.+insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKey f kx x t+  = case t of+      Tip -> single kx x+      Bin sy ky y l r+          -> case compare kx ky of+               LT -> balance ky y (insertWithKey f kx x l) r+               GT -> balance ky y l (insertWithKey f kx x r)+               EQ -> Bin sy ky (f ky x y) l r++-- | /O(log n)/. The expression (@insertLookupWithKey f k x map@) is a pair where+-- the first element is equal to (@lookup k map@) and the second element+-- equal to (@insertWithKey f k x map@).+insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)+insertLookupWithKey f kx x t+  = case t of+      Tip -> (Nothing, single kx x)+      Bin sy ky y l r+          -> case compare kx ky of+               LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)+               GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')+               EQ -> (Just y, Bin sy ky (f ky x y) l r)++{--------------------------------------------------------------------+  Deletion+  [delete] is the inlined version of [deleteWith (\k x -> Nothing)]+--------------------------------------------------------------------}+-- | /O(log n)/. Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+delete :: Ord k => k -> Map k a -> Map k a+delete k t+  = case t of+      Tip -> Tip+      Bin sx kx x l r +          -> case compare k kx of+               LT -> balance kx x (delete k l) r+               GT -> balance kx x l (delete k r)+               EQ -> glue l r++-- | /O(log n)/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a+adjust f k m+  = adjustWithKey (\k x -> f x) k m++-- | /O(log n)/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a+adjustWithKey f k m+  = updateWithKey (\k x -> Just (f k x)) k m++-- | /O(log n)/. The expression (@update f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is @Nothing@, the element is+-- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.+update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a+update f k m+  = updateWithKey (\k x -> f x) k m++-- | /O(log n)/. The expression (@update f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f k x@) is @Nothing@, the element is+-- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.+updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a+updateWithKey f k t+  = case t of+      Tip -> Tip+      Bin sx kx x l r +          -> case compare k kx of+               LT -> balance kx x (updateWithKey f k l) r+               GT -> balance kx x l (updateWithKey f k r)+               EQ -> case f kx x of+                       Just x' -> Bin sx kx x' l r+                       Nothing -> glue l r++-- | /O(log n)/. Lookup and update.+updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)+updateLookupWithKey f k t+  = case t of+      Tip -> (Nothing,Tip)+      Bin sx kx x l r +          -> case compare k kx of+               LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)+               GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r') +               EQ -> case f kx x of+                       Just x' -> (Just x',Bin sx kx x' l r)+                       Nothing -> (Just x,glue l r)++{--------------------------------------------------------------------+  Indexing+--------------------------------------------------------------------}+-- | /O(log n)/. Return the /index/ of a key. The index is a number from+-- /0/ up to, but not including, the 'size' of the map. Calls 'error' when+-- the key is not a 'member' of the map.+findIndex :: Ord k => k -> Map k a -> Int+findIndex k t+  = case lookupIndex k t of+      Nothing  -> error "Map.findIndex: element is not in the map"+      Just idx -> idx++-- | /O(log n)/. Lookup the /index/ of a key. The index is a number from+-- /0/ up to, but not including, the 'size' of the map. +lookupIndex :: Ord k => k -> Map k a -> Maybe Int+lookupIndex k t+  = lookup 0 t+  where+    lookup idx Tip  = Nothing+    lookup idx (Bin _ kx x l r)+      = case compare k kx of+          LT -> lookup idx l+          GT -> lookup (idx + size l + 1) r +          EQ -> Just (idx + size l)++-- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an+-- invalid index is used.+elemAt :: Int -> Map k a -> (k,a)+elemAt i Tip = error "Map.elemAt: index out of range"+elemAt i (Bin _ kx x l r)+  = case compare i sizeL of+      LT -> elemAt i l+      GT -> elemAt (i-sizeL-1) r+      EQ -> (kx,x)+  where+    sizeL = size l++-- | /O(log n)/. Update the element at /index/. Calls 'error' when an+-- invalid index is used.+updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a+updateAt f i Tip  = error "Map.updateAt: index out of range"+updateAt f i (Bin sx kx x l r)+  = case compare i sizeL of+      LT -> updateAt f i l+      GT -> updateAt f (i-sizeL-1) r+      EQ -> case f kx x of+              Just x' -> Bin sx kx x' l r+              Nothing -> glue l r+  where+    sizeL = size l++-- | /O(log n)/. Delete the element at /index/. Defined as (@deleteAt i map = updateAt (\k x -> Nothing) i map@).+deleteAt :: Int -> Map k a -> Map k a+deleteAt i map+  = updateAt (\k x -> Nothing) i map+++{--------------------------------------------------------------------+  Minimal, Maximal+--------------------------------------------------------------------}+-- | /O(log n)/. The minimal key of the map.+findMin :: Map k a -> (k,a)+findMin (Bin _ kx x Tip r)  = (kx,x)+findMin (Bin _ kx x l r)    = findMin l+findMin Tip                 = error "Map.findMin: empty tree has no minimal element"++-- | /O(log n)/. The maximal key of the map.+findMax :: Map k a -> (k,a)+findMax (Bin _ kx x l Tip)  = (kx,x)+findMax (Bin _ kx x l r)    = findMax r+findMax Tip                 = error "Map.findMax: empty tree has no maximal element"++-- | /O(log n)/. Delete the minimal key+deleteMin :: Map k a -> Map k a+deleteMin (Bin _ kx x Tip r)  = r+deleteMin (Bin _ kx x l r)    = balance kx x (deleteMin l) r+deleteMin Tip                 = Tip++-- | /O(log n)/. Delete the maximal key+deleteMax :: Map k a -> Map k a+deleteMax (Bin _ kx x l Tip)  = l+deleteMax (Bin _ kx x l r)    = balance kx x l (deleteMax r)+deleteMax Tip                 = Tip++-- | /O(log n)/. Update the minimal key+updateMin :: (a -> Maybe a) -> Map k a -> Map k a+updateMin f m+  = updateMinWithKey (\k x -> f x) m++-- | /O(log n)/. Update the maximal key+updateMax :: (a -> Maybe a) -> Map k a -> Map k a+updateMax f m+  = updateMaxWithKey (\k x -> f x) m+++-- | /O(log n)/. Update the minimal key+updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMinWithKey f t+  = case t of+      Bin sx kx x Tip r  -> case f kx x of+                              Nothing -> r+                              Just x' -> Bin sx kx x' Tip r+      Bin sx kx x l r    -> balance kx x (updateMinWithKey f l) r+      Tip                -> Tip++-- | /O(log n)/. Update the maximal key+updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMaxWithKey f t+  = case t of+      Bin sx kx x l Tip  -> case f kx x of+                              Nothing -> l+                              Just x' -> Bin sx kx x' l Tip+      Bin sx kx x l r    -> balance kx x l (updateMaxWithKey f r)+      Tip                -> Tip+++{--------------------------------------------------------------------+  Union. +--------------------------------------------------------------------}+-- | The union of a list of maps: (@unions == foldl union empty@).+unions :: Ord k => [Map k a] -> Map k a+unions ts+  = foldlStrict union empty ts++-- | /O(n+m)/.+-- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. +-- It prefers @t1@ when duplicate keys are encountered, ie. (@union == unionWith const@).+-- The implementation uses the efficient /hedge-union/ algorithm.+union :: Ord k => Map k a -> Map k a -> Map k a+union Tip t2  = t2+union t1 Tip  = t1+union t1 t2  -- hedge-union is more efficient on (bigset `union` smallset)+   | size t1 >= size t2  = hedgeUnionL (const LT) (const GT) t1 t2+   | otherwise           = hedgeUnionR (const LT) (const GT) t2 t1++-- left-biased hedge union+hedgeUnionL cmplo cmphi t1 Tip +  = t1+hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)+  = join kx x (filterGt cmplo l) (filterLt cmphi r)+hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2+  = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2)) +              (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))+  where+    cmpkx k  = compare kx k++-- right-biased hedge union+hedgeUnionR cmplo cmphi t1 Tip +  = t1+hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)+  = join kx x (filterGt cmplo l) (filterLt cmphi r)+hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2+  = join kx newx (hedgeUnionR cmplo cmpkx l lt) +                 (hedgeUnionR cmpkx cmphi r gt)+  where+    cmpkx k     = compare kx k+    lt          = trim cmplo cmpkx t2+    (found,gt)  = trimLookupLo kx cmphi t2+    newx        = case found of+                    Nothing -> x+                    Just y  -> y++{--------------------------------------------------------------------+  Union with a combining function+--------------------------------------------------------------------}+-- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.+unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a+unionWith f m1 m2+  = unionWithKey (\k x y -> f x y) m1 m2++-- | /O(n+m)/.+-- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.+unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a+unionWithKey f Tip t2  = t2+unionWithKey f t1 Tip  = t1+unionWithKey f t1 t2  -- hedge-union is more efficient on (bigset `union` smallset)+  | size t1 >= size t2  = hedgeUnionWithKey f (const LT) (const GT) t1 t2+  | otherwise           = hedgeUnionWithKey flipf (const LT) (const GT) t2 t1+  where+    flipf k x y   = f k y x++hedgeUnionWithKey f cmplo cmphi t1 Tip +  = t1+hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r)+  = join kx x (filterGt cmplo l) (filterLt cmphi r)+hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2+  = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt) +                 (hedgeUnionWithKey f cmpkx cmphi r gt)+  where+    cmpkx k     = compare kx k+    lt          = trim cmplo cmpkx t2+    (found,gt)  = trimLookupLo kx cmphi t2+    newx        = case found of+                    Nothing -> x+                    Just y  -> f kx x y++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | /O(n+m)/. Difference of two maps. +-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.+difference :: Ord k => Map k a -> Map k a -> Map k a+difference Tip t2  = Tip+difference t1 Tip  = t1+difference t1 t2   = hedgeDiff (const LT) (const GT) t1 t2++hedgeDiff cmplo cmphi Tip t     +  = Tip+hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip +  = join kx x (filterGt cmplo l) (filterLt cmphi r)+hedgeDiff cmplo cmphi t (Bin _ kx x l r) +  = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l) +          (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)+  where+    cmpkx k = compare kx k   ++-- | /O(n+m)/. Difference with a combining function. +-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.+differenceWith :: Ord k => (a -> a -> Maybe a) -> Map k a -> Map k a -> Map k a+differenceWith f m1 m2+  = differenceWithKey (\k x y -> f x y) m1 m2++-- | /O(n+m)/. Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns @Nothing@, the element is discarded (proper set difference). If+-- it returns (@Just y@), the element is updated with a new value @y@. +-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.+differenceWithKey :: Ord k => (k -> a -> a -> Maybe a) -> Map k a -> Map k a -> Map k a+differenceWithKey f Tip t2  = Tip+differenceWithKey f t1 Tip  = t1+differenceWithKey f t1 t2   = hedgeDiffWithKey f (const LT) (const GT) t1 t2++hedgeDiffWithKey f cmplo cmphi Tip t     +  = Tip+hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip +  = join kx x (filterGt cmplo l) (filterLt cmphi r)+hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r) +  = case found of+      Nothing -> merge tl tr+      Just y  -> case f kx y x of+                   Nothing -> merge tl tr+                   Just z  -> join kx z tl tr+  where+    cmpkx k     = compare kx k   +    lt          = trim cmplo cmpkx t+    (found,gt)  = trimLookupLo kx cmphi t+    tl          = hedgeDiffWithKey f cmplo cmpkx lt l+    tr          = hedgeDiffWithKey f cmpkx cmphi gt r++++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | /O(n+m)/. Intersection of two maps. The values in the first+-- map are returned, i.e. (@intersection m1 m2 == intersectionWith const m1 m2@).+intersection :: Ord k => Map k a -> Map k a -> Map k a+intersection m1 m2+  = intersectionWithKey (\k x y -> x) m1 m2++-- | /O(n+m)/. Intersection with a combining function.+intersectionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a+intersectionWith f m1 m2+  = intersectionWithKey (\k x y -> f x y) m1 m2++-- | /O(n+m)/. Intersection with a combining function.+intersectionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a+intersectionWithKey f Tip t = Tip+intersectionWithKey f t Tip = Tip+intersectionWithKey f t1 t2  -- intersection is more efficient on (bigset `intersection` smallset)+  | size t1 >= size t2  = intersectWithKey f t1 t2+  | otherwise           = intersectWithKey flipf t2 t1+  where+    flipf k x y   = f k y x++intersectWithKey f Tip t = Tip+intersectWithKey f t Tip = Tip+intersectWithKey f t (Bin _ kx x l r)+  = case found of+      Nothing -> merge tl tr+      Just y  -> join kx (f kx y x) tl tr+  where+    (found,lt,gt) = splitLookup kx t+    tl            = intersectWithKey f lt l+    tr            = intersectWithKey f gt r++++{--------------------------------------------------------------------+  Subset+--------------------------------------------------------------------}+-- | /O(n+m)/. +-- This function is defined as (@subset = subsetBy (==)@).+subset :: (Ord k,Eq a) => Map k a -> Map k a -> Bool+subset m1 m2+  = subsetBy (==) m1 m2++{- | /O(n+m)/. + The expression (@subsetBy f t1 t2@) returns @True@ if+ all keys in @t1@ are in tree @t2@, and when @f@ returns @True@ when+ applied to their respective values. For example, the following + expressions are all @True@.+ + > subsetBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > subsetBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > subsetBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])++ But the following are all @False@:+ + > subsetBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])+ > subsetBy (<)  (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > subsetBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])+-}+subsetBy :: Ord k => (a->a->Bool) -> Map k a -> Map k a -> Bool+subsetBy f t1 t2+  = (size t1 <= size t2) && (subset' f t1 t2)++subset' f Tip t = True+subset' f t Tip = False+subset' f (Bin _ kx x l r) t+  = case found of+      Nothing -> False+      Just y  -> f x y && subset' f l lt && subset' f r gt+  where+    (found,lt,gt) = splitLookup kx t++-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). +-- Defined as (@properSubset = properSubsetBy (==)@).+properSubset :: (Ord k,Eq a) => Map k a -> Map k a -> Bool+properSubset m1 m2+  = properSubsetBy (==) m1 m2++{- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).+ The expression (@properSubsetBy f m1 m2@) returns @True@ when+ @m1@ and @m2@ are not equal,+ all keys in @m1@ are in @m2@, and when @f@ returns @True@ when+ applied to their respective values. For example, the following + expressions are all @True@.+ +  > properSubsetBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > properSubsetBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])++ But the following are all @False@:+ +  > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])+  > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+  > properSubsetBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])+-}+properSubsetBy :: (Ord k,Eq a) => (a -> a -> Bool) -> Map k a -> Map k a -> Bool+properSubsetBy f t1 t2+  = (size t1 < size t2) && (subset' f t1 t2)++{--------------------------------------------------------------------+  Filter and partition+--------------------------------------------------------------------}+-- | /O(n)/. Filter all values that satisfy the predicate.+filter :: Ord k => (a -> Bool) -> Map k a -> Map k a+filter p m+  = filterWithKey (\k x -> p x) m++-- | /O(n)/. Filter all keys\values that satisfy the predicate.+filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a+filterWithKey p Tip = Tip+filterWithKey p (Bin _ kx x l r)+  | p kx x    = join kx x (filterWithKey p l) (filterWithKey p r)+  | otherwise = merge (filterWithKey p l) (filterWithKey p r)+++-- | /O(n)/. partition the map according to a predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)+partition p m+  = partitionWithKey (\k x -> p x) m++-- | /O(n)/. partition the map according to a predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)+partitionWithKey p Tip = (Tip,Tip)+partitionWithKey p (Bin _ kx x l r)+  | p kx x    = (join kx x l1 r1,merge l2 r2)+  | otherwise = (merge l1 r1,join kx x l2 r2)+  where+    (l1,l2) = partitionWithKey p l+    (r1,r2) = partitionWithKey p r+++{--------------------------------------------------------------------+  Mapping+--------------------------------------------------------------------}+-- | /O(n)/. Map a function over all values in the map.+map :: (a -> b) -> Map k a -> Map k b+map f m+  = mapWithKey (\k x -> f x) m++-- | /O(n)/. Map a function over all values in the map.+mapWithKey :: (k -> a -> b) -> Map k a -> Map k b+mapWithKey f Tip = Tip+mapWithKey f (Bin sx kx x l r) +  = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)++-- | /O(n)/. The function @mapAccum@ threads an accumulating+-- argument through the map in an unspecified order.+mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccum f a m+  = mapAccumWithKey (\a k x -> f a x) a m++-- | /O(n)/. The function @mapAccumWithKey@ threads an accumulating+-- argument through the map in unspecified order. (= ascending pre-order)+mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumWithKey f a t+  = mapAccumL f a t++-- | /O(n)/. The function @mapAccumL@ threads an accumulating+-- argument throught the map in (ascending) pre-order.+mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumL f a t+  = case t of+      Tip -> (a,Tip)+      Bin sx kx x l r+          -> let (a1,l') = mapAccumL f a l+                 (a2,x') = f a1 kx x+                 (a3,r') = mapAccumL f a2 r+             in (a3,Bin sx kx x' l' r')++-- | /O(n)/. The function @mapAccumR@ threads an accumulating+-- argument throught the map in (descending) post-order.+mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumR f a t+  = case t of+      Tip -> (a,Tip)+      Bin sx kx x l r +          -> let (a1,r') = mapAccumR f a r+                 (a2,x') = f a1 kx x+                 (a3,l') = mapAccumR f a2 l+             in (a3,Bin sx kx x' l' r')++{--------------------------------------------------------------------+  Folds  +--------------------------------------------------------------------}+-- | /O(n)/. Fold the map in an unspecified order. (= descending post-order).+fold :: (a -> b -> b) -> b -> Map k a -> b+fold f z m+  = foldWithKey (\k x z -> f x z) z m++-- | /O(n)/. Fold the map in an unspecified order. (= descending post-order).+foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b+foldWithKey f z t+  = foldR f z t++-- | /O(n)/. In-order fold.+foldI :: (k -> a -> b -> b -> b) -> b -> Map k a -> b +foldI f z Tip               = z+foldI f z (Bin _ kx x l r)  = f kx x (foldI f z l) (foldI f z r)++-- | /O(n)/. Post-order fold.+foldR :: (k -> a -> b -> b) -> b -> Map k a -> b+foldR f z Tip              = z+foldR f z (Bin _ kx x l r) = foldR f (f kx x (foldR f z r)) l++-- | /O(n)/. Pre-order fold.+foldL :: (b -> k -> a -> b) -> b -> Map k a -> b+foldL f z Tip              = z+foldL f z (Bin _ kx x l r) = foldL f (f (foldL f z l) kx x) r++{--------------------------------------------------------------------+  List variations +--------------------------------------------------------------------}+-- | /O(n)/. Return all elements of the map.+elems :: Map k a -> [a]+elems m+  = [x | (k,x) <- assocs m]++-- | /O(n)/. Return all keys of the map.+keys  :: Map k a -> [k]+keys m+  = [k | (k,x) <- assocs m]++-- | /O(n)/. Return all key\/value pairs in the map.+assocs :: Map k a -> [(k,a)]+assocs m+  = toList m++{--------------------------------------------------------------------+  Lists +  use [foldlStrict] to reduce demand on the control-stack+--------------------------------------------------------------------}+-- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.+fromList :: Ord k => [(k,a)] -> Map k a +fromList xs       +  = foldlStrict ins empty xs+  where+    ins t (k,x) = insert k x t++-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a +fromListWith f xs+  = fromListWithKey (\k x y -> f x y) xs++-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.+fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a +fromListWithKey f xs +  = foldlStrict ins empty xs+  where+    ins t (k,x) = insertWithKey f k x t++-- | /O(n)/. Convert to a list of key\/value pairs.+toList :: Map k a -> [(k,a)]+toList t      = toAscList t++-- | /O(n)/. Convert to an ascending list.+toAscList :: Map k a -> [(k,a)]+toAscList t   = foldR (\k x xs -> (k,x):xs) [] t++-- | /O(n)/. +toDescList :: Map k a -> [(k,a)]+toDescList t  = foldL (\xs k x -> (k,x):xs) [] t+++{--------------------------------------------------------------------+  Building trees from ascending/descending lists can be done in linear time.+  +  Note that if [xs] is ascending that: +    fromAscList xs       == fromList xs+    fromAscListWith f xs == fromListWith f xs+--------------------------------------------------------------------}+-- | /O(n)/. Build a map from an ascending list in linear time.+fromAscList :: Eq k => [(k,a)] -> Map k a +fromAscList xs+  = fromAscListWithKey (\k x y -> x) xs++-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.+fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a +fromAscListWith f xs+  = fromAscListWithKey (\k x y -> f x y) xs++-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys+fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a +fromAscListWithKey f xs+  = fromDistinctAscList (combineEq f xs)+  where+  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]+  combineEq f xs+    = case xs of+        []     -> []+        [x]    -> [x]+        (x:xx) -> combineEq' x xx++  combineEq' z [] = [z]+  combineEq' z@(kz,zz) (x@(kx,xx):xs)+    | kx==kz    = let yy = f kx xx zz in combineEq' (kx,yy) xs+    | otherwise = z:combineEq' x xs+++-- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.+fromDistinctAscList :: [(k,a)] -> Map k a +fromDistinctAscList xs+  = build const (length xs) xs+  where+    -- 1) use continutations so that we use heap space instead of stack space.+    -- 2) special case for n==5 to build bushier trees. +    build c 0 xs   = c Tip xs +    build c 5 xs   = case xs of+                       ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx) +                            -> c (bin k4 x4 (bin k2 x2 (single k1 x1) (single k3 x3)) (single k5 x5)) xx+    build c n xs   = seq nr $ build (buildR nr c) nl xs+                   where+                     nl = n `div` 2+                     nr = n - nl - 1++    buildR n c l ((k,x):ys) = build (buildB l k x c) n ys+    buildB l k x c r zs     = c (bin k x l r) zs+                      +++{--------------------------------------------------------------------+  Utility functions that return sub-ranges of the original+  tree. Some functions take a comparison function as argument to+  allow comparisons against infinite values. A function [cmplo k]+  should be read as [compare lo k].++  [trim cmplo cmphi t]  A tree that is either empty or where [cmplo k == LT]+                        and [cmphi k == GT] for the key [k] of the root.+  [filterGt cmp t]      A tree where for all keys [k]. [cmp k == LT]+  [filterLt cmp t]      A tree where for all keys [k]. [cmp k == GT]++  [split k t]           Returns two trees [l] and [r] where all keys+                        in [l] are <[k] and all keys in [r] are >[k].+  [splitLookup k t]     Just like [split] but also returns whether [k]+                        was found in the tree.+--------------------------------------------------------------------}++{--------------------------------------------------------------------+  [trim lo hi t] trims away all subtrees that surely contain no+  values between the range [lo] to [hi]. The returned tree is either+  empty or the key of the root is between @lo@ and @hi@.+--------------------------------------------------------------------}+trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a+trim cmplo cmphi Tip = Tip+trim cmplo cmphi t@(Bin sx kx x l r)+  = case cmplo kx of+      LT -> case cmphi kx of+              GT -> t+              le -> trim cmplo cmphi l+      ge -> trim cmplo cmphi r+              +trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe a, Map k a)+trimLookupLo lo cmphi Tip = (Nothing,Tip)+trimLookupLo lo cmphi t@(Bin sx kx x l r)+  = case compare lo kx of+      LT -> case cmphi kx of+              GT -> (lookup lo t, t)+              le -> trimLookupLo lo cmphi l+      GT -> trimLookupLo lo cmphi r+      EQ -> (Just x,trim (compare lo) cmphi r)+++{--------------------------------------------------------------------+  [filterGt k t] filter all keys >[k] from tree [t]+  [filterLt k t] filter all keys <[k] from tree [t]+--------------------------------------------------------------------}+filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a+filterGt cmp Tip = Tip+filterGt cmp (Bin sx kx x l r)+  = case cmp kx of+      LT -> join kx x (filterGt cmp l) r+      GT -> filterGt cmp r+      EQ -> r+      +filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a+filterLt cmp Tip = Tip+filterLt cmp (Bin sx kx x l r)+  = case cmp kx of+      LT -> filterLt cmp l+      GT -> join kx x l (filterLt cmp r)+      EQ -> l++{--------------------------------------------------------------------+  Split+--------------------------------------------------------------------}+-- | /O(log n)/. The expression (@split k map@) is a pair @(map1,map2)@ where+-- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.+split :: Ord k => k -> Map k a -> (Map k a,Map k a)+split k Tip = (Tip,Tip)+split k (Bin sx kx x l r)+  = case compare k kx of+      LT -> let (lt,gt) = split k l in (lt,join kx x gt r)+      GT -> let (lt,gt) = split k r in (join kx x l lt,gt)+      EQ -> (l,r)++-- | /O(log n)/. The expression (@splitLookup k map@) splits a map just+-- like 'split' but also returns @lookup k map@.+splitLookup :: Ord k => k -> Map k a -> (Maybe a,Map k a,Map k a)+splitLookup k Tip = (Nothing,Tip,Tip)+splitLookup k (Bin sx kx x l r)+  = case compare k kx of+      LT -> let (z,lt,gt) = splitLookup k l in (z,lt,join kx x gt r)+      GT -> let (z,lt,gt) = splitLookup k r in (z,join kx x l lt,gt)+      EQ -> (Just x,l,r)++{--------------------------------------------------------------------+  Utility functions that maintain the balance properties of the tree.+  All constructors assume that all values in [l] < [k] and all values+  in [r] > [k], and that [l] and [r] are valid trees.+  +  In order of sophistication:+    [Bin sz k x l r]  The type constructor.+    [bin k x l r]     Maintains the correct size, assumes that both [l]+                      and [r] are balanced with respect to each other.+    [balance k x l r] Restores the balance and size.+                      Assumes that the original tree was balanced and+                      that [l] or [r] has changed by at most one element.+    [join k x l r]    Restores balance and size. ++  Furthermore, we can construct a new tree from two trees. Both operations+  assume that all values in [l] < all values in [r] and that [l] and [r]+  are valid:+    [glue l r]        Glues [l] and [r] together. Assumes that [l] and+                      [r] are already balanced with respect to each other.+    [merge l r]       Merges two trees and restores balance.++  Note: in contrast to Adam's paper, we use (<=) comparisons instead+  of (<) comparisons in [join], [merge] and [balance]. +  Quickcheck (on [difference]) showed that this was necessary in order +  to maintain the invariants. It is quite unsatisfactory that I haven't +  been able to find out why this is actually the case! Fortunately, it +  doesn't hurt to be a bit more conservative.+--------------------------------------------------------------------}++{--------------------------------------------------------------------+  Join +--------------------------------------------------------------------}+join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a+join kx x Tip r  = insertMin kx x r+join kx x l Tip  = insertMax kx x l+join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)+  | delta*sizeL <= sizeR  = balance kz z (join kx x l lz) rz+  | delta*sizeR <= sizeL  = balance ky y ly (join kx x ry r)+  | otherwise             = bin kx x l r+++-- insertMin and insertMax don't perform potentially expensive comparisons.+insertMax,insertMin :: k -> a -> Map k a -> Map k a +insertMax kx x t+  = case t of+      Tip -> single kx x+      Bin sz ky y l r+          -> balance ky y l (insertMax kx x r)+             +insertMin kx x t+  = case t of+      Tip -> single kx x+      Bin sz ky y l r+          -> balance ky y (insertMin kx x l) r+             +{--------------------------------------------------------------------+  [merge l r]: merges two trees.+--------------------------------------------------------------------}+merge :: Map k a -> Map k a -> Map k a+merge Tip r   = r+merge l Tip   = l+merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)+  | delta*sizeL <= sizeR = balance ky y (merge l ly) ry+  | delta*sizeR <= sizeL = balance kx x lx (merge rx r)+  | otherwise            = glue l r++{--------------------------------------------------------------------+  [glue l r]: glues two trees together.+  Assumes that [l] and [r] are already balanced with respect to each other.+--------------------------------------------------------------------}+glue :: Map k a -> Map k a -> Map k a+glue Tip r = r+glue l Tip = l+glue l r   +  | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r+  | otherwise       = let ((km,m),r') = deleteFindMin r in balance km m l r'+++-- | /O(log n)/. Delete and find the minimal element.+deleteFindMin :: Map k a -> ((k,a),Map k a)+deleteFindMin t +  = case t of+      Bin _ k x Tip r -> ((k,x),r)+      Bin _ k x l r   -> let (km,l') = deleteFindMin l in (km,balance k x l' r)+      Tip             -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)++-- | /O(log n)/. Delete and find the maximal element.+deleteFindMax :: Map k a -> ((k,a),Map k a)+deleteFindMax t+  = case t of+      Bin _ k x l Tip -> ((k,x),l)+      Bin _ k x l r   -> let (km,r') = deleteFindMax r in (km,balance k x l r')+      Tip             -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)+++{--------------------------------------------------------------------+  [balance l x r] balances two trees with value x.+  The sizes of the trees should balance after decreasing the+  size of one of them. (a rotation).++  [delta] is the maximal relative difference between the sizes of+          two trees, it corresponds with the [w] in Adams' paper.+  [ratio] is the ratio between an outer and inner sibling of the+          heavier subtree in an unbalanced setting. It determines+          whether a double or single rotation should be performed+          to restore balance. It is correspondes with the inverse+          of $\alpha$ in Adam's article.++  Note that:+  - [delta] should be larger than 4.646 with a [ratio] of 2.+  - [delta] should be larger than 3.745 with a [ratio] of 1.534.+  +  - A lower [delta] leads to a more 'perfectly' balanced tree.+  - A higher [delta] performs less rebalancing.++  - Balancing is automaic for random data and a balancing+    scheme is only necessary to avoid pathological worst cases.+    Almost any choice will do, and in practice, a rather large+    [delta] may perform better than smaller one.++  Note: in contrast to Adam's paper, we use a ratio of (at least) [2]+  to decide whether a single or double rotation is needed. Allthough+  he actually proves that this ratio is needed to maintain the+  invariants, his implementation uses an invalid ratio of [1].+--------------------------------------------------------------------}+delta,ratio :: Int+delta = 5+ratio = 2++balance :: k -> a -> Map k a -> Map k a -> Map k a+balance k x l r+  | sizeL + sizeR <= 1    = Bin sizeX k x l r+  | sizeR >= delta*sizeL  = rotateL k x l r+  | sizeL >= delta*sizeR  = rotateR k x l r+  | otherwise             = Bin sizeX k x l r+  where+    sizeL = size l+    sizeR = size r+    sizeX = sizeL + sizeR + 1++-- rotate+rotateL k x l r@(Bin _ _ _ ly ry)+  | size ly < ratio*size ry = singleL k x l r+  | otherwise               = doubleL k x l r++rotateR k x l@(Bin _ _ _ ly ry) r+  | size ry < ratio*size ly = singleR k x l r+  | otherwise               = doubleR k x l r++-- basic rotations+singleL k1 x1 t1 (Bin _ k2 x2 t2 t3)  = bin k2 x2 (bin k1 x1 t1 t2) t3+singleR k1 x1 (Bin _ k2 x2 t1 t2) t3  = bin k2 x2 t1 (bin k1 x1 t2 t3)++doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)+doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)+++{--------------------------------------------------------------------+  The bin constructor maintains the size of the tree+--------------------------------------------------------------------}+bin :: k -> a -> Map k a -> Map k a -> Map k a+bin k x l r+  = Bin (size l + size r + 1) k x l r+++{--------------------------------------------------------------------+  Eq converts the tree to a list. In a lazy setting, this +  actually seems one of the faster methods to compare two trees +  and it is certainly the simplest :-)+--------------------------------------------------------------------}+instance (Eq k,Eq a) => Eq (Map k a) where+  t1 == t2  = (size t1 == size t2) && (toAscList t1 == toAscList t2)++{--------------------------------------------------------------------+  Functor+--------------------------------------------------------------------}+instance Functor (Map k) where+  fmap f m  = map f m++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}+instance (Show k, Show a) => Show (Map k a) where+  showsPrec d m  = showMap (toAscList m)++showMap :: (Show k,Show a) => [(k,a)] -> ShowS+showMap []     +  = showString "{}" +showMap (x:xs) +  = showChar '{' . showElem x . showTail xs+  where+    showTail []     = showChar '}'+    showTail (x:xs) = showChar ',' . showElem x . showTail xs+    +    showElem (k,x)  = shows k . showString ":=" . shows x+  ++-- | /O(n)/. Show the tree that implements the map. The tree is shown+-- in a compressed, hanging format.+showTree :: (Show k,Show a) => Map k a -> String+showTree m+  = showTreeWith showElem True False m+  where+    showElem k x  = show k ++ ":=" ++ show x+++{- | /O(n)/. The expression (@showTreeWith showelem hang wide map@) shows+ the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is+ @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is true, an extra wide version is shown.++>  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False $ fromDistinctAscList [(x,()) | x <- [1..5]]+>  (4,())+>  +--(2,())+>  |  +--(1,())+>  |  +--(3,())+>  +--(5,())+>+>  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True $ fromDistinctAscList [(x,()) | x <- [1..5]]+>  (4,())+>  |+>  +--(2,())+>  |  |+>  |  +--(1,())+>  |  |+>  |  +--(3,())+>  |+>  +--(5,())+>+>  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True $ fromDistinctAscList [(x,()) | x <- [1..5]]+>  +--(5,())+>  |+>  (4,())+>  |+>  |  +--(3,())+>  |  |+>  +--(2,())+>     |+>     +--(1,())++-}+showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String+showTreeWith showelem hang wide t+  | hang      = (showsTreeHang showelem wide [] t) ""+  | otherwise = (showsTree showelem wide [] [] t) ""++showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS+showsTree showelem wide lbars rbars t+  = case t of+      Tip -> showsBars lbars . showString "|\n"+      Bin sz kx x Tip Tip+          -> showsBars lbars . showString (showelem kx x) . showString "\n" +      Bin sz kx x l r+          -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .+             showWide wide rbars .+             showsBars lbars . showString (showelem kx x) . showString "\n" .+             showWide wide lbars .+             showsTree showelem wide (withEmpty lbars) (withBar lbars) l++showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS+showsTreeHang showelem wide bars t+  = case t of+      Tip -> showsBars bars . showString "|\n" +      Bin sz kx x Tip Tip+          -> showsBars bars . showString (showelem kx x) . showString "\n" +      Bin sz kx x l r+          -> showsBars bars . showString (showelem kx x) . showString "\n" . +             showWide wide bars .+             showsTreeHang showelem wide (withBar bars) l .+             showWide wide bars .+             showsTreeHang showelem wide (withEmpty bars) r+++showWide wide bars +  | wide      = showString (concat (reverse bars)) . showString "|\n" +  | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+  = case bars of+      [] -> id+      _  -> showString (concat (reverse (tail bars))) . showString node++node           = "+--"+withBar bars   = "|  ":bars+withEmpty bars = "   ":bars+++{--------------------------------------------------------------------+  Assertions+--------------------------------------------------------------------}+-- | /O(n)/. Test if the internal map structure is valid.+valid :: Ord k => Map k a -> Bool+valid t+  = balanced t && ordered t && validsize t++ordered t+  = bounded (const True) (const True) t+  where+    bounded lo hi t+      = case t of+          Tip              -> True+          Bin sz kx x l r  -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r++-- | Exported only for "Debug.QuickCheck"+balanced :: Map k a -> Bool+balanced t+  = case t of+      Tip              -> True+      Bin sz kx x l r  -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&+                          balanced l && balanced r+++validsize t+  = (realsize t == Just (size t))+  where+    realsize t+      = case t of+          Tip             -> Just 0+          Bin sz kx x l r -> case (realsize l,realsize r) of+                              (Just n,Just m)  | n+m+1 == sz  -> Just sz+                              other            -> Nothing++{--------------------------------------------------------------------+  Utilities+--------------------------------------------------------------------}+foldlStrict f z xs+  = case xs of+      []     -> z+      (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)+++{-+{--------------------------------------------------------------------+  Testing+--------------------------------------------------------------------}+testTree xs   = fromList [(x,"*") | x <- xs]+test1 = testTree [1..20]+test2 = testTree [30,29..10]+test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]++{--------------------------------------------------------------------+  QuickCheck+--------------------------------------------------------------------}+qcheck prop+  = check config prop+  where+    config = Config+      { configMaxTest = 500+      , configMaxFail = 5000+      , configSize    = \n -> (div n 2 + 3)+      , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]+      }+++{--------------------------------------------------------------------+  Arbitrary, reasonably balanced trees+--------------------------------------------------------------------}+instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where+  arbitrary = sized (arbtree 0 maxkey)+            where maxkey  = 10000++arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)+arbtree lo hi n+  | n <= 0        = return Tip+  | lo >= hi      = return Tip+  | otherwise     = do{ x  <- arbitrary +                      ; i  <- choose (lo,hi)+                      ; m  <- choose (1,30)+                      ; let (ml,mr)  | m==(1::Int)= (1,2)+                                     | m==2       = (2,1)+                                     | m==3       = (1,1)+                                     | otherwise  = (2,2)+                      ; l  <- arbtree lo (i-1) (n `div` ml)+                      ; r  <- arbtree (i+1) hi (n `div` mr)+                      ; return (bin (toEnum i) x l r)+                      }  +++{--------------------------------------------------------------------+  Valid tree's+--------------------------------------------------------------------}+forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property+forValid f+  = forAll arbitrary $ \t -> +--    classify (balanced t) "balanced" $+    classify (size t == 0) "empty" $+    classify (size t > 0  && size t <= 10) "small" $+    classify (size t > 10 && size t <= 64) "medium" $+    classify (size t > 64) "large" $+    balanced t ==> f t++forValidIntTree :: Testable a => (Map Int Int -> a) -> Property+forValidIntTree f+  = forValid f++forValidUnitTree :: Testable a => (Map Int () -> a) -> Property+forValidUnitTree f+  = forValid f+++prop_Valid +  = forValidUnitTree $ \t -> valid t++{--------------------------------------------------------------------+  Single, Insert, Delete+--------------------------------------------------------------------}+prop_Single :: Int -> Int -> Bool+prop_Single k x+  = (insert k x empty == single k x)++prop_InsertValid :: Int -> Property+prop_InsertValid k+  = forValidUnitTree $ \t -> valid (insert k () t)++prop_InsertDelete :: Int -> Map Int () -> Property+prop_InsertDelete k t+  = (lookup k t == Nothing) ==> delete k (insert k () t) == t++prop_DeleteValid :: Int -> Property+prop_DeleteValid k+  = forValidUnitTree $ \t -> +    valid (delete k (insert k () t))++{--------------------------------------------------------------------+  Balance+--------------------------------------------------------------------}+prop_Join :: Int -> Property +prop_Join k +  = forValidUnitTree $ \t ->+    let (l,r) = split k t+    in valid (join k () l r)++prop_Merge :: Int -> Property +prop_Merge k+  = forValidUnitTree $ \t ->+    let (l,r) = split k t+    in valid (merge l r)+++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+prop_UnionValid :: Property+prop_UnionValid+  = forValidUnitTree $ \t1 ->+    forValidUnitTree $ \t2 ->+    valid (union t1 t2)++prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool+prop_UnionInsert k x t+  = union (single k x) t == insert k x t++prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool+prop_UnionAssoc t1 t2 t3+  = union t1 (union t2 t3) == union (union t1 t2) t3++prop_UnionComm :: Map Int Int -> Map Int Int -> Bool+prop_UnionComm t1 t2+  = (union t1 t2 == unionWith (\x y -> y) t2 t1)++prop_UnionWithValid +  = forValidIntTree $ \t1 ->+    forValidIntTree $ \t2 ->+    valid (unionWithKey (\k x y -> x+y) t1 t2)++prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool+prop_UnionWith xs ys+  = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys))) +    == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))++prop_DiffValid+  = forValidUnitTree $ \t1 ->+    forValidUnitTree $ \t2 ->+    valid (difference t1 t2)++prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool+prop_Diff xs ys+  =  List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys))) +    == List.sort ((List.\\) (nub (Prelude.map fst xs))  (nub (Prelude.map fst ys)))++prop_IntValid+  = forValidUnitTree $ \t1 ->+    forValidUnitTree $ \t2 ->+    valid (intersection t1 t2)++prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool+prop_Int xs ys+  =  List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys))) +    == List.sort (nub ((List.intersect) (Prelude.map fst xs)  (Prelude.map fst ys)))++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}+prop_Ordered+  = forAll (choose (5,100)) $ \n ->+    let xs = [(x,()) | x <- [0..n::Int]] +    in fromAscList xs == fromList xs++prop_List :: [Int] -> Bool+prop_List xs+  = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])+-}
+ src/UU/DData/MultiSet.hs view
@@ -0,0 +1,430 @@+--------------------------------------------------------------------------------+{-| Module      :  MultiSet+    Copyright   :  (c) Daan Leijen 2002+    License     :  BSD-style++    Maintainer  :  daan@cs.uu.nl+    Stability   :  provisional+    Portability :  portable++  An implementation of multi sets on top of the "Map" module. A multi set+  differs from a /bag/ in the sense that it is represented as a map from elements+  to occurrence counts instead of retaining all elements. This means that equality +  on elements should be defined as a /structural/ equality instead of an +  equivalence relation.   If this is not the  case, operations that observe the +  elements, like 'filter' and 'fold',  should be used with care.+-}+---------------------------------------------------------------------------------}+module UU.DData.MultiSet ( +            -- * MultiSet type+              MultiSet          -- instance Eq,Show+            +            -- * Operators+            , (\\)++            -- *Query+            , isEmpty+            , size+            , distinctSize+            , member+            , occur++            , subset+            , properSubset+            +            -- * Construction+            , empty+            , single+            , insert+            , insertMany+            , delete+            , deleteAll+            +            -- * Combine+            , union+            , difference+            , intersection+            , unions+            +            -- * Filter+            , filter+            , partition++            -- * Fold+            , fold+            , foldOccur++            -- * Min\/Max+            , findMin+            , findMax+            , deleteMin+            , deleteMax+            , deleteMinAll+            , deleteMaxAll+            +            -- * Conversion+            , elems++            -- ** List+            , toList+            , fromList++            -- ** Ordered list+            , toAscList+            , fromAscList+            , fromDistinctAscList++            -- ** Occurrence lists+            , toOccurList+            , toAscOccurList+            , fromOccurList+            , fromAscOccurList++            -- ** Map+            , toMap+            , fromMap+            , fromOccurMap+            +            -- * Debugging+            , showTree+            , showTreeWith+            , valid+            ) where++import Prelude   hiding  (map,filter)+import qualified Prelude (map,filter)++import qualified UU.DData.Map as M++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+infixl 9 \\ --++-- | /O(n+m)/. See 'difference'.+(\\) :: Ord a => MultiSet a -> MultiSet a -> MultiSet a+b1 \\ b2 = difference b1 b2++{--------------------------------------------------------------------+  MultiSets are a simple wrapper around Maps, 'Map.Map'+--------------------------------------------------------------------}+-- | A multi set of values @a@.+newtype MultiSet a  = MultiSet (M.Map a Int)++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | /O(1)/. Is the multi set empty?+isEmpty :: MultiSet a -> Bool+isEmpty (MultiSet m)  +  = M.isEmpty m++-- | /O(1)/. Returns the number of distinct elements in the multi set, ie. (@distinctSize mset == Set.size ('toSet' mset)@).+distinctSize :: MultiSet a -> Int+distinctSize (MultiSet m)     +  = M.size m++-- | /O(n)/. The number of elements in the multi set.+size :: MultiSet a -> Int+size b+  = foldOccur (\x n m -> n+m) 0 b++-- | /O(log n)/. Is the element in the multi set?+member :: Ord a => a -> MultiSet a -> Bool+member x m+  = (occur x m > 0)++-- | /O(log n)/. The number of occurrences of an element in the multi set.+occur :: Ord a => a -> MultiSet a -> Int+occur x (MultiSet m)+  = case M.lookup x m of+      Nothing -> 0+      Just n  -> n++-- | /O(n+m)/. Is this a subset of the multi set? +subset :: Ord a => MultiSet a -> MultiSet a -> Bool+subset (MultiSet m1) (MultiSet m2)+  = M.subsetBy (<=) m1 m2++-- | /O(n+m)/. Is this a proper subset? (ie. a subset and not equal)+properSubset :: Ord a => MultiSet a -> MultiSet a -> Bool+properSubset b1 b2+  | distinctSize b1 == distinctSize b2 = (subset b1 b2) && (b1 /= b2)+  | distinctSize b1 <  distinctSize b2 = (subset b1 b2)+  | otherwise                      = False++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | /O(1)/. Create an empty multi set.+empty :: MultiSet a+empty+  = MultiSet (M.empty)++-- | /O(1)/. Create a singleton multi set.+single :: a -> MultiSet a+single x +  = MultiSet (M.single x 1)+    +{--------------------------------------------------------------------+  Insertion, Deletion+--------------------------------------------------------------------}+-- | /O(log n)/. Insert an element in the multi set.+insert :: Ord a => a -> MultiSet a -> MultiSet a+insert x (MultiSet m)          +  = MultiSet (M.insertWith (+) x 1 m)++-- | /O(min(n,W))/. The expression (@insertMany x count mset@)+-- inserts @count@ instances of @x@ in the multi set @mset@.+insertMany ::  Ord a => a -> Int -> MultiSet a -> MultiSet a+-- We still expect not to get count < 0+insertMany x 0 multiset = multiset+insertMany x count (MultiSet m)          +  = MultiSet (M.insertWith (+) x count m)++-- | /O(log n)/. Delete a single element.+delete :: Ord a => a -> MultiSet a -> MultiSet a+delete x (MultiSet m)+  = MultiSet (M.updateWithKey f x m)+  where+    f x n  | n > 1     = Just (n-1)+           | otherwise = Nothing++-- | /O(log n)/. Delete all occurrences of an element.+deleteAll :: Ord a => a -> MultiSet a -> MultiSet a+deleteAll x (MultiSet m)+  = MultiSet (M.delete x m)++{--------------------------------------------------------------------+  Combine+--------------------------------------------------------------------}+-- | /O(n+m)/. Union of two multisets. The union adds the elements together.+--+-- > MultiSet\> union (fromList [1,1,2]) (fromList [1,2,2,3])+-- > {1,1,1,2,2,2,3}+union :: Ord a => MultiSet a -> MultiSet a -> MultiSet a+union (MultiSet t1) (MultiSet t2)+  = MultiSet (M.unionWith (+) t1 t2)++-- | /O(n+m)/. Intersection of two multisets.+--+-- > MultiSet\> intersection (fromList [1,1,2]) (fromList [1,2,2,3])+-- > {1,2}+intersection :: Ord a => MultiSet a -> MultiSet a -> MultiSet a+intersection (MultiSet t1) (MultiSet t2)+  = MultiSet (M.intersectionWith min t1 t2)++-- | /O(n+m)/. Difference between two multisets.+--+-- > MultiSet\> difference (fromList [1,1,2]) (fromList [1,2,2,3])+-- > {1}+difference   :: Ord a => MultiSet a -> MultiSet a -> MultiSet a+difference (MultiSet t1) (MultiSet t2)+  = MultiSet (M.differenceWithKey f t1 t2)+  where+    f x n m  | n-m > 0   = Just (n-m)+             | otherwise = Nothing++-- | The union of a list of multisets.+unions :: Ord a => [MultiSet a] -> MultiSet a+unions multisets+  -- Original, wrong+  -- = MultiSet (M.unions [m | MultiSet m <- multisets])+  -- Map has no unionsWith+  -- = MultiSet (M.unionsWith (+) [m | MultiSet m <- multisets])+  -- Correct, but requires Data.List.foldl'+  -- = MultiSet (foldl' (M.unionWith (+)) M.empty [m | MultiSet m <- multisets])+  -- Correct, but not strict like the original (M.unions uses foldStrict)+  = foldr union empty multisets++{--------------------------------------------------------------------+  Filter and partition+--------------------------------------------------------------------}+-- | /O(n)/. Filter all elements that satisfy some predicate.+filter :: Ord a => (a -> Bool) -> MultiSet a -> MultiSet a+filter p (MultiSet m)+  = MultiSet (M.filterWithKey (\x n -> p x) m)++-- | /O(n)/. Partition the multi set according to some predicate.+partition :: Ord a => (a -> Bool) -> MultiSet a -> (MultiSet a,MultiSet a)+partition p (MultiSet m)+  = (MultiSet l,MultiSet r)+  where+    (l,r) = M.partitionWithKey (\x n -> p x) m++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | /O(n)/. Fold over each element in the multi set.+fold :: (a -> b -> b) -> b -> MultiSet a -> b+fold f z (MultiSet m)+  = M.foldWithKey apply z m+  where+    apply x n z  | n > 0     = apply x (n-1) (f x z)+                 | otherwise = z++-- | /O(n)/. Fold over all occurrences of an element at once.+foldOccur :: (a -> Int -> b -> b) -> b -> MultiSet a -> b+foldOccur f z (MultiSet m)+  = M.foldWithKey f z m++{--------------------------------------------------------------------+  Minimal, Maximal+--------------------------------------------------------------------}+-- | /O(log n)/. The minimal element of a multi set.+findMin :: MultiSet a -> a+findMin (MultiSet m)+  = fst (M.findMin m)++-- | /O(log n)/. The maximal element of a multi set.+findMax :: MultiSet a -> a+findMax (MultiSet m)+  = fst (M.findMax m)++-- | /O(log n)/. Delete the minimal element.+deleteMin :: MultiSet a -> MultiSet a+deleteMin (MultiSet m)+  = MultiSet (M.updateMin f m)+  where+    f n  | n > 0     = Just (n-1)+         | otherwise = Nothing++-- | /O(log n)/. Delete the maximal element.+deleteMax :: MultiSet a -> MultiSet a+deleteMax (MultiSet m)+  = MultiSet (M.updateMax f m)+  where+    f n  | n > 0     = Just (n-1)+         | otherwise = Nothing++-- | /O(log n)/. Delete all occurrences of the minimal element.+deleteMinAll :: MultiSet a -> MultiSet a+deleteMinAll (MultiSet m)+  = MultiSet (M.deleteMin m)++-- | /O(log n)/. Delete all occurrences of the maximal element.+deleteMaxAll :: MultiSet a -> MultiSet a+deleteMaxAll (MultiSet m)+  = MultiSet (M.deleteMax m)+++{--------------------------------------------------------------------+  List variations +--------------------------------------------------------------------}+-- | /O(n)/. The list of elements.+elems :: MultiSet a -> [a]+elems s+  = toList s++{--------------------------------------------------------------------+  Lists +--------------------------------------------------------------------}+-- | /O(n)/. Create a list with all elements.+toList :: MultiSet a -> [a]+toList s+  = toAscList s++-- | /O(n)/. Create an ascending list of all elements.+toAscList :: MultiSet a -> [a]+toAscList (MultiSet m)+  = [y | (x,n) <- M.toAscList m, y <- replicate n x]+++-- | /O(n*log n)/. Create a multi set from a list of elements.+fromList :: Ord a => [a] -> MultiSet a +fromList xs+  = MultiSet (M.fromListWith (+) [(x,1) | x <- xs])++-- | /O(n)/. Create a multi set from an ascending list in linear time.+fromAscList :: Eq a => [a] -> MultiSet a +fromAscList xs+  = MultiSet (M.fromAscListWith (+) [(x,1) | x <- xs])++-- | /O(n)/. Create a multi set from an ascending list of distinct elements in linear time.+fromDistinctAscList :: [a] -> MultiSet a +fromDistinctAscList xs+  = MultiSet (M.fromDistinctAscList [(x,1) | x <- xs])++-- | /O(n)/. Create a list of element\/occurrence pairs.+toOccurList :: MultiSet a -> [(a,Int)]+toOccurList b+  = toAscOccurList b++-- | /O(n)/. Create an ascending list of element\/occurrence pairs.+toAscOccurList :: MultiSet a -> [(a,Int)]+toAscOccurList (MultiSet m)+  = M.toAscList m++-- | /O(n*log n)/. Create a multi set from a list of element\/occurrence pairs.+fromOccurList :: Ord a => [(a,Int)] -> MultiSet a+fromOccurList xs+  = MultiSet (M.fromListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs))++-- | /O(n)/. Create a multi set from an ascending list of element\/occurrence pairs.+fromAscOccurList :: Ord a => [(a,Int)] -> MultiSet a+fromAscOccurList xs+  = MultiSet (M.fromAscListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs))++{--------------------------------------------------------------------+  Maps+--------------------------------------------------------------------}+-- | /O(1)/. Convert to a 'Map.Map' from elements to number of occurrences.+toMap   :: MultiSet a -> M.Map a Int+toMap (MultiSet m)+  = m++-- | /O(n)/. Convert a 'Map.Map' from elements to occurrences into a multi set.+fromMap :: Ord a => M.Map a Int -> MultiSet a+fromMap m+  = MultiSet (M.filter (>0) m)++-- | /O(1)/. Convert a 'Map.Map' from elements to occurrences into a multi set.+-- Assumes that the 'Map.Map' contains only elements that occur at least once.+fromOccurMap :: M.Map a Int -> MultiSet a+fromOccurMap m+  = MultiSet m++{--------------------------------------------------------------------+  Eq, Ord+--------------------------------------------------------------------}+instance Eq a => Eq (MultiSet a) where+  (MultiSet m1) == (MultiSet m2)  = (m1==m2) ++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}+instance Show a => Show (MultiSet a) where+  showsPrec d b  = showSet (toAscList b)++showSet :: Show a => [a] -> ShowS+showSet []     +  = showString "{}" +showSet (x:xs) +  = showChar '{' . shows x . showTail xs+  where+    showTail []     = showChar '}'+    showTail (x:xs) = showChar ',' . shows x . showTail xs+    ++{--------------------------------------------------------------------+  Debugging+--------------------------------------------------------------------}+-- | /O(n)/. Show the tree structure that implements the 'MultiSet'. The tree+-- is shown as a compressed and /hanging/.+showTree :: (Show a) => MultiSet a -> String+showTree mset+  = showTreeWith True False mset++-- | /O(n)/. The expression (@showTreeWith hang wide map@) shows+-- the tree that implements the multi set. The tree is shown /hanging/ when @hang@ is @True@ +-- and otherwise as a /rotated/ tree. When @wide@ is @True@ an extra wide version+-- is shown.+showTreeWith :: Show a => Bool -> Bool -> MultiSet a -> String+showTreeWith hang wide (MultiSet m)+  = M.showTreeWith (\x n -> show x ++ " (" ++ show n ++ ")") hang wide m+++-- | /O(n)/. Is this a valid multi set?+valid :: Ord a => MultiSet a -> Bool+valid (MultiSet m)+  = M.valid m && (M.isEmpty (M.filter (<=0) m))
+ src/UU/DData/Queue.hs view
@@ -0,0 +1,281 @@+--------------------------------------------------------------------------------+{-| Module      :  Queue+    Copyright   :  (c) Daan Leijen 2002+    License     :  BSD-style++    Maintainer  :  daan@cs.uu.nl+    Stability   :  provisional+    Portability :  portable++  An efficient implementation of queues (FIFO buffers). Based on:++  * Chris Okasaki, \"/Simple and Efficient Purely Functional Queues and Deques/\",+    Journal of Functional Programming 5(4):583-592, October 1995.+-}+---------------------------------------------------------------------------------}+module UU.DData.Queue ( +            -- * Queue type+              Queue          -- instance Eq,Show++            -- * Operators+            , (<>)+            +            -- * Query+            , isEmpty+            , length+            , head+            , tail+            , front++            -- * Construction+            , empty+            , single+            , insert+            , append+            +            -- * Filter+            , filter+            , partition++            -- * Fold+            , foldL+            , foldR+           +            -- * Conversion+            , elems++            -- ** List+            , toList+            , fromList+            ) where++import qualified Prelude as P (length,filter)+import Prelude   hiding       (length,head,tail,filter)+import qualified List++-- just for testing+-- import QuickCheck ++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+infixr 5 <>++-- | /O(n)/. Append two queues, see 'append'.+(<>) :: Queue a -> Queue a -> Queue a+s <> t+  = append s t++{--------------------------------------------------------------------+  Queue.+  Invariants for @(Queue xs ys zs)@:+  * @length ys <= length xs@+  * @length zs == length xs - length ys@+--------------------------------------------------------------------}+-- A queue of elements @a@.+data Queue a  = Queue [a] [a] [a]++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}++-- | /O(1)/. Is the queue empty?+isEmpty :: Queue a -> Bool+isEmpty (Queue xs ys zs)+  = null xs++-- | /O(n)/. The number of elements in the queue.+length :: Queue a -> Int+length (Queue xs ys zs)+  = P.length xs + P.length ys++-- | /O(1)/. The element in front of the queue. Raises an error+-- when the queue is empty.+head :: Queue a -> a+head (Queue xs ys zs)+  = case xs of+      (x:xx)  -> x+      []      -> error "Queue.head: empty queue"++-- | /O(1)/. The tail of the queue.+-- Raises an error when the queue is empty.+tail :: Queue a -> Queue a+tail (Queue xs ys zs)+  = case xs of+      (x:xx)  -> queue xx ys zs+      []      -> error "Queue.tail: empty queue"++-- | /O(1)/. The head and tail of the queue.+front :: Queue a -> Maybe (a,Queue a)+front (Queue xs ys zs)+  = case xs of+      (x:xx)  -> Just (x,queue xx ys zs)+      []      -> Nothing+++{--------------------------------------------------------------------+  Construction  +--------------------------------------------------------------------}+-- | /O(1)/. The empty queue.+empty :: Queue a+empty +  = Queue [] [] []++-- | /O(1)/. A queue of one element.+single :: a -> Queue a+single x+  = Queue [x] [] [x]++-- | /O(1)/. Insert an element at the back of a queue.+insert :: a -> Queue a -> Queue a+insert x (Queue xs ys zs)+  = queue xs (x:ys) zs+++-- | /O(n)/. Append two queues.+append :: Queue a -> Queue a -> Queue a+append (Queue xs1 ys1 zs1) (Queue xs2 ys2 zs2)+  = Queue (xs1++xs2) (ys1++ys2) (zs1++zs2)++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | /O(n)/. Filter elements according to some predicate.+filter :: (a -> Bool) -> Queue a -> Queue a+filter pred (Queue xs ys zs)+  = balance xs' ys'+  where+    xs' = P.filter pred xs+    ys' = P.filter pred ys++-- | /O(n)/. Partition the elements according to some predicate.+partition :: (a -> Bool) -> Queue a -> (Queue a,Queue a)+partition pred (Queue xs ys zs)+  = (balance xs1 ys1, balance xs2 ys2)+  where+    (xs1,xs2) = List.partition pred xs+    (ys1,ys2) = List.partition pred ys+++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | /O(n)/. Fold over the elements from left to right (ie. head to tail).+foldL :: (b -> a -> b) -> b -> Queue a -> b+foldL f z (Queue xs ys zs)+  = foldr (flip f) (foldl f z xs) ys++-- | /O(n)/. Fold over the elements from right to left (ie. tail to head).+foldR :: (a -> b -> b) -> b -> Queue a -> b+foldR f z (Queue xs ys zs)+  = foldr f (foldl (flip f) z ys) xs+++{--------------------------------------------------------------------+  Conversion+--------------------------------------------------------------------}+-- | /O(n)/. The elements of a queue.+elems :: Queue a -> [a]+elems q+  = toList q++-- | /O(n)/. Convert to a list.+toList :: Queue a -> [a]+toList (Queue xs ys zs)+  = xs ++ reverse ys++-- | /O(n)/. Convert from a list.+fromList :: [a] -> Queue a+fromList xs+  = Queue xs [] xs+++{--------------------------------------------------------------------+  instance Eq, Show+--------------------------------------------------------------------}+instance Eq a => Eq (Queue a) where+  q1 == q2  = toList q1 == toList q2++instance Show a => Show (Queue a) where+  showsPrec d q  = showsPrec d (toList q)+++{--------------------------------------------------------------------+  Smart constructor:+  Note that @(queue xs ys zs)@ is always called with +    @(length zs == length xs - length ys + 1)@. and thus+  @rotate@ is always called when @(length xs == length ys+1)@.+--------------------------------------------------------------------}+balance :: [a] -> [a] -> Queue a+balance xs ys+  = Queue qs [] qs+  where+    qs = xs ++ reverse ys++queue :: [a] -> [a] -> [a] -> Queue a+queue xs ys (z:zs) = Queue xs ys zs+queue xs ys []     = Queue qs [] qs+                   where+                     qs = rotate xs ys []++-- @(rotate xs ys []) == xs ++ reverse ys)@ +rotate :: [a] -> [a] -> [a] -> [a]+rotate []     [y]    zs  = y:zs+rotate (x:xs) (y:ys) zs  = x:rotate xs ys (y:zs) +rotate xs     ys     zs  = error "Queue.rotate: unbalanced queue"+++valid :: Queue a -> Bool+valid (Queue xs ys zs)+  = (P.length zs == P.length xs - P.length ys) && (P.length ys <= P.length xs)++{-+{--------------------------------------------------------------------+  QuickCheck+--------------------------------------------------------------------}+qcheck prop+  = check config prop+  where+    config = Config+      { configMaxTest = 500+      , configMaxFail = 10000+      , configSize    = \n -> (div n 2 + 3)+      , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]+      }+++{--------------------------------------------------------------------+  Arbitrary, reasonably balanced queues+--------------------------------------------------------------------}+instance Arbitrary a => Arbitrary (Queue a) where+  arbitrary = do{ qs <- arbitrary+                ; let (ys,xs) = splitAt (P.length qs `div` 2) qs+                ; return (Queue xs ys (xs ++ reverse ys))+                }+++prop_Valid :: Queue Int -> Bool+prop_Valid q+  = valid q++prop_InsertLast :: [Int] -> Property+prop_InsertLast xs+  = not (null xs) ==> head (foldr insert empty xs) == last xs++prop_InsertValid :: [Int] -> Bool+prop_InsertValid xs+  = valid (foldr insert empty xs)++prop_Queue :: [Int] -> Bool+prop_Queue xs+  = toList (foldl (flip insert) empty xs) == foldr (:) [] xs+  +prop_List :: [Int] -> Bool+prop_List xs+  = toList (fromList xs) == xs++prop_TailValid :: [Int] -> Bool+prop_TailValid xs+  = valid (tail (foldr insert empty (1:xs)))+-}+
+ src/UU/DData/Scc.hs view
@@ -0,0 +1,309 @@+--------------------------------------------------------------------------------+{-| Module      :  Scc+    Copyright   :  (c) Daan Leijen 2002+    License     :  BSD-style++    Maintainer  :  daan@cs.uu.nl+    Stability   :  provisional+    Portability :  portable++  Compute the /strongly connected components/ of a directed graph.+  The implementation is based on the following article:++  * David King and John Launchbury, /Lazy Depth-First Search and Linear Graph Algorithms in Haskell/,+    ACM Principles of Programming Languages, San Francisco, 1995.++  In contrast to their description, this module doesn't use lazy state+  threads but is instead purely functional -- using the "Map" and "Set" module.+  This means that the complexity of 'scc' is /O(n*log n)/ instead of /O(n)/ but+  due to the hidden constant factor, this implementation performs very well in practice.+-}+---------------------------------------------------------------------------------}+module UU.DData.Scc ( scc ) where++import qualified UU.DData.Map as Map+import qualified UU.DData.Set as Set ++{-+-- just for testing+import Debug.QuickCheck       +import List(nub,sort)    +-}++{--------------------------------------------------------------------+  Graph+--------------------------------------------------------------------}+-- | A @Graph v@ is a directed graph with nodes @v@.+newtype Graph v = Graph (Map.Map v [v])++-- | An @Edge v@ is a pair @(x,y)@ that represents an arrow from+-- node @x@ to node @y@.+type Edge v     = (v,v)+type Node v     = (v,[v])++{--------------------------------------------------------------------+  Conversion+--------------------------------------------------------------------}+nodes :: Graph v -> [Node v]+nodes (Graph g)+  = Map.toList g++graph :: Ord v => [Node v] -> Graph v+graph es+  = Graph (Map.fromListWith (++) es)++{--------------------------------------------------------------------+  Graph functions+--------------------------------------------------------------------}+edges :: Graph v -> [Edge v]+edges g+  = [(v,w) | (v,vs) <- nodes g, w <- vs]++vertices :: Graph v -> [v]+vertices g+  = [v | (v,vs) <- nodes g]++successors :: Ord v => v -> Graph v -> [v]+successors v (Graph g)+  = Map.findWithDefault [] v g++transpose :: Ord v => Graph v -> Graph v+transpose g@(Graph m)+  = Graph (foldr add empty (edges g))+  where+    empty       = Map.map (const []) m+    add (v,w) m = Map.adjust (v:) w m+++{--------------------------------------------------------------------+  Depth first search and forests+--------------------------------------------------------------------}+data Tree v   = Node v (Forest v) +type Forest v = [Tree v]++dff :: Ord v => Graph v -> Forest v+dff g+  = dfs g (vertices g)++dfs :: Ord v => Graph v -> [v] -> Forest v+dfs g vs      +  = prune (map (tree g) vs)++tree :: Ord v => Graph v -> v -> Tree v+tree g v  +  = Node v (map (tree g) (successors v g))++prune :: Ord v => Forest v -> Forest v+prune fs+  = snd (chop Set.empty  fs)+  where+    chop ms []  = (ms,[])+    chop ms (Node v vs:fs)+      | visited   = chop ms fs+      | otherwise = let ms0       = Set.insert v ms+                        (ms1,vs') = chop ms0 vs+                        (ms2,fs') = chop ms1 fs+                    in (ms2,Node v vs':fs')+      where+        visited   = Set.member v ms++{--------------------------------------------------------------------+  Orderings+--------------------------------------------------------------------}+preorder :: Ord v => Graph v -> [v]+preorder g+  = preorderF (dff g)++preorderF fs+  = concatMap preorderT fs++preorderT (Node v fs)+  = v:preorderF fs++postorder :: Ord v => Graph v -> [v]+postorder g+  = postorderF (dff g) ++postorderT t+  = postorderF [t]++postorderF ts+  = postorderF' ts []+  where+    -- efficient concatenation by passing the tail around.+    postorderF' [] tl          = tl+    postorderF' (t:ts) tl      = postorderT' t (postorderF' ts tl)+    postorderT' (Node v fs) tl = postorderF' fs (v:tl)+++{--------------------------------------------------------------------+  Strongly connected components +--------------------------------------------------------------------}++{- | + Compute the strongly connected components of a graph. The algorithm+ is tailored toward the needs of compiler writers that need to compute+ recursive binding groups (for example, the original order is preserved+ as much as possible). + + The expression (@scc xs@) computes the strongly connectected components+ of graph @xs@. A graph is a list of nodes @(v,ws)@ where @v@ is the node + label and @ws@ a list of nodes where @v@ points to, ie. there is an + arrow\/dependency from @v@ to each node in @ws@. Here is an example+ of @scc@:++>  Scc\> scc [(0,[1]),(1,[1,2,3]),(2,[1]),(3,[]),(4,[])]+>  [[3],[1,2],[0],[4]]++ In an expression @(scc xs)@, the graph @xs@ should contain an entry for + every node in the graph, ie:++>  all (`elem` nodes) targets+>  where nodes   = map fst xs+>        targets = concat (map snd xs)++ Furthermore, the returned components consist exactly of the original nodes:++>  sort (concat (scc xs)) == sort (map fst xs)++ The connected components are sorted by dependency, ie. there are+ no arrows\/dependencies from left-to-right. Furthermore, the original order+ is preserved as much as possible. +-}+scc :: Ord v => [(v,[v])] -> [[v]]+scc nodes+  = sccG (graph nodes)++sccG :: Ord v => Graph v -> [[v]]+sccG g+  = map preorderT (sccF g)++sccF :: Ord v => Graph v -> Forest v+sccF g         +  = reverse (dfs (transpose g) (topsort g))++topsort g+  = reverse (postorder g)++{--------------------------------------------------------------------+  Reachable and path+--------------------------------------------------------------------}+reachable v g+  = preorderF (dfs g [v])++path v w g+  = elem w (reachable v g)+++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}+instance Show v => Show (Graph v) where+  showsPrec d (Graph m) = shows m+  +instance Show v => Show (Tree v) where+  showsPrec d (Node v []) = shows v +  showsPrec d (Node v fs) = shows v . showList fs+++{--------------------------------------------------------------------+  Quick Test+--------------------------------------------------------------------}+tgraph0 :: Graph Int+tgraph0 = graph +          [(0,[1])+          ,(1,[2,1,3])+          ,(2,[1])+          ,(3,[])+          ]++tgraph1 = graph+          [  ('a',"jg") +          ,  ('b',"ia")+          ,  ('c',"he")+          ,  ('d',"")+          ,  ('e',"jhd")+          ,  ('f',"i")+          ,  ('g',"fb")+          ,  ('h',"")+          ]++{-+{--------------------------------------------------------------------+  Quickcheck+--------------------------------------------------------------------}+qcheck prop+  = check config prop+  where+    config = Config+      { configMaxTest = 500+      , configMaxFail = 5000+      , configSize    = \n -> (div n 2 + 3)+      , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]+      }+++{--------------------------------------------------------------------+  Arbitrary Graph's+--------------------------------------------------------------------}+instance (Ord v,Arbitrary v) => Arbitrary (Graph v) where+  arbitrary   = sized arbgraph+++arbgraph :: (Ord v,Arbitrary v) => Int -> Gen (Graph v)+arbgraph n+  = do nodes <- arbitrary+       g     <- mapM (targets nodes) nodes+       return (graph g)+  where+    targets nodes v+      = do sz <- choose (0,length nodes-1)+           ts <- mapM (target nodes) [1..sz]+           return (v,ts)+        +    target nodes _+      = do idx <- choose (0,length nodes-1)+           return (nodes!!idx)++{--------------------------------------------------------------------+  Properties+--------------------------------------------------------------------}+prop_ValidGraph :: Graph Int -> Bool+prop_ValidGraph g+  = all (`elem` srcs) targets+  where+    srcs    = map fst (nodes g)+    targets = concatMap snd (nodes g)++-- all scc nodes are in the original graph and the other way around+prop_SccComplete :: Graph Int -> Bool+prop_SccComplete g+  = sort (concat (sccG g)) == sort (vertices g)++-- all scc nodes have only backward dependencies+prop_SccForward :: Graph Int -> Bool+prop_SccForward g+  = all noforwards (zip prevs ss) +  where+    ss      = sccG g+    prevs   = scanl1 (++) ss++    noforwards (prev,xs)+      = all (noforward prev) xs+  +    noforward prev x+      = all (`elem` prev) (successors x g)++-- all strongly connected components refer to each other+prop_SccConnected :: Graph Int -> Bool+prop_SccConnected g+  = all connected (sccG g)+  where+    connected xs+      = all (paths xs) xs++    paths xs x+      = all (\y -> path x y g) xs++-}+
+ src/UU/DData/Seq.hs view
@@ -0,0 +1,91 @@+--------------------------------------------------------------------------------+{-| Module      :  Seq+    Copyright   :  (c) Daan Leijen 2002+    License     :  BSD-style++    Maintainer  :  daan@cs.uu.nl+    Stability   :  provisional+    Portability :  portable++  An implementation of John Hughes's efficient catenable sequence type. A lazy sequence+  @Seq a@ can be concatenated in /O(1)/ time. After+  construction, the sequence in converted in /O(n)/ time into a list.+-}+---------------------------------------------------------------------------------}+module UU.DData.Seq( -- * Type+            Seq+            -- * Operators+          , (<>)++            -- * Construction+          , empty+          , single+          , cons+          , append++            -- * Conversion+          , toList+          , fromList+          ) where+++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+infixr 5 <>++-- | /O(1)/. Append two sequences, see 'append'.+(<>) :: Seq a -> Seq a -> Seq a+s <> t+  = append s t++{--------------------------------------------------------------------+  Type+--------------------------------------------------------------------}+-- | Sequences of values @a@.+newtype Seq a = Seq ([a] -> [a])++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | /O(1)/. Create an empty sequence.+empty :: Seq a+empty+  = Seq (\ts -> ts)++-- | /O(1)/. Create a sequence of one element.+single :: a -> Seq a+single x+  = Seq (\ts -> x:ts)++-- | /O(1)/. Put a value in front of a sequence.+cons :: a -> Seq a -> Seq a+cons x (Seq f)+  = Seq (\ts -> x:f ts)++-- | /O(1)/. Append two sequences.+append :: Seq a -> Seq a -> Seq a+append (Seq f) (Seq g)+  = Seq (\ts -> f (g ts))+++{--------------------------------------------------------------------+  Conversion+--------------------------------------------------------------------}+-- | /O(n)/. Convert a sequence to a list.+toList :: Seq a -> [a]+toList (Seq f)+  = f []++-- | /O(n)/. Create a sequence from a list.+fromList :: [a] -> Seq a+fromList xs+  = Seq (\ts -> xs++ts)++++++++
+ src/UU/DData/Set.hs view
@@ -0,0 +1,1032 @@+--------------------------------------------------------------------------------+{-| Module      :  Set+    Copyright   :  (c) Daan Leijen 2002+    License     :  BSD-style++    Maintainer  :  daan@cs.uu.nl+    Stability   :  provisional+    Portability :  portable++  An efficient implementation of sets. ++  1) The 'filter' function clashes with the "Prelude". +      If you want to use "Set" unqualified, this function should be hidden.++      > import Prelude hiding (filter)+      > import Set++      Another solution is to use qualified names. This is also the only way how+      a "Map", "Set", and "MultiSet" can be used within one module. ++      > import qualified Set+      >+      > ... Set.single "Paris" ++      Or, if you prefer a terse coding style:++      > import qualified Set as S+      >+      > ... S.single "Berlin" +  +  2) The implementation of "Set" is based on /size balanced/ binary trees (or+     trees of /bounded balance/) as described by:++     * Stephen Adams, \"/Efficient sets: a balancing act/\", Journal of Functional+       Programming 3(4):553-562, October 1993, <http://www.swiss.ai.mit.edu/~adams/BB>.++     * J. Nievergelt and E.M. Reingold, \"/Binary search trees of bounded balance/\",+       SIAM journal of computing 2(1), March 1973.++  3) Note that the implementation /left-biased/ -- the elements of a first argument+      are always perferred to the second, for example in 'union' or 'insert'.+      Off course, left-biasing can only be observed when equality an equivalence relation+      instead of structural equality.++  4) Another implementation of sets based on size balanced trees+      exists as "Data.Set" in the Ghc libraries. The good part about this library +      is that it is highly tuned and thorougly tested. However, it is also fairly old, +      it is implemented indirectly on top of "Data.FiniteMap" and only supports +      the basic set operations. +      The "Set" module overcomes some of these issues:+        +      * It tries to export a more complete and consistent set of operations, like+        'partition', 'subset' etc. ++      * It uses the efficient /hedge/ algorithm for both 'union' and 'difference'+        (a /hedge/ algorithm is not applicable to 'intersection').+      +      * It converts ordered lists in linear time ('fromAscList').  ++      * It takes advantage of the module system with names like 'empty' instead of 'Data.Set.emptySet'.+      +      * It is implemented directly, instead of using a seperate finite map implementation. +-}+---------------------------------------------------------------------------------+module UU.DData.Set  ( +            -- * Set type+              Set          -- instance Eq,Show++            -- * Operators+            , (\\)++            -- * Query+            , isEmpty+            , size+            , member+            , subset+            , properSubset+            +            -- * Construction+            , empty+            , single+            , insert+            , delete+            +            -- * Combine+            , union, unions+            , difference+            , intersection+            +            -- * Filter+            , filter+            , partition+            , split+            , splitMember++            -- * Fold+            , fold++            -- * Min\/Max+            , findMin+            , findMax+            , deleteMin+            , deleteMax+            , deleteFindMin+            , deleteFindMax++            -- * Conversion++            -- ** List+            , elems+            , toList+            , fromList+            +            -- ** Ordered list+            , toAscList+            , fromAscList+            , fromDistinctAscList+                        +            -- * Debugging+            , showTree+            , showTreeWith+            , valid+            ) where++import Prelude hiding (filter)++{-+-- just for testing+import QuickCheck +import List (nub,sort)+import qualified List+-}++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+infixl 9 \\ --++-- | /O(n+m)/. See 'difference'.+(\\) :: Ord a => Set a -> Set a -> Set a+m1 \\ m2 = difference m1 m2++{--------------------------------------------------------------------+  Sets are size balanced trees+--------------------------------------------------------------------}+-- | A set of values @a@.+data Set a    = Tip +              | Bin !Size a !(Set a) !(Set a) ++type Size     = Int++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | /O(1)/. Is this the empty set?+isEmpty :: Set a -> Bool+isEmpty t+  = case t of+      Tip           -> True+      Bin sz x l r  -> False++-- | /O(1)/. The number of elements in the set.+size :: Set a -> Int+size t+  = case t of+      Tip           -> 0+      Bin sz x l r  -> sz++-- | /O(log n)/. Is the element in the set?+member :: Ord a => a -> Set a -> Bool+member x t+  = case t of+      Tip -> False+      Bin sz y l r+          -> case compare x y of+               LT -> member x l+               GT -> member x r+               EQ -> True       ++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | /O(1)/. The empty set.+empty  :: Set a+empty+  = Tip++-- | /O(1)/. Create a singleton set.+single :: a -> Set a+single x +  = Bin 1 x Tip Tip++{--------------------------------------------------------------------+  Insertion, Deletion+--------------------------------------------------------------------}+-- | /O(log n)/. Insert an element in a set.+insert :: Ord a => a -> Set a -> Set a+insert x t+  = case t of+      Tip -> single x+      Bin sz y l r+          -> case compare x y of+               LT -> balance y (insert x l) r+               GT -> balance y l (insert x r)+               EQ -> Bin sz x l r+++-- | /O(log n)/. Delete an element from a set.+delete :: Ord a => a -> Set a -> Set a+delete x t+  = case t of+      Tip -> Tip+      Bin sz y l r +          -> case compare x y of+               LT -> balance y (delete x l) r+               GT -> balance y l (delete x r)+               EQ -> glue l r++{--------------------------------------------------------------------+  Subset+--------------------------------------------------------------------}+-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).+properSubset :: Ord a => Set a -> Set a -> Bool+properSubset s1 s2+  = (size s1 < size s2) && (subset s1 s2)+++-- | /O(n+m)/. Is this a subset?+subset :: Ord a => Set a -> Set a -> Bool+subset t1 t2+  = (size t1 <= size t2) && (subsetX t1 t2)++subsetX Tip t = True+subsetX t Tip = False+subsetX (Bin _ x l r) t+  = found && subsetX l lt && subsetX r gt+  where+    (found,lt,gt) = splitMember x t+++{--------------------------------------------------------------------+  Minimal, Maximal+--------------------------------------------------------------------}+-- | /O(log n)/. The minimal element of a set.+findMin :: Set a -> a+findMin (Bin _ x Tip r) = x+findMin (Bin _ x l r)   = findMin l+findMin Tip             = error "Set.findMin: empty set has no minimal element"++-- | /O(log n)/. The maximal element of a set.+findMax :: Set a -> a+findMax (Bin _ x l Tip)  = x+findMax (Bin _ x l r)    = findMax r+findMax Tip              = error "Set.findMax: empty set has no maximal element"++-- | /O(log n)/. Delete the minimal element.+deleteMin :: Set a -> Set a+deleteMin (Bin _ x Tip r) = r+deleteMin (Bin _ x l r)   = balance x (deleteMin l) r+deleteMin Tip             = Tip++-- | /O(log n)/. Delete the maximal element.+deleteMax :: Set a -> Set a+deleteMax (Bin _ x l Tip) = l+deleteMax (Bin _ x l r)   = balance x l (deleteMax r)+deleteMax Tip             = Tip+++{--------------------------------------------------------------------+  Union. +--------------------------------------------------------------------}+-- | The union of a list of sets: (@unions == foldl union empty@).+unions :: Ord a => [Set a] -> Set a+unions ts+  = foldlStrict union empty ts+++-- | /O(n+m)/. The union of two sets. Uses the efficient /hedge-union/ algorithm.+union :: Ord a => Set a -> Set a -> Set a+union Tip t2  = t2+union t1 Tip  = t1+union t1 t2  -- hedge-union is more efficient on (bigset `union` smallset)+  | size t1 >= size t2  = hedgeUnion (const LT) (const GT) t1 t2+  | otherwise           = hedgeUnion (const LT) (const GT) t2 t1++hedgeUnion cmplo cmphi t1 Tip +  = t1+hedgeUnion cmplo cmphi Tip (Bin _ x l r)+  = join x (filterGt cmplo l) (filterLt cmphi r)+hedgeUnion cmplo cmphi (Bin _ x l r) t2+  = join x (hedgeUnion cmplo cmpx l (trim cmplo cmpx t2)) +           (hedgeUnion cmpx cmphi r (trim cmpx cmphi t2))+  where+    cmpx y  = compare x y++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | /O(n+m)/. Difference of two sets. +-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.+difference :: Ord a => Set a -> Set a -> Set a+difference Tip t2  = Tip+difference t1 Tip  = t1+difference t1 t2   = hedgeDiff (const LT) (const GT) t1 t2++hedgeDiff cmplo cmphi Tip t     +  = Tip+hedgeDiff cmplo cmphi (Bin _ x l r) Tip +  = join x (filterGt cmplo l) (filterLt cmphi r)+hedgeDiff cmplo cmphi t (Bin _ x l r) +  = merge (hedgeDiff cmplo cmpx (trim cmplo cmpx t) l) +          (hedgeDiff cmpx cmphi (trim cmpx cmphi t) r)+  where+    cmpx y = compare x y++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | /O(n+m)/. The intersection of two sets.+intersection :: Ord a => Set a -> Set a -> Set a+intersection Tip t = Tip+intersection t Tip = Tip+intersection t1 t2  -- intersection is more efficient on (bigset `intersection` smallset)+  | size t1 >= size t2  = intersect t1 t2+  | otherwise           = intersect t2 t1++intersect Tip t = Tip+intersect t Tip = Tip+intersect t (Bin _ x l r)+  | found     = join x tl tr+  | otherwise = merge tl tr+  where+    (found,lt,gt) = splitMember x t+    tl            = intersect lt l+    tr            = intersect gt r+++{--------------------------------------------------------------------+  Filter and partition+--------------------------------------------------------------------}+-- | /O(n)/. Filter all elements that satisfy the predicate.+filter :: Ord a => (a -> Bool) -> Set a -> Set a+filter p Tip = Tip+filter p (Bin _ x l r)+  | p x       = join x (filter p l) (filter p r)+  | otherwise = merge (filter p l) (filter p r)++-- | /O(n)/. Partition the set into two sets, one with all elements that satisfy+-- the predicate and one with all elements that don't satisfy the predicate.+-- See also 'split'.+partition :: Ord a => (a -> Bool) -> Set a -> (Set a,Set a)+partition p Tip = (Tip,Tip)+partition p (Bin _ x l r)+  | p x       = (join x l1 r1,merge l2 r2)+  | otherwise = (merge l1 r1,join x l2 r2)+  where+    (l1,l2) = partition p l+    (r1,r2) = partition p r++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | /O(n)/. Fold the elements of a set.+fold :: (a -> b -> b) -> b -> Set a -> b+fold f z s+  = foldR f z s++-- | /O(n)/. Post-order fold.+foldR :: (a -> b -> b) -> b -> Set a -> b+foldR f z Tip           = z+foldR f z (Bin _ x l r) = foldR f (f x (foldR f z r)) l+++{--------------------------------------------------------------------+  List variations +--------------------------------------------------------------------}+-- | /O(n)/. The elements of a set.+elems :: Set a -> [a]+elems s+  = toList s++{--------------------------------------------------------------------+  Lists +--------------------------------------------------------------------}+-- | /O(n)/. Convert the set to a list of elements.+toList :: Set a -> [a]+toList s+  = toAscList s++-- | /O(n)/. Convert the set to an ascending list of elements.+toAscList :: Set a -> [a]+toAscList t   +  = foldR (:) [] t+++-- | /O(n*log n)/. Create a set from a list of elements.+fromList :: Ord a => [a] -> Set a +fromList xs +  = foldlStrict ins empty xs+  where+    ins t x = insert x t++{--------------------------------------------------------------------+  Building trees from ascending/descending lists can be done in linear time.+  +  Note that if [xs] is ascending that: +    fromAscList xs == fromList xs+--------------------------------------------------------------------}+-- | /O(n)/. Build a map from an ascending list in linear time.+fromAscList :: Eq a => [a] -> Set a +fromAscList xs+  = fromDistinctAscList (combineEq xs)+  where+  -- [combineEq xs] combines equal elements with [const] in an ordered list [xs]+  combineEq xs+    = case xs of+        []     -> []+        [x]    -> [x]+        (x:xx) -> combineEq' x xx++  combineEq' z [] = [z]+  combineEq' z (x:xs)+    | z==x      = combineEq' z xs+    | otherwise = z:combineEq' x xs+++-- | /O(n)/. Build a set from an ascending list of distinct elements in linear time.+fromDistinctAscList :: [a] -> Set a +fromDistinctAscList xs+  = build const (length xs) xs+  where+    -- 1) use continutations so that we use heap space instead of stack space.+    -- 2) special case for n==5 to build bushier trees. +    build c 0 xs   = c Tip xs +    build c 5 xs   = case xs of+                       (x1:x2:x3:x4:x5:xx) +                            -> c (bin x4 (bin x2 (single x1) (single x3)) (single x5)) xx+    build c n xs   = seq nr $ build (buildR nr c) nl xs+                   where+                     nl = n `div` 2+                     nr = n - nl - 1++    buildR n c l (x:ys) = build (buildB l x c) n ys+    buildB l x c r zs   = c (bin x l r) zs++{--------------------------------------------------------------------+  Eq converts the set to a list. In a lazy setting, this +  actually seems one of the faster methods to compare two trees +  and it is certainly the simplest :-)+--------------------------------------------------------------------}+instance Eq a => Eq (Set a) where+  t1 == t2  = (size t1 == size t2) && (toAscList t1 == toAscList t2)++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}+instance Show a => Show (Set a) where+  showsPrec d s  = showSet (toAscList s)++showSet :: (Show a) => [a] -> ShowS+showSet []     +  = showString "{}" +showSet (x:xs) +  = showChar '{' . shows x . showTail xs+  where+    showTail []     = showChar '}'+    showTail (x:xs) = showChar ',' . shows x . showTail xs+    ++{--------------------------------------------------------------------+  Utility functions that return sub-ranges of the original+  tree. Some functions take a comparison function as argument to+  allow comparisons against infinite values. A function [cmplo x]+  should be read as [compare lo x].++  [trim cmplo cmphi t]  A tree that is either empty or where [cmplo x == LT]+                        and [cmphi x == GT] for the value [x] of the root.+  [filterGt cmp t]      A tree where for all values [k]. [cmp k == LT]+  [filterLt cmp t]      A tree where for all values [k]. [cmp k == GT]++  [split k t]           Returns two trees [l] and [r] where all values+                        in [l] are <[k] and all keys in [r] are >[k].+  [splitMember k t]     Just like [split] but also returns whether [k]+                        was found in the tree.+--------------------------------------------------------------------}++{--------------------------------------------------------------------+  [trim lo hi t] trims away all subtrees that surely contain no+  values between the range [lo] to [hi]. The returned tree is either+  empty or the key of the root is between @lo@ and @hi@.+--------------------------------------------------------------------}+trim :: (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a+trim cmplo cmphi Tip = Tip+trim cmplo cmphi t@(Bin sx x l r)+  = case cmplo x of+      LT -> case cmphi x of+              GT -> t+              le -> trim cmplo cmphi l+      ge -> trim cmplo cmphi r+              +trimMemberLo :: Ord a => a -> (a -> Ordering) -> Set a -> (Bool, Set a)+trimMemberLo lo cmphi Tip = (False,Tip)+trimMemberLo lo cmphi t@(Bin sx x l r)+  = case compare lo x of+      LT -> case cmphi x of+              GT -> (member lo t, t)+              le -> trimMemberLo lo cmphi l+      GT -> trimMemberLo lo cmphi r+      EQ -> (True,trim (compare lo) cmphi r)+++{--------------------------------------------------------------------+  [filterGt x t] filter all values >[x] from tree [t]+  [filterLt x t] filter all values <[x] from tree [t]+--------------------------------------------------------------------}+filterGt :: (a -> Ordering) -> Set a -> Set a+filterGt cmp Tip = Tip+filterGt cmp (Bin sx x l r)+  = case cmp x of+      LT -> join x (filterGt cmp l) r+      GT -> filterGt cmp r+      EQ -> r+      +filterLt :: (a -> Ordering) -> Set a -> Set a+filterLt cmp Tip = Tip+filterLt cmp (Bin sx x l r)+  = case cmp x of+      LT -> filterLt cmp l+      GT -> join x l (filterLt cmp r)+      EQ -> l+++{--------------------------------------------------------------------+  Split+--------------------------------------------------------------------}+-- | /O(log n)/. The expression (@split x set@) is a pair @(set1,set2)@+-- where all elements in @set1@ are lower than @x@ and all elements in+-- @set2@ larger than @x@.+split :: Ord a => a -> Set a -> (Set a,Set a)+split x Tip = (Tip,Tip)+split x (Bin sy y l r)+  = case compare x y of+      LT -> let (lt,gt) = split x l in (lt,join y gt r)+      GT -> let (lt,gt) = split x r in (join y l lt,gt)+      EQ -> (l,r)++-- | /O(log n)/. Performs a 'split' but also returns whether the pivot+-- element was found in the original set.+splitMember :: Ord a => a -> Set a -> (Bool,Set a,Set a)+splitMember x Tip = (False,Tip,Tip)+splitMember x (Bin sy y l r)+  = case compare x y of+      LT -> let (found,lt,gt) = splitMember x l in (found,lt,join y gt r)+      GT -> let (found,lt,gt) = splitMember x r in (found,join y l lt,gt)+      EQ -> (True,l,r)++{--------------------------------------------------------------------+  Utility functions that maintain the balance properties of the tree.+  All constructors assume that all values in [l] < [x] and all values+  in [r] > [x], and that [l] and [r] are valid trees.+  +  In order of sophistication:+    [Bin sz x l r]    The type constructor.+    [bin x l r]       Maintains the correct size, assumes that both [l]+                      and [r] are balanced with respect to each other.+    [balance x l r]   Restores the balance and size.+                      Assumes that the original tree was balanced and+                      that [l] or [r] has changed by at most one element.+    [join x l r]      Restores balance and size. ++  Furthermore, we can construct a new tree from two trees. Both operations+  assume that all values in [l] < all values in [r] and that [l] and [r]+  are valid:+    [glue l r]        Glues [l] and [r] together. Assumes that [l] and+                      [r] are already balanced with respect to each other.+    [merge l r]       Merges two trees and restores balance.++  Note: in contrast to Adam's paper, we use (<=) comparisons instead+  of (<) comparisons in [join], [merge] and [balance]. +  Quickcheck (on [difference]) showed that this was necessary in order +  to maintain the invariants. It is quite unsatisfactory that I haven't +  been able to find out why this is actually the case! Fortunately, it +  doesn't hurt to be a bit more conservative.+--------------------------------------------------------------------}++{--------------------------------------------------------------------+  Join +--------------------------------------------------------------------}+join :: a -> Set a -> Set a -> Set a+join x Tip r  = insertMin x r+join x l Tip  = insertMax x l+join x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)+  | delta*sizeL <= sizeR  = balance z (join x l lz) rz+  | delta*sizeR <= sizeL  = balance y ly (join x ry r)+  | otherwise             = bin x l r+++-- insertMin and insertMax don't perform potentially expensive comparisons.+insertMax,insertMin :: a -> Set a -> Set a +insertMax x t+  = case t of+      Tip -> single x+      Bin sz y l r+          -> balance y l (insertMax x r)+             +insertMin x t+  = case t of+      Tip -> single x+      Bin sz y l r+          -> balance y (insertMin x l) r+             +{--------------------------------------------------------------------+  [merge l r]: merges two trees.+--------------------------------------------------------------------}+merge :: Set a -> Set a -> Set a+merge Tip r   = r+merge l Tip   = l+merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)+  | delta*sizeL <= sizeR = balance y (merge l ly) ry+  | delta*sizeR <= sizeL = balance x lx (merge rx r)+  | otherwise            = glue l r++{--------------------------------------------------------------------+  [glue l r]: glues two trees together.+  Assumes that [l] and [r] are already balanced with respect to each other.+--------------------------------------------------------------------}+glue :: Set a -> Set a -> Set a+glue Tip r = r+glue l Tip = l+glue l r   +  | size l > size r = let (m,l') = deleteFindMax l in balance m l' r+  | otherwise       = let (m,r') = deleteFindMin r in balance m l r'+++-- | /O(log n)/. Delete and find the minimal element.+deleteFindMin :: Set a -> (a,Set a)+deleteFindMin t +  = case t of+      Bin _ x Tip r -> (x,r)+      Bin _ x l r   -> let (xm,l') = deleteFindMin l in (xm,balance x l' r)+      Tip           -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip)++-- | /O(log n)/. Delete and find the maximal element.+deleteFindMax :: Set a -> (a,Set a)+deleteFindMax t+  = case t of+      Bin _ x l Tip -> (x,l)+      Bin _ x l r   -> let (xm,r') = deleteFindMax r in (xm,balance x l r')+      Tip           -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip)+++{--------------------------------------------------------------------+  [balance x l r] balances two trees with value x.+  The sizes of the trees should balance after decreasing the+  size of one of them. (a rotation).++  [delta] is the maximal relative difference between the sizes of+          two trees, it corresponds with the [w] in Adams' paper,+          or equivalently, [1/delta] corresponds with the $\alpha$+          in Nievergelt's paper. Adams shows that [delta] should+          be larger than 3.745 in order to garantee that the+          rotations can always restore balance.         ++  [ratio] is the ratio between an outer and inner sibling of the+          heavier subtree in an unbalanced setting. It determines+          whether a double or single rotation should be performed+          to restore balance. It is correspondes with the inverse+          of $\alpha$ in Adam's article.++  Note that:+  - [delta] should be larger than 4.646 with a [ratio] of 2.+  - [delta] should be larger than 3.745 with a [ratio] of 1.534.+  +  - A lower [delta] leads to a more 'perfectly' balanced tree.+  - A higher [delta] performs less rebalancing.++  - Balancing is automatic for random data and a balancing+    scheme is only necessary to avoid pathological worst cases.+    Almost any choice will do in practice+    +  - Allthough it seems that a rather large [delta] may perform better +    than smaller one, measurements have shown that the smallest [delta]+    of 4 is actually the fastest on a wide range of operations. It+    especially improves performance on worst-case scenarios like+    a sequence of ordered insertions.++  Note: in contrast to Adams' paper, we use a ratio of (at least) 2+  to decide whether a single or double rotation is needed. Allthough+  he actually proves that this ratio is needed to maintain the+  invariants, his implementation uses a (invalid) ratio of 1. +  He is aware of the problem though since he has put a comment in his +  original source code that he doesn't care about generating a +  slightly inbalanced tree since it doesn't seem to matter in practice. +  However (since we use quickcheck :-) we will stick to strictly balanced +  trees.+--------------------------------------------------------------------}+delta,ratio :: Int+delta = 4+ratio = 2++balance :: a -> Set a -> Set a -> Set a+balance x l r+  | sizeL + sizeR <= 1    = Bin sizeX x l r+  | sizeR >= delta*sizeL  = rotateL x l r+  | sizeL >= delta*sizeR  = rotateR x l r+  | otherwise             = Bin sizeX x l r+  where+    sizeL = size l+    sizeR = size r+    sizeX = sizeL + sizeR + 1++-- rotate+rotateL x l r@(Bin _ _ ly ry)+  | size ly < ratio*size ry = singleL x l r+  | otherwise               = doubleL x l r++rotateR x l@(Bin _ _ ly ry) r+  | size ry < ratio*size ly = singleR x l r+  | otherwise               = doubleR x l r++-- basic rotations+singleL x1 t1 (Bin _ x2 t2 t3)  = bin x2 (bin x1 t1 t2) t3+singleR x1 (Bin _ x2 t1 t2) t3  = bin x2 t1 (bin x1 t2 t3)++doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)+doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)+++{--------------------------------------------------------------------+  The bin constructor maintains the size of the tree+--------------------------------------------------------------------}+bin :: a -> Set a -> Set a -> Set a+bin x l r+  = Bin (size l + size r + 1) x l r+++{--------------------------------------------------------------------+  Utilities+--------------------------------------------------------------------}+foldlStrict f z xs+  = case xs of+      []     -> z+      (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)+++{--------------------------------------------------------------------+  Debugging+--------------------------------------------------------------------}+-- | /O(n)/. Show the tree that implements the set. The tree is shown+-- in a compressed, hanging format.+showTree :: Show a => Set a -> String+showTree s+  = showTreeWith True False s+++{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows+ the tree that implements the set. If @hang@ is+ @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is true, an extra wide version is shown.++> Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5]+> 4+> +--2+> |  +--1+> |  +--3+> +--5+> +> Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5]+> 4+> |+> +--2+> |  |+> |  +--1+> |  |+> |  +--3+> |+> +--5+> +> Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5]+> +--5+> |+> 4+> |+> |  +--3+> |  |+> +--2+>    |+>    +--1++-}+showTreeWith :: Show a => Bool -> Bool -> Set a -> String+showTreeWith hang wide t+  | hang      = (showsTreeHang wide [] t) ""+  | otherwise = (showsTree wide [] [] t) ""++showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS+showsTree wide lbars rbars t+  = case t of+      Tip -> showsBars lbars . showString "|\n"+      Bin sz x Tip Tip+          -> showsBars lbars . shows x . showString "\n" +      Bin sz x l r+          -> showsTree wide (withBar rbars) (withEmpty rbars) r .+             showWide wide rbars .+             showsBars lbars . shows x . showString "\n" .+             showWide wide lbars .+             showsTree wide (withEmpty lbars) (withBar lbars) l++showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS+showsTreeHang wide bars t+  = case t of+      Tip -> showsBars bars . showString "|\n" +      Bin sz x Tip Tip+          -> showsBars bars . shows x . showString "\n" +      Bin sz x l r+          -> showsBars bars . shows x . showString "\n" . +             showWide wide bars .+             showsTreeHang wide (withBar bars) l .+             showWide wide bars .+             showsTreeHang wide (withEmpty bars) r+++showWide wide bars +  | wide      = showString (concat (reverse bars)) . showString "|\n" +  | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+  = case bars of+      [] -> id+      _  -> showString (concat (reverse (tail bars))) . showString node++node           = "+--"+withBar bars   = "|  ":bars+withEmpty bars = "   ":bars++{--------------------------------------------------------------------+  Assertions+--------------------------------------------------------------------}+-- | /O(n)/. Test if the internal set structure is valid.+valid :: Ord a => Set a -> Bool+valid t+  = balanced t && ordered t && validsize t++ordered t+  = bounded (const True) (const True) t+  where+    bounded lo hi t+      = case t of+          Tip           -> True+          Bin sz x l r  -> (lo x) && (hi x) && bounded lo (<x) l && bounded (>x) hi r++balanced :: Set a -> Bool+balanced t+  = case t of+      Tip           -> True+      Bin sz x l r  -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&+                       balanced l && balanced r+++validsize t+  = (realsize t == Just (size t))+  where+    realsize t+      = case t of+          Tip          -> Just 0+          Bin sz x l r -> case (realsize l,realsize r) of+                            (Just n,Just m)  | n+m+1 == sz  -> Just sz+                            other            -> Nothing++{-+{--------------------------------------------------------------------+  Testing+--------------------------------------------------------------------}+testTree :: [Int] -> Set Int+testTree xs   = fromList xs+test1 = testTree [1..20]+test2 = testTree [30,29..10]+test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]++{--------------------------------------------------------------------+  QuickCheck+--------------------------------------------------------------------}+qcheck prop+  = check config prop+  where+    config = Config+      { configMaxTest = 500+      , configMaxFail = 5000+      , configSize    = \n -> (div n 2 + 3)+      , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]+      }+++{--------------------------------------------------------------------+  Arbitrary, reasonably balanced trees+--------------------------------------------------------------------}+instance (Enum a) => Arbitrary (Set a) where+  arbitrary = sized (arbtree 0 maxkey)+            where maxkey  = 10000++arbtree :: (Enum a) => Int -> Int -> Int -> Gen (Set a)+arbtree lo hi n+  | n <= 0        = return Tip+  | lo >= hi      = return Tip+  | otherwise     = do{ i  <- choose (lo,hi)+                      ; m  <- choose (1,30)+                      ; let (ml,mr)  | m==(1::Int)= (1,2)+                                     | m==2       = (2,1)+                                     | m==3       = (1,1)+                                     | otherwise  = (2,2)+                      ; l  <- arbtree lo (i-1) (n `div` ml)+                      ; r  <- arbtree (i+1) hi (n `div` mr)+                      ; return (bin (toEnum i) l r)+                      }  +++{--------------------------------------------------------------------+  Valid tree's+--------------------------------------------------------------------}+forValid :: (Enum a,Show a,Testable b) => (Set a -> b) -> Property+forValid f+  = forAll arbitrary $ \t -> +--    classify (balanced t) "balanced" $+    classify (size t == 0) "empty" $+    classify (size t > 0  && size t <= 10) "small" $+    classify (size t > 10 && size t <= 64) "medium" $+    classify (size t > 64) "large" $+    balanced t ==> f t++forValidIntTree :: Testable a => (Set Int -> a) -> Property+forValidIntTree f+  = forValid f++forValidUnitTree :: Testable a => (Set Int -> a) -> Property+forValidUnitTree f+  = forValid f+++prop_Valid +  = forValidUnitTree $ \t -> valid t++{--------------------------------------------------------------------+  Single, Insert, Delete+--------------------------------------------------------------------}+prop_Single :: Int -> Bool+prop_Single x+  = (insert x empty == single x)++prop_InsertValid :: Int -> Property+prop_InsertValid k+  = forValidUnitTree $ \t -> valid (insert k t)++prop_InsertDelete :: Int -> Set Int -> Property+prop_InsertDelete k t+  = not (member k t) ==> delete k (insert k t) == t++prop_DeleteValid :: Int -> Property+prop_DeleteValid k+  = forValidUnitTree $ \t -> +    valid (delete k (insert k t))++{--------------------------------------------------------------------+  Balance+--------------------------------------------------------------------}+prop_Join :: Int -> Property +prop_Join x+  = forValidUnitTree $ \t ->+    let (l,r) = split x t+    in valid (join x l r)++prop_Merge :: Int -> Property +prop_Merge x+  = forValidUnitTree $ \t ->+    let (l,r) = split x t+    in valid (merge l r)+++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+prop_UnionValid :: Property+prop_UnionValid+  = forValidUnitTree $ \t1 ->+    forValidUnitTree $ \t2 ->+    valid (union t1 t2)++prop_UnionInsert :: Int -> Set Int -> Bool+prop_UnionInsert x t+  = union t (single x) == insert x t++prop_UnionAssoc :: Set Int -> Set Int -> Set Int -> Bool+prop_UnionAssoc t1 t2 t3+  = union t1 (union t2 t3) == union (union t1 t2) t3++prop_UnionComm :: Set Int -> Set Int -> Bool+prop_UnionComm t1 t2+  = (union t1 t2 == union t2 t1)+++prop_DiffValid+  = forValidUnitTree $ \t1 ->+    forValidUnitTree $ \t2 ->+    valid (difference t1 t2)++prop_Diff :: [Int] -> [Int] -> Bool+prop_Diff xs ys+  =  toAscList (difference (fromList xs) (fromList ys))+    == List.sort ((List.\\) (nub xs)  (nub ys))++prop_IntValid+  = forValidUnitTree $ \t1 ->+    forValidUnitTree $ \t2 ->+    valid (intersection t1 t2)++prop_Int :: [Int] -> [Int] -> Bool+prop_Int xs ys+  =  toAscList (intersection (fromList xs) (fromList ys))+    == List.sort (nub ((List.intersect) (xs)  (ys)))++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}+prop_Ordered+  = forAll (choose (5,100)) $ \n ->+    let xs = [0..n::Int]+    in fromAscList xs == fromList xs++prop_List :: [Int] -> Bool+prop_List xs+  = (sort (nub xs) == toList (fromList xs))+-}
+ src/UU/PPrint.hs view
@@ -0,0 +1,414 @@+-------------------------------------------------------------------------------- +{-| Module      :  PPrint+    Copyright   :  (c) Daan Leijen 2000, <http://www.cs.uu.nl/~daan>+    Version      : $version: $++    Maintainer  :  daan@cs.uu.nl+    Stability   :  provisional+    Portability :  portable++    Pretty print library based on Philip Wadlers "prettier printer"+         "A prettier printer"+         Draft paper, April 1997, revised March 1998. +         <http://cm.bell-labs.com/cm/cs/who/wadler/papers/prettier/prettier.ps>+   +    Haskell98 compatible+-}+--------------------------------------------------------------------------------- +module UU.PPrint +        ( Doc+        , Pretty, pretty+        +        , show, putDoc, hPutDoc+        +        , (<>)+        , (<+>)+        , (</>), (<//>)+        , (<$>), (<$$>)+        +        , sep, fillSep, hsep, vsep+        , cat, fillCat, hcat, vcat+        , punctuate+        +        , align, hang, indent+        , fill, fillBreak+        +        , list, tupled, semiBraces, encloseSep+        , angles, langle, rangle+        , parens, lparen, rparen+        , braces, lbrace, rbrace+        , brackets, lbracket, rbracket+        , dquotes, dquote, squotes, squote+        +        , comma, space, dot, backslash+        , semi, colon, equals+        +        , string, bool, int, integer, float, double, rational+        +        , softline, softbreak+        , empty, char, text, line, linebreak, nest, group        +        , column, nesting, width        +        +        , SimpleDoc(..)+        , renderPretty, renderCompact+        , displayS, displayIO                +        ) where++import IO      (Handle,hPutStr,hPutChar,stdout)++infixr 5 </>,<//>,<$>,<$$>+infixr 6 <>,<+>+++-----------------------------------------------------------+-- list, tupled and semiBraces pretty print a list of+-- documents either horizontally or vertically aligned.+-----------------------------------------------------------+list            = encloseSep lbracket rbracket comma+tupled          = encloseSep lparen   rparen  comma+semiBraces      = encloseSep lbrace   rbrace  semi++encloseSep left right sep ds+    = case ds of+        []  -> left <> right+        [d] -> left <> d <> right+        _   -> align (cat (zipWith (<>) (left : repeat sep) ds) <> right) +++-----------------------------------------------------------+-- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn]+-----------------------------------------------------------+punctuate p []      = []+punctuate p [d]     = [d]+punctuate p (d:ds)  = (d <> p) : punctuate p ds++                   +-----------------------------------------------------------+-- high-level combinators+-----------------------------------------------------------+sep             = group . vsep+fillSep         = fold (</>)+hsep            = fold (<+>)+vsep            = fold (<$>) ++cat             = group . vcat+fillCat         = fold (<//>)+hcat            = fold (<>)+vcat            = fold (<$$>) ++fold f []       = empty+fold f ds       = foldr1 f ds++x <> y          = x `beside` y+x <+> y         = x <> space <> y+x </> y         = x <> softline <> y+x <//> y        = x <> softbreak <> y   +x <$> y         = x <> line <> y+x <$$> y        = x <> linebreak <> y++softline        = group line+softbreak       = group linebreak++squotes         = enclose squote squote+dquotes         = enclose dquote dquote+braces          = enclose lbrace rbrace+parens          = enclose lparen rparen+angles          = enclose langle rangle+brackets        = enclose lbracket rbracket+enclose l r x   = l <> x <> r++lparen          = char '('+rparen          = char ')'+langle          = char '<'+rangle          = char '>'+lbrace          = char '{'+rbrace          = char '}'+lbracket        = char '['+rbracket        = char ']'++squote          = char '\''+dquote          = char '"'+semi            = char ';'+colon           = char ':'+comma           = char ','+space           = char ' '+dot             = char '.'+backslash       = char '\\'+equals          = char '='+++-----------------------------------------------------------+-- Combinators for prelude types+-----------------------------------------------------------++-- string is like "text" but replaces '\n' by "line"+string ""       = empty+string ('\n':s) = line <> string s+string s        = case (span (/='\n') s) of+                    (xs,ys) -> text xs <> string ys+                  +bool :: Bool -> Doc+bool b          = text (show b)++int :: Int -> Doc                  +int i           = text (show i)++integer :: Integer -> Doc+integer i       = text (show i)++float :: Float -> Doc+float f         = text (show f)++double :: Double -> Doc+double d        = text (show d)++rational :: Rational -> Doc+rational r      = text (show r)+                  +                                                     +-----------------------------------------------------------+-- overloading "pretty"+-----------------------------------------------------------+class Pretty a where+  pretty        :: a -> Doc +  prettyList    :: [a] -> Doc+  prettyList    = list . map pretty++instance Pretty a => Pretty [a] where+  pretty        = prettyList+  +instance Pretty Doc where+  pretty        = id  +  +instance Pretty () where+  pretty ()     = text "()"++instance Pretty Bool where+  pretty b      = bool b+  +instance Pretty Char where+  pretty c      = char c+  prettyList s  = string s+    +instance Pretty Int where+  pretty i      = int i+  +instance Pretty Integer where+  pretty i      = integer i++instance Pretty Float where+  pretty f      = float f++instance Pretty Double where+  pretty d      = double d+  ++--instance Pretty Rational where+--  pretty r      = rational r  ++instance (Pretty a,Pretty b) => Pretty (a,b) where+  pretty (x,y)  = tupled [pretty x, pretty y]++instance (Pretty a,Pretty b,Pretty c) => Pretty (a,b,c) where+  pretty (x,y,z)= tupled [pretty x, pretty y, pretty z]++instance Pretty a => Pretty (Maybe a) where+  pretty Nothing        = empty+  pretty (Just x)       = pretty x+  +++-----------------------------------------------------------+-- semi primitive: fill and fillBreak +-----------------------------------------------------------+fillBreak f x   = width x (\w ->+                  if (w > f) then nest f linebreak +                             else text (spaces (f - w)))+    +fill f d        = width d (\w ->+                  if (w >= f) then empty+                              else text (spaces (f - w)))+        +width d f       = column (\k1 -> d <> column (\k2 -> f (k2 - k1)))        +        ++-----------------------------------------------------------+-- semi primitive: Alignment and indentation+-----------------------------------------------------------+indent i d      = hang i (text (spaces i) <> d)++hang i d        = align (nest i d)++align d         = column (\k ->+                  nesting (\i -> nest (k - i) d))   --nesting might be negative :-)++++-----------------------------------------------------------+-- Primitives+-----------------------------------------------------------+data Doc        = Empty+                | Char Char             -- invariant: char is not '\n'+                | Text !Int String      -- invariant: text doesn't contain '\n'+                | Line !Bool            -- True <=> when undone by group, do not insert a space +                | Cat Doc Doc+                | Nest !Int Doc+                | Union Doc Doc         -- invariant: first lines of first doc longer than the first lines of the second doc+                | Column  (Int -> Doc)+                | Nesting (Int -> Doc)+                +data SimpleDoc  = SEmpty+                | SChar Char SimpleDoc+                | SText !Int String SimpleDoc+                | SLine !Int SimpleDoc+                +                +empty           = Empty++char '\n'       = line+char c          = Char c++text ""         = Empty+text s          = Text (length s) s++line            = Line False+linebreak       = Line True++beside x y      = Cat x y+nest i x        = Nest i x+column f        = Column f+nesting f       = Nesting f     +group x         = Union (flatten x) x++flatten :: Doc -> Doc+flatten (Cat x y)       = Cat (flatten x) (flatten y)+flatten (Nest i x)      = Nest i (flatten x)+flatten (Line break)    = if break then Empty else Text 1 " "+flatten (Union x y)     = flatten x+flatten (Column f)      = Column (flatten . f)+flatten (Nesting f)     = Nesting (flatten . f)+flatten other           = other                     --Empty,Char,Text+  +  ++-----------------------------------------------------------+-- Renderers+-----------------------------------------------------------++-----------------------------------------------------------+-- renderPretty: the default pretty printing algorithm+-----------------------------------------------------------++-- list of indentation/document pairs; saves an indirection over [(Int,Doc)]+data Docs   = Nil+            | Cons !Int Doc Docs++renderPretty :: Float -> Int -> Doc -> SimpleDoc+renderPretty rfrac w x      +    = best 0 0 (Cons 0 x Nil)                +    where+      -- r :: the ribbon width in characters+      r  = max 0 (min w (round (fromIntegral w * rfrac)))+      +      -- best :: n = indentation of current line+      --         k = current column  +      --        (ie. (k >= n) && (k - n == count of inserted characters)+      best n k Nil      = SEmpty+      best n k (Cons i d ds)  +        = case d of+            Empty       -> best n k ds                +            Char c      -> let k' = k+1 in seq k' (SChar c (best n k' ds))+            Text l s    -> let k' = k+l in seq k' (SText l s (best n k' ds))+            Line _      -> SLine i (best i i ds)                 +            Cat x y     -> best n k (Cons i x (Cons i y ds))                +            Nest j x    -> let i' = i+j in seq i' (best n k (Cons i' x ds))+            Union x y   -> nicest n k (best n k (Cons i x ds))                +                                      (best n k (Cons i y ds))                ++            Column f    -> best n k (Cons i (f k) ds)+            Nesting f   -> best n k (Cons i (f i) ds)                            ++      --nicest :: r = ribbon width, w = page width, +      --          n = indentation of current line, k = current column+      --          x and y, the (simple) documents to chose from.+      --          precondition: first lines of x are longer than the first lines of y.                                      +      nicest n k x y    | fits width x  = x+                        | otherwise     = y+                        where+                          width = min (w - k) (r - k + n)+  +                                                                                      +fits w x        | w < 0         = False+fits w SEmpty                   = True+fits w (SChar c x)              = fits (w - 1) x                  +fits w (SText l s x)            = fits (w - l) x+fits w (SLine i x)              = True+++-----------------------------------------------------------+-- renderCompact: renders documents without indentation+--  fast and fewer characters output, good for machines+-----------------------------------------------------------+renderCompact :: Doc -> SimpleDoc+renderCompact x   +    = scan 0 [x]+    where+      scan k []     = SEmpty+      scan k (d:ds) = case d of+                        Empty       -> scan k ds+                        Char c      -> let k' = k+1 in seq k' (SChar c (scan k' ds))+                        Text l s    -> let k' = k+l in seq k' (SText l s (scan k' ds))+                        Line _      -> SLine 0 (scan 0 ds)    +                        Cat x y     -> scan k (x:y:ds)+                        Nest j x    -> scan k (x:ds)+                        Union x y   -> scan k (y:ds)+                        Column f    -> scan k (f k:ds)+                        Nesting f   -> scan k (f 0:ds)++++-----------------------------------------------------------+-- Displayers:  displayS and displayIO+-----------------------------------------------------------+displayS :: SimpleDoc -> ShowS+displayS SEmpty             = id+displayS (SChar c x)        = showChar c . displayS x+displayS (SText l s x)      = showString s . displayS x+displayS (SLine i x)        = showString ('\n':indentation i) . displayS x++displayIO :: Handle -> SimpleDoc -> IO ()+displayIO handle simpleDoc+    = display simpleDoc+    where+      display SEmpty        = return ()+      display (SChar c x)   = do{ hPutChar handle c; display x}  +      display (SText l s x) = do{ hPutStr handle s; display x}+      display (SLine i x)   = do{ hPutStr handle ('\n':indentation i); display x}+++-----------------------------------------------------------+-- default pretty printers: show, putDoc and hPutDoc+-----------------------------------------------------------+instance Show Doc where+  showsPrec d doc       = displayS (renderPretty 0.4 80 doc)++putDoc :: Doc -> IO ()+putDoc doc              = hPutDoc stdout doc++hPutDoc :: Handle -> Doc -> IO ()+hPutDoc handle doc      = displayIO handle (renderPretty 0.4 80 doc)++++-----------------------------------------------------------+-- insert spaces+-- "indentation" used to insert tabs but tabs seem to cause+-- more trouble than they solve :-) +-----------------------------------------------------------+spaces n        | n <= 0    = ""+                | otherwise = replicate n ' '++indentation n   = spaces n++--indentation n   | n >= 8    = '\t' : indentation (n-8)+--                | otherwise = spaces n
+ src/UU/Parsing.hs view
@@ -0,0 +1,20 @@+module UU.Parsing( module UU.Parsing.Derived+                 , module UU.Parsing.Interface+                 , parseIO+                 ) where++import UU.Parsing.Derived+import UU.Parsing.Interface++parseIO :: (Eq s, Show s, Symbol s) => Parser s a -> [s] -> IO a+parseIO = parseIOMessage showMessage +  where showMessage (Msg expecting position action)  +          =  let pos = case position of+                           Nothing -> "at end of file"+                           Just s  -> case action of +                                Insert _ -> "before " ++ show s+                                Delete t -> "at " ++ show t  +             in "\n?? Error      : " ++ pos +++                "\n?? Expecting  : " ++ show expecting +++                "\n?? Repaired by: " ++ show action ++ "\n"                +
+ src/UU/Parsing/CharParser.hs view
@@ -0,0 +1,53 @@+module UU.Parsing.CharParser where++import UU.Parsing.Interface+import UU.Scanner.Position+++type CharParser = AnaParser Input Pair Char Pos++instance Symbol Char where+ symBefore    = pred+ symAfter     = succ+ deleteCost _ = 5++data Input = Input String !Pos++instance InputState Input Char Pos where+  splitStateE (Input inp pos) = +        case inp of+          ('\CR':      xs) -> case xs of+                                ('\LF' : _ ) -> Left' '\CR' (Input xs pos)+                                _            -> Left' '\CR' (Input xs (newl pos))+          ('\LF':      xs) -> Left' '\LF' (Input xs (newl   pos))+--          ('\n' :      xs) -> Left' '\n'  (Input xs (newl pos))  -- \n already captured above+          ('\t' :      xs) -> Left' '\t' (Input xs (tab    pos))+          (x    :      xs) -> Left' x    (Input xs (advc 1 pos))+          []               -> Right'     (Input [] pos)+            +  splitState  (Input inp pos) =  +        case inp of+          ('\CR':      xs) -> case xs of+                                ('\LF' : _ ) -> ('\CR', Input xs pos)+                                _            -> ('\CR', Input xs (newl pos))+          ('\LF':      xs) -> ( '\LF', Input xs (newl   pos))+--          ('\n' :      xs) -> ( '\n' , Input xs (newl   pos)) -- \n already captured above+          ('\t' :      xs) -> ( '\t' , Input xs (tab    pos))+          (x    :      xs) -> ( x    , Input xs (advc 1 pos))++  getPosition (Input inp pos) = pos++parseString :: CharParser a +            -> [Char] +            -> Steps (Pair a (Pair Input ())) Char Pos+parseString p txt = parse p ((Input txt (initPos "")))++parseStringIO :: (Message Char Pos -> String) +              -> CharParser a +              -> [Char] +              -> IO a+parseStringIO showM p txt = parseIOMessage showM p (Input txt (initPos ""))++parseFile :: (Message Char Pos -> String) -> CharParser a -> [Char] -> IO a+parseFile showM p filename = do txt <- readFile filename+                                parseIOMessage showM p (Input txt (initPos filename))
+ src/UU/Parsing/Derived.hs view
@@ -0,0 +1,213 @@+module UU.Parsing.Derived where++import UU.Parsing.Interface++infixl 2 <?>+infixl 4  <**>, <??>, <+>+infixl 2 `opt`+infixl 5 <..>+++-- =======================================================================================+-- ===== CHECKING ========================================================================+-- =======================================================================================+-- | Checks if the parser accepts epsilon.+acceptsepsilon :: (IsParser p s) => p v -> Bool+acceptsepsilon p       = case getzerop p of {Nothing -> False; _ -> True}++mnz :: (IsParser p s) => p v -> t -> String -> t+mnz p v comb+   = if( acceptsepsilon p)+     then   usererror ("The combinator <" ++ comb ++ "> from <Derived.hs>is called with a parser that accepts the empty string.\n"+                    +++                   "The library cannot handle the resulting left recursive formulation (which is ambiguous too).\n"+                 --  +++                 --  (case getfirsts p of+                 --   ESeq []  ->  "There are no other alternatives for this parser"+                 --   d        ->  "The other alternatives of this parser may start with:\n"++ show d+                  ) --)+     else v+-- =======================================================================================+-- ===== START OF PRELUDE DEFINITIONS ========== =========================================+-- =======================================================================================++-- | Parses the specified range, see also 'pRange'.+-- +-- Example:+-- +-- > pDig = 'a' <..> 'z'+(<..>) :: (IsParser p s) => s -> s -> p s+a <..> b   = pRange a (Range a b)++pExcept :: (IsParser p s, Symbol s, Ord s, Eq (SymbolR s)) => (s, s, s) -> [s] -> p s+pExcept (l,r,err) elems = let ranges = filter (/= EmptyR) (Range l r `except` elems)+                          in if null ranges then pFail+                             else foldr (<|>) pFail (map (pRange err) ranges)++++-- | Optionally recognize parser 'p'.+-- +-- If 'p' can be recognized, the return value of 'p' is used. Otherwise,+-- the value 'v' is used. Note that opt is greedy, if you do not want+-- this use @... <|> pSucceed v@  instead. Furthermore, 'p' should not+-- recognise the empty string.+opt ::  (IsParser p s) => p a -> a -> p a+p `opt` v       = mnz p (p  <|> pLow v)  "opt"  +                                                +                                                ++-- =======================================================================================+-- ===== Special sequential compositions =========================================+-- =======================================================================================+asList ::  (IsParser p s) =>  Expecting s -> p v -> p v+asList  exp = setfirsts (ESeq [EStr "(",  exp, EStr  " ...)*"])++asList1 :: (IsParser p s) => Expecting s -> p v -> p v+asList1 exp = setfirsts (ESeq [EStr "(",  exp, EStr  " ...)+"])++asOpt :: (IsParser p s) => Expecting s -> p v -> p v+asOpt   exp = setfirsts (ESeq [EStr "( ", exp, EStr  " ...)?"])++-- | Parses the sequence of 'pa' and 'pb', and combines them as a tuple.+(<+>) :: (IsParser p s) => p a -> p b -> p (a, b)+pa <+> pb       = (,) <$> pa <*> pb++-- | Suppose we have a parser a with two alternatives that both start+-- with recognizing a non-terminal p, then we will typically rewrite:+--+-- > a =     f <$> p <*> q +-- >     <|> g <$> p <*> r +--+-- into: +--+-- > a = p <**> (f <$$> q <|> g <$$> r)+(<**>) :: (IsParser p s) => p a -> p (a -> b) -> p b+p <**> q        = (\ x f -> f x) <$> p <*> q++(<$$>) :: (IsParser p s) => (a -> b -> c) -> p b -> p (a -> c)+f <$$> p        = pSucceed (flip f) <*> p++(<??>) :: (IsParser p s) => p a -> p (a -> a) -> p a+p <??> q        = p <**> (q `opt` id)++(<?>) :: (IsParser p s) => p v -> String -> p v+p <?>  str      = setfirsts  (EStr str) p++-- | This can be used to parse 'x' surrounded by 'l' and 'r'.+-- +-- Example:+--+-- > pParens = pPacked pOParen pCParen+pPacked :: (IsParser p s) => p a -> p b1 -> p b -> p b+pPacked l r x   =   l *>  x <*   r++-- =======================================================================================+-- ===== Iterating ps ===============================================================+-- =======================================================================================+pFoldr_ng :: (IsParser p s) => (a -> a1 -> a1, a1) -> p a -> p a1+pFoldr_ng      alg@(op,e)     p = mnz p (asList (getfirsts p) pfm) "pFoldr_ng"+                                  where pfm = (op <$> p <*> pfm)  <|> pSucceed e+pFoldr_gr :: (IsParser p s) => (a -> b -> b, b) -> p a -> p b+pFoldr_gr      alg@(op,e)     p = mnz p (asList (getfirsts p) pfm) "pFoldr_gr"+                                  where pfm = (op <$> p <*> pfm) `opt` e+pFoldr :: (IsParser p s) =>(a -> b -> b, b) -> p a -> p b+pFoldr         alg            p = pFoldr_gr alg p++pFoldr1_gr :: (IsParser p s) => (v -> b -> b, b) -> p v -> p b+pFoldr1_gr     alg@(op,e)     p = asList1 (getfirsts p) (op <$> p <*> pFoldr_gr  alg p)+pFoldr1_ng ::  (IsParser p s) => (v -> b -> b, b) -> p v -> p b+pFoldr1_ng     alg@(op,e)     p = asList1 (getfirsts p) (op <$> p <*> pFoldr_ng  alg p)+pFoldr1 :: (IsParser p s) => (v -> b -> b, b) -> p v -> p b+pFoldr1        alg            p = pFoldr1_gr alg  p++pFoldrSep_gr :: (IsParser p s) => (v -> b -> b, b) -> p a -> p v -> p b+pFoldrSep_gr   alg@(op,e) sep p = mnz sepp (asList (getfirsts p)((op <$> p <*> pFoldr_gr alg sepp) `opt` e )) "pFoldrSep_gr (both args)"+                                  where sepp = sep *> p+pFoldrSep_ng :: (IsParser p s) => (v -> b -> b, b) -> p a -> p v -> p b+pFoldrSep_ng   alg@(op,e) sep p = mnz sepp (asList (getfirsts p)((op <$> p <*> pFoldr_ng alg sepp)  <|>  pSucceed e)) "pFoldrSep_ng (both args)"+                                  where sepp = sep *> p+pFoldrSep ::  (IsParser p s) => (v -> b -> b, b) -> p a -> p v -> p b+pFoldrSep      alg        sep p = pFoldrSep_gr alg sep p++pFoldr1Sep_gr :: (IsParser p s) => (a -> b -> b, b) -> p a1 -> p a -> p b+pFoldr1Sep_gr  alg@(op,e) sep p = if acceptsepsilon sep then mnz p pfm "pFoldr1Sep_gr (both arguments)" else pfm+                                  where pfm = op <$> p <*> pFoldr_gr alg (sep *> p)+pFoldr1Sep_ng :: (IsParser p s) => (a -> b -> b, b) -> p a1 -> p a -> p b+pFoldr1Sep_ng  alg@(op,e) sep p = if acceptsepsilon sep  then mnz p pfm "pFoldr1Sep_ng (both arguments)" else pfm+                                  where pfm = op <$> p <*> pFoldr_ng alg (sep *> p)+pFoldr1Sep :: (IsParser p s) => (a -> b -> b, b) -> p a1 -> p a -> p b+pFoldr1Sep     alg        sep p = pFoldr1Sep_gr alg sep p++list_alg :: (a -> [a] -> [a], [a1])+list_alg = ((:), [])++pList_gr ::  (IsParser p s) => p a -> p [a]+pList_gr        p = pFoldr_gr     list_alg   p+pList_ng :: (IsParser p s) =>  p a -> p [a]+pList_ng        p = pFoldr_ng     list_alg   p+pList ::  (IsParser p s) => p a -> p [a]+pList           p = pList_gr p++pList1_gr ::  (IsParser p s) => p a -> p [a]+pList1_gr       p = pFoldr1_gr    list_alg   p+pList1_ng :: (IsParser p s) => p a -> p [a]+pList1_ng       p = pFoldr1_ng    list_alg   p+pList1 :: (IsParser p s) =>  p a -> p [a]+pList1          p = pList1_gr                p++pListSep_gr :: (IsParser p s) => p a1 -> p a -> p [a]+pListSep_gr   s p = pFoldrSep_gr  list_alg s p+pListSep_ng :: (IsParser p s) => p a1 -> p a -> p [a]+pListSep_ng   s p = pFoldrSep_ng  list_alg s p+pListSep :: (IsParser p s) => p a -> p a1 -> p [a1]+pListSep      s p = pListSep_gr            s p++pList1Sep_gr :: (IsParser p s) => p a1 -> p a -> p [a]+pList1Sep_gr  s p = pFoldr1Sep_gr list_alg s p+pList1Sep_ng :: (IsParser p s) =>  p a1 -> p a -> p [a]+pList1Sep_ng  s p = pFoldr1Sep_ng list_alg s p+pList1Sep :: (IsParser p s) =>p a -> p a1 -> p [a1]+pList1Sep     s p = pList1Sep_gr          s p++pChainr_gr :: (IsParser p s) => p (c -> c -> c) -> p c -> p c+pChainr_gr op x    =  if acceptsepsilon op then mnz x r "pChainr_gr (both arguments)" else r+                   where r = x <??> (flip <$> op <*> r)+pChainr_ng :: (IsParser p s) => p (a -> a -> a) -> p a -> p a+pChainr_ng op x    =  if acceptsepsilon op then mnz x r "pChainr_ng (both arguments)" else r+                   where r = x <**> ((flip <$> op <*> r)  <|> pSucceed id)+pChainr :: (IsParser p s) => p (c -> c -> c) -> p c -> p c+pChainr    op x    = pChainr_gr op x++pChainl_gr :: (IsParser p s) => p (c -> c -> c) -> p c -> p c+pChainl_gr op x    =  if acceptsepsilon op then mnz x r "pChainl_gr (both arguments)" else r+                      where+                       r      = (f <$> x <*> pList_gr (flip <$> op <*> x) )+                       f x [] = x+                       f x (func:rest) = f (func x) rest++pChainl_ng :: (IsParser p s) => p (c -> c -> c) -> p c -> p c+pChainl_ng op x    =  if acceptsepsilon op then mnz x r "pChainl_ng (both arguments)" else r+                   where+                    r      = (f <$> x <*> pList_ng (flip <$> op <*> x) )+                    f x [] = x+                    f x (func:rest) = f (func x) rest+pChainl :: (IsParser p s) => p (c -> c -> c) -> p c -> p c+pChainl    op x    = pChainl_gr op x++-- | Parses using any of the parsers in the list 'l'.+--+-- Warning: 'l' may not be an empty list.+pAny :: (IsParser p s) =>(a -> p a1) -> [a] -> p a1+pAny  f l = if null l then usererror "pAny: argument may not be empty list" else foldr1 (<|>) (map f l)++-- | Parses any of the symbols in 'l'.+pAnySym :: (IsParser p s) =>[s] -> p s+pAnySym l = pAny pSym l -- used to be called pAnySym++pToks :: (IsParser p s) => [s] -> p [s]+pToks []     = pSucceed []+pToks (a:as) = (:) <$> pSym a <*> pToks as++pLocate :: (IsParser p s) => [[s]] -> p [s]+pLocate list = pAny pToks list
+ src/UU/Parsing/Interface.hs view
@@ -0,0 +1,199 @@+{-# OPTIONS -fglasgow-exts  #-}+module UU.Parsing.Interface +       ( AnaParser, pWrap, pMap+       , module UU.Parsing.MachineInterface+       , module UU.Parsing.Interface+       ) where++import UU.Parsing.Machine+import UU.Parsing.MachineInterface+--import IOExts+import System.IO.Unsafe+import System.IO+-- ==================================================================================+-- ===== PRIORITIES ======================================================================+-- =======================================================================================+infixl 3 <|>+infixl 4 <*>, <$> +infixl 4 <$, <*, *>+++-- =======================================================================================+-- ===== ANAPARSER INSTANCES =============================================================+-- =======================================================================================+type Parser s = AnaParser [s] Pair s (Maybe s)+-- =======================================================================================+-- ===== PARSER CLASSES ==================================================================+-- =======================================================================================++-- | The 'IsParser' class contains the base combinators with which+-- to write parsers. A minimal complete instance definition consists of+-- definitions for '(<*>)', '(<|>)', 'pSucceed', 'pLow', 'pFail', +-- 'pCostRange', 'pCostSym', 'getfirsts', 'setfirsts', and 'getzerop'.+class  IsParser p s | p -> s where+  -- | Sequential composition. Often used in combination with <$>.+  -- The function returned by parsing the left-hand side is applied +  -- to the value returned by parsing the right-hand side.+  -- Note: Implementations of this combinator should lazily match on+  -- and evaluate the right-hand side parser. The derived combinators +  -- for list parsing will explode if they do not.+  (<*>) :: p (a->b) -> p a -> p b+  -- | Value ignoring versions of sequential composition. These ignore+  -- either the value returned by the parser on the right-hand side or +  -- the left-hand side, depending on the visual direction of the+  -- combinator.+  (<* ) :: p a      -> p b -> p a+  ( *>) :: p a      -> p b -> p b+  -- | Applies the function f to the result of p after parsing p.+  (<$>) :: (a->b)   -> p a -> p b+  (<$ ) :: b        -> p a -> p b+  -- | Two variants of the parser for empty strings. 'pSucceed' parses the+  -- empty string, and fully counts as an alternative parse. It returns the+  -- value passed to it.+  pSucceed :: a -> p a+  -- | 'pLow' parses the empty string, but alternatives to pLow are always+  -- preferred over 'pLow' parsing the empty string.+  pLow     :: a -> p a+  f <$> p = pSucceed f <*> p+  f <$  q = pSucceed f <*  q+  p <*  q = pSucceed       const  <*> p <*> q+  p  *> q = pSucceed (flip const) <*> p <*> q+  -- | Alternative combinator. Succeeds if either of the two arguments+  -- succeed, and returns the result of the best success parse.+  (<|>) :: p a -> p a -> p a+  -- | This parser always fails, and never returns any value at all.+  pFail :: p a+  -- | Parses a range of symbols with an associated cost and the symbol to+  -- insert if no symbol in the range is present. Returns the actual symbol+  -- parsed.+  pCostRange   :: Int{-#L-} -> s -> SymbolR s -> p s+  -- | Parses a symbol with an associated cost and the symbol to insert if+  -- the symbol to parse isn't present. Returns either the symbol parsed or+  -- the symbol inserted.+  pCostSym     :: Int{-#L-} -> s -> s         -> p s+  -- | Parses a symbol. Returns the symbol parsed.+  pSym         ::                   s         -> p s+  pRange       ::              s -> SymbolR s -> p s+  -- | Get the firsts set from the parser, i.e. the symbols it expects.+  getfirsts    :: p v -> Expecting s+  -- | Set the firsts set in the parser.+  setfirsts    :: Expecting s -> p v ->  p v+  pSym a       =  pCostSym   5{-#L-} a a+  pRange       =  pCostRange 5{-#L-}+  -- | 'getzerop' returns @Nothing@ if the parser can not parse the empty+  -- string, and returns @Just p@ with @p@ a parser that parses the empty +  -- string and returns the appropriate value.+  getzerop     ::              p v -> Maybe (p v)+  -- | 'getonep' returns @Nothing@ if the parser can only parse the empty+  -- string, and returns @Just p@ with @p@ a parser that does not parse any+  -- empty string.+  getonep      :: p v -> Maybe (p v)+++-- | The fast 'AnaParser' instance of the 'IsParser' class. Note that this+-- requires a functioning 'Ord' for the symbol type s, as tokens are+-- often compared using the 'compare' function in 'Ord' rather than always+-- using '==' rom 'Eq'. The two do need to be consistent though, that is+-- for any two @x1@, @x2@ such that @x1 == x2@ you must have +-- @compare x1 x2 == EQ@.+instance (Ord s, Symbol s, InputState state s p, OutputState result) => IsParser (AnaParser state result s p) s   where+  (<*>) p q = anaSeq libDollar  libSeq  ($) p q+  (<* ) p q = anaSeq libDollarL libSeqL const p q+  ( *>) p q = anaSeq libDollarR libSeqR (flip const) p q+  pSucceed =  anaSucceed+  pLow     =  anaLow+  (<|>) =  anaOr+  pFail = anaFail+  pCostRange   = anaCostRange+  pCostSym i ins sym = anaCostRange i ins (mk_range sym sym)+  getfirsts    = anaGetFirsts+  setfirsts    = anaSetFirsts+  getzerop  p  = case zerop p of+                 Nothing     -> Nothing+                 Just (b,e)  -> Just p { pars = libSucceed `either` id $ e+                                       , leng = Zero+                                       , onep = noOneParser+                                       }+  getonep   p = let tab = table (onep p)+                in if null tab then Nothing else Just (mkParser (leng p) Nothing (onep p))++instance InputState [s] s (Maybe s) where+ splitStateE []     = Right' []+ splitStateE (s:ss) = Left'  s ss+ splitState  (s:ss) = ({-#L-} s, ss{-L#-})+ getPosition []     = Nothing+ getPosition (s:ss) = Just s+++instance OutputState Pair  where+  acceptR            = Pair+  nextR       acc    = \ f   ~(Pair a r) -> acc  (f a) r  +  +pCost :: (OutputState out, InputState inp sym pos, Symbol sym, Ord sym) +      => Int -> AnaParser inp out sym pos ()+pCost x = pMap f f' (pSucceed ())+  where f  acc inp steps = (inp, Cost x (val (uncurry acc) steps))+        f'     inp steps = (inp, Cost x steps)++getInputState :: (InputState a c d, Symbol c, Ord c, OutputState b)=>AnaParser a b c d a+getInputState = pMap f g (pSucceed id)+  where f acc inp steps = (inp, val (acc inp . snd) steps)+        g = (,)++handleEof input = case splitStateE input+                   of Left'  s  ss  ->  StRepair (deleteCost s)  +                                                 (Msg (EStr "end of file") (getPosition input) +                                                                   (Delete s)+                                                 ) +                                                 (handleEof ss)+                      Right' ss      ->  NoMoreSteps (Pair ss ())++parse :: (Symbol s, InputState inp s pos) +      => AnaParser inp Pair s pos a +      -> inp +      -> Steps (Pair a (Pair inp ())) s pos+parse = parsebasic handleEof+++parseIOMessage :: ( Symbol s, InputState inp s p) +               => (Message s p -> String) +               -> AnaParser inp Pair s p a +               -> inp +               -> IO a+parseIOMessage showMessage p inp+ = do  (Pair v final) <- evalStepsIO showMessage (parse p inp) +       final `seq` return v -- in order to force the trailing error messages to be printed+       +parseIOMessageN :: ( Symbol s, InputState inp s p) +               => (Message s p -> String) +               -> Int+               -> AnaParser inp Pair s p a +               -> inp +               -> IO a+parseIOMessageN showMessage n p inp+ = do  (Pair v final) <- evalStepsIO' showMessage n (parse p inp) +       final `seq` return v -- in order to force the trailing error messages to be printed++data Pair a r = Pair a r++evalStepsIO :: (Message s p -> String) +            ->  Steps b s p +            -> IO b+evalStepsIO showMessage = evalStepsIO' showMessage (-1)      +       +evalStepsIO' :: (Message s p -> String) +            -> Int+            ->  Steps b s p +            -> IO b+evalStepsIO' showMessage n (steps :: Steps b s p) = eval n steps+  where eval                      :: Int -> Steps a s p -> IO a+        eval 0 steps               = return (evalSteps steps)+        eval n steps = case steps of+          OkVal v        rest -> do arg <- unsafeInterleaveIO (eval n rest)+                                    return (v arg)+          Ok             rest -> eval n rest+          Cost  _        rest -> eval n rest+          StRepair _ msg rest -> do hPutStr stderr (showMessage msg)+                                    eval (n-1) rest+          Best _   rest   _   -> eval n rest+          NoMoreSteps v       -> return v
+ src/UU/Parsing/Machine.hs view
@@ -0,0 +1,481 @@+module UU.Parsing.Machine where+import UU.Util.BinaryTrees +import UU.Parsing.MachineInterface++pDynE v = anaDynE v+pDynL v = anaDynL v++-- ==========================================================================================+-- ===== BASIC PARSER TYPE  =================================================================+-- =======================================================================================++newtype RealParser    state        s p a = P(forall r' r'' . (a -> r'' -> r') ->+                                                        (state -> Steps r'' s p) ->  state -> Steps r'           s p)++newtype RealRecogn    state        s p   = R(forall r . (state -> Steps r   s p) ->  state -> Steps r            s p)++newtype RealAccept    state result s p a = A(forall r . (state -> Steps r   s p) ->  state -> Steps (result a r) s p)++newtype ParsRec       state result s p a = PR  ( RealParser  state        s p a+                                               , RealRecogn  state        s p+                                               , RealAccept  state result s p a+                                               )+                                             +mkPR (P p, R r) = PR (P p, R r, A (p acceptR))++{-# INLINE unP #-}+{-# INLINE unR #-}+unP  (P  p) = p+unR  (R  p) = p++parseRecbasic :: (inp -> Steps (out c d) sym pos) +              -> ParsRec inp out sym pos a +              -> inp +              -> Steps (out a (out c d)) sym pos+parseRecbasic eof (PR ( P rp, rr, A ra))  inp = (ra eof inp)++parsebasic :: (inp -> Steps (out c d) sym pos) +           -> AnaParser inp out sym pos a +           -> inp +           -> Steps (out a (out c d)) sym pos+parsebasic eof (pp) inp+ = parseRecbasic eof (pars pp) inp ++-- =======================================================================================+-- ===== CORE PARSERS ====================================================================+-- ======================================================================================= +libAccept :: (OutputState a, InputState b s p) => ParsRec b a s p s+libAccept            = mkPR (P (\ acc k state ->+                                case splitState state of+                                ({-#L-} s, ss {-L#-})  -> OkVal (acc s) (k ss))+                            ,R (\ k state ->+                                case splitState state of+                                ({-#L-} s, ss {-L#-})  ->   Ok (k ss))+                            )+libInsert  c sym  firsts =mkPR( P (\acc k state ->  let msg = Msg  firsts +                                                                     (getPosition state)+                                                                     (Insert sym)            +                                                    in StRepair c msg (val (acc sym) (k (insertSymbol sym (reportError msg state)))))+                              , R (\    k state ->  let msg = Msg  firsts +                                                                     (getPosition state)+                                                                     (Insert sym)       +                                                    in StRepair c msg (k (insertSymbol sym (reportError msg state))))+                              )+{-# INLINE libSeq  #-}+{-# INLINE libSeqL #-}+{-# INLINE libSeqR #-}+{-# INLINE libDollar #-}+{-# INLINE libDollarL #-}+{-# INLINE libDollarR #-}+{-# INLINE libSucceed #-}++libSucceed v                                 =mkPR( P (\ acc -> let accv = val (acc v) in {-# SCC "machine" #-} \ k state -> accv (k state))+                                                  , R id+                                                  )+libSeq  (PR (P pp, R pr, _)) ~(PR (P qp, R qr, A qa)) =mkPR ( P (\ acc -> let p = pp (nextR acc) in {-# SCC "machine" #-} \k state -> p (qa k) state)+                                                            , R ( pr.qr)+                                                            )+libDollar f                   (PR (P qp, R qr, _   )) = mkPR ( P (\ acc -> {-# SCC "machine" #-} qp (acc.f))+                                                             , R qr+                                                             )+libDollarL f                  (PR (P qp, R qr, _   )) = mkPR ( P (\ acc -> let accf = val (acc f) in {-# SCC "machine" #-} \ k state -> qr (\ inp -> accf ( k inp)) state)+                                                             , R qr+                                                             )+libDollarR f                   (PR (P qp, R qr, _ )) = mkPR (P  qp, R qr)++libSeqL (PR (P pp, R pr, _ )) ~(PR (P qp, R qr , _ )) = mkPR ( P (\acc -> let p = pp acc in {-# SCC "machine" #-}\k state -> p (qr k) state)+                                                             , R (pr.qr)+                                                             )+libSeqR (PR (P pp, R pr, _ )) ~(PR (P qp, R qr, _ )) = mkPR  ( P (\acc -> let q = qp acc in {-# SCC "machine" #-}\k state -> pr (q k) state)+                                                             , R (pr.qr)+                                                             )+libOr   (PR (P pp, R pr,_ ))   (PR (P qp, R qr, _ )) = mkPR  ( P (\ acc -> let p = pp acc+                                                                               q = qp acc+                                                                           in {-# SCC "machine" #-} \ k state   -> p  k state `libBest` q  k state)+                                                             , R (\                                   k state   -> pr k state `libBest` qr k state)+                                                             )+libFail :: OutputState a => ParsRec b a c p d+libFail                                      = mkPR ( P (\ _ _  _  -> (usererror  "calling an always failing parser"    ))+                                                    , R (\   _  _  -> (usererror  "calling an always failing recogniser"))+                                                    )+      +++starting :: Steps a s p -> Expecting s+starting (StRepair _ m _ ) = getStart m+starting (Best l _  _ )    = starting l+starting _                 = systemerror "UU.Parsing.Machine" "starting"++{-# INLINE hasSuccess #-}+hasSuccess :: Steps a s p -> Bool+hasSuccess (StRepair _ _ _ ) = False+hasSuccess (Best     _ _ _ ) = False +hasSuccess _                 = True++getStart (Msg st _ _) = st++addToMessage (Msg exp pos act) more = Msg (more `eor` exp) pos act+++addexpecting more  (StRepair    cost   msg   rest) = StRepair cost (addToMessage msg more) rest+addexpecting more  (Best     l    sel           r) = Best (addexpecting more   l)+                                                          (addexpecting more sel) +                                                          (addexpecting more   r)+addexpecting more  (OkVal v rest                 ) =  systemerror "UU_Parsing" ("addexpecting: OkVal")+addexpecting more  (Ok   _                       ) =  systemerror "UU_Parsing" ("addexpecting: Ok")+addexpecting more  (Cost _ _                     ) =  systemerror "UU_Parsing" ("addexpecting: Cost")+addexpecting more  _                               =  systemerror "UU_Parsing" ("addexpecting: other")+++eor :: Ord a => Expecting a -> Expecting a -> Expecting a+eor p  q  = EOr (merge (tolist p) (tolist q))+            where merge x@(l:ll) y@(r:rr) = case compare l r of+                                            LT -> l:( ll `merge`  y)+                                            GT -> r:( x  `merge` rr)+                                            EQ -> l:( ll `merge` rr)+                  merge l [] = l+                  merge [] r = r+                  tolist (EOr l) = l+                  tolist x       = [x]++-- =======================================================================================+-- ===== SELECTING THE BEST RESULT  ======================================================+-- =======================================================================================+-- INV: the first argument should be the shorter insertion+libBest :: Ord s => Steps b s p -> Steps b s p -> Steps b s p+libBest ls rs = libBest' ls rs id id++libBest' :: Ord s => Steps b s p -> Steps c s p -> (b -> d) -> (c -> d) -> Steps d s p+libBest' (OkVal v ls) (OkVal w rs) lf rf = Ok (libBest' ls rs (lf.v) (rf.w))+libBest' (OkVal v ls) (Ok      rs) lf rf = Ok (libBest' ls rs (lf.v)  rf   )+libBest' (Ok      ls) (OkVal w rs) lf rf = Ok (libBest' ls rs  lf    (rf.w))+libBest' (Ok      ls) (Ok      rs) lf rf = Ok (libBest' ls rs  lf     rf   )+libBest' (OkVal v ls) _            lf rf = OkVal (lf.v) ls +libBest' _            (OkVal w rs) lf rf = OkVal (rf.w) rs +libBest' (Ok      ls) _            lf rf = OkVal lf ls           +libBest' _            (Ok      rs) lf rf = OkVal rf rs   +libBest' l@(Cost i ls ) r@(Cost j rs ) lf rf+ | i =={-#L-} j = Cost i (libBest' ls rs lf rf)+ | i <{-#L-} j  = Cost i (val lf ls)+ | i >{-#L-} j  = Cost j (val rf rs)+libBest' l@(NoMoreSteps v) _                 lf rf = NoMoreSteps (lf v)+libBest' _                 r@(NoMoreSteps w) lf rf = NoMoreSteps (rf w)+libBest' l@(Cost i ls)     _                 lf rf = Cost i (val lf ls)+libBest' _                 r@(Cost j rs)     lf rf = Cost j (val rf rs)+libBest' l                 r                 lf rf = libCorrect l r lf rf++lib_correct :: Ord s => (b -> c -> Steps d s p) -> (b -> c -> Steps d s p) -> b -> c -> Steps d s p+lib_correct p q = \k inp -> libCorrect (p k inp) ( q k inp) id id++libCorrect :: Ord s => Steps a s p -> Steps c s p -> (a -> d) -> (c -> d) -> Steps d s p+libCorrect ls rs lf rf+ =  let (ToBeat _ choice) = traverse +                            (traverse (ToBeat 999{-#L-} (val lf newleft)) +                                  (val lf, newleft,  0{-#L-}) 4{-#L-})+                                  (val rf, newright, 0{-#L-}) 4{-#L-} +        newleft    = addexpecting (starting rs) ls+        newright   = addexpecting (starting ls) rs+    in Best (val lf newleft)+            choice+            (val rf newright)++data ToBeat a = ToBeat Int{-#L-} a++traverse :: ToBeat (Steps a s p) -> (Steps v s p -> Steps a s p, Steps v s p, Int{-L#-}) -> Int{-L#-} -> ToBeat (Steps a s p)+traverse b@(ToBeat bv br) (f, s, v)              0{-#L-} = {- trace ("comparing " ++ show bv ++ " with " ++ show v ++ "\n") $ -}+                                                           if bv <={-#L-} v +                                                           then b +                                                           else ToBeat v (f s)+traverse b@(ToBeat bv br) (f, Ok      l, v)            n = {- trace ("adding" ++ show n ++ "\n") $-} traverse b (f.Ok     , l, v - n + 4) (n -{-#L-} 1{-#L-})+traverse b@(ToBeat bv br) (f, OkVal w l, v)            n = {- trace ("adding" ++ show n ++ "\n") $-} traverse b (f.OkVal w, l, v - n + 4) (n -{-#L-} 1{-#L-})+traverse b@(ToBeat bv br) (f, Cost i  l, v)            n = if i +{-#L-} v >={-#L-} bv +                                                           then b +                                                           else traverse b (f.Cost i, l, i +{-#L-} v) n+traverse b@(ToBeat bv br) (f, Best l _ r, v)           n = traverse (traverse b (f, l, v) n) (f, r, v) n+traverse b@(ToBeat bv br) (f, StRepair i msgs r, v)    n = if i +{-#L-} v >={-#L-} bv then b +                                                           else traverse b (f.StRepair i msgs, r, i +{-#L-} v) (n -{-#L-} 1{-#L-})+traverse b@(ToBeat bv br) (f, t@(NoMoreSteps _), v)    n = if bv <={-#L-} v then b else ToBeat v (f t)+-- =======================================================================================+-- ===== DESCRIPTORS =====================================================================+-- =======================================================================================+data AnaParser  state result s p a+ = AnaParser { pars     :: ParsRec state result s p a+             , leng     :: Nat+             , zerop    :: Maybe (Bool, Either a (ParsRec state result s p a))+             , onep     :: OneDescr state  result s p a+             } -- deriving Show+data OneDescr  state result s p a+ = OneDescr  { firsts   :: Expecting s+             , table    :: [(SymbolR s, TableEntry state result s p a)]+             } -- deriving Show+             +data TableEntry state result s p a = TableEntry (ParsRec  state result s p a) (Expecting s -> ParsRec state result s p a)+-- =======================================================================================+-- ===== ANALYSING COMBINATORS ===========================================================+-- =======================================================================================+anaFail :: OutputState a => AnaParser b a c p d+anaFail = AnaParser { pars    = libFail+                    , leng    = Infinite+                    , zerop   = Nothing+                    , onep    = noOneParser+                    }+noOneParser = OneDescr (EOr []) []++pEmpty p zp = AnaParser { pars    = p+                        , leng    = Zero+                        , zerop   = Just zp+                        , onep    = noOneParser+                        }++anaSucceed  v = pEmpty (libSucceed v) (False, Left v)+anaLow      v = pEmpty (libSucceed v) (True,  Left v)+anaDynE     p = pEmpty p              (False, Right p)+anaDynL     p = pEmpty p              (True , Right p)+--anaDynN  fi len range p = mkParser  Nothing (OneDescr len fi [(range, p)]) ++anaOr ld@(AnaParser _ ll zl ol)  rd@(AnaParser _ lr zr or)+ = mkParser newlength newZeroDescr newOneDescr +   where (newlength, maybeswap) = ll `nat_min` lr+         newZeroDescr  = case zl of {Nothing -> zr+                                    ;_       -> case zr of {Nothing -> zl+                                                           ;_       -> usererror ("Two empty alternatives")+                                    }                      }+         newOneDescr   =  maybeswap orOneOneDescr ol or False++{-# INLINE anaSeq #-}++anaSeq libdollar libseq comb (AnaParser  pl ll zl ol)  ~rd@(AnaParser pr lr zr or)+ = case zl of+   Just (b, zp ) -> let newZeroDescr = seqZeroZero zl zr   libdollar libseq comb+                        newOneDescr = let newOneOne  = mapOnePars (   `libseq` pr) ol+                                          newZeroOne = case zp of+                                                       Left  f -> mapOnePars (f `libdollar`   )  or+                                                       Right p -> mapOnePars (p `libseq`      )  or+                                      in orOneOneDescr newZeroOne newOneOne  b -- left one is shortest+                    in mkParser lr newZeroDescr newOneDescr+   _            ->  AnaParser  (pl `libseq` pr) (ll `nat_add` lr) Nothing  (mapOnePars (`libseq` pr) ol)++seqZeroZero Nothing             _                    _          _      _   = Nothing+seqZeroZero _                   Nothing              _          _      _   = Nothing +seqZeroZero (Just (llow, left)) (Just (rlow, right))  libdollar libseq comb+    = Just      ( llow || rlow+               , case left of+                 Left  lv  -> case right of+                              Left  rv -> Left (comb lv rv)+                              Right rp -> Right (lv `libdollar` rp)+                 Right lp  -> case right of+                              Left  rv  -> Right (lp `libseq` libSucceed rv)+                              Right rp  -> Right (lp `libseq` rp)+               )++orOneOneDescr ~(OneDescr fl tl) ~(OneDescr fr tr)  b+                  = let keystr          = map fst tr+                        lefttab         = if b then [r | r@(k,_) <- tl, not (k `elem` keystr)] else tl+                    in OneDescr (fl `eor` fr) (lefttab ++ tr)++anaCostRange _        _     EmptyR = anaFail+anaCostRange ins_cost ins_sym range+  = mkParser (Succ Zero) Nothing ( OneDescr  (ESym range) [(range, TableEntry  libAccept +                                                                              (libInsert ins_cost ins_sym)+                                                         )]) ++--anaCostSym   i ins sym = pCostRange i ins (Range sym sym)++anaGetFirsts (AnaParser  p l z od) = firsts od++anaSetFirsts newexp (AnaParser  _ l zd od)+ = mkParser l zd (od{firsts = newexp })++-- =======================================================================================+-- ===== UTILITIES ========================================================================+-- =======================================================================================+mapOnePars fp    ~(OneDescr   fi t) = OneDescr  fi [ (k, TableEntry (fp p) (fp.corr))+                                                   | (k, TableEntry     p      corr ) <- t+                                                   ]++-- =======================================================================================+-- ===== MKPARSER ========================================================================+-- =======================================================================================+mkParser length zd ~descr@(OneDescr firsts tab) -- pattern matching should be lazy for lazy computation of length for empty parsers+ = let parstab    = foldr1 mergeTables  [[(k, p)]| (k, TableEntry p _) <- tab]+       mkactualparser getp +         = let ptab = [(k, (getp pr) )| (k, pr) <- parstab]+               find       = case  ptab of+                            [(s1,  p1)]                      ->  ({-# SCC "Locating" #-}\ s -> if r1 s then Just p1 else Nothing )                                           +                                                                where  r1 = symInRange s1+                            [(s1,  p1), (s2, p2)]            -> ({-# SCC "Locating" #-} \ s -> if r1 s then Just p1 else +                                                                                               if r2 s then Just p2 else Nothing) +                                                                where  r1 = symInRange s1+                                                                       r2 = symInRange s2+                            [(s1,  p1), (s2, p2), (s3, p3)]  -> ({-# SCC "Locating" #-}\ s -> if r1 s then Just p1 else +                                                                                              if r2 s then Just p2 else +                                                                                              if r3 s then Just p3 else Nothing)+                                                                where  r1 = symInRange s1+                                                                       r2 = symInRange s2+                                                                       r3 = symInRange s3                                           +                            _           -> lookupSym (tab2tree ptab)+               zerop      = getp (case zd of+                                 Nothing           -> libFail+                                 Just (_, Left v)  -> libSucceed v+                                 Just (_, Right p) -> p+                                 )+-- SDS/AD 20050603: only the shortest alternative in possible corrections now is taken+--               insertsyms = foldr1 lib_correct [   getp (pr firsts)| (_ , TableEntry _ pr) <- tab    ]+               insertsyms = head [   getp (pr firsts)| (_ , TableEntry _ pr) <- tab    ]+               correct k inp+                 = case splitState inp of+                       ({-#L-} s, ss {-L#-}) -> let { msg = Msg firsts (getPosition inp) (Delete s)+                                                    ; newinp = deleteSymbol s (reportError msg ss)+                                                    }+                                                in libCorrect (StRepair (deleteCost s) msg (result k newinp))+                                                              (insertsyms k inp) id id+               result = if null tab then zerop+                        else case zd of+                        Nothing        ->({-# SCC "mkParser1" #-}\k inp -> +                                         case splitStateE inp of+                                                    Left' s ss -> case find s of +                                                                  Just p  ->  p k inp+                                                                  Nothing -> correct k inp+                                                    Right' ss  -> insertsyms   k ss)+                        Just (True, _) ->({-# SCC "mkParser2" #-}\k inp -> +                                         case splitStateE inp of+                                                    Left' s ss -> case find s of +                                                                  Just p  -> p k inp +                                                                  Nothing -> let r = zerop k inp +                                                                             in if hasSuccess r then r else libCorrect r (correct k inp) id id+                                                    Right'  ss -> zerop k ss)+                        Just (False, _) ->({-# SCC "mkParser3" #-}\k inp -> +                                          case splitStateE inp of+                                                    Left' s ss -> case find s of +                                                                  Just p  -> p k inp `libBest` zerop k inp+                                                                  Nothing -> let r = zerop k inp +                                                                             in if hasSuccess r then r else libCorrect r (correct k inp) id id+                                                    Right' ss  -> zerop k ss)+           in result+       res    = mkPR (P ( \ acc ->  mkactualparser (\ (PR (P p, _  , _)) -> p acc))+                     ,R (           mkactualparser (\ (PR (_  , R p, _)) -> p    ))+                     )            +   in AnaParser res length zd descr+   +-- =======================================================================================+-- ===== MINIMAL LENGTHS (lazily formulated) =============================================+-- =======================================================================================+data Nat = Zero+         | Succ Nat+         | Infinite+         deriving (Eq, Show)++nat_le Zero      _        = True+nat_le _         Zero     = False+nat_le Infinite  _        = False+nat_le _         Infinite = True+nat_le (Succ l) (Succ r) = nat_le l r++nat_min Infinite   r          = (r, flip) +nat_min l          Infinite   = (l, id)+nat_min Zero       _          = (Zero, id)+nat_min _          Zero       = (Zero, flip) +nat_min (Succ ll)  (Succ rr)  = let (v, fl) = ll `nat_min` rr in (Succ v, fl)++nat_add Infinite  _ = Infinite+nat_add Zero      r = r+nat_add (Succ l)  r = Succ (nat_add l r)+-- =======================================================================================+-- ===== CHOICE STRUCTURES   =============================================================+-- =======================================================================================+mergeTables l []  = l+mergeTables [] r  = r+mergeTables lss@(l@(le@(Range a b),ct ):ls) rss@(r@(re@(Range c d),ct'):rs)+ = let ct'' =  ct `libOr` ct'+   in  if      c<a then   mergeTables rss lss     -- swap+       else if b<c then l:mergeTables ls  rss     -- disjoint case+       else if a<c then (Range a (symBefore c),ct) :mergeTables ((Range c b,ct):ls)             rss+       else if b<d then (Range a b,ct'')           :mergeTables ((Range (symAfter b) d,ct'):rs) ls+       else if b>d then mergeTables rss lss+                   else (le,ct'') : mergeTables ls rs-- equals++-- =======================================================================================+-- ===== WRAPPING AND MAPPING ==============================================================+-- =======================================================================================++libMap :: OutputState result =>+             (forall r r'' . (b -> r -> r'') -> state -> Steps (a, r) s p -> ( state, Steps  r'' s p)) +          -> (forall r     .                    state -> Steps (   r) s p -> ( state, Steps  r   s p))+          -> ParsRec state result s p a -> ParsRec state result s p b+libMap f f' (PR (P p, R r, _))  = mkPR ( P(\acc -> let pp   = p (,)+                                                       facc = f acc +                                                   in \ k instate  -> let inresult = pp k outstate+                                                                          (outstate, outresult) = facc instate inresult+                                                                      in outresult+                                          )+                                       , R(\ k instate  -> let inresult = r k outstate+                                                               (outstate, outresult) = f' instate inresult+                                                           in outresult)+                                       )++pMap ::    OutputState result =>+             (forall r r'' . (b -> r -> r'') -> state -> Steps (a, r) s p -> ( state, Steps r'' s p)) +          -> (forall r     .                    state -> Steps (   r) s p -> ( state, Steps r   s p))+          ->  AnaParser state result s p a -> AnaParser state result s p b++pMap f f'  (AnaParser p l z o) = AnaParser (libMap f f' p)+                                           l+                                          (case z of+                                           Nothing     -> Nothing+                                           Just (b, v) -> Just (b, case v of+                                                                   Left w   -> Right (libMap f f' (libSucceed w))+                                                                   Right pp -> Right (libMap f f' pp)))+                                          (mapOnePars (libMap f f')  o)+++libWrap :: OutputState result =>+           (forall r r'' .  (b -> r -> r'') +                                    -> state +                                    -> Steps (a, r) s p+                                    -> (state -> Steps r s p) +                                    -> (state, Steps r'' s p, state -> Steps r s p))+           -> (forall r        .   state +                                -> Steps r s p +                                -> (state -> Steps r s p) +                                -> (state, Steps r s p, state -> Steps r s p)) +           -> ParsRec state result s p a -> ParsRec state result s p b+libWrap f f' (PR (P p, R r, _)) = mkPR ( P(\ acc -> let pp = p (,)+                                                        facc = f acc+                                                    in \ k instate  -> let (stl, ar, str2rr) = facc instate rl k+                                                                           rl                = pp str2rr stl+                                                                       in  ar+                                     )+                                  , R(\ k instate  -> let (stl, ar, str2rr) = f' instate rl k+                                                          rl                = r str2rr stl+                                                      in  ar)+                                  )++pWrap ::    OutputState result +           => (forall r  r'' .   (b -> r -> r'') +                                    -> state+                                    -> Steps (a, r) s p +                                    -> (state -> Steps r s p) +                                    -> (state, Steps r'' s p, state -> Steps r s p))+           -> (forall r        .   state  +                                -> Steps r s p +                                -> (state -> Steps r s p) +                                -> (state, Steps r s p, state -> Steps r s p)) +           -> AnaParser state result s p a -> AnaParser state result s p b++pWrap f f'  (AnaParser p l z o) = AnaParser (libWrap f f' p)+                                          l+                                          (case z of+                                           Nothing     -> Nothing+                                           Just (b, v) -> Just (b, case v of+                                                                   Left w   -> Right (libWrap f f' (libSucceed w))+                                                                   Right pp -> Right (libWrap f f' pp)))+                                          (mapOnePars (libWrap f f')  o)++++-- =======================================================================================+-- ===== BINARY SEARCH TREES =============================================================+-- =======================================================================================++lookupSym :: Ord a => BinSearchTree (SymbolR a, b) -> a -> Maybe b+lookupSym = btFind symRS
+ src/UU/Parsing/MachineInterface.hs view
@@ -0,0 +1,152 @@+module UU.Parsing.MachineInterface where++-- | The 'InputState' class contains the interface that the AnaParser+-- parsers expect for the input. A minimal complete instance definition+-- consists of 'splitStateE', 'splitState' and 'getPosition'.+class InputState state s pos | state -> s, state -> pos where+ -- | Splits the state in a strict variant of 'Either', with 'Left'' if a symbol+ --   can be split off and 'Right'' if none can+ splitStateE :: state             -> Either' state s+ -- | Splits the state in the first symbol and the remaining state+ splitState  :: state             -> ({-#L-} s, state  {-L#-})+ -- | Gets the current position in the input+ getPosition :: state             -> pos+ -- | Reports an error+ reportError :: Message s pos     -> state -> state+ reportError _ = id+ -- | Modify the state as the result of inserting a symbol 's' in the input.+ -- The symbol that has already been considered as having been inserted + -- is passed. It should normally not be added to the state.+ insertSymbol :: s                -> state -> state+ insertSymbol _ = id+ -- | Modify the state as the result of deleting a symbol 's' from the input.+ -- The symbol that has already been deleted from the input state is passed.+ -- It should normally not be deleted from the state.+ deleteSymbol :: s                -> state -> state+ deleteSymbol _ = id+ {-# INLINE splitStateE #-}+ {-# INLINE splitState  #-}+ {-# INLINE insertSymbol  #-}+ {-# INLINE deleteSymbol  #-}++class OutputState r  where+  acceptR      ::                     v                   -> rest        -> r v rest+  nextR        ::  (a -> rest  -> rest') -> (b -> a)      -> (r b rest)  -> rest'+  {-# INLINE acceptR #-}+  {-# INLINE nextR   #-}++class Symbol s where+ deleteCost :: s -> Int{-#L-}+ symBefore  :: s -> s+ symAfter   :: s -> s+ deleteCost b = 5{-#L-}+ symBefore  = error "You should have made your token type an instance of the Class Symbol. eg by defining symBefore = pred"+ symAfter   = error "You should have made your token type an instance of the Class Symbol. eg by defining symAfter  = succ"++data Either' state s = Left' !s (state )+                     | Right' (state )++-- =======================================================================================+-- ===== STEPS ===========================================================================+-- =======================================================================================+data Steps val s p +             = forall a . OkVal           (a -> val)                                (Steps a   s p)+             |            Ok         {                                       rest :: Steps val s p}+             |            Cost       {costing::Int{-#L-}                   , rest :: Steps val s p}+             |            StRepair   {costing::Int{-#L-}, m :: !(Message s p) , rest :: Steps val s p}+             |            Best       (Steps val s p) (Steps val s p) ( Steps val s p)+             |            NoMoreSteps val+data Action s  =  Insert s+               |  Delete s +               |  Other  String++val :: (a -> b) -> Steps a s p -> Steps b s p++val f (OkVal a rest) = OkVal (f.a) rest+val f (Ok      rest) = OkVal  f rest+val f (Cost i  rest) = Cost i (val f rest)+val f (StRepair c m r) = StRepair c m (val f r)+val f (Best l s     r) = Best (val f l) (val f s) (val f r)+val f (NoMoreSteps v)  = NoMoreSteps (f v)++evalSteps :: Steps a s p -> a+evalSteps (OkVal v  rest    ) = v (evalSteps rest)+evalSteps (Ok       rest    ) =    evalSteps rest+evalSteps (Cost  _  rest    ) =    evalSteps rest+evalSteps (StRepair _ msg rest    ) =    evalSteps rest+evalSteps (Best _   rest  _) =  evalSteps rest+evalSteps (NoMoreSteps v    ) =  v+++getMsgs :: Steps a s p -> [Message s p]+getMsgs (OkVal _        rest) = getMsgs rest+getMsgs (Ok             rest) = getMsgs rest+getMsgs (Cost _         rest) = getMsgs rest+getMsgs (StRepair _ m   rest) = m:getMsgs rest+getMsgs (Best _ m   _)        = getMsgs m+getMsgs (NoMoreSteps _      ) = []++data Message sym pos = Msg (Expecting sym) !pos (Action sym) +-- Msg (String, String, Expecting s) -- action, position, expecting +instance (Eq s, Show s) => Show (Expecting s) where+ show (ESym     s)   = show s+ show (EStr   str)   = str+ show (EOr     [])   = "Nothing expected "+ show (EOr    [e])   = show e+ show (EOr  (e:ee))  = show e ++ " or " ++ show (EOr ee)+ show (ESeq  seq)    = concat (map show seq)++instance (Eq s, Show s, Show p) => Show (Message s p) where+ show (Msg expecting position action)  +   =  "\n?? Error      : " ++ show position +++      "\n?? Expecting  : " ++ show expecting +++      "\n?? Repaired by: "  ++ show action ++"\n"++instance Show s => Show (Action s) where+  show (Insert s) = "inserting: " ++ show s +  show (Delete s) = "deleting: "  ++ show s +  show (Other s)  = s +data Expecting s = ESym (SymbolR s)+                 | EStr String+                 | EOr  [Expecting s]+                 | ESeq [Expecting s]+                 deriving (Ord, Eq)+-- =======================================================================================+-- ===== SYMBOLS and RANGES ==============================================================+-- =======================================================================================++data  SymbolR s  =  Range !s !s | EmptyR deriving (Eq,Ord)++instance (Eq s,Show s) => Show (SymbolR s) where+ show EmptyR      = "the empty range"+ show (Range a b) = if a == b then show a else show a ++ ".." ++ show b+++mk_range             l    r =  if l > r then EmptyR else Range l r++symInRange (Range l r) = if l == r then (l==)+                                   else (\ s ->  s >= l && s <= r)++symRS (Range l r)+  = if l == r then (compare l)+    else (\ s -> if      s < l then GT+                 else if s > r then LT+                 else               EQ)++range `except` elems+ = foldr removeelem [range] elems+   where removeelem elem ranges = [r | ran <- ranges, r <- ran `minus` elem]+         EmptyR          `minus` _    = []+         ran@(Range l r) `minus` elem = if symInRange ran elem+                                        then [mk_range l (symBefore elem), mk_range (symAfter elem) r]+                                        else [ran]+-- =======================================================================================+-- ===== TRACING  and ERRORS  and MISC ===================================================+-- =======================================================================================+usererror   m = error ("Your grammar contains a problem:\n" ++ m)+systemerror modname m+  = error ("I apologise: I made a mistake in my design. This should not have happened.\n"+                       +++           " Please report: " ++ modname ++": " ++ m ++ " to doaitse@cs.uu.nl\n")++
+ src/UU/Parsing/Merge.hs view
@@ -0,0 +1,25 @@+module UU.Parsing.Merge((<||>), pMerged, list_of) where++import UU.Parsing++-- ==== merging+-- e.g. chars_digs = cat3 `pMerged` (list_of pDig <||> list_of pL <||> list_of pU)+--      parsing "12abCD1aV" now returns "121abaCDV", so the sequence of+-- recognised elements is stored in three lists, which are then passed to cat3++(<||>) :: IsParser p s => (c,p (d -> d),e -> f -> g) -> (h,p (i -> i),g -> j -> k) -> ((c,h),p ((d,i) -> (d,i)),e -> (f,j) -> k)+(pe, pp, punp) <||> (qe, qp, qunp)+ =( (pe, qe)+  , (\f (pv, qv) -> (f pv, qv)) <$> pp+              <|>+    (\f (pv, qv) -> (pv, f qv)) <$> qp+  , \f (x, y) -> qunp (punp f x) y+  )++pMerged :: IsParser p s => c -> (d,p (d -> d),c -> d -> e) -> p e+sem `pMerged` (units, alts, unp)+ = let pres = alts <*> pres `opt` units+   in unp sem <$> pres++list_of :: IsParser p s => p c -> ([d],p ([c] -> [c]),e -> e)+list_of p = ([], (:) <$> p, id)
+ src/UU/Parsing/Offside.hs view
@@ -0,0 +1,231 @@+module UU.Parsing.Offside( parseOffside +                         , pBlock +                         , pBlock1 +                         , pOffside +                         , pOpen +                         , pClose +                         , pSeparator +                         , scanOffside +                         , OffsideSymbol(..)+                         , OffsideInput+                         , Stream+                         , OffsideParser(..)+                         ) where+                         +import UU.Parsing.Interface+import UU.Parsing.Machine+import UU.Parsing.Derived(opt, pFoldr1Sep,pList,pList1, pList1Sep)+import UU.Scanner.Position++data OffsideSymbol s = +                Symbol s+              | SemiColon+              | CloseBrace+              | OpenBrace+              deriving (Ord,Eq,Show)+++scanOffside :: (InputState i s p, Position p, Eq s) +            =>  s ->  s -> s -> [s] -> i -> OffsideInput i s p  +scanOffside mod open close triggers ts = start ts []+ where+ isModule  t = t == mod + isOpen    t = t == open+ isClose   t = t == close+ isTrigger t = t `elem` triggers+ end ts    = Off (getPosition ts) (End ts)+ cons :: p -> OffsideSymbol s -> OffsideInput i s p -> OffsideInput i s p+ cons p s r =  Off p (Cons s r) Nothing  + start = case splitStateE ts of+          Left' t _ | not (isModule t || isOpen t) -> implicitL 0 (column (getPosition ts) )+          _                                        -> layoutL   0+ + -- L (<n>:ts) (m:ms) 	= ; : (L ts (m:ms)) 	if m = n + --	                = } : (L (<n>:ts) ms) 	if n < m + -- L (<n>:ts) ms 	= L ts ms + startlnL l n ts (m:ms) | m == n  = cons (getPosition ts) SemiColon  (layoutL (line (getPosition ts)) ts (m:ms))    +                          | n <  m  = cons (getPosition ts) CloseBrace (startlnL l n ts ms)+ startlnL l n ts ms               = layoutL (line (getPosition ts))  ts ms+ -- L  ({n}:ts)  (m:ms) = { : (L  ts (n:m:ms))     if n > m    (Note  1) + -- L  ({n}:ts)  []     = { : (L  ts [n])          if n > 0    (Note  1) + -- L  ({n}:ts)  ms     = { : } : (L  (<n>:ts) ms) (Note  2) + implicitL l n ts (m:ms) | n > m  = cons (getPosition ts) OpenBrace (layoutL (line (getPosition ts)) ts (n:m:ms))+ implicitL l n ts []     | n > 0  = cons (getPosition ts) OpenBrace (layoutL (line (getPosition ts)) ts [n])+ implicitL l n ts ms              = cons (getPosition ts) OpenBrace (cons (getPosition ts) CloseBrace (startlnL l n ts ms))+ layoutL ln ts ms | ln /= sln = startln (column pos) ts ms+                    | otherwise     = sameln ts ms+      +  where sln = line pos+        pos   = getPosition ts+        layout    = layoutL ln      +        implicit  = implicitL ln+        startln = startlnL ln    +        -- If a let ,where ,do , or of keyword is not followed by the lexeme {,  +        -- the token {n} is inserted after the keyword, where nis the indentation of+        -- the  next lexeme if there is one, or 0 if the end of file has been reached. +        aftertrigger ts ms = case splitStateE ts of+                                Left' t _  | isOpen t  -> layout ts ms+                                           | otherwise -> implicit (column(getPosition ts)) ts ms+                                Right' _               -> implicit 0 ts ms+++        -- L  ( }:ts)  (0:ms) = } : (L  ts ms)          (Note  3) +        --              L  ( }:ts)  ms     = parse-error             (Note  3), matching of implicit/explicit braces is handled by parser+        -- L  ( {:ts)  ms     = {: (L  ts (0:ms))       (Note  4) +        -- L  (t:ts)  (m:ms)  = }: (L  (t:ts)  ms)      if  m /= 0  and  parse-error(t) (Note  5) +        -- L  (t:ts)  ms      = t : (L  ts ms) +        sameln tts ms = case splitStateE tts of+                Left'  t ts  | isTrigger t -> cons pos (Symbol t) (aftertrigger ts ms)+                             | isClose t   -> cons pos (Symbol t) +                                                (case ms of+                                                   0:ms -> layout ts ms+                                                   _    -> layout ts ms+                                                )   +                             | isOpen t    -> cons pos (Symbol t) (layout ts (0:ms))                            +                             | otherwise   -> let parseError = case ms of+                                                                  m:ms  | m /= 0 -> Just (layout tts ms)+                                                                  _              -> Nothing+                                              in Off pos (Cons (Symbol t) (layout ts ms)) parseError+                Right' rest -> endofinput pos rest ms+          where pos = getPosition tts                        ++        -- L  []  []          = [] +        -- L  []  (m:ms)      = } : L  []  ms           if m /=0   (Note  6) +        --                    = L [] ms, if m == 0 (this is an error, the parser should yield a parse error, if this situation occurs)+        endofinput pos rest []                 = Off pos (End rest) Nothing+        endofinput pos rest (m:ms) | m /= 0    = cons pos CloseBrace (endofinput pos rest ms)+                                   | otherwise = endofinput pos rest ms+++data Stream inp s p = Cons (OffsideSymbol s) (OffsideInput inp s p) +                    | End inp++data OffsideInput inp s p = Off p (Stream inp s p) (Maybe (OffsideInput inp s p))++instance InputState inp s p => InputState (OffsideInput inp s p) (OffsideSymbol s) p where+  splitStateE inp@(Off p stream _) = case stream of+                                     Cons s rest -> Left' s rest+                                     _           -> Right' inp                                 +  splitState (Off _ stream _) = +           case stream of+            Cons s rest -> (s ,rest)                        ++  getPosition (Off pos _ _ ) = pos+  +instance Symbol s => Symbol (OffsideSymbol s) where+  deleteCost s = case s of+                  Symbol s   -> deleteCost s+                  SemiColon  -> 5+                  OpenBrace  -> 5+                  CloseBrace -> 5+  symBefore s = case s of+                 Symbol s   -> Symbol (symBefore s)+                 SemiColon  -> error "Symbol.symBefore SemiColon"+                 OpenBrace  -> error "Symbol.symBeforeOpenBrace"+                 CloseBrace -> error "Symbol.symBefore CloseBrace"+  symAfter s = case s of+                 Symbol s   -> Symbol (symAfter s)+                 SemiColon  -> error "Symbol.symAfter SemiColon"+                 OpenBrace  -> error "Symbol.symAfter OpenBrace"+                 CloseBrace -> error "Symbol.symAfter CloseBrace"++newtype OffsideParser i o s p a  = OP (AnaParser (OffsideInput i s p) o (OffsideSymbol s) p a)        ++instance  (Symbol s, Ord s, InputState i s p, OutputState o) => IsParser (OffsideParser i o s p) s where+  (<*>) = operator (<*>)+  (<* ) = operator (<* )+  ( *>) = operator ( *>)+  (<|>) = operator (<|>)+  (<$>) = operatorr (<$>)+  (<$ ) = operatorr (<$ )+  pSucceed = OP . pSucceed+  pLow     = OP . pLow+  pFail    = OP pFail+  pCostRange c s (Range l r) = OP (getSymbol <$> pCostRange c (Symbol s) (Range (Symbol l)(Symbol r)))  +  pCostSym   c s t           = OP (getSymbol <$> pCostSym c (Symbol s) (Symbol t))  +  pSym   s                   = OP (getSymbol <$> pSym (Symbol s))  +  pRange s (Range l r)       = OP (getSymbol <$> pRange (Symbol s) (Range (Symbol l)(Symbol r)))  +  getfirsts  (OP p)          = removeSymbol (getfirsts p)+  setfirsts  exp (OP p)      = OP (setfirsts (addSymbol exp) p)+  getzerop  (OP p)           = fmap OP (getzerop p)+  getonep   (OP p)           = fmap OP (getonep p)++removeSymbol exp = case exp of+        ESym (Range (Symbol l) (Symbol r)) -> ESym (Range l r)+        ESym _                             -> EOr []+        EStr txt                           -> EStr txt+        EOr  exps                          -> EOr  (map removeSymbol exps)+        ESeq exps                          -> ESeq (map removeSymbol exps)++addSymbol exp = case exp of+        ESym (Range l r) -> ESym (Range (Symbol l) (Symbol r))+        EStr txt         -> EStr txt+        EOr  exps        -> EOr  (map addSymbol exps)+        ESeq exps        -> ESeq (map addSymbol exps)++getSymbol (Symbol s) = s++operator  f (OP p) (OP q) = OP (f p q)+operatorr f g (OP p) = OP (f g p)++pSeparator :: (OutputState o, InputState i s p, Position p, Symbol s, Ord s) +           => OffsideParser i o s p ()+pSeparator = OP (() <$ pCostSym 5 SemiColon SemiColon)++pClose, pOpen :: (OutputState o, InputState i s p, Position p, Symbol s, Ord s) +           => OffsideParser i o s p ()+           ++pClose = OP (pWrap f g ( () <$ pSym CloseBrace) )+  where g state steps1 k = (state,ar,k)+          where ar = case state of+                               Off _ _ (Just state') -> let steps2 = k state'+                                                        in if not (hasSuccess steps1) && hasSuccess steps2 then steps2 else steps1+                               _                     -> steps1+            +        f acc state steps k = let (stl,ar,str2rr) = g state (val snd steps)  k+                              in (stl ,val (acc ()) ar , str2rr )++pOpen  = OP (() <$ pSym OpenBrace) ++pOffside :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s) +         => OffsideParser i o s p x +         -> OffsideParser i o s p y +         -> OffsideParser i o s p a +         -> OffsideParser i o s p a +         -> OffsideParser i o s p a+pOffside open close bodyE bodyI = +       open *> bodyE <* close+   <|> pOpen *> bodyI <* pClose+   +pBlock :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s) +       => OffsideParser i o s p x +       -> OffsideParser i o s p y +       -> OffsideParser i o s p z +       -> OffsideParser i o s p a +       -> OffsideParser i o s p [a]+pBlock open sep close p =  pOffside open close explicit implicit+ where elem = (:) <$> p `opt` id+       sep' = () <$ sep        +       elems s = ($[]) <$> pFoldr1Sep ((.),id) s elem+       explicit = elems sep'+       implicit = elems (sep' <|> pSeparator)++pBlock1 :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s) +       => OffsideParser i o s p x +       -> OffsideParser i o s p y +       -> OffsideParser i o s p z +       -> OffsideParser i o s p a +       -> OffsideParser i o s p [a]+pBlock1 open sep close p =  pOffside open close explicit implicit+ where sep'    = () <$ sep+       elems s = pList s *> pList1Sep (pList1 s) p <* pList s+       explicit = elems sep'+       implicit = elems (sep' <|> pSeparator)++parseOffside :: (Symbol s, InputState i s p, Position p) +             => OffsideParser i Pair s p a +             -> OffsideInput i s p+             -> Steps (a, OffsideInput i s p) (OffsideSymbol s) p+parseOffside (OP p) inp = val fromPair (parse p inp)+  where fromPair (Pair x (Pair y _)) = (x,y)
+ src/UU/Parsing/Perms.hs view
@@ -0,0 +1,57 @@+{-# OPTIONS -fglasgow-exts  #-}+module UU.Parsing.Perms(Perms(), pPerms, pPermsSep, succeedPerms, (~*~), (~$~)) where++import UU.Parsing+import Maybe++-- =======================================================================================+-- ===== PERMUTATIONS ================================================================+-- =======================================================================================++newtype Perms p a = Perms (Maybe (p a), [Br p a])+data Br p a = forall b. Br (Perms p (b -> a)) (p b)++instance IsParser p s => Functor (Perms p) where+  fmap f (Perms (mb, bs)) = Perms (fmap (f<$>) mb, map (fmap f) bs)++instance IsParser p s => Functor (Br p) where+  fmap f (Br perm p) = Br (fmap (f.) perm) p ++(~*~) :: IsParser p s => Perms p (a -> b) -> p a -> Perms p b+perms ~*~ p = perms `add` (getzerop p, getonep p)++(~$~) :: IsParser p s => (a -> b) -> p a -> Perms p b+f     ~$~ p = succeedPerms f ~*~ p++succeedPerms :: IsParser p s => a -> Perms p a+succeedPerms x = Perms (Just (pLow x), []) ++add :: IsParser p s => Perms p (a -> b) -> (Maybe (p a),Maybe (p a)) -> Perms p b+add b2a@(Perms (eb2a, nb2a)) bp@(eb, nb)+ =  let changing :: IsParser p s => (a -> b) -> Perms p a -> Perms p b+        f `changing` Perms (ep, np) = Perms (fmap (f <$>) ep, [Br ((f.) `changing` pp) p | Br pp p <- np])+    in Perms+      ( do { f <- eb2a+           ; x <- eb+           ; return (f <*>  x)+           }+      ,  (case nb of+          Nothing     -> id+          Just pb     -> (Br b2a  pb:)+        )[ Br ((flip `changing` c) `add`  bp) d |  Br c d <- nb2a]+      )++pPerms :: IsParser p s => Perms p a -> p a +pPerms (Perms (empty,nonempty))+ = foldl (<|>) (fromMaybe pFail empty) [ (flip ($)) <$> p <*> pPerms pp+                                       | Br pp  p <- nonempty+                                       ]++pPermsSep :: IsParser p s => p x -> Perms p a -> p a+pPermsSep (sep :: p z) perm = p2p (pSucceed ()) perm+ where  p2p :: IsParser p s => p x -> Perms p a -> p a+        p2p fsep (Perms (mbempty, nonempties)) = +                let empty          = fromMaybe  pFail mbempty+                    pars (Br t p)  = flip ($) <$ fsep <*> p <*> p2p sep t+                in foldr (<|>) empty (map pars nonempties)              +        p2p_sep =  p2p sep
+ src/UU/Parsing/StateParser.hs view
@@ -0,0 +1,35 @@+module UU.Parsing.StateParser(StateParser(..)) where+import UU.Parsing.MachineInterface+import UU.Parsing.Machine(AnaParser, ParsRec(..),RealParser(..),RealRecogn(..), mkPR, anaDynE)++instance (InputState inp s p) => InputState (inp, state) s p where+  splitStateE (inp, st) = case splitStateE inp of+                  Left'   x xs   -> Left'  x (xs, st)+                  Right'  xs     -> Right'   (xs, st)+  splitState  (inp, st) = case splitState inp of+                  (x,xs) -> (x, (xs, st))+  getPosition (inp, _) = getPosition inp++class StateParser p st | p -> st where+  change :: (st -> st) -> p st -- return the old state+  set    :: st -> p st+  set x = change (const x)+  get    :: p st+  get = change id++fconst x y = y++instance (InputState inp s p ,OutputState out) =>+          StateParser (AnaParser (inp, st) out s p) st where+  get = anaDynE (mkPR (rp,rr))+    where f addRes k state =  (val (addRes (snd state)) (k state))+          rp = P f+          rr = R (f fconst )+          +  change ch = anaDynE (mkPR (rp,rr))+    where f addRes k state = case state of (inp, st) -> val (addRes st) (k (inp, ch st))+          rp = P f +          rr = R (f fconst)++newtype Errors s p = Errors [[Message s p]]+
+ src/UU/Pretty.hs view
@@ -0,0 +1,5 @@+module UU.Pretty(module UU.Pretty.Basic, module UU.Pretty.Ext ) where++import UU.Pretty.Basic+import UU.Pretty.Ext+
+ src/UU/Pretty/Basic.hs view
@@ -0,0 +1,798 @@+--  $Header: /data/cvs-rep/uust/lib/pretty/UU/Pretty/Basic.hs,v 1.2 2003/02/26 11:18:27 uust Exp $+--  $Name:  $ (version name)++module UU.Pretty.Basic ( PP (..), PP_Doc, PP_Exp+                   -- Single layout combinators+                 , empty, text, indent, (>|<), (>-<), fill , fillblock+                   -- Multiple layout combinators+                 , (>//<), join, par, (>>$<)+                 , eindent, (>>|<<), (>>-<<), (>>//<<), ejoin, (>>$<<)+                   -- Displaying the result+                 , render, renderAll, disp+                   -- Additional generated combinators+                 , c2e, element_h1, eelement_h1, vcenter, invisible+                   -- Additional derived combinators+                 , fpar, spar+                 ) where++{- Pretty-printers and pretty-printing combinators. Version 2.0d+   Authors: S. Doaitse Swierstra and Pablo R. Azero+   Date: July, 1999+ -}++-- ...................................................................+-- ..... Interface definition ........................................++infixr 3 >|< , >>|<<+infixr 2 >-< , >>-<<+infixr 1 >//<, >>//<<+infixr 0 >>$<, >>$<<++-- -------------------------------------------------------------------+-- PP class ----------------------------------------------------------++newtype PP_Doc = PPDoc T_PPS++class Show a => PP a where+  pp     :: a   -> PP_Doc+  pp       = text . show++  ppList :: [a] -> PP_Doc+  ppList as = if null as+              then empty+              else foldr (>|<) empty . map pp $ as++instance PP PP_Doc where+  pp     = id++instance PP Char where+  pp c   = text [c]+  ppList = text++instance PP a => PP [a] where+  pp = ppList++instance Show PP_Doc where+  show p = disp p 200 ""++-- -------------------------------------------------------------------+-- Single layout combinators -----------------------------------------++empty :: PP_Doc+empty = PPDoc sem_PPS_Empty++text :: String -> PP_Doc+text  = PPDoc . sem_PPS_Text++indent :: PP a => Int -> a -> PP_Doc+indent i fs = PPDoc (sem_PPS_Indent i nfs)+   where (PPDoc nfs) = pp fs++(>|<) :: (PP a, PP b) => a -> b -> PP_Doc+l >|< r  = PPDoc (sem_PPS_Beside ppl ppr)+  where (PPDoc ppl) = pp l+        (PPDoc ppr) = pp r++(>-<) :: (PP a, PP b) => a -> b -> PP_Doc+u >-< l  = PPDoc (sem_PPS_Above ppu ppl)+  where (PPDoc ppu) = pp u+        (PPDoc ppl) = pp l++fill :: PP a => [a] -> PP_Doc+fill = PPDoc . sem_PPS_Fill . foldr fill_alg sem_FillList_Nil+  where fill_alg f+          = sem_FillList_Cons (case (pp f) of (PPDoc ppp) -> ppp)++fillblock :: PP a => Int -> [a] -> PP_Doc+fillblock i = PPDoc . sem_PPS_FillBlock i . foldr fill_alg sem_FillList_Nil+  where fill_alg f+          = sem_FillList_Cons (case (pp f) of (PPDoc ppp) -> ppp)++-- -------------------------------------------------------------------+-- Multiple layout combinators ---------------------------------------++(>//<) :: (PP a, PP b) => a -> b -> PP_Doc+a  >//<  b  = PPDoc (sem_PPS_Dup  ppa ppb)+  where (PPDoc ppa) = pp a+        (PPDoc ppb) = pp b++join :: PP_Doc -> PP_Doc+join (PPDoc d) = PPDoc . sem_PPS_Join $ d++newtype PP_Exp = PPExp T_PPC++eindent :: Int -> PP_Exp -> PP_Exp+eindent i (PPExp ppc) = PPExp (sem_PPC_Indent i ppc)++(>>|<<), (>>-<<), (>>//<<) :: PP_Exp -> PP_Exp -> PP_Exp+(PPExp l)  >>|<< (PPExp r)  =  PPExp (sem_PPC_Beside l r)+(PPExp u)  >>-<< (PPExp l)  =  PPExp (sem_PPC_Above  u l)+(PPExp a) >>//<< (PPExp b)  =  PPExp (sem_PPC_Dup    a b)++ejoin :: PP_Exp -> PP_Exp+ejoin (PPExp dc) = PPExp . sem_PPC_Join $ dc++par :: PP_Exp+par = PPExp sem_PPC_Par++(>>$<) :: PP a => PP_Exp -> [a] -> PP_Doc+(PPExp e) >>$< pl = PPDoc . sem_PPS_Apply e . foldr ppslist sem_PPSArgs_Nil $ pl+  where ppslist p = sem_PPSArgs_Cons (case (pp p) of (PPDoc ppp) -> ppp)++(>>$<<) :: PP_Exp -> [PP_Exp] -> PP_Exp+(PPExp e) >>$<< pl = PPExp . sem_PPC_Apply e . foldr ppclist sem_PPCArgs_Nil $ pl+  where ppclist (PPExp p) = sem_PPCArgs_Cons p++-- -------------------------------------------------------------------+-- Displaying the result ---------------------------------------------++render, renderAll   ::  PP_Doc -> Int -> IO ()+render    (PPDoc fs)  =  putStr . sem_Root_Best fs+renderAll (PPDoc fs)  =  putStr . sem_Root_All fs++disp  ::  PP_Doc -> Int -> ShowS+disp (PPDoc fs) =  sem_Disp_Disp fs++-- -------------------------------------------------------------------+-- Additional generated combinators ----------------------------------++c2e :: PP a => a -> PP_Exp+c2e s = let (PPDoc s') = pp s in PPExp . sem_PPC_Pps $ s'++element_h1 :: PP_Doc -> PP_Doc+element_h1 = \(PPDoc fs) -> PPDoc (sem_PPS_Filt fs)++eelement_h1 :: PP_Exp -> PP_Exp+eelement_h1 (PPExp pe) = PPExp . sem_PPC_Filt $ pe++vcenter :: PP a => [ a ] -> PP_Doc+vcenter = PPDoc . sem_PPS_Center . foldr center_alg sem_CenterList_Nil+  where center_alg f = sem_CenterList_Cons (case (pp f) of (PPDoc pf) -> pf)++invisible :: PP_Doc -> PP_Doc+invisible (PPDoc a) = PPDoc . sem_PPS_Inv $ a++-- -------------------------------------------------------------------+-- Additional derived combinators ------------------------------------++fpar, spar :: PP_Exp+fpar = plift  first   par+spar = plift  second  par++first fs  = case fs of+              (TFormats fa _ ea _) -> (AFormat fa, ea   )+              (AFormat fa)         -> (AFormat fa, False)+second fs = case fs of+              (TFormats _ fb _ eb) -> (AFormat fb, eb   )+              (AFormat fb)         -> (AFormat fb, False)++-- Utilities++lift :: (T_Formats -> T_Formats) -> PP_Doc -> PP_Doc+lift f (PPDoc p) = PPDoc . sem_LiftS_Lift p $ f++--elift :: (T_Formats -> T_Formats) -> T_PPC -> T_PPC+elift f (PPExp e) = PPExp . sem_LiftC_Lift e $ f++--plift :: (a -> b) -> T_PPC -> T_PPC+plift f (PPExp e) = PPExp . sem_LiftC_Pair e $ f++-- ...................................................................+-- ..... Basic machinery .............................................++type Formats = [Format]++{- Pretty-printer combinators with global page width -}++type T_PW  = Int+type T_PLL = Int+type T_PH  = Int+--                Width  Width last line+data T_Frame = F  T_PW   T_PLL+             deriving Eq++instance Ord T_Frame where+  max x@(F w _) y@(F w' _)+    | w > w'    = x+    | otherwise = y++empty_fmts ::Formats+empty_fmts = []++text_fmts :: String -> Formats+text_fmts s = [ s2fmt s ]++indent_fmts :: T_Frame -> Int -> Formats -> Formats+indent_fmts (F pw _) i = map (indent_fmt i)+                       . dropWhile (notFits (pw - i))+notFits delta e = total_w e > delta++beside_fmts :: T_Frame -> Formats -> Formats -> Formats+beside_fmts (F pw _) left  right+  = mergel [ map (l `beside_fmt`)+           . dropWhile (tooWide pw l)+           $ right+           | l <- left+           ]+tooWide pw x y+  = (total_w x `max` (last_w x + total_w y)) > pw++above_fmts :: Formats -> Formats -> Formats+above_fmts [] ls = []+above_fmts us [] = []+above_fmts up@(upper:ru) low@(lower:rl)+  | utw >= ltw = firstelem : above_fmts ru low+  | utw <  ltw = firstelem : above_fmts up rl+  where utw = total_w upper+        ltw = total_w lower+        firstelem = upper `above_fmt` lower++{- Pretty-printing with error correction -}++error_indent :: Int -> Formats -> Formats+error_indent i = map (indent_fmt i)++error_beside :: Formats -> Formats -> Formats+error_beside left right = mergel [ map (l `beside_fmt`) right+                                 | l <- left+                                 ]++-- -------------------------------------------------------------------+-- Formatting one layout ---------------------------------------------++data Format = Elem { height  :: T_PH+                   , last_w  :: T_PLL+                   , total_w :: T_PW+                   , txtstr  :: Int -> String -> String+                   }++instance Eq Format  where+  x == y =  height x  == height y+         && total_w x == total_w y+         && last_w  x == last_w  y++instance Ord Format where+  x <  y =  height x < height y+         || (  height x == height y+            && total_w x < total_w y )++s2fmt     :: String -> Format+s2fmt s   = Elem 1 l l (\_ -> (s++))+  where l = length s++indent_fmt :: Int -> Format -> Format+indent_fmt i   (Elem dh dl dw dt)+   = Elem dh (i + dl) (i + dw) (\n -> ((sp i) ++) . dt (i + n))++above_fmt, beside_fmt :: Format -> Format -> Format+(Elem uh ul uw ut) `above_fmt` (Elem lh ll lw lt)+  = Elem (uh + lh) ll (uw `max` lw)+         (make_ts_above ut lt)+  where make_ts_above ut lt = \n -> let nl_skip = (('\n':sp n)++)+                                    in  ut n . nl_skip . lt n+(Elem lh ll lw lt) `beside_fmt` (Elem rh rl rw rt)+  = Elem (lh + rh - 1) (ll + rl)+         (lw `max` (ll + rw)) (\n -> lt n . rt (ll + n))++-- -------------------------------------------------------------------+-- Display the layout found ------------------------------------------++best fs  = if null fs then "" else (txtstr . head $ fs) 0 ""+allf     = concatMap (\fmt -> (txtstr fmt) 0 "\n\n")+dispf fs = if null fs then id else (txtstr . head $ fs) 0++-- -------------------------------------------------------------------+-- Utility functions -------------------------------------------------++merge []        ys        = ys+merge xs        []        = xs+merge xl@(x:xs) yl@(y:ys)+  | x == y    = x : merge xs ys+  | x <  y    = x : merge xs yl+  | otherwise = y : merge xl ys++spaces = ' ':spaces+sp n = if n >= 0 then take n spaces else ""++mergel :: Ord a => [[a]] -> [a]+mergel = foldr merge []++-- ...................................................................+-- ..... Generated code from Pretty.ag ...............................++narrow_frame i  (F s l) = F (s - i)  (l - i)+narrow_ll    i  (F s l) = F s        (l - i)++type T_Mins  = [ (T_PW, T_PLL, T_PH) ]++set_var_apply cond va vb = if cond then va else vb++type T_Reqs  = [ T_Frame ]++type T_Fmts = [ T_Formats ]+type T_Errs = [ T_Error ]++beside_height lh rh+  = lh + rh - if (lh == 0 || rh == 0) then 0 else 1++cons_height pPh acth avail+  | acth == 0  = if pPh > 0 then 1 else 0+  | otherwise  = acth + if avail then 0 else 1++type T_Error = Bool++data T_Formats = AFormat   Formats+               | TFormats  Formats  Formats  T_Error  T_Error++afmt_txt = AFormat . text_fmts++set_fmts_empty = AFormat empty_fmts++set_fmts_text string minw error+  = afmt_txt string+  --(if error then (asts minw) else string)++set_fmts_indent int fmts pw minw frame error+  | int < 0    = afmt_txt "<Error: negative indentation>"+ -- int > pw   = afmt_txt . asts $ minw+  | error      = set_fmts_indent' error_indent+  | otherwise  = set_fmts_indent' (indent_fmts frame)+  where set_fmts_indent' fmt_fc+          = case fmts of+              AFormat fs -> AFormat (fmt_fc int fs)+              TFormats as bs ae be+                         -> TFormats (fmt_fc int as)+                                     (fmt_fc int bs) ae be++set_fmts_beside ls rs lh rh frame err+  = set_fmts_ab ls rs set_fmts_beside' "<Error: can't beside two pairs>"+  where set_fmts_beside' as bs+          = set_ab (lh == 0) (rh == 0) as bs+               (if err then error_beside+                       else beside_fmts frame)++set_fmts_above us ls uh lh+  = set_fmts_ab us ls set_fmts_above' "<Error: can't above two pairs>"+  where set_fmts_above' as bs = set_ab (uh == 0) (lh == 0) as bs above_fmts++set_ab aempty bempty as bs fmt_fc+  = if aempty       {- left operand empty?  -}+    then bs+    else if bempty  {- right operand empty? -}+         then as+         else fmt_fc as bs++set_fmts_ab fs gs fmt_fc etxt+  = case fs of+      AFormat ffmts -> case gs of+                         AFormat gfmts -> ( AFormat (fmt_fc ffmts gfmts), False )+                         TFormats as bs ae be+                                       -> ( TFormats (fmt_fc ffmts as)+                                                     (fmt_fc ffmts bs) ae be+                                          , False )+      TFormats as bs ae be+                    -> case gs of+                         AFormat gfmts -> ( TFormats (fmt_fc as gfmts)+                                                     (fmt_fc bs gfmts) ae be+                                          , False )+                         otherwise     -> ( afmt_txt etxt, True )++sem_fmts_dup afs bfs ae be minw+  = {-if (ae && be)+    then afmt_txt . asts $ minw+    else-}+         let get_fmts fs+               = case fs of+                   AFormat as       -> as+                   TFormats _ _ _ _ -> text_fmts "<Error: can't dup a dup>"+             afmts = get_fmts afs+             bfmts = get_fmts bfs+         in  TFormats afmts bfmts ae be++set_fmts_join    (TFormats as bs ae be)  err+  = ( AFormat $ if be+                then (if null as then bs else as)+                else if ae+                     then (if null bs then as else bs)+                     else merge as bs+    , False+    )+set_fmts_join fs@(AFormat _) err+  = if err then (fs, err)+           else (afmt_txt "<Error: can't join a single result>", True)++set_fmts_apply True  a  _  =  a+set_fmts_apply False _  b  =  b++set_fmts_fillblock int fmts+  | int < 0     = afmt_txt "<Error: negative page width in fillblock>"+  | otherwise   = AFormat fmts++set_error_msg numpars len+  = "<Error: incorrect apply expression. #pars "+  ++ show numpars ++ " /= #args "+  ++ show len     ++ ">"+{-+asts 0 = ""+asts 1 = "*"+asts s = '<' : replicate (s-2) '*' ++ ">"+-}+sem_fmts_cdup afs bfs ae be an bn minw em+  = if an /= bn then afmt_txt em+                else sem_fmts_dup afs bfs ae be minw++set_error_msg' apars bpars+  =  "<Error: incorrect choice expression. #pars left " ++ show apars+  ++ " /= #pars right " ++ show bpars+  ++ ">"++set_fmts_filllist ifmts nfmts ih nh frame avail+  = case nfmts of+      AFormat ns -> if ih == 0                       {- left operand empty?   -}+                    then (ns, False)+                    else if nh == 0                  {- right operand empty?  -}+                         then (ifmts, False)+                         else if nh <= 1+                              then ( choose_ab (beside_fmts frame) ifmts ns, False )+                              else ( choose_ab error_beside+                                       ifmts (text_fmts "<Error: element in fill higher than 1>")+                                   , True )+      otherwise  -> ( set_fmts_filllist' . text_fmts $ "<Error: element in fill list is a pair>"+                    , True )+  where set_fmts_filllist' fs+          = set_ab (ih == 0) (nh == 0) fs ifmts (choose_ab error_beside)+        choose_ab bsd_fc = if avail then bsd_fc else above_fmts++set_fmts_render pw fs+  = if pw < 0+    then text_fmts "<Error: negative page width >"+    else case fs of+           AFormat fmts -> fmts+           otherwise    -> text_fmts "<Error: can't render a pair>"++type T_Function = T_Formats -> T_Formats++set_fmts_filt (AFormat  fs     ) minw+  = {-if null height1 then ( afmt_txt . asts $ minw , True  )+                    else-} ( AFormat height1        , False )+  where height1 = takeWhile ((<=1).height) fs+set_fmts_filt _ _+  = ( afmt_txt $ "<Error: can not filter a pair>", True )++set_fmts_inv fs+  = case fs of+      AFormat fmts         -> AFormat . set_inv $ fmts+      TFormats as bs ae be -> TFormats (set_inv as) (set_inv bs) ae be+  where set_inv = (:[]) . (Elem 1 0 0) . txtstr . head++type T_SynPPS = ( T_Formats, T_Error, T_PH, T_PLL, T_PW )++vapp fmts spaces pPS frame+  = sem_PPS_Above (\frame -> fmts) (sem_PPS_Indent spaces pPS) frame++---------------------- PPS -------------------------+-- semantic domains+type T_PPS =  T_Frame ->(T_Formats,T_Error,T_PH,T_PLL,T_PW)+-- funcs+sem_PPS_Empty :: T_PPS+sem_PPS_Empty lhs_frame =  ( (set_fmts_empty), False, 0, (0), (0) )+sem_PPS_Text ::String -> T_PPS+sem_PPS_Text string lhs_frame+ = let{ minw = (length string)+   ;    error = (minw > pw)+   ;    f@(F pw _ ) = (lhs_frame)+   }in  ( (set_fmts_text string minw error), error, (1), (minw), minw )+sem_PPS_Indent ::Int -> T_PPS -> T_PPS+sem_PPS_Indent int pPS lhs_frame+ = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw )  = pPS (narrow_frame int lhs_frame)+   ;    minw = (int + pPS_minw)+   ;    f@(F pw _ ) = (lhs_frame)+   }in  ( (set_fmts_indent int pPS_fmts pw minw lhs_frame pPS_error)+        , (or [int < 0, int > pw, pPS_error])+        , pPS_maxh+        , (int + pPS_minll)+        , (minw)+        )+sem_PPS_Beside :: T_PPS -> T_PPS -> T_PPS+sem_PPS_Beside left right lhs_frame+ = let{ ( left_fmts, left_error, left_maxh, left_minll, left_minw )  = left (narrow_ll right_minw lhs_frame)+   ;    ( right_fmts, right_error, right_maxh, right_minll, right_minw )  = right (narrow_frame left_minll lhs_frame)+   ;    error = (left_error || right_error)+   ;    fe@(bfmts,berror) = (set_fmts_beside left_fmts right_fmts left_maxh right_maxh lhs_frame error)+   }in  ( (bfmts)+        , (error || berror)+        , (beside_height left_maxh right_maxh)+        , (left_minll + right_minll)+        , (left_minw `max` (left_minll + right_minw))+        )+sem_PPS_Above :: T_PPS -> T_PPS -> T_PPS+sem_PPS_Above upper lower lhs_frame+ = let{ ( upper_fmts, upper_error, upper_maxh, upper_minll, upper_minw )  = upper lhs_frame+   ;    ( lower_fmts, lower_error, lower_maxh, lower_minll, lower_minw )  = lower lhs_frame+   ;    fe@(afmts,aerror) = (set_fmts_above upper_fmts lower_fmts upper_maxh lower_maxh)+   }in  ( (afmts)+        , (or [lower_error, upper_error, aerror])+        , upper_maxh + lower_maxh+        , (lower_minll)+        , (upper_minw `max` lower_minw)+        )+sem_PPS_Dup :: T_PPS -> T_PPS -> T_PPS+sem_PPS_Dup opta optb lhs_frame+ = let{ ( opta_fmts, opta_error, opta_maxh, opta_minll, opta_minw )  = opta lhs_frame+   ;    ( optb_fmts, optb_error, optb_maxh, optb_minll, optb_minw )  = optb lhs_frame+   ;    minw = (opta_minw `min` optb_minw)+   ;    error = (opta_error && optb_error)+   }in  ( (sem_fmts_dup opta_fmts optb_fmts opta_error optb_error minw)+        , (error)+        , (opta_maxh `max` optb_maxh)+        , (opta_minll `min` optb_minll)+        , (minw)+        )+sem_PPS_Join :: T_PPS -> T_PPS+sem_PPS_Join pPS lhs_frame+ = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw )  = pPS lhs_frame+   ;    fe@(jfmts,jerror) = (set_fmts_join pPS_fmts pPS_error)+   }in  ( (jfmts), (pPS_error || jerror), pPS_maxh, pPS_minll, pPS_minw )+sem_PPS_Apply :: T_PPC -> T_PPSArgs -> T_PPS+sem_PPS_Apply pPC pPSArgs lhs_frame+ = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )+         = pPC (pPSArgs_error) (pPSArgs_fmts) lhs_frame (pPSArgs_mins)+   ;    ( pPSArgs_error, pPSArgs_fmts, pPSArgs_mins, pPSArgs_len )  = pPSArgs pPC_reqs+   ;    error = (set_var_apply error_cond True pPC_error)+   ;    error_cond = (pPC_numpars /= pPSArgs_len)+   ;    lem = (length error_msg)+   ;    error_msg = (set_error_msg pPC_numpars pPSArgs_len)+   }in  ( (set_fmts_apply error_cond (AFormat . text_fmts $ error_msg) pPC_fmts)+        , (error)+        , (set_var_apply error_cond 1 pPC_maxh)+        , (set_var_apply error_cond lem pPC_minll)+        , (set_var_apply error_cond lem pPC_minw)+        )+sem_PPS_Fill :: T_FillList -> T_PPS+sem_PPS_Fill fillList lhs_frame+ = let{ ( fillList_fmts, fillList_error, fillList_maxh, fillList_minw, fillList_minll )+         = fillList (empty_fmts) (False) (0) (0) (0) (F w w) (w)+   ;    f@(F w _ ) = (lhs_frame)+   }in  ( (AFormat fillList_fmts), fillList_error, fillList_maxh, fillList_minll, fillList_minw )+sem_PPS_FillBlock ::Int -> T_FillList -> T_PPS+sem_PPS_FillBlock int fillList lhs_frame+ = let{ ( fillList_fmts, fillList_error, fillList_maxh, fillList_minw, fillList_minll )+         = fillList (empty_fmts) (False) (0) (0) (0) (f_frame) (f_width)+   ;    f@(F w _ ) = (lhs_frame)+   ;    f_width = (if int > w then w else int)+   ;    f_frame = (if int > w then lhs_frame else (F int int))+   ;    error = (or [int < 0, fillList_error])+   }in  ( (set_fmts_fillblock int fillList_fmts), (error), fillList_maxh, fillList_minll, fillList_minw )+sem_PPS_Filt :: T_PPS -> T_PPS+sem_PPS_Filt pPS lhs_frame+ = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw )  = pPS lhs_frame+   ;    ef@(fmts,error) = (set_fmts_filt pPS_fmts pPS_minw)+   }in  ( (fmts), (error || pPS_error), pPS_maxh, pPS_minll, pPS_minw )+sem_PPS_Inv :: T_PPS -> T_PPS+sem_PPS_Inv pPS lhs_frame+ = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw )  = pPS (F maxBound maxBound)+   }in  ( (set_fmts_inv pPS_fmts), (False), (1), (0), (0) )+sem_PPS_Center :: T_CenterList -> T_PPS+sem_PPS_Center centerList lhs_frame+ = let{ ( centerList_maxw, centerList_fmts )  = centerList (centerList_maxw) (sem_PPS_Empty lhs_frame) lhs_frame+   ;    clf@(fmts,error,maxh,minll,minw) = (centerList_fmts)+   }in  ( (fmts), (error), (maxh), (minll), (minw) )+---------------------- PPC -------------------------+-- semantic domains+type T_PPC =  T_Errs -> T_Fmts -> T_Frame -> T_Mins ->+              (T_Formats,T_Error,T_PH,T_Reqs,T_PLL+              ,T_PW,Int)+-- funcs+sem_PPC_Indent ::Int -> T_PPC -> T_PPC+sem_PPC_Indent int pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins+ = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )+         = pPC lhs_fillerrs lhs_fillfmts (narrow_frame int lhs_frame) lhs_fillmins+   ;    minw = (int + pPC_minw)+   ;    f@(F pw _ ) = (lhs_frame)+   }in  ( (set_fmts_indent int pPC_fmts pw minw lhs_frame pPC_error)+        , (or [int < 0, int > pw, pPC_error])+        , pPC_maxh+        , pPC_reqs+        , (int + pPC_minll)+        , (minw)+        , pPC_numpars+        )+sem_PPC_Beside :: T_PPC -> T_PPC -> T_PPC+sem_PPC_Beside left right lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins+ = let{ ( left_fmts, left_error, left_maxh, left_reqs, left_minll, left_minw, left_numpars )+         = left (les) (lfs) (narrow_ll right_minw lhs_frame) (lim)+   ;    ( right_fmts, right_error, right_maxh, right_reqs, right_minll, right_minw, right_numpars )+         = right (res) (rfs) (narrow_frame left_minll lhs_frame) (rim)+   ;    i@(lim,rim) = (splitAt left_numpars lhs_fillmins)+   ;    e@(les,res) = (splitAt left_numpars lhs_fillerrs)+   ;    m@(lfs,rfs) = (splitAt left_numpars lhs_fillfmts)+   ;    error = (left_error || right_error)+   ;    fe@(bfmts,berror) = (set_fmts_beside left_fmts right_fmts left_maxh right_maxh lhs_frame error)+   }in  ( (bfmts)+        , (error || berror)+        , (beside_height left_maxh right_maxh)+        , left_reqs ++ right_reqs+        , (left_minll + right_minll)+        , (left_minw `max` (left_minll + right_minw))+        , left_numpars + right_numpars+        )+sem_PPC_Above :: T_PPC -> T_PPC -> T_PPC+sem_PPC_Above upper lower lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins+ = let{ ( upper_fmts, upper_error, upper_maxh, upper_reqs, upper_minll, upper_minw, upper_numpars )+         = upper (ues) (ufs) lhs_frame (uim)+   ;    ( lower_fmts, lower_error, lower_maxh, lower_reqs, lower_minll, lower_minw, lower_numpars )+         = lower (les) (lfs) lhs_frame (lim)+   ;    i@(uim,lim) = (splitAt upper_numpars lhs_fillmins)+   ;    e@(ues,les) = (splitAt upper_numpars lhs_fillerrs)+   ;    m@(ufs,lfs) = (splitAt upper_numpars lhs_fillfmts)+   ;    fe@(afmts,aerror) = (set_fmts_above upper_fmts lower_fmts upper_maxh lower_maxh)+   }in  ( (afmts)+        , (or [lower_error, upper_error, aerror])+        , (upper_maxh + lower_maxh)+        , upper_reqs ++ lower_reqs+        , lower_minll+        , (upper_minw `max` lower_minw)+        , upper_numpars + lower_numpars+        )+sem_PPC_Dup :: T_PPC -> T_PPC -> T_PPC+sem_PPC_Dup opta optb lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins+ = let{ ( opta_fmts, opta_error, opta_maxh, opta_reqs, opta_minll, opta_minw, opta_numpars )+         = opta lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins+   ;    ( optb_fmts, optb_error, optb_maxh, optb_reqs, optb_minll, optb_minw, optb_numpars )+         = optb lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins+   ;    minw = (opta_minw `min` optb_minw)+   ;    error = (or [opta_numpars /= optb_numpars, opta_error && optb_error])+   ;    error_msg = (set_error_msg' opta_numpars optb_numpars)+   }in  ( (sem_fmts_cdup opta_fmts optb_fmts opta_error optb_error opta_numpars optb_numpars minw error_msg)+        , (error)+        , (opta_maxh `max` optb_maxh)+        , (zipWith max opta_reqs optb_reqs)+        , (opta_minll `min` optb_minll)+        , (minw)+        , (opta_numpars)+        )+sem_PPC_Join :: T_PPC -> T_PPC+sem_PPC_Join pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins+ = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )+         = pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins+   ;    fe@(jfmts,jerror) = (set_fmts_join pPC_fmts pPC_error)+   }in  ( (jfmts), (pPC_error || jerror), pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )+sem_PPC_Par :: T_PPC+sem_PPC_Par lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins+ = let{ m@(minw,minll,maxh) = (head lhs_fillmins)+   ;    error = (head lhs_fillerrs)+   ;    fmts = (head lhs_fillfmts)+   }in  ( fmts, error, maxh, ([lhs_frame]), minll, minw, 1 )+sem_PPC_Apply :: T_PPC -> T_PPCArgs -> T_PPC+sem_PPC_Apply pPC pPCArgs lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins+ = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )+         = pPC (pPCArgs_error) (pPCArgs_fmts) (lhs_frame) (pPCArgs_ofillmins)+   ;    ( pPCArgs_error, pPCArgs_fmts, pPCArgs_reqs, pPCArgs_ofillmins, pPCArgs_numpars, pPCArgs_len )+         = pPCArgs (lhs_fillerrs) (lhs_fillfmts) (pPC_reqs) (lhs_fillmins)+   ;    error = (set_var_apply error_cond True pPC_error)+   ;    error_cond = (pPC_numpars /= pPCArgs_len)+   ;    lem = (length error_msg)+   ;    error_msg = (set_error_msg pPC_numpars pPCArgs_len)+   }in  ( (set_fmts_apply error_cond (AFormat . text_fmts $ error_msg) pPC_fmts)+        , (error)+        , (set_var_apply error_cond 1 pPC_maxh)+        , (pPCArgs_reqs)+        , (set_var_apply error_cond lem pPC_minll)+        , (set_var_apply error_cond lem pPC_minw)+        , (pPCArgs_numpars)+        )+sem_PPC_Pps :: T_PPS -> T_PPC+sem_PPC_Pps pPS lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins+ = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw )  = pPS lhs_frame+   }in  ( pPS_fmts, pPS_error, pPS_maxh, ([]), pPS_minll, pPS_minw, (0) )+sem_PPC_Filt :: T_PPC -> T_PPC+sem_PPC_Filt pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins+ = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )+         = pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins+   ;    ef@(fmts,error) = (set_fmts_filt pPC_fmts pPC_minw)+   }in  ( (fmts), (error || pPC_error), pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )+---------------------- PPSArgs -------------------------+-- semantic domains+type T_PPSArgs =  T_Reqs ->(T_Errs,T_Fmts,T_Mins,Int)+-- funcs+sem_PPSArgs_Nil :: T_PPSArgs+sem_PPSArgs_Nil lhs_reqs =  ( ([]), ([]), ([]), (0) )+sem_PPSArgs_Cons :: T_PPS -> T_PPSArgs -> T_PPSArgs+sem_PPSArgs_Cons pPS pPSArgs lhs_reqs+ = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw )  = pPS (head lhs_reqs)+   ;    ( pPSArgs_error, pPSArgs_fmts, pPSArgs_mins, pPSArgs_len )  = pPSArgs (tail lhs_reqs)+   }in  ( (pPS_error:pPSArgs_error), (pPS_fmts:pPSArgs_fmts), ((pPS_minw ,pPS_minll, pPS_maxh):pPSArgs_mins), (pPSArgs_len + 1) )+---------------------- PPCArgs -------------------------+-- semantic domains+type T_PPCArgs =  T_Errs -> T_Fmts -> T_Reqs -> T_Mins ->(T_Errs,T_Fmts,T_Reqs,T_Mins,Int,Int)+-- funcs+sem_PPCArgs_Nil :: T_PPCArgs+sem_PPCArgs_Nil lhs_ifillerrs lhs_ifillfmts lhs_ireqs lhs_ifillmins =  ( ([]), ([]), [], ([]), 0, (0) )+sem_PPCArgs_Cons :: T_PPC -> T_PPCArgs -> T_PPCArgs+sem_PPCArgs_Cons pPC pPCArgs lhs_ifillerrs lhs_ifillfmts lhs_ireqs lhs_ifillmins+ = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )  = pPC (pef) (pff) (head lhs_ireqs) (pim)+   ;    ( pPCArgs_error, pPCArgs_fmts, pPCArgs_reqs, pPCArgs_ofillmins, pPCArgs_numpars, pPCArgs_len )+         = pPCArgs (lef) (lff) (tail lhs_ireqs) (lim)+   ;    i@(pim,lim) = (splitAt pPC_numpars lhs_ifillmins)+   ;    e@(pef,lef) = (splitAt pPC_numpars lhs_ifillerrs)+   ;    m@(pff,lff) = (splitAt pPC_numpars lhs_ifillfmts)+   }in  ( (pPC_error:pPCArgs_error)+        , (pPC_fmts:pPCArgs_fmts)+        , pPC_reqs ++ pPCArgs_reqs+        , ((pPC_minw ,pPC_minll,pPC_maxh):pPCArgs_ofillmins)+        , pPC_numpars + pPCArgs_numpars+        , (pPCArgs_len + 1)+        )+---------------------- FillList -------------------------+-- semantic domains+type T_FillList =  Formats -> T_Error -> T_PH -> T_PW -> T_PLL -> T_Frame -> T_PW ->(Formats,T_Error,T_PH,T_PW,T_PLL)+-- funcs+sem_FillList_Nil :: T_FillList+sem_FillList_Nil lhs_fmts lhs_error lhs_maxh lhs_minw lhs_minll lhs_frame lhs_pw+ =  ( lhs_fmts, lhs_error, lhs_maxh, lhs_minw, lhs_minll )+sem_FillList_Cons :: T_PPS -> T_FillList -> T_FillList+sem_FillList_Cons pPS fillList lhs_fmts lhs_error lhs_maxh lhs_minw lhs_minll lhs_frame lhs_pw+ = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw )  = pPS (lhs_frame)+   ;    ( fillList_fmts, fillList_error, fillList_maxh, fillList_minw, fillList_minll )+         = fillList (ffmts)+                    (lhs_error || ferror)+                    (cons_height pPS_maxh lhs_maxh avail)+                    (if (not avail) || (lhs_minw == lhs_pw) then lhs_pw else lhs_minll)+                    (if ferror then lhs_pw + 1 else if avail then newll else pPS_minw)+                    lhs_frame+                    lhs_pw+   ;    avail = (lhs_pw - newll >= 0)+   ;    newll = (lhs_minll + pPS_minw)+   ;    fe@(ffmts,ferror) = (set_fmts_filllist lhs_fmts pPS_fmts lhs_maxh pPS_maxh lhs_frame avail)+   }in  ( fillList_fmts, (fillList_error || pPS_error), fillList_maxh, fillList_minw, fillList_minll )+---------------------- Root -------------------------+-- semantic domains+type T_Root =  T_PW ->String+-- funcs+sem_Root_Best :: T_PPS -> T_Root+sem_Root_Best pPS lhs_pw+ = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw )  = pPS (F lhs_pw lhs_pw)+   }in  (best . set_fmts_render lhs_pw $ pPS_fmts)+sem_Root_All :: T_PPS -> T_Root+sem_Root_All pPS lhs_pw+ = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw )  = pPS (F lhs_pw lhs_pw)+   }in  (allf . set_fmts_render lhs_pw $ pPS_fmts)+---------------------- Disp -------------------------+-- semantic domains+type T_Disp =  T_PW ->ShowS+-- funcs+sem_Disp_Disp :: T_PPS -> T_Disp+sem_Disp_Disp pPS lhs_pw+ = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw )  = pPS (F lhs_pw lhs_pw)+   }in  (dispf . set_fmts_render lhs_pw $ pPS_fmts)+---------------------- LiftS -------------------------+-- semantic domains+type T_LiftS =  T_Function -> T_Frame ->(T_Formats,T_Error,T_PH,T_PLL,T_PW)+-- funcs+sem_LiftS_Lift :: T_PPS -> T_LiftS+sem_LiftS_Lift pPS lhs_f lhs_frame+ = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw )  = pPS lhs_frame+   }in  ( (lhs_f pPS_fmts), pPS_error, pPS_maxh, pPS_minll, pPS_minw )+---------------------- LiftC -------------------------+-- funcs+sem_LiftC_Lift pPC lhs_f lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins+ = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )+         = pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins+   }in  ( (lhs_f pPC_fmts), pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )+sem_LiftC_Pair pPC lhs_f lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins+ = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )+         = pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins+   ;    fe@(fmts,error) = (lhs_f pPC_fmts)+   }in  ( (fmts), (pPC_error || error), pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )+---------------------- CenterList -------------------------+-- semantic domains+type T_CenterList =  Int -> T_SynPPS -> T_Frame ->(Int,T_SynPPS)+-- funcs+sem_CenterList_Nil :: T_CenterList+sem_CenterList_Nil lhs_maxw lhs_fmts lhs_frame =  ( (0), lhs_fmts )+sem_CenterList_Cons :: T_PPS -> T_CenterList -> T_CenterList+sem_CenterList_Cons pPS centerList lhs_maxw lhs_fmts lhs_frame+ = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw )  = pPS (lhs_frame)+   ;    ( centerList_maxw, centerList_fmts )  = centerList lhs_maxw (vapp lhs_fmts spaces pPS lhs_frame) lhs_frame+   ;    spaces = ((lhs_maxw - pPS_minw) `div` 2)+   }in  ( (pPS_minw `max` centerList_maxw), centerList_fmts )
+ src/UU/Pretty/Ext.hs view
@@ -0,0 +1,190 @@+--  $Header: /data/cvs-rep/uust/lib/pretty/UU/Pretty/Ext.hs,v 1.1 2002/11/13 16:05:20 uust Exp $+--  $Name:  $ (version name)++module UU.Pretty.Ext ( -- Derived from single and multiple+                       (>^<), (>>^<<), (>#<), (>>#<<), wide_text+                     , vlist, hlist, hlist_sp, list_h1, hlist_h1+                     , (>|<<), (>-<<), (>>|<), (>>-<), pp_es+                       -- Displaying the result+                     , vdisp+                       -- Printing brackets+                     , pp_wrap, pp_quotes, pp_doubleQuotes+                     , pp_parens, pp_brackets, pp_braces+                       -- Printing structures+                     , hv, hv_sp, pp_block, pp_ite+                     , pp_list, pp_slist, pp_parens_list+                     ) where++{- Derived pretty-printing combinators. Version 2.0c+   Authors: S. Doaitse Swierstra and Pablo R. Azero+   Date: July, 1999+ -}++import UU.Pretty.Basic++infixr 3 >#<, >>#<<, >>|<, >|<<+infixr 2 >>-<, >-<<+infixr 1 >^<, >>^<<++-- -------------------------------------------------------------------+-- PP instances for often used simple data types ---------------------++instance PP Int where+  pp = text . show++instance PP Float where+  pp = text . show++-- -------------------------------------------------------------------+-- Derived from single and multiple ----------------------------------++(>^<), (>#<) :: (PP a, PP b) => a -> b -> PP_Doc+a  >^<  b  =  join  (a  >//<  b)+l  >#<  r  =  l >|< " " >|< r++pp_es string = if null string then empty else pp string++wide_text t s | ls > t    = text s+              | otherwise = text . (if t >= 0 then take t else take 0) $ (s ++ spaces)+  where ls     = length s+        spaces = repeat ' '++hlist, vlist, hlist_sp :: PP a => [a] -> PP_Doc+vlist    = foldr  (>-<) empty+hlist    = foldr  (>|<) empty+hlist_sp = foldr  (>#<) empty++list_h1 :: [PP_Doc] -> [PP_Doc]+list_h1   = map element_h1++hlist_h1  = foldr1 (>|<) . list_h1++(>>^<<), (>>#<<) :: PP_Exp -> PP_Exp -> PP_Exp+a >>^<< b  =  ejoin (a >>//<< b)+l >>#<< r  =  l >>|<< (" " >|<< r)++(>|<<), (>-<<) :: PP a => a -> PP_Exp -> PP_Exp+l >|<< r = c2e l >>|<< r+u >-<< l = c2e u >>-<< l++(>>|<), (>>-<) :: PP a => PP_Exp -> a -> PP_Exp+l >>|< r = l >>|<< c2e r+u >>-< l = u >>-<< c2e l++-- -------------------------------------------------------------------+-- Displaying the result ---------------------------------------------++vdisp :: Int -> [PP_Doc] -> ShowS+vdisp pw = foldr (\f fs -> disp f pw . ("\n"++) . fs) id++-- -------------------------------------------------------------------+-- Printing brackets -------------------------------------------------++pp_wrap :: PP a =>  a -> a -> PP_Doc -> PP_Doc+pp_wrap op cl p = op >|< (p >|< cl)++pp_quotes       = pp_wrap '`' '\''+pp_doubleQuotes = pp_wrap '"' '"'+pp_parens       = pp_wrap '(' ')'+pp_brackets     = pp_wrap '[' ']'+pp_braces       = pp_wrap '{' '}'++-- -------------------------------------------------------------------+-- Printing structures++-- hv: display a list of elements either horizontally or vertically,+-- 2 possible layouts: horizonal or vertical++hv :: PP a => [a] -> PP_Doc+hv = join . foldr onehv (empty >//< empty) . map pp+  where onehv p ps =      eelement_h1 par >>|<< fpar+                   >>//<< par >>-<< spar+                   >>$<   [p, ps]++-- hv_sp: same as hv but inserts spaces between the elements+-- 2 possible layouts: horizonal or vertical++hv_sp :: PP a => [a] -> PP_Doc+hv_sp l | null l    = empty+        | otherwise = lhv_sp . map pp $ l++lhv_sp fs@(f:fss) = hs >>^<< vs >>$< fs+  where (hs, vs)  = foldr paralg (par, par) fss+        paralg    = \_ (nhs,nvs) -> (eelement_h1 par >>#<< nhs, par >>-<< nvs)++-- pp_block: printing of block structures with open, close and separator+--           keywords+-- 2 possible layouts: horizonal or vertical++--pp_block :: String -> String -> String -> [PP_Doc] -> PP_Doc+pp_block okw ckw sep fs+  | null fs   = hv [open, close]+  | otherwise = join+      (      eelement_h1  par >>|<< fpar+      >>//<<              par >>-<< spar+      >>$< [open >|< (indent (startcolumn-lk) . head $ fs), hvopts]+      )+  where lk           =  length okw+        lsep         =  length sep+        startcolumn  =  (lk `max` lsep)+        hvopts       =  foldr hvoptalg dclose (tail fs)+        hvoptalg p ps+          = (       par  >>|<<  eelement_h1 par                   >>|<<  fpar+             >>//<< par  >>|<<  eindent (startcolumn - lsep) par  >>-<<  spar+            ) >>$< [pp_es sep, p, ps]+        dclose       =  eindent (startcolumn-lk) par >>//<< par >>$< [close]+        open         =  pp_es okw+        close        =  pp_es ckw++-- pp_ite: printing an if-then-else-fi statement+-- three possible layouts: horizonal, vertical or mixed++--pp_ite :: (PP a, PP b, PP c, PP d)+--       => a -> b -> c -> d -> PP_Doc -> PP_Doc -> PP_Doc -> PP_Doc+pp_ite kw_if kw_then kw_else kw_fi c t e+  = (     eelement_h1 ( par >>|<< par >>|<< par >>|<< par )+    >>^<< (     (     ( par >>|<< par >>^<< par >>-<< par )+                >>$<< [par, par >>-<< par]+                )+          >>-<< par+          )+    )  >>$< [ kw_if   >|< c+            , kw_then >|< t+            , kw_else >|< e+            , pp kw_fi+            ]++-- pp_slist: printing a list of elements in a "mini page", needs open, close and+--          separator keywords and a "mini page" width+-- one possible layout: depends on the page width given, when it reaches the end+-- of the page it continues on the next line+-- restrictions: only simple elements allowed (no pp_slists or flexible layouts+--               in the list [PP_Doc])++pp_slist :: Int -> String -> String -> String -> [PP_Doc] -> PP_Doc+pp_slist pw ol cl sep fl+  | null fl    =   hv [open, close]+  | otherwise  =   eelement_h1 (par >>|<< par) >>^<< (par >>-<< par)+               >>$< [nes, close]+  where nes    =   fillblock pw (open: ne: map (pp_es sep >|<) (tail fl))+        ne     =   (replicate (if ws == 0 then 0 else ws - 1) ' ')+               >|< (head fl)+        ws     =   length sep+        open   = pp_es ol+        close  = pp_es cl++-- pp_list: printing a list of elements in a "mini page", needs open, close and+--          separator keywords and a "mini page" width+-- one possible layout: depends on the page width given, when it reaches the end+-- of the page it continues on the next line++pp_list :: Int -> String -> String -> String -> [PP_Doc] -> PP_Doc+pp_list pw ol cl _   []     = pp_es (ol ++ cl)+pp_list pw ol cl sep (f:fs)+  = fillblock pw (pp ol: (pp f): (map (pp_es sep >|<) fs) ++ [ pp cl ])++-- pp_parens_list: idem pp_list, with parenthesis and comma separator++pp_parens_list :: Int -> [PP_Doc] -> PP_Doc+pp_parens_list mpw = pp_list mpw "(" ")" ", "+
+ src/UU/Scanner.hs view
@@ -0,0 +1,18 @@+module UU.Scanner+ ( module UU.Scanner.Scanner+ , module UU.Scanner.Token+ , module UU.Scanner.TokenParser+ , module UU.Scanner.Position+ )+ where++import UU.Scanner.Scanner+import UU.Scanner.Token+import UU.Scanner.TokenParser+import UU.Scanner.Position++-- instances+import UU.Scanner.TokenShow()+import UU.Scanner.GenTokenOrd()+import UU.Scanner.GenTokenSymbol()+
+ src/UU/Scanner/GenToken.hs view
@@ -0,0 +1,12 @@+module UU.Scanner.GenToken where++import UU.Scanner.Position(Pos)++data GenToken key tp val =  Reserved !key !Pos+                         |  ValToken !tp val !Pos    +                 +position :: GenToken k t v -> Pos+position tok = case tok of+                   Reserved _ p   -> p+                   ValToken _ _ p -> p+
+ src/UU/Scanner/GenTokenOrd.hs view
@@ -0,0 +1,15 @@+module UU.Scanner.GenTokenOrd() where++import UU.Scanner.GenToken(GenToken(..))++instance (Eq key, Eq tp) => Eq (GenToken key tp val) where+   Reserved x    _ == Reserved y    _ = x == y+   ValToken tx _ _ == ValToken ty _ _ = tx == ty+   _               == _               = False+   +instance (Ord key, Ord tp) => Ord (GenToken key tp val) where+  compare (Reserved x    _) (Reserved y    _) = compare x y+  compare (Reserved _    _) _                 = LT+  compare (ValToken tx _ _) (ValToken ty _ _) = compare tx ty+  compare _              _                    = GT+
+ src/UU/Scanner/GenTokenParser.hs view
@@ -0,0 +1,54 @@+module UU.Scanner.GenTokenParser where++import UU.Parsing.Interface(IsParser(pCostSym, pSym, (<$>)))+import UU.Scanner.GenToken(GenToken(..))+import UU.Scanner.Position(Pos, noPos)+++pCostReserved'          :: IsParser p (GenToken key tp val) +                        => Int -> key -> p (GenToken key tp val)+pCostReserved' c key    =  let tok = Reserved key noPos +                           in  pCostSym c tok tok ++pReserved'              :: IsParser p (GenToken key tp val) +                        => key -> p (GenToken key tp val)+pReserved' key          =  let tok = Reserved key noPos +                           in  pSym tok ++pCostValToken'          :: IsParser p (GenToken key tp val) +                        => Int -> tp -> val -> p (GenToken key tp val)+pCostValToken' c tp val =  let tok = ValToken tp val noPos +                           in  pCostSym c tok tok ++pValToken'              :: IsParser p (GenToken key tp val) +                        => tp -> val -> p (GenToken key tp val)+pValToken' tp val       =  let tok = ValToken tp val noPos +                           in  pSym tok +++pCostReserved           :: IsParser p (GenToken key tp val) +                        => Int -> key -> p Pos+pCostReserved c key     =  let getPos x = case x of+                                Reserved _   p -> p+                                ValToken _ _ p -> p+                           in getPos <$> pCostReserved' c key+                          +pCostValToken           :: IsParser p (GenToken key tp val) +                        => Int -> tp -> val -> p (val,Pos)+pCostValToken c tp val  =  let getVal x = case x of+                                ValToken _ v p -> (v,p)+                                _              -> error "pValToken: cannot get value of Reserved"+                           in getVal <$> pCostValToken' c tp val++pReserved               :: IsParser p (GenToken key tp val) +                        => key -> p Pos+pReserved               =  pCostReserved 5 ++pValToken               :: IsParser p (GenToken key tp val) +                        => tp -> val -> p (val,Pos)+pValToken               =  pCostValToken 5++pValTokenNoPos          :: IsParser p (GenToken key tp val) +                        => tp -> val -> p val+pValTokenNoPos tp val   =  fst <$> pValToken tp val                          +
+ src/UU/Scanner/GenTokenSymbol.hs view
@@ -0,0 +1,8 @@+module UU.Scanner.GenTokenSymbol() where++import UU.Scanner.GenToken(GenToken(..))+import UU.Parsing.MachineInterface(Symbol(..))++instance Symbol (GenToken key tp val) where+  deleteCost (Reserved _ _) = 5+  deleteCost _              = 5
+ src/UU/Scanner/Position.hs view
@@ -0,0 +1,70 @@+module UU.Scanner.Position where++type Line     = Int+type Column   = Int+type Filename = String+++class Position p where +  line   :: p -> Line+  column :: p -> Column+  file   :: p -> Filename+++instance Position Pos where+   line   (Pos l _ _) = l+   column (Pos _ c _) = c+   file   (Pos _ _ f) = f++data Pos = Pos !Line !Column Filename ++instance Show Pos where+  show (Pos l c f) | l == (-1) = ""+                   | otherwise = let file = if null f then "" else show f+                                     lc = "(line " ++ show l ++ ", column " ++ show c ++")"+                                 in file ++ lc+initPos :: FilePath -> Pos+initPos fn = Pos 1 1 fn++noPos :: Pos+noPos = Pos (-1) (-1) ""++advl ::  Line -> Pos ->Pos+advl i (Pos l c f) = (Pos (l+i) 1 f)++advc :: Column -> Pos ->  Pos+advc i (Pos l c f) = (Pos l (c+i) f)++adv :: Pos -> Char -> Pos+adv pos c = case c of+  '\t' -> advc (tabWidth (column pos)) pos+  '\n' -> advl 1 pos+  _    -> advc 1 pos++updPos :: Char -> Pos -> Pos+updPos x = case x of+ '\n' -> newl+ '\t' -> tab+ _    -> advc 1++tab              :: Pos -> Pos+tab  (Pos l c f) =  Pos l (c+tabWidth c) f++newl :: Pos ->Pos+newl =  advl 1++tabWidth :: Column -> Int+tabWidth c = 8 - ((c-1) `mod` 8)+++updPos' :: Char -> Pos -> (Pos -> a) -> a+updPos' c p cont = p `seq` cont (updPos c p)++advc' :: Int -> Pos -> (Pos -> a) -> a+advc' i p cont = p `seq` cont (advc i p)++tab' :: Pos -> (Pos -> a) -> a+tab'  p cont = p `seq` cont (tab p)++newl' :: Pos -> (Pos -> a) -> a+newl' p cont = p `seq` cont (newl p)
+ src/UU/Scanner/Scanner.hs view
@@ -0,0 +1,236 @@+module UU.Scanner.Scanner where++import Char(isLower, isUpper, isSpace, isAlphaNum, isDigit, chr, ord)+import List(sort)+import Maybe(isJust)+import UU.Util.BinaryTrees(tab2tree,btLocateIn)+import UU.Scanner.Token(Token, EnumValToken(..), valueToken, reserved, errToken)+import UU.Scanner.Position(Pos, initPos, advc, adv)+{- A parametrisable scanner+ -+ - Author: Doaitse Swierstra: doaitse@cs.uu.nl+      and: Pablo Azero      : pablo@cs.uu.nl+ - Version 1.0 , May 25, 1998, SDS+    first appearance on the software web site.+ - Version 1.01, June 7, 1998, SDS+    changed String recognition to recognise escaped characters+ - Version 1.02, Aug 30, 1998, SDS+    includes with unsafePerformIO+ - Version 2.1,  Jul  7, 1999, slightly different definition of valueToken+                               ordering between tokens introduced+ - Version 2.2,  Jul  8, 1999, AG_Scanner and UU_Scanner merged+ - Version 2.3,  Jul 15, 1999, modifications: recognize decimal, octal and+ -                             hexadecimal numbers; handles ' as part of a+ -                             lower case identifier+ -                             fixes: bug in msort (loops when passing an+ -                             empty list)+ - Version 2.4,  Jul 23, 1999, additions: recognize characters and infix+ -                             operators+ -+ - Lang. compat: Hugs 98 (because it is required by UU_Parsing)+ - Version 2.5,  Aug 15, 1999, changed names, pSym -> pSpec+                             , all parsers start with p....+ - Version 2.6,  Sept 15, 1999, changed error message for unterminated string+ - Version 2.7,  Sept 23, 1999, changed definition of pOper_Any+ - Version 2.8   Aug 14,  2000, adapted to changes in search trees+ - ??            Oct 25,  2000, adapted to use column numbers+ - ??            Feb 2,   2001, incorporated changes of AD+ - ??            Feb 28,  2001, tabs are handled correctly for column numbers+ - ??            Mar 1,   2001, now generates space tokens that have to be filtered again+ - ??            Apr 4,   2001, tabs are now handled relative to current column number+ -}++scanFile :: [String] -> [String] -> String -> String -> FilePath -> IO [Token]+scanFile keywordstxt keywordsops specchars opchars fn = +        do txt <- readFile fn+           return (scan keywordstxt keywordsops specchars opchars (initPos fn) txt) ++scan :: [String] -> [String] -> String -> String -> Pos -> String -> [Token]+scan keywordstxt keywordsops specchars opchars pos input+  = doScan pos input++ where+   locatein :: Ord a => [a] -> a -> Bool+   locatein es = isJust . btLocateIn compare (tab2tree (sort es))+   iskw     = locatein keywordstxt+   isop     = locatein keywordsops+   isSymbol = locatein specchars+   isOpsym  = locatein opchars++   isIdStart c = isLower c || c == '_'++   isIdChar c =  isAlphaNum c+              || c == '\''+              || c == '_'++   scanIdent p s = let (name,rest) = span isIdChar s+                   in (name,advc (length name) p,rest)+++   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,swidth,rest) = scanString ss+       in if null rest || head rest /= '"'+             then errToken "Unterminated string literal" p : doScan (advc swidth p) rest+             else valueToken TkString s p : doScan (advc (swidth+2) p) (tail rest)++   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)++   {-+   In Haskell infix identifiers consist of three separate tokens(two backquotes + identifier)+   doScan p ('`':ss)+     = case ss of+         []    -> [errToken "Unterminated infix identifier" p]+         (c:s) -> let res | isIdStart c || isUpper c =+                                   let (name,p1,rest) = scanIdent (advc 2 p) s+                                       ident = c:name+                                       tokens | null rest ||+                                                head rest /= '`' = errToken "Unterminated infix identifier" p +                                                                 : doScan p1 rest+                                              | iskw ident       = errToken ("Keyword used as infix identifier: " ++ ident) p +                                                                 : doScan (advc 1 p1) (tail rest)+                                              | otherwise        = valueToken TkOp ident p +                                                                 : doScan (advc 1 p1) (tail rest)+                                   in tokens+                          | otherwise = errToken ("Unexpected character in infix identifier: " ++ show c) p +                                      : doScan (adv p c) s+                  in res+   -}+   doScan p cs@(c:s)+     | isSymbol c = reserved [c] p+                  : doScan(advc 1 p) s+     | isIdStart c || isUpper c+         = let (name', p', s')    = scanIdent (advc 1 p) s+               name               = c:name'+               tok                = if iskw name+                                    then reserved name p+                                    else if null name' && isSymbol c+                                    then reserved [c] p+                                    else valueToken (if isIdStart c then TkVarid else TkConid) name p+           in tok :  doScan p' s'+     | isOpsym c = let (name, s') = span isOpsym cs+                       tok | isop name = reserved name p+                           | c==':'    = valueToken TkConOp name p+                           | otherwise = valueToken TkOp name p+                   in tok : doScan (foldl adv p name) s'+     | isDigit c = let (tktype,number,width,s') = getNumber cs+                   in  valueToken tktype number p : doScan (advc width p) s'+     | otherwise = errToken ("Unexpected character " ++ show c) p+                 : doScan (adv p c) s++{-++-- ks: no clean implementation of columns+readname s lc = (name,orest,nlc)+  where (line,irest) = span (/='\n') s+        orest = if null irest then "" else irest+        nlc   = if null irest then lc else (lc `advl` 1)+        name  = takename . dropWhile (\x -> not $ x `elem` "{[") $ line+        takename ln | null ln   = ""+                    | otherwise = if not (null tln) && (isAlpha . head $ tln)+                                  then if not (null rln) && (head rln `elem` "}]")+                                       then cname+                                       else err lc 1+                                  else err lc 1+          where (cname, rln) = span validChar tln+                tln          = tail ln+                validChar c  = isAlpha c || c `elem` ".-_" || isDigit c++-- ks: changed definition from (lc+1) to (lc)+err lc 1 = error ("in scanner bad name definition" ++ maybeshow (lc))+err lc fn 2+   = error ("in scanner not a valid name in file inclusion" ++ maybeshow (lc))+-}+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 :: String -> (String,Int,String)+scanString []            = ("",0,[])+scanString ('\\':'&':xs) = let (str,w,r) = scanString xs+                           in (str,w+2,r)+scanString ('\'':xs)     = let (str,w,r) = scanString xs+                           in ('\'': str,w+1,r)+scanString xs = let (ch,cw,cr) = getchar xs+                    (str,w,r)  = scanString cr+                    str' = maybe "" (:str) ch+                in maybe ("",0,xs) (\c -> (c:str,cw+w,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)++getEscChar :: [Char] -> (Maybe Char,Int,[Char])+getEscChar [] = (Nothing,0,[])+getEscChar s@(x:xs) | isDigit x = let (tp,n,len,rest) = getNumber s+                                      val = case tp of+                                              TkInteger8  -> readn 8  n+                                              TkInteger16 -> readn 16 n+                                              TkInteger10 -> readn 10 n+                                  in  if val >= 0 && val <= 255+                                         then (Just (chr val),len, rest)+                                         else (Nothing,1,rest)+                    | otherwise = case x `lookup` cntrChars of+                                 Nothing -> (Nothing,0,s)+                                 Just c  -> (Just c,1,xs)+  where cntrChars = [('a','\a'),('b','\b'),('f','\f'),('n','\n'),('r','\r'),('t','\t')+                    ,('v','\v'),('\\','\\'),('\"','\"'),('\'','\'')]++readn :: Int -> [Char] -> Int+readn base n = foldl (\r x  -> 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)++isHexaDigit :: Char -> Bool+isHexaDigit  d = isDigit d || (d >= 'A' && d <= 'F') || (d >= 'a' && d <= 'f')++isOctalDigit :: Char -> Bool+isOctalDigit d = d >= '0' && d <= '7'++value :: Char -> Int+value c | isDigit c = ord c - ord '0'+        | isUpper c = ord c - ord 'A' + 10+        | isLower c = ord c - ord 'a' + 10
+ src/UU/Scanner/Token.hs view
@@ -0,0 +1,32 @@+module UU.Scanner.Token where++import UU.Scanner.GenToken(GenToken(..)) +import UU.Scanner.Position(Pos) ++type Token = GenToken String EnumValToken String++data EnumValToken+  = TkVarid+  | TkConid+  | TkString+  | TkChar+  | TkInteger8+  | TkInteger10+  | TkInteger16+  | TkFraction+  | TkTextnm+  | TkTextln +  | TkOp+  | TkConOp+  | TkError+  deriving (Eq, Ord)++reserved                :: String -> Pos -> Token+reserved                =  Reserved ++valueToken              :: EnumValToken -> String -> Pos -> Token+valueToken              =  ValToken ++errToken                :: String -> Pos -> Token+errToken                =  valueToken TkError +
+ src/UU/Scanner/TokenParser.hs view
@@ -0,0 +1,107 @@+module UU.Scanner.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 UU.Scanner.Token(Token,EnumValToken(..))++-------------------------------------------------------------------------+-- IsParsers for  Symbols+-------------------------------------------------------------------------++pKeyPos           :: IsParser p Token => String -> p Pos+pKeyPos  keyword  =  pReserved keyword+++pSpecPos          :: IsParser p Token => Char -> p Pos+pSpecPos s        =  pReserved [s]++pKey              :: IsParser p Token => String -> p String+pKey  key         =  key <$ pKeyPos key++pSpec             :: IsParser p Token => Char -> p String +pSpec c           =  [c] <$ pSpecPos c+      +pStringPos, pCharPos,+  pInteger8Pos, pInteger10Pos, pInteger16Pos, pFractionPos,+  pVaridPos, pConidPos,+  pTextnmPos, pTextlnPos, pIntegerPos, pVarsymPos, pConsymPos  :: IsParser p Token => p (String,Pos)++pStringPos     =   pValToken TkString    ""        +pCharPos       =   pValToken TkChar      "\NUL"    +pInteger8Pos   =   pValToken TkInteger8  "0"       +pInteger10Pos  =   pValToken TkInteger10 "0"       +pInteger16Pos  =   pValToken TkInteger16 "0"+pFractionPos   =   pValToken TkFraction  "0.0"+pVaridPos      =   pValToken TkVarid     "<identifier>" +pConidPos      =   pValToken TkConid     "<Identifier>" +pConsymPos     =   pValToken TkConOp 	 "<conoperator>"+pVarsymPos     =   pValToken TkOp        "<operator>" +pTextnmPos     =   pValToken TkTextnm    "<name>"       +pTextlnPos     =   pValToken TkTextln    "<line>"     +pIntegerPos    =   pInteger10Pos++pString, pChar,+  pInteger8, pInteger10, pInteger16, pFraction,+  pVarid, pConid,+  pTextnm, pTextln, pInteger, pVarsym, pConsym  :: IsParser p Token => p String++pString        = fst <$> pStringPos        +pChar          = fst <$> pCharPos          +pInteger8      = fst <$> pInteger8Pos      +pInteger10     = fst <$> pInteger10Pos     +pInteger16     = fst <$> pInteger16Pos     +pFraction      = fst <$> pFractionPos     +pVarid         = fst <$> pVaridPos         +pConid         = fst <$> pConidPos         +pVarsym        = fst <$> pVarsymPos  +pConsym        = fst <$> pConsymPos       +pTextnm        = fst <$> pTextnmPos       +pTextln        = fst <$> pTextlnPos            +pInteger       = fst <$> pIntegerPos       +  +pComma, pSemi, pOParen, pCParen, pOBrack, pCBrack, pOCurly, pCCurly+   :: IsParser p Token => p String++pComma  = pSpec ','+pSemi   = pSpec ';'+pOParen = pSpec '('+pCParen = pSpec ')'+pOBrack = pSpec '['+pCBrack = pSpec ']'+pOCurly = pSpec '{'+pCCurly = pSpec '}'++pCommaPos, pSemiPos, pOParenPos, pCParenPos, pOBrackPos, pCBrackPos, pOCurlyPos, pCCurlyPos+   :: IsParser p Token => p Pos++pCommaPos  = pSpecPos ','+pSemiPos   = pSpecPos ';'+pOParenPos = pSpecPos '('+pCParenPos = pSpecPos ')'+pOBrackPos = pSpecPos '['+pCBrackPos = pSpecPos ']'+pOCurlyPos = pSpecPos '{'+pCCurlyPos = pSpecPos '}'++pCommas ::  IsParser p Token => p a -> p [a]+pSemics ::  IsParser p Token => p a -> p [a]+pParens ::  IsParser p Token => p a -> p a+pBracks ::  IsParser p Token => p a -> p a+pCurly  ::  IsParser p Token => p a -> p a++pCommas  = pListSep pComma+pSemics  = pListSep pSemi+pParens  = pPacked pOParen pCParen+pBracks  = pPacked pOBrack pCBrack+pCurly   = pPacked pOCurly pCCurly++pParens_pCommas :: IsParser p Token => p a -> p [a]+pBracks_pCommas :: IsParser p Token => p a -> p [a]+pCurly_pSemics  :: IsParser p Token => p a -> p [a]++pParens_pCommas = pParens.pCommas+pBracks_pCommas = pBracks.pCommas+pCurly_pSemics  = pCurly .pSemics+
+ src/UU/Scanner/TokenShow.hs view
@@ -0,0 +1,35 @@+module UU.Scanner.TokenShow() where++import UU.Scanner.Token(Token,EnumValToken(..))+import UU.Scanner.Position(Pos(..))+import UU.Scanner.GenToken(GenToken(..))++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       +  TkOp         -> "operator"  +  TkConOp      -> "con operator"            +  TkString     -> "string"              +  TkChar       -> "character"            +  TkInteger8   -> "octal integer"         +  TkInteger10  -> "decimal Integer"       +  TkInteger16  -> "hexadecimal integer"   +  TkFraction   -> "fraction (float,...)"   +  TkVarid      -> "lower case identifier" +  TkConid      -> "upper case identifier" +  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+
+ src/UU/Util/BinaryTrees.hs view
@@ -0,0 +1,84 @@+{-  Copyright:  S. Doaitse Swierstra+               Department of Computer Science+               Utrecht University+               P.O. Box 80.089+               3508 TB UTRECHT+               the Netherlands+               swierstra@cs.uu.nl+-}+module UU.Util.BinaryTrees++( BinSearchTree(..)+, tab2tree+, btFind+, btLocateIn+, btLookup+)+where+-- =======================================================================================+-- ===== BINARY SEARCH TREES =============================================================+-- =======================================================================================++data BinSearchTree av+ = Node (BinSearchTree av) av (BinSearchTree av)+ | Nil++tab2tree :: [av] -> BinSearchTree av+tab2tree tab = tree+ where+  (tree,[]) = sl2bst (length tab) (tab)+  sl2bst 0 list     = (Nil   , list)+  sl2bst n list+   = let+      ll = (n - 1) `div` 2 ; rl = n - 1 - ll+      (lt,a:list1) = sl2bst ll list+      (rt,  list2) = sl2bst rl list1+     in (Node lt a rt, list2)++-- remember we compare the key value with the lookup value++btFind     :: (a -> b -> Ordering) -> BinSearchTree (a, c) -> b -> Maybe c+btFind     = btLookup fst snd++btLocateIn :: (a -> b -> Ordering) -> BinSearchTree a      -> b -> Maybe a+btLocateIn = btLookup id id++btLookup :: (a -> b) -> (a -> c) -> (b -> d -> Ordering) -> BinSearchTree a -> d -> Maybe c+btLookup  key val cmp (Node Nil  kv Nil)+  =  let comp = cmp (key kv)+         r    = val kv+     in \i -> case comp i of+              LT -> Nothing+              EQ -> Just r+              GT -> Nothing++btLookup key val cmp (Node left kv Nil)+  =  let comp = cmp (key kv)+         findleft = btLookup key val cmp left+         r    = val kv+     in \i -> case comp i of+              LT -> Nothing+              EQ -> Just r+              GT -> findleft i++btLookup key val cmp (Node Nil kv right )+  =  let comp      = cmp (key kv)+         findright = btLookup key val cmp right+         r         = val kv+         in \i -> case comp i of+                  LT -> findright i+                  EQ -> Just r+                  GT -> Nothing++btLookup key val cmp (Node left kv right)+  =  let comp = cmp (key kv)+         findleft  = btLookup key val cmp left+         findright = btLookup key val cmp right+         r    = val kv+     in \i -> case comp i of+              LT -> findright i+              EQ -> Just r+              GT -> findleft i++btLookup _ _ _ Nil   =  \i -> Nothing+
+ src/UU/Util/PermTree.hs view
@@ -0,0 +1,57 @@+module UU.Util.PermTree where ++import Monad(ap,liftM2)++------------------------------------------------------------------------------------+-- data type for permutation trees+------------------------------------------------------------------------------------++data Perms p a  = Choice (Maybe a) [Branch p a]+data Branch p a = forall x . Br  (p x) (Perms p  (x->a))   ++------------------------------------------------------------------------------------+-- definition of fmap on permutation trees+------------------------------------------------------------------------------------++instance Functor (Perms p) where+  fmap f (Choice e bs) = Choice (fmap f e) (map (fmap f) bs) ++instance Functor (Branch p) where+  fmap f (Br p ps) = Br p (fmap (f.) ps)++------------------------------------------------------------------------------------+-- add single parser to permutation tree+------------------------------------------------------------------------------------++{-+ap :: Maybe (a->b)-> Maybe a -> Maybe b+ap (Just f) (Just x) = Just (f x)+ap _        _        = Nothing+-}++add :: Maybe a -> p a -> Perms p (a->b) -> Perms p b+add da pa tab@(Choice dab bsab) = let empty = dab `ap` da+                                      insert (Br px txab) = Br px (add da pa (fmap flip txab))+                                  in Choice empty (Br pa tab:map insert bsab)   +                            +                      +------------------------------------------------------------------------------------+-- permutation construction combinators+------------------------------------------------------------------------------------+empty         :: a -> Perms p a+empty x       =  Choice (Just x) [] +++(<$$>)        :: (a->b) -> p a -> Perms p b+f <$$> p      =  empty f <||> p     ++(<$?>)        :: (a->b) -> (a, p a) -> Perms p b+f <$?> (e,p)  =  empty f <|?> (e,p) ++(<||>)        :: Perms p (a->b) -> p a -> Perms p b+ps <||> p     =  add Nothing p ps++(<|?>)        :: Perms p (a->b) -> (a, p a) -> Perms p b+ps <|?> (e,p) =  add (Just e) p ps ++
+ src/UU/Util/Utils.hs view
@@ -0,0 +1,19 @@+module UU.Util.Utils where++newtype Id x = Id x++cross :: (a->c) -> (b->d) -> (a,b) -> (c,d)+cross f g (x,y) = (f x, g y)++split :: (a->b) -> (a->c) -> a -> (b,c)+split f g x = (f x,g x)++fst3 :: (a,b,c) -> a+fst3 (a,_,_) = a++snd3 :: (a,b,c) -> b+snd3 (_,b,_) = b++thd3 :: (a,b,c) -> c+thd3 (_,_,c) = c+
+ uulib.cabal view
@@ -0,0 +1,31 @@+cabal-version: >=1.1+build-type: Simple+name: uulib+version: 0.9.5+license: LGPL+license-file: COPYRIGHT+maintainer: Arie Middelkoop <ariem@cs.uu.nl>+homepage: http://www.cs.uu.nl/wiki/HUT/WebHome+description: Fast Parser Combinators and Pretty Printing Combinators+synopsis: Haskell Utrecht Tools Library+category: Parsing+stability: Stable+copyright: Universiteit Utrecht+build-depends: base, haskell98+exposed-modules: UU.Parsing.CharParser UU.Parsing.Derived+                 UU.Parsing.Interface UU.Parsing.MachineInterface+                 UU.Parsing.Merge UU.Parsing.Offside UU.Parsing.Perms+                 UU.Parsing.StateParser UU.Parsing UU.DData.IntBag +                 UU.DData.Map UU.DData.MultiSet UU.DData.Queue+                 UU.DData.Scc UU.DData.Seq UU.DData.Set UU.PPrint+                 UU.Pretty.Ext UU.Pretty UU.Scanner.GenToken UU.Scanner.GenTokenOrd+                 UU.Scanner.GenTokenParser UU.Scanner.GenTokenSymbol+                 UU.Scanner.Position UU.Scanner.Scanner+                 UU.Scanner.Token UU.Scanner.TokenParser UU.Scanner.TokenShow+                 UU.Scanner UU.Util.BinaryTrees UU.Util.PermTree UU.Util.Utils+                 UU.Pretty.Basic UU.Parsing.Machine    +                 UU.DData.IntMap  +                 UU.DData.IntSet        +extensions:  RankNTypes FunctionalDependencies TypeSynonymInstances UndecidableInstances FlexibleInstances MultiParamTypeClasses FlexibleContexts CPP ExistentialQuantification+hs-source-dirs: src+extra-source-files: README, LICENSE-LGPL