Cardinality (empty) → 0.1
raw patch · 13 files changed
+2204/−0 lines, 13 filesdep +basedep +containersdep +mtlsetup-changed
Dependencies added: base, containers, mtl
Files
- COPYING +502/−0
- COPYRIGHT +18/−0
- Cardinality.cabal +98/−0
- Data/Cardinality.hs +537/−0
- Data/CardinalityRange.hs +721/−0
- Data/EmptySet.hs +17/−0
- Data/Intersectable.hs +21/−0
- Data/NeverEmptyList.hs +29/−0
- Setup.hs +4/−0
- doinst.sh +8/−0
- examples/CardinalityRangeCompareTest.hs +55/−0
- examples/ContainerTransformsTests.hs +48/−0
- examples/HelloWorld.hs +146/−0
+ COPYING view
@@ -0,0 +1,502 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 2.1, February 1999++ Copyright (C) 1991, 1999 Free Software Foundation, Inc.+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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!
+ COPYRIGHT view
@@ -0,0 +1,18 @@+Copyright (C) 2010 Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru>++ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA++Please see COPYING for the license.+
+ Cardinality.cabal view
@@ -0,0 +1,98 @@+Name: Cardinality+Synopsis: Measure container capacity. Use it to safely change container.+Description:+ This module introduces typeclasses+ .+ * @HasCard@ = \"Has cardinality\". In other words, \"it's possible to + measure current count of elements for this container\"+ .+ * @HasCardT@ = \"Has cardinality (for container types of kind + @(* -> *)@)\". In other words, \"it's possible to measure+ current count of elements for this container (for container types of+ kind @(* -> *)@)\"+ .+ * @HasCardConstr@ = \"Has cardinality constraint\". In other words, + \"there is a capacity constraint for this container\".+ .+ * @HasCardConstrT@ = \"Has cardinality constraint (for container types + of kind @(* -> *)@)\".+ In other words, \"there is a capacity constraint for this container type+ of kind @(* -> *)@\".+ .+ * @HasCardUCT@ = \"Has cardinality-unsafe container transform\".+ Define transform that may thow an error, if contents of @from@ don't + fit in @to@ .+ .+ * @HasCardUCT_T@ = \"Has cardinality-unsafe container + transform (for container types of kind @(* -> *)@)\".+ Same thing as @HasCardUCT@, but for containers of kind @(* -> *)@.+ .+ No, it's not about playing cards. It's about cardinalities. + Wikipedia: \"/In mathematics, the cardinality of a set is a measure of + the number of elements of the set. For example, the set A = {2, 4, 6}+ contains 3 elements, and therefore A has a cardinality of 3./\"+ In this package I dare to extend the definition a bit to + \"/C. is a measure of the number of elements in a container/\"+ .+ Usual containers are (together with their cardinality ranges): + .+ * @Identity a@ (1 element)+ .+ * @Maybe a@ (0..1 element)+ .+ * @[a]@ (0..inf elements)+ .+ * @Map k e@ (0..inf elements)+ . + I extended this to the folowing list:+ .+ * @EmptySet a@ (0 elements)+ .+ * @Identity a@ (1 element)+ .+ * @Maybe a@ (0..1 element)+ .+ * @[a]@ (0..inf elements)+ .+ * @NeverEmptyList a@ (1..inf elements)+ .+ * @Map k e@ (0..inf elements)+ .+ Typeclass @HasCardUCT@ together with function @sContTrans@ + (safe container transform) provides a facility to safely change + container from one to another keepeng the content. If content doesn't + fit to target container, @Nothing@ is returned. However, when + transforming from list @[a]@ to @(Maybe a)@ it won't check list length+ further first 2 elements. The complexity and power of this package is + that it provides a facility to /lazily/ evaluate amount of content in+ the container.+Version: 0.1+Copyright: Copyright (c) 2010 Andrejs Sisojevs+License: LGPL+License-File: COPYRIGHT+Author: Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru>+Maintainer: Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru>+Stability: experimental+Category: Data+Tested-With: GHC == 6.10.4+Cabal-Version: >= 1.6+Build-Type: Simple++Extra-Source-Files:+ COPYRIGHT+ COPYING+ doinst.sh+ examples/CardinalityRangeCompareTest.hs+ examples/ContainerTransformsTests.hs+ examples/HelloWorld.hs+Library+ Build-Depends:+ base >= 4 && < 5, containers, mtl+ Exposed-Modules:+ Data.Cardinality+ Data.CardinalityRange+ Data.EmptySet+ Data.Intersectable+ Data.NeverEmptyList+ Extensions:+ DeriveDataTypeable
+ Data/Cardinality.hs view
@@ -0,0 +1,537 @@+{- +Copyright (C) 2010 Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru> + +All rights reserved. + +For license and copyright information, see the file COPYRIGHT + +-} + +-------------------------------------------------------------------------- +-------------------------------------------------------------------------- + +{-# LANGUAGE BangPatterns, FlexibleInstances #-} + +-- | Two main assumptions (and constraints) of this module: +-- +-- (1) Cardinality can't be negative. +-- +-- (2) For @'refinableC'@ construction it is always refined by growing. F.e., +-- if @'refinableC' (7, ref_f_1)@ refines to @'refinableC' (x, ref_f_2)@, then +-- @x@ SHOULD NEVER be less then @7@. +-- On this assumption relies heavily functions @'lazyIsZeroLC'@, +-- @'lazyCompare2LCs'@, @'addLCToLC'@ and also almost every refinement routine. +module Data.Cardinality ( + -- * Core + PreciseCardinality + , CurrentNotFinalPreciseCardinality + , BoundaryPreciseCardinality + , ContinueCounting_DoWe + , ContinueRefiningCardinalityUntil + , CardinalityRefinementState + , LazyCardinality + , infiniteC + , preciseC + , refinableC + , lazyIsZeroLC + , refinementState + , addPCToLC + , addLCToLC + , sumLCs + , refineCRS_Till + , refineCRS_TillOneAbove + , refineCRS_TillOneBelow + , crsRefinementStep + , refineCRS_TillEnd + , refineTill + , refineTillOneAbove + , refineTillOneBelow + , refinementStep + , refineTillEnd + , equalize2Refinements + , compare2Refinements + , almostStrictCompare2LCs + , lazyCompare2LCs + , showLazy + , showStrict + + -- * Application + , HasCard(..) + , HasCardT(..) + + -- * Instances + -- ** Cardinality = 0 + , cardOf_Unity + , cardOf_EmptySet + -- ** Cardinality = 1 + -- , cardOf_Identity0 + , cardOf_Identity1 + -- ** Cardinality = 0..1 + , cardOf_Maybe + -- ** Cardinality = 0..Inf + , cardOf_List + , cardOf_Map + -- ** Cardinality = 1..Inf + , cardOf_NeverEmptyList + + -- * Helpers + , length2 + ) where + +import Data.EmptySet +import Data.NeverEmptyList +import qualified Data.Map as M +import Data.Map (Map, (!)) +import Data.Word +import Data.Typeable +import Control.Monad.Identity + +-------------------------------------------------------------- +-- * Core + +-- | Count of elements in container. It's always positive or zero. +-- +-- It would be best here to use @'Word32'@ instead, however, with @Integer@ +-- it's easier to catch the error of going down below zero (in case +-- of @'Word32' 0-1==4294967295@ ). +-- +-- However it is decided not to allow the direct use of @'PreciseC'@ data +-- constructor, but to wrap it into function @'preciseC'@, which guards from +-- the attemts to conctruct negative cardinality (by throwing an error). +type PreciseCardinality = Integer +type CurrentNotFinalPreciseCardinality = PreciseCardinality +type BoundaryPreciseCardinality = CurrentNotFinalPreciseCardinality +type ContinueCounting_DoWe = Bool +-- | An example of this is @'length2'@ function. +type ContinueRefiningCardinalityUntil = CurrentNotFinalPreciseCardinality -> (CurrentNotFinalPreciseCardinality -> ContinueCounting_DoWe) -> LazyCardinality +type CardinalityRefinementState = (CurrentNotFinalPreciseCardinality, ContinueRefiningCardinalityUntil) + +-- | In other words: count of elements in a container, +-- with an opportunity not to refine the whole content of the container +-- (and the container's structure). +-- +-- Constructors: +-- +-- * @'infiniteC'@ +-- +-- * @'preciseC' 'PreciseCardinality'@ +-- +-- * @'refinableC' 'CardinalityRefinementState'@ +data LazyCardinality = + InfiniteC + | PreciseC PreciseCardinality + | RefinableC CardinalityRefinementState + deriving (Typeable) + +-- | @'LazyCardinality'@ constructor. +-- +-- F.e., @[1..]@ list has such cardinality. +infiniteC :: LazyCardinality +infiniteC = InfiniteC + +-- | @'LazyCardinality'@ constructor. If given negative value, raises error. +-- +-- F.e., the tuple @(5,6)@ has a precise cardinality 2. +preciseC :: PreciseCardinality -> LazyCardinality +preciseC c = case c < 0 of { True -> error ("Can't construct negative cardinality '" ++ show c ++ "' "); False -> PreciseC c } + +-- | @'LazyCardinality'@ constructor. +-- +-- For lists it happens, that we do not want to count all the elements +-- of a container, +-- but want to count them until some lower boundary. For example, +-- I do not want to know the length of the list (which involves taking +-- each element of it, and counting it in) to reason about whether +-- it's content fit into the @(,,)@ data constructor. For this +-- case I only need to count till 3rd element and check, if list is +-- continued. It's actual especially, when dealing with infinite lists +-- or with lists, whose reading may block. +-- +-- For @(refinableC (x0, refine_f))@ important rules: +-- +-- 1. If @(refine_f x0 (<= 5))@ evaluates to another @refinableC@, then +-- it is not fully refined, but (at least) @5@ is achieved (the precise +-- cardinality is @>= 5@). +-- +-- 2. If @x0@ is @10@ and @(refine_f 10 (<= 15))@ returned +-- @(refinableC (17, refine_f_2))@, then it is known, that precise +-- cardinality is already >= @10 + 7@. In sight of @refine_f@ there +-- SHOULD be everything except for what's already counted in @x0@ +-- (which is @10@), and in sight of @refine_f_2@ there should be even +-- less by @7@ elements comparing to @refine_f@. So if total cardinality was +-- @25@, then @(refine_f_2 17 (<= 30))@ MUST return @preciseC 25@, to make +-- @10 + 7 + 8 = 25@. +-- +-- 3. The theatment of the first argument of refinement function @refine_f@ +-- must be relative. For example, given total count of elements @= 25@ , +-- and @x0 = 20@ - these 20 elements are already counted, and in sight of +-- @refine_f@ there are only 5 last elements. +-- Then @refine_f 20 (<= 26)@ will result in @preciseC 25@, but(!) +-- @refine_f 10 (<= 16)@ MUST result in @preciseC 15@. +-- +-- Recomendations: +-- +-- 1. If subject has infinite cardinality, it's best to determine +-- it's cardinality as @'infiniteC'@ at early stages and +-- avoid using @refinableC@ for it. +refinableC :: CardinalityRefinementState -> LazyCardinality +refinableC = RefinableC + +lcIsInfinite :: LazyCardinality -> Bool +lcIsInfinite InfiniteC = True +lcIsInfinite _ = False + +preciseOfLC :: LazyCardinality -> Maybe PreciseCardinality +preciseOfLC (PreciseC c) = Just c +preciseOfLC _ = Nothing + +-- | Returns @Nothing@, ONLY if LC is @'refinableC' (0, _)@ +-- (according to 2nd assumption of the module). Returns @Just True@ +-- only for @'preciseC' 0@. +lazyIsZeroLC :: LazyCardinality -> Maybe Bool +lazyIsZeroLC (PreciseC c) = Just (c == 0) +lazyIsZeroLC InfiniteC = Just False +lazyIsZeroLC (RefinableC (c, _)) = case c `compare` 0 of { EQ -> Nothing; _ -> Just False } + +refinementState :: LazyCardinality -> Maybe CardinalityRefinementState +refinementState (RefinableC rs) = Just rs +refinementState _ = Nothing + +infixr 6 `addPCToLC` +-- Throws an error if @'preciseC'@ is attempted to construct with negative +-- resulting cardinality. +addPCToLC :: PreciseCardinality -> LazyCardinality -> LazyCardinality +addPCToLC n lc = + case lc of + InfiniteC -> lc + PreciseC m -> preciseC (m + n) + RefinableC (c, ref_while) -> refinableC (c + n, ref_while) + +infixr 6 `addLCToLC` +-- | For case when adding up 2 refinables, if both of them sooner or later +-- refines to @'infiniteC'@, then one that returns infinity earlier is +-- recommended to put as a first term. Infinity + any LazyCardinality +-- = infinity. Another recommendation would be to put +-- refinable that's easier to compute as a first term. +addLCToLC :: LazyCardinality -> LazyCardinality -> LazyCardinality +addLCToLC lc_1 lc_2 = + case (lc_1, lc_2) of + (InfiniteC, _) -> InfiniteC + (_, InfiniteC) -> InfiniteC + (PreciseC m, PreciseC n) -> preciseC (m + n) + (PreciseC m, RefinableC (c, ref_while)) -> refinableC (c + m, ref_while) + (RefinableC (c, ref_while), PreciseC m) -> refinableC (c + m, ref_while) + (RefinableC (c, ref_while_1), RefinableC (d, ref_while_2)) -> refinableC (c + d, refWhileSyn ref_while_1 ref_while_2) + where + refWhileSyn :: ContinueRefiningCardinalityUntil -> ContinueRefiningCardinalityUntil -> ContinueRefiningCardinalityUntil + refWhileSyn ref_while_1 ref_while_2 = + (\ sofar stop_cond -> + case ref_while_1 sofar stop_cond of + InfiniteC -> InfiniteC + RefinableC (sofar_2, ref_while_1_2) -> RefinableC (sofar_2, refWhileSyn ref_while_1_2 ref_while_2) + PreciseC c -> + case ref_while_1 (sofar + c) stop_cond of + InfiniteC -> InfiniteC + RefinableC (sofar_3, ref_while_2_2) -> RefinableC (sofar_3, ref_while_2_2) + PreciseC final_c -> PreciseC final_c + ) + +-- | @foldl 'addLCToLC'@ +-- +-- See recommendations by @'addLCToLC'@. +sumLCs :: [LazyCardinality] -> LazyCardinality +sumLCs = foldl addLCToLC (preciseC 0) + +refineCRS_Till :: CardinalityRefinementState -> BoundaryPreciseCardinality -> LazyCardinality +refineCRS_Till crs@(c, ref_while) n = + case c >= n of + True -> refinableC crs + False -> ref_while c (<= n) +-- [1,2,3,4,5,6,7,8,9,10] +-- refineCRS_Till (refinableC (5, ref_while)) 8 +-- ref_while sees [6,7,8,9,10] +-- ref_while (<= 8 - 5) -> ref_while (<= 3) -> refinableC (8, ref_while')) +-- ref_while' sees [9, 10] + +refineCRS_TillOneAbove :: CardinalityRefinementState -> BoundaryPreciseCardinality -> LazyCardinality +refineCRS_TillOneBelow :: CardinalityRefinementState -> BoundaryPreciseCardinality -> LazyCardinality +refineCRS_TillOneAbove crs n = refineCRS_Till crs (n + 1) +refineCRS_TillOneBelow crs n = refineCRS_Till crs (n - 1) + +crsRefinementStep :: CardinalityRefinementState -> LazyCardinality +crsRefinementStep crs@(c, ref_while) = ref_while c (<= (c + 1)) + +-- | Don't use it on infinite refinables not measured with 'infiniteC'. +refineCRS_TillEnd :: CardinalityRefinementState -> LazyCardinality +refineCRS_TillEnd crs@(c, ref_while) = ref_while c (const True) + +-- | Wrapper around @'refineCRS_Till'@. +refineTill :: LazyCardinality -> BoundaryPreciseCardinality -> LazyCardinality +refineTill lc n = + case lc of + RefinableC crs -> refineCRS_Till crs n + _ -> lc + +-- | Wrapper around @'refineTillOneAbove'@. +refineTillOneAbove :: LazyCardinality -> BoundaryPreciseCardinality -> LazyCardinality +-- | Wrapper around @'refineTillOneBelow'@. +refineTillOneBelow :: LazyCardinality -> BoundaryPreciseCardinality -> LazyCardinality +refineTillOneAbove lc n = case lc of { RefinableC crs -> refineCRS_Till crs (n + 1); _ -> lc } +refineTillOneBelow lc n = case lc of { RefinableC crs -> refineCRS_Till crs (n - 1); _ -> lc } + +-- | Wrapper around @'crsRefinementStep'@. +refinementStep :: LazyCardinality -> LazyCardinality +refinementStep lc = case lc of { RefinableC crs -> crsRefinementStep crs ; _ -> lc } + +-- | Wrapper around @'refineCRS_TillEnd'@. +refineTillEnd :: LazyCardinality -> LazyCardinality +refineTillEnd lc = case lc of { RefinableC crs -> refineCRS_TillEnd crs ; _ -> lc } + +-- | For @equalize2Refinements (m, ref_f_1) (n, ref_f_2)@ finishes when m == n. +-- Else refines them. Another termination condition is when in result of +-- refinement one of cardinalities becomes final (not @'refinableC'@). +equalize2Refinements :: CardinalityRefinementState -> CardinalityRefinementState -> (LazyCardinality, LazyCardinality) +equalize2Refinements crs1@(m, ref_f_1) crs2@(n, ref_f_2) = + case m `compare` n of + LT -> let lc_of_crs1_refined = ref_f_1 m (<= n) + in case refinementState lc_of_crs1_refined of + Nothing -> (lc_of_crs1_refined, refinableC crs2) + Just crs1_refined -> equalize2Refinements crs1_refined crs2 + EQ -> (refinableC crs1, refinableC crs2) + GT -> let lc_of_crs2_refined = ref_f_2 n (<= m) + in case refinementState lc_of_crs2_refined of + Nothing -> (refinableC crs1, lc_of_crs2_refined) + Just crs2_refined -> equalize2Refinements crs1 crs2_refined + +compare2Refinements :: CardinalityRefinementState -> CardinalityRefinementState -> (Ordering, LazyCardinality, LazyCardinality) +compare2Refinements crs1@(m, _) crs2@(n, _) = + let cards = equalize2Refinements crs1 crs2 + in case cards of + (lc1_2@(RefinableC crs1_2), lc2_2@(RefinableC crs2_2)) -> -- m == n + let lc1_3 = crsRefinementStep crs1_2 + in case lc1_3 of -- I could have made crsRefinementStep for both in tuple here, but let's keep it as lazy as possible + RefinableC crs1_3 -> + let lc2_3 = crsRefinementStep crs2_2 + in case lc2_3 of + RefinableC crs2_3 -> compare2Refinements crs1_3 crs2_3 + _ -> almostStrictCompare2LCs lc1_3 lc2_3 + _ -> almostStrictCompare2LCs lc1_3 lc2_2 + _ -> uncurry almostStrictCompare2LCs cards + +infixr 9 `almostStrictCompare2LCs` +-- | Used for instance of Ord typeclass. +-- +-- Together with @'Ordering'@ returns also probably refined cardinalities +-- for reuse. +-- +-- WARNING!!! When comparing @'refinableC'@ with @'infiniteC'@ +-- , it results in @'LT'@ (less than)! +-- While comparing @'infiniteC' \`almostStrictCompare2LCs\` 'infiniteC' == +-- 'EQ'@. +-- That's the reason for an /almost-/ prefix in function name. +-- If there is a probability that refinement of +-- @'refinableC'@ may evaluate to @'infiniteC'@, and it's important to you, +-- that infinities are equal, then before comparing this refinable, +-- use 'refineCRS_TillEnd' on it. That's laziness. +-- +-- Trying to compare 2 @'refinableC'@s that are actually infinite, but don't +-- use @'infiniteC'@ will hang +-- the system (the same as if you try to determine length of an infinite +-- list). +almostStrictCompare2LCs :: LazyCardinality -> LazyCardinality -> (Ordering, LazyCardinality, LazyCardinality) +almostStrictCompare2LCs a b = + let reverseOrdering :: (Ordering, LazyCardinality, LazyCardinality) -> (Ordering, LazyCardinality, LazyCardinality) + reverseOrdering (GT, a, b) = (LT, b, a) + reverseOrdering (LT, a, b) = (GT, b, a) + reverseOrdering (EQ, a, b) = (EQ, b, a) + in case (a,b) of + (InfiniteC , InfiniteC) -> (EQ, a, b) + (InfiniteC , _ ) -> (GT, a, b) + (_ , InfiniteC) -> (LT, a, b) -- !!! even though 'refinableC' may return 'infiniteC' !!! + (PreciseC m, PreciseC n) -> (m `compare` n, a, b) + ---------------------------- + (RefinableC crs@(m, _), PreciseC n) -> case m > n of { True -> (GT, a, b); False -> almostStrictCompare2LCs (refineCRS_TillOneAbove crs n) b } + (RefinableC crs1, RefinableC crs2) -> compare2Refinements crs1 crs2 + (_ , RefinableC _) -> reverseOrdering $ almostStrictCompare2LCs b a + +instance Eq LazyCardinality where + lc1 == lc2 = (fst3 $ almostStrictCompare2LCs lc1 lc2) == EQ + +instance Ord LazyCardinality where + lc1 `compare` lc2 = fst3 $ almostStrictCompare2LCs lc1 lc2 + +infixr 9 `lazyCompare2LCs` +-- | Won't refine refinables. According to 2nd assumption of the module: +-- +-- @'refinableC' (m, _) \`lazyCompare2LCs\` 'preciseC' n@ +-- +-- equals to @Just GT@ if @m > n@ , and @Nothing@ otherwise. +lazyCompare2LCs :: LazyCardinality -> LazyCardinality -> Maybe Ordering +lazyCompare2LCs a b = + let reverseOrdering :: Maybe Ordering -> Maybe Ordering + reverseOrdering (Just GT) = (Just LT) + reverseOrdering (Just LT) = (Just GT) + reverseOrdering (Just EQ) = (Just EQ) + reverseOrdering Nothing = Nothing + in case (a,b) of + (InfiniteC , InfiniteC) -> Just EQ + (InfiniteC , _ ) -> Just GT + (_ , InfiniteC) -> Just LT -- !!! even though 'refinableC' may return 'infiniteC' !!! + (PreciseC m, PreciseC n) -> Just (m `compare` n) + ---------------------------- + (RefinableC crs@(m, _), PreciseC n) -> case m > n of { True -> Just GT; False -> Nothing } + (PreciseC n, RefinableC crs@(m, _)) -> case m > n of { True -> Just LT; False -> Nothing } + _ -> Nothing + +-- | Used for Show typeclass instaniation. Here @'refinableC'@ isn't refined. +showLazy :: LazyCardinality -> String +showLazy lc = + case lc of + InfiniteC -> "infiniteC" + PreciseC c -> "preciseC " ++ show c + RefinableC (c, _) -> "Refinable (" ++ show c ++ ", refine_f)" + +-- | Here @ 'refineCRS_TillEnd'@ is applied to @'refinableC'@ argument. +showStrict :: LazyCardinality -> String +showStrict lc = + case lc of + InfiniteC -> "infiniteC" + PreciseC c -> "preciseC " ++ show c + RefinableC crs -> show $ refineCRS_TillEnd crs + +instance Show LazyCardinality where + show = showLazy + +-------------------------------------------------------------- +-- * Application + +-- | @HasCard@ = \"Has cardinality\". In other words, \"it's possible to measure +-- current count of elements for this container\" +class HasCard a where + cardOf :: a -> LazyCardinality + +-- | @HasCardT@ = \"Has cardinality (for container types of kind @(* -> *)@)\". +-- In other words, \"it's possible to measure +-- current count of elements for this container (for container types of +-- kind @(* -> *)@)\" +class HasCardT t where + cardOfT :: t elem -> LazyCardinality + +-------------------------------------------------------------- +-------------------------------------------------------------- +-- * Instances + +-- ** Cardinality = 0 + +cardOf_Unity :: () -> LazyCardinality +cardOf_Unity _ = preciseC 0 +instance HasCard () where + cardOf = cardOf_Unity + +cardOf_EmptySet :: EmptySet a -> LazyCardinality +cardOf_EmptySet _ = preciseC 0 +instance HasCard (EmptySet a) where + cardOf = cardOf_EmptySet +instance HasCardT EmptySet where + cardOfT = cardOf_EmptySet + +-- ** Cardinality = 1 +{- +cardOf_Identity0 :: a -> LazyCardinality +cardOf_Identity0 _ = preciseC 1 +instance HasCard a where + cardOf = cardOf_Identity0 +-} +cardOf_Identity1 :: Identity a -> LazyCardinality +cardOf_Identity1 _ = preciseC 1 +instance HasCard (Identity a) where + cardOf = cardOf_Identity1 +instance HasCardT Identity where + cardOfT = cardOf_Identity1 + +-- ** Cardinality = 0..1 +cardOf_Maybe :: Maybe a -> LazyCardinality +cardOf_Maybe Nothing = preciseC 0 +cardOf_Maybe (Just _) = preciseC 1 +instance HasCard (Maybe a) where + cardOf = cardOf_Maybe +instance HasCardT Maybe where + cardOfT = cardOf_Maybe + +-- ** Cardinality = 0..N + +-- | Refinable starting from 0, uses @'length2'@ +cardOf_List :: [a] -> LazyCardinality +cardOf_List l = refinableC (0, \ sofar refine_while -> length2 l sofar refine_while) +instance HasCard [a] where + cardOf = cardOf_List +instance HasCardT ([]) where + cardOfT = cardOf_List + +-- | Not refinable, since @'Data.Map.Map'@ is a strict structure. +cardOf_Map :: Map k e -> LazyCardinality +cardOf_Map = preciseC . fromIntegral . M.size +instance HasCard (Map k e) where + cardOf = cardOf_Map +instance HasCardT (Map k) where + cardOfT = cardOf_Map + +-- ** Cardinality = 1..N + +-- | Refinable starting from 1. +cardOf_NeverEmptyList :: NeverEmptyList k -> LazyCardinality +cardOf_NeverEmptyList (NEL _ l) = 1 `addPCToLC` cardOf l +instance HasCard (NeverEmptyList a) where + cardOf = cardOf_NeverEmptyList +instance HasCardT NeverEmptyList where + cardOfT = cardOf_NeverEmptyList + +-- Other instances + +instance HasCardT ((,) key) where { cardOfT _ = preciseC 1 } -- this messes up things, in the context of HasCard (a,a) instance... + +instance HasCard (a,a) where { cardOf _ = preciseC 2 } +instance HasCard (a,a,a) where { cardOf _ = preciseC 3 } +instance HasCard (a,a,a,a) where { cardOf _ = preciseC 4 } +instance HasCard (a,a,a,a,a) where { cardOf _ = preciseC 5 } +instance HasCard (a,a,a,a,a,a) where { cardOf _ = preciseC 6 } +instance HasCard (a,a,a,a,a,a,a) where { cardOf _ = preciseC 7 } +instance HasCard (a,a,a,a,a,a,a,a) where { cardOf _ = preciseC 8 } +instance HasCard (a,a,a,a,a,a,a,a,a) where { cardOf _ = preciseC 9 } +instance HasCard (a,a,a,a,a,a,a,a,a,a) where { cardOf _ = preciseC 10 } +instance HasCard (a,a,a,a,a,a,a,a,a,a,a) where { cardOf _ = preciseC 11 } +instance HasCard (a,a,a,a,a,a,a,a,a,a,a,a) where { cardOf _ = preciseC 12 } + +-------------------------------------------------------------- +-- * Helpers + +-- type ContinueRefiningCardinalityUntil = +-- CurrentNotFinalPreciseCardinality +-- -> (CurrentNotFinalPreciseCardinality -> ContinueCounting_DoWe) +-- -> LazyCardinality + + +-- | List length of controlable greediness. +length2 :: [a] -> ContinueRefiningCardinalityUntil +length2 l !sofar p = + case _length2 l sofar of + (i, Nothing) -> preciseC i + (i, Just new_ref_while) -> RefinableC (i, new_ref_while) + where + _length2 :: [a] -> CurrentNotFinalPreciseCardinality + -> ( BoundaryPreciseCardinality + , Maybe ContinueRefiningCardinalityUntil + ) + _length2 [] !_sofar = (_sofar, Nothing) + _length2 l@(_:t) !_sofar = + let next_sofar = _sofar + 1 + in case p next_sofar of + False -> (_sofar, Just (length2 l)) + True -> _length2 t next_sofar + +fst3 :: (a,b,c) -> a +snd3 :: (a,b,c) -> b +thrd3 :: (a,b,c) -> c +fst3 (a,_,_) = a +snd3 (_,b,_) = b +thrd3 (_,_,c) = c
+ Data/CardinalityRange.hs view
@@ -0,0 +1,721 @@+{- +Copyright (C) 2010 Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru> + +All rights reserved. + +For license and copyright information, see the file COPYRIGHT + +-} + +-------------------------------------------------------------------------- +-------------------------------------------------------------------------- + +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +module Data.CardinalityRange ( + -- * Core + CardinalityRange_From + , CardinalityRange_To + , CardinalityRange + , cardinalityRange + , cr2Tuple + , lazyVerfyCR + , cFitsInCR_Proto + , cFitsInCR + , fitsInCR + , fitsInCR_T + , FirstOrSecond(..) + , Compare2CRsError(..) + , compare2CRs + , crFitsInCR + + -- * Popular cardinality ranges constructors + , crNoConstraint + , cr0 + , cr1 + , cr0_1 + , cr0_Inf + , cr1_Inf + , crX + , crXY + + -- * Application 1 + , CardinalityConstraint + , cFitsInCC + , fitsInCC + , fitsInCC_T + , HasCardConstr(..) + , HasCardConstrT(..) + , cFitsIn + , cFitsInT + , fitsIn + , fitsInT + + -- * Application 2 + , HasCardUCT(..) + , HasCardUCT_T(..) + , TransformError_FromTypeName + , TransformError_ToTypeName + , TransformError_Details + , uContError + , uContErrorT + , sContTrans + , sContTransT + ) where + +import Data.Cardinality +import Data.EmptySet +import Data.Intersectable +import Data.NeverEmptyList +import qualified Data.Map as M +import Data.Map (Map, (!)) +import Data.Word +import Data.Typeable +-- import Debug.Trace +import Control.Monad.Identity + +-------------------------------------------------------------- +-- * Core + +type CardinalityRange_From = LazyCardinality +type CardinalityRange_To = LazyCardinality +-- | Constructor: @'cardinalityRange' 'CardinalityRange_From' 'CardinalityRange_To'@ +data CardinalityRange = CardinalityRange CardinalityRange_From CardinalityRange_To deriving (Show) + +-- | @CardinalityRange@ data constructor. The range is always including it's +-- boundaries. F.e., range +-- @'CardinalityRange' ('preciseC' 1) ('preciseC' 4)@ contains +-- cardinalities [1,2,3,4]. +-- First cardinality MUST always be less or equal to second one. However, +-- we do not fully guard from such type of error - we do not refine +-- @'refinableC'@, if it participates in the constriction. +cardinalityRange :: CardinalityRange_From -> CardinalityRange_To -> CardinalityRange +cardinalityRange from to = + case lazyVerfyCR from to of + Just False -> error $ "Cardinality range can't be constructed with lower boundary higher than lower one (" ++ show from ++ ", "++ show to ++ ")." + _ -> CardinalityRange from to + +cr2Tuple :: CardinalityRange -> (CardinalityRange_From, CardinalityRange_From) +cr2Tuple (CardinalityRange from to) = (from, to) + +lazyVerfyCR :: CardinalityRange_From -> CardinalityRange_To -> Maybe Bool +lazyVerfyCR from to = lazyCompare2LCs from to >>= return . (/= GT) + +-- | Root prototype for all subsequent \"FitsIn\" functions. Returns probably +-- refined cardinality and range, which is useful for reuse. +-- If returns @EQ@ then subject cardinality +-- is between boundaries (including) of cardinality range. +cFitsInCR_Proto :: LazyCardinality -> CardinalityRange -> (Ordering, LazyCardinality, CardinalityRange) +cFitsInCR_Proto c (CardinalityRange lo_c hi_c) = + let (ord1, c_2, lo_c_2) = c `almostStrictCompare2LCs` lo_c + in case ord1 of + LT -> (ord1, c_2, cardinalityRange lo_c_2 hi_c) + _ -> let (ord2, c_3, hi_c_2) = c_2 `almostStrictCompare2LCs` hi_c + ord3 = case ord2 of { GT -> GT; _ -> EQ } + in (ord3, c_3, cardinalityRange lo_c_2 hi_c_2) +infixr 9 `cFitsInCR_Proto` + +-- | @'LazyCardinality'@ fits in @'CardinalityRange'@? +cFitsInCR :: LazyCardinality -> CardinalityRange -> Bool +cFitsInCR c cr = fst3 (c `cFitsInCR_Proto` cr) == EQ + where fst3 (a,_,_) = a +infixr 9 `cFitsInCR` + +-- | Wrapper around @'cFitsInCR'@. +fitsInCR :: HasCard a => a -> CardinalityRange -> Bool +fitsInCR hasC cr = cardOf hasC `cFitsInCR` cr +infixr 9 `fitsInCR` + +-- | Wrapper around @'cFitsInCR'@. +fitsInCR_T :: HasCardT c => c a -> CardinalityRange -> Bool +fitsInCR_T hasC cr = cardOfT hasC `cFitsInCR` cr +infixr 9 `fitsInCR_T` + +-- | Used in @'Compare2CRsError'@ +data FirstOrSecond = First | Second deriving (Show) +-- | Error, that may occur, when performing @'compare2CRs'@ +data Compare2CRsError = LowerBoundaryAfterHigher FirstOrSecond CardinalityRange +instance Show Compare2CRsError where + show e = "An error occurred when trying to compare 2 cardinality ranges: " ++ + case e of + LowerBoundaryAfterHigher fs cr -> show fs ++ " cardinality range (" ++ show cr ++ ") is ill defined - lower boundary is greater then higher one." + +-- | This function is made hard, but fast. It tends to make minimal amount +-- of comparisons, reusing refinements. +compare2CRs :: CardinalityRange -> CardinalityRange -> (Either Compare2CRsError (SetsFit CardinalityRange), CardinalityRange, CardinalityRange) +compare2CRs (CardinalityRange lo_cr1_0 hi_cr1_0) (CardinalityRange lo_cr2_0 hi_cr2_0) = + let step1@(order1, hi_cr1_1, lo_cr2_1) = almostStrictCompare2LCs hi_cr1_0 lo_cr2_0 -- 1: 0 1 1 0 + in case order1 of -- traceShow ("Step 1: ", step1) + LT -> (Right NoIntersection, CardinalityRange lo_cr1_0 hi_cr1_1, CardinalityRange lo_cr2_1 hi_cr2_0) + EQ -> let step2@(order2, lo_cr1_1, hi_cr1_2) = almostStrictCompare2LCs lo_cr1_0 hi_cr1_1 -- 2: 1 2 1 0 + cr1_2 = CardinalityRange lo_cr1_1 hi_cr1_2 + cr2_2 = CardinalityRange lo_cr2_1 hi_cr2_0 + answ_2 err_or_fit = (err_or_fit, cr1_2, cr2_2) + in case order2 of -- traceShow ("Step 2: ", step2) + LT -> let step21@(order21, lo_cr2_2, hi_cr2_1) = almostStrictCompare2LCs lo_cr2_1 hi_cr2_0 -- 21: 1 2 2 1 + cr1_21 = CardinalityRange lo_cr1_1 hi_cr1_2 + cr2_21 = CardinalityRange lo_cr2_2 hi_cr2_1 + answ_21 err_or_fit = (err_or_fit, cr1_21, cr2_21) + in answ_21 $ case order21 of + EQ -> Right SecondInFirst + GT -> Right $ Intersection $ CardinalityRange hi_cr1_2 lo_cr2_2 + LT -> Left $ LowerBoundaryAfterHigher Second cr2_21 + GT -> answ_2 $ Left $ LowerBoundaryAfterHigher First cr1_2 + EQ -> let step3@(order3, lo_cr2_2, hi_cr2_1) = almostStrictCompare2LCs lo_cr2_1 hi_cr2_0 -- 3: 1 2 2 1 + cr1_3 = CardinalityRange lo_cr1_1 hi_cr1_2 + cr2_3 = CardinalityRange lo_cr2_2 hi_cr2_1 + answ_3 err_or_fit = (err_or_fit, cr1_3, cr2_3) + in answ_3 $ case order3 of -- traceShow ("Step 3: ", step3) + LT -> Right FirstInSecond + EQ -> Right EqualSets + GT -> Left $ LowerBoundaryAfterHigher First cr1_3 + GT -> let step4@(order4, lo_cr1_1, hi_cr2_1) = almostStrictCompare2LCs lo_cr1_0 hi_cr2_0 -- 4: 1 1 1 1 + in case order4 of + GT -> (Right NoIntersection, CardinalityRange lo_cr1_1 hi_cr1_1, CardinalityRange lo_cr2_1 hi_cr2_1) + EQ -> let step5@(order5, lo_cr2_2, hi_cr2_2) = almostStrictCompare2LCs lo_cr2_1 hi_cr2_1 -- 5: 1 1 2 2 + cr1_5 = CardinalityRange lo_cr1_1 hi_cr1_1 + cr2_5 = CardinalityRange lo_cr2_2 hi_cr2_2 + answ_5 err_or_fit = (err_or_fit, cr1_5, cr2_5) + in case order5 of + LT -> let step51@(order51, lo_cr1_2, hi_cr1_2) = almostStrictCompare2LCs lo_cr1_1 hi_cr1_1 -- 51: 2 2 2 2 + cr1_51 = CardinalityRange lo_cr1_2 hi_cr1_2 + cr2_51 = CardinalityRange lo_cr2_2 hi_cr2_2 + answ_51 err_or_fit = (err_or_fit, cr1_51, cr2_51) + in answ_51 $ case order51 of + LT -> Left $ LowerBoundaryAfterHigher First cr1_51 + EQ -> Right FirstInSecond + GT -> Right $ Intersection $ CardinalityRange lo_cr1_2 hi_cr2_2 + EQ -> answ_5 $ Right SecondInFirst + GT -> answ_5 $ Left $ LowerBoundaryAfterHigher Second cr2_5 + LT -> let step6@(order6, lo_cr1_2, lo_cr2_2) = almostStrictCompare2LCs lo_cr1_1 lo_cr2_1 -- 6: 2 1 2 1 + step7@(order7, hi_cr1_2, hi_cr2_2) = almostStrictCompare2LCs hi_cr1_1 hi_cr2_1 -- 7: 2 2 2 2 + cr1_67 = CardinalityRange lo_cr1_2 hi_cr1_2 + cr2_67 = CardinalityRange lo_cr2_2 hi_cr2_2 + answ_67 _fit = (Right _fit, cr1_67, cr2_67) + in answ_67 $ case (order6, order7) of + (EQ, EQ) -> EqualSets + (EQ, GT) -> SecondInFirst + (LT, EQ) -> SecondInFirst + (LT, GT) -> SecondInFirst + (EQ, LT) -> FirstInSecond + (GT, LT) -> FirstInSecond + (GT, EQ) -> FirstInSecond + (LT, LT) -> Intersection $ CardinalityRange lo_cr2_2 hi_cr1_2 + (GT, GT) -> Intersection $ CardinalityRange lo_cr1_2 hi_cr2_2 + +instance Intersectable CardinalityRange where + setFits cr1 cr2 = case fst3 $ compare2CRs cr1 cr2 of { Right r -> r; Left e -> error $ show e } + where + fst3 :: (a,b,c) -> a + fst3 (a,_,_) = a + +-- | Wrapper around @'setFits'@ of typeclass @'Intersectable'@ +crFitsInCR :: CardinalityRange -> CardinalityRange -> SetsFit CardinalityRange +crFitsInCR = setFits +infixr 9 `crFitsInCR` + +-- * Popular cardinality ranges constructors. + +-- | Same as @'cr0_Inf'@. +crNoConstraint :: CardinalityRange +-- | Only zero elements. +cr0 :: CardinalityRange +-- | Only one element. +cr1 :: CardinalityRange +-- | Zero or one element. +cr0_1 :: CardinalityRange +-- | Any count of elements. +cr0_Inf :: CardinalityRange +-- | Any nonzero count of elements. +cr1_Inf :: CardinalityRange +-- | Concrete count of elements. +crX :: PreciseCardinality -> CardinalityRange +-- | A concrete range. +crXY :: PreciseCardinality -> PreciseCardinality -> CardinalityRange + +crNoConstraint = cr0_Inf +cr0 = cardinalityRange (preciseC 0) (preciseC 0) +cr1 = cardinalityRange (preciseC 1) (preciseC 1) +cr0_1 = cardinalityRange (preciseC 0) (preciseC 1) +cr0_Inf = cardinalityRange (preciseC 0) infiniteC +cr1_Inf = cardinalityRange (preciseC 1) infiniteC +crX x = cardinalityRange (preciseC x) (preciseC x) +crXY x y = cardinalityRange (preciseC x) (preciseC y) + +-------------------------------------------------------------- +-- * Application 0 + +type CardinalityConstraint = CardinalityRange + +-- | @cFitsInCC = 'cFitsInCR'@ +-- +-- Defined to satisfy abbreviation. +cFitsInCC :: LazyCardinality -> CardinalityConstraint -> Bool +cFitsInCC = cFitsInCR +infixr 9 `cFitsInCC` + +-- | @fitsInCC = 'fitsInCR'@ +-- +-- Defined to satisfy abbreviation. +fitsInCC :: HasCard a => a -> CardinalityConstraint -> Bool +fitsInCC = fitsInCR +infixr 9 `fitsInCC` + +-- | @fitsInCC = 'fitsInCR_T'@ +-- +-- Defined to satisfy abbreviation. +fitsInCC_T :: HasCardT c => c a -> CardinalityConstraint -> Bool +fitsInCC_T = fitsInCR_T +infixr 9 `fitsInCC_T` + +-- | @HasCardConstr@ = \"Has cardinality constraint\". In other words, \"there +-- is a capacity constraint for this container\". +class HasCardConstr a where + cardinalityConstraintOf :: a -> CardinalityConstraint + +-- | @HasCardConstrT@ = \"Has cardinality constraint (for container types of +-- kind @(* -> *)@)\". +-- In other words, \"there is a capacity constraint for this container type +-- of kind @(* -> *)@\". +class HasCardConstrT c where + cardinalityConstraintOfT :: c a -> CardinalityConstraint + +-- | Wrapper around @'cFitsInCC'@. +cFitsIn :: HasCardConstr b => LazyCardinality -> b -> Bool +cFitsIn c hasCC = c `cFitsInCC` cardinalityConstraintOf hasCC +infixr 9 `cFitsIn` + +-- | Wrapper around @'cFitsInCC'@. +cFitsInT :: HasCardConstrT c => LazyCardinality -> c b -> Bool +cFitsInT c hasCC = c `cFitsInCC` cardinalityConstraintOfT hasCC +infixr 9 `cFitsInT` + +-- | Wrapper around @'cFitsInCC'@. +fitsIn :: (HasCard a, HasCardConstr b) => a -> b -> Bool +fitsIn hasC hasCC = cardOf hasC `cFitsInCC` cardinalityConstraintOf hasCC +infixr 9 `fitsIn` + +-- | Wrapper around @'cFitsInCC'@. +fitsInT :: (HasCardT c, HasCardConstrT d) => c a -> d b -> Bool +fitsInT hasC hasCC = cardOfT hasC `cFitsInCC` cardinalityConstraintOfT hasCC +infixr 9 `fitsInT` + +-------------------------------------------------------------- +-- * Application 1 + +-- | @HasCardUCT@ = \"Has cardinality-unsafe container transform\". +-- Define transform that may thow an error, if contents of @from@ don't fit +-- in @to@ . +class HasCardUCT from to where + -- | \"u-\" prefix stands for \"unsafe-\" + uContTrans :: from -> to +-- | @HasCardUCT_T@ = \"Has cardinality-unsafe container +-- transform (for container types of kind @(* -> *)@)\". +-- Same thing as @'HasCardUCT'@, but for containers of kind @(* -> *)@. +class HasCardUCT_T from to where + -- | \"u-\" prefix stands for \"unsafe-\" + uContTransT :: from a -> to a + +type TransformError_FromTypeName = String +type TransformError_ToTypeName = String +type TransformError_Details = String + +-- | This error is used by @'HasCardUCT'@ +-- typeclass instances in cases when @from@ container's contents +-- don't fit in @to@ container. +uContError :: TransformError_FromTypeName -> TransformError_ToTypeName -> TransformError_Details -> a +uContError from_t_name to_t_name details = error $ + "An error occurred in the instance of HasCardUCT" + ++ ", when trying to transform from type '" ++ from_t_name ++ "' to type '" ++ to_t_name ++ "'." + ++ (case details of + [] -> "" + _ -> "Details: '" ++ details ++ "'." + ) + +-- | Same as @'uContError'@, but for use in +-- @'HasCardUCT_T'@ typeclass instances +uContErrorT :: TransformError_FromTypeName -> TransformError_ToTypeName -> TransformError_Details -> a +uContErrorT from_t_name to_t_name details = error $ + "An error occurred in the instance of HasCardUCT_T" + ++ ", when trying to transform from type '" ++ from_t_name ++ "' to type '" ++ to_t_name ++ "'." + ++ (case details of + [] -> "" + _ -> "Details: '" ++ details ++ "'." + ) + +-- | A wrapper around @'uContTrans'@. Contrary to it, where \"u-\" prefix stands +-- for \"unsafe-\", here \"s-\" prefix stands for \"safe-\". +-- This is aimed to localize and exclude case, when contents of @from@ don't +-- fit in @to@ If @'HasCardUCT'@ instaniated +-- correctly, then @'sContTrans'@ should never allow +-- @'uContError'@ to be called by subject instance. It should return @Nothing@ +-- instead. +sContTrans :: ( HasCard from + , HasCardConstr to + , HasCardUCT from to + ) => from -> Maybe to +sContTrans from = + let to = uContTrans from + in case from `fitsIn` to of + True -> Just to + False -> Nothing + +-- | A wrapper around @'uContTransT'@. Contrary to it, where \"u-\" prefix stands +-- for \"unsafe-\", here \"s-\" prefix stands for \"safe-\". +-- This is aimed to localize and exclude case, when contents of @(from a)@ don't +-- fit in @(to a)@ . If @'HasCardUCT_T'@ instaniated +-- correctly, then @'sContTransT'@ should never allow +-- @'uContErrorT'@ to be called by subject instance. It should return @Nothing@ +-- instead. +sContTransT :: ( HasCardT from + , HasCardConstrT to + , HasCardUCT_T from to + ) => from a -> Maybe (to a) +sContTransT from = + let to = uContTransT from + in case from `fitsInT` to of + True -> Just to + False -> Nothing + +-------------------------------------------------------------- +-------------------------------------------------------------- +-- Instances 0 + +instance HasCardConstr () where + cardinalityConstraintOf _ = cr0 +instance HasCardConstr (EmptySet a) where + cardinalityConstraintOf _ = cr0 +instance HasCardConstrT EmptySet where + cardinalityConstraintOfT _ = cr0 + +-- instance HasCardConstr a where +-- cardinalityConstraintOf _ = cr1 +instance HasCardConstr (Identity a) where + cardinalityConstraintOf _ = cr1 +instance HasCardConstrT Identity where + cardinalityConstraintOfT _ = cr1 + +instance HasCardConstr (Maybe a) where + cardinalityConstraintOf _ = cr0_1 +instance HasCardConstrT Maybe where + cardinalityConstraintOfT _ = cr0_1 + +instance HasCardConstr [a] where + cardinalityConstraintOf _ = cr0_Inf +instance HasCardConstrT ([]) where + cardinalityConstraintOfT _ = cr0_Inf + +instance HasCardConstr (NeverEmptyList a) where + cardinalityConstraintOf _ = cr1_Inf +instance HasCardConstrT NeverEmptyList where + cardinalityConstraintOfT _ = cr1_Inf + +instance HasCardConstr (Map k e) where + cardinalityConstraintOf _ = cr0_Inf +instance HasCardConstrT (Map k) where + cardinalityConstraintOfT _ = cr0_Inf +-- Here actually we may want an other look - one that involves the count of possible values key may take... + +instance HasCardConstr (a,a) where { cardinalityConstraintOf _ = crX 2 } +instance HasCardConstr (a,a,a) where { cardinalityConstraintOf _ = crX 3 } +instance HasCardConstr (a,a,a,a) where { cardinalityConstraintOf _ = crX 4 } +instance HasCardConstr (a,a,a,a,a) where { cardinalityConstraintOf _ = crX 5 } +instance HasCardConstr (a,a,a,a,a,a) where { cardinalityConstraintOf _ = crX 6 } +instance HasCardConstr (a,a,a,a,a,a,a) where { cardinalityConstraintOf _ = crX 7 } +instance HasCardConstr (a,a,a,a,a,a,a,a) where { cardinalityConstraintOf _ = crX 8 } +instance HasCardConstr (a,a,a,a,a,a,a,a,a) where { cardinalityConstraintOf _ = crX 9 } +instance HasCardConstr (a,a,a,a,a,a,a,a,a,a) where { cardinalityConstraintOf _ = crX 10 } +instance HasCardConstr (a,a,a,a,a,a,a,a,a,a,a) where { cardinalityConstraintOf _ = crX 11 } + +-------------------------------------------------------------- +-- Instances 1 +{- + +instance HasCardUCT a a where + uContTrans = id +instance HasCardUCT_T a a where + uContTransT = id +-} + +-------- + +instance HasCardUCT (EmptySet a) () where + uContTrans _ = () + +instance HasCardUCT () (EmptySet a) where + uContTrans _ = EmptySet + +-- + +instance HasCardUCT (EmptySet a) (Maybe a) where + uContTrans _ = Nothing +instance HasCardUCT_T EmptySet Maybe where + uContTransT = uContTrans + +instance HasCardUCT (Maybe a) (EmptySet a) where + uContTrans Nothing = EmptySet + uContTrans _ = uContError "Maybe a" "EmptySet a" "something can not be nothing" +instance HasCardUCT_T Maybe EmptySet where + uContTransT Nothing = EmptySet + uContTransT _ = uContErrorT "Maybe" "EmptySet" "something can not be nothing" + +-- + +instance HasCardUCT (EmptySet a) [a] where + uContTrans _ = [] +instance HasCardUCT_T EmptySet ([]) where + uContTransT = uContTrans + +instance HasCardUCT [a] (EmptySet a) where + uContTrans [] = EmptySet + uContTrans _ = uContError "[a]" "EmptySet a" "something can not be nothing" +instance HasCardUCT_T ([]) EmptySet where + uContTransT [] = EmptySet + uContTransT _ = uContErrorT "[]" "EmptySet" "something can not be nothing" + +-- + +instance HasCardUCT (EmptySet (k, e)) (Map k e) where + uContTrans _ = M.empty +-- Can't see any way to make an instance HasCardUCT here + +instance HasCardUCT (Map k e) (EmptySet (k, e)) where + uContTrans mp = + case M.null mp of + True -> EmptySet + False -> uContError "Map k e" "EmptySet (k, e)" "something can not be nothing" +-- Can't see any way to make an instance HasCardUCT here + +-------- + +{- +instance HasCardUCT a (Identity a) where + uContTrans = Identity + +instance HasCardUCT a (Maybe a) where + uContTrans = Just + +instance HasCardUCT a [a] where + uContTrans = (: []) + +instance HasCardUCT a (NeverEmptyList a) where + uContTrans = nelSingleton +-} +instance HasCardUCT (k, e) (Map k e) where + uContTrans = uncurry M.singleton +instance HasCardUCT_T ((,) k) (Map k) where + uContTransT = uContTrans + +-------- +{- +instance HasCardUCT (Identity a) a where + uContTrans = runIdentity + +instance HasCardUCT (Maybe a) a where + uContTrans (Just a) = a + uContTrans Nothing = uContError "Maybe a" "a" "nothing to identify in Nothing" + +instance HasCardUCT [a] a where + uContTrans [] = uContError "[a]" "a" "nothing to identify in empty list" + uContTrans (h : []) = h + uContTrans (h : _) = uContError "[a]" "a" "too many identities" + +instance HasCardUCT (NeverEmptyList a) a where + uContTrans (NEL h []) = h + uContTrans (NEL _ _) = uContError "NeverEmptyList a" "a" "too many identities" +-} +instance HasCardUCT (Map k e) (k, e) where + uContTrans mp = + case M.minViewWithKey mp of + Nothing -> uContError "Map k e" "(k, e)" "nothing to identify in empty list" + Just (row, rest_mp) -> + case M.null rest_mp of + True -> row + False -> uContError "Map k e" "(k, e)" "too many identities" +instance HasCardUCT_T (Map k) ((,) k) where + uContTransT = uContTrans + +-------- + +instance HasCardUCT (Identity a) (Maybe a) where + uContTrans = Just . runIdentity +instance HasCardUCT_T Identity Maybe where + uContTransT = uContTrans + +instance HasCardUCT (Identity a) [a] where + uContTrans i = [runIdentity i] +instance HasCardUCT_T Identity ([]) where + uContTransT = uContTrans + +instance HasCardUCT (Identity a) (NeverEmptyList a) where + uContTrans i = NEL (runIdentity i) [] +instance HasCardUCT_T Identity NeverEmptyList where + uContTransT = uContTrans + +instance HasCardUCT (Identity (k, e)) (Map k e) where + uContTrans = uContTrans . runIdentity +-- Can't see any way to make an instance HasCardUCT here + +-------- + +instance HasCardUCT (Maybe a) (Identity a) where + uContTrans (Just a) = Identity a + uContTrans Nothing = uContError "Maybe a" "Identity a" "nothing to identify in Nothing" +instance HasCardUCT_T Maybe Identity where + uContTransT = uContTrans + +instance HasCardUCT [a] (Identity a) where + uContTrans [] = uContError "[a]" "Identity a" "nothing to identify in empty list" + uContTrans (h : []) = Identity h + uContTrans (h : _) = uContError "[a]" "Identity a" "too many identities" +instance HasCardUCT_T ([]) Identity where + uContTransT = uContTrans + +instance HasCardUCT (NeverEmptyList a) (Identity a) where + uContTrans (NEL h []) = Identity h + uContTrans (NEL _ _) = uContError "NeverEmptyList a" "Identity a" "too many identities" +instance HasCardUCT_T NeverEmptyList Identity where + uContTransT = uContTrans + +instance HasCardUCT (Map k e) (Identity (k, e)) where + uContTrans mp = + case M.minViewWithKey mp of + Nothing -> uContError "Map k e" "Identity (k, e)" "nothing to identify in empty list" + Just (row, rest_mp) -> + case M.null rest_mp of + True -> Identity row + False -> uContError "Map k e" "Identity (k, e)" "too many identities" +-- Can't see any way to make an instance HasCardUCT_T here + +-------- + +instance HasCardUCT () (Maybe a) where + uContTrans _ = Nothing + +instance HasCardUCT () [a] where + uContTrans _ = [] + +instance HasCardUCT () (Map k e) where + uContTrans _ = M.empty + +-------- + +instance HasCardUCT (Maybe a) () where + uContTrans Nothing = () + uContTrans _ = uContError "Maybe a" "()" "only Nothing transforms to unity" -- xD ... political, yes + +instance HasCardUCT [a] () where + uContTrans [] = () + uContTrans _ = uContError "[a]" "()" "only empty list transforms to unity" + +instance HasCardUCT (Map k e) () where + uContTrans mp = case M.null mp of { True -> (); False -> uContError "Map a" "()" "only empty map transforms to unity"} + +-------- + +instance HasCardUCT (Maybe a) [a] where + uContTrans Nothing = [] + uContTrans (Just a) = [a] +instance HasCardUCT_T Maybe ([]) where + uContTransT = uContTrans + +instance HasCardUCT (Maybe a) (NeverEmptyList a) where + uContTrans Nothing = uContError "Maybe a" "NeverEmptyList a" "there must be at least 1 element, Nothing is not the case" + uContTrans (Just a) = (NEL a []) +instance HasCardUCT_T Maybe NeverEmptyList where + uContTransT Nothing = uContErrorT "Maybe" "NeverEmptyList" "there must be at least 1 element, Nothing is not the case" + uContTransT (Just a) = (NEL a []) + +instance HasCardUCT (Maybe (k, e)) (Map k e) where + uContTrans Nothing = M.empty + uContTrans (Just (k, e)) = M.singleton k e +-- Can't see any way to make an instance HasCardUCT_T here + +-------- + +instance HasCardUCT [a] (Maybe a) where + uContTrans [] = Nothing + uContTrans (h : []) = Just h + uContTrans _ = uContError "[a]" "Maybe a" "too many elements to fit in Maybe" +instance HasCardUCT_T ([]) Maybe where + uContTransT [] = Nothing + uContTransT (h : []) = Just h + uContTransT _ = uContErrorT "[]" "Maybe" "too many elements to fit in Maybe" + +instance HasCardUCT (NeverEmptyList a) (Maybe a) where + uContTrans (NEL a []) = Just a + uContTrans _ = uContError "NeverEmptyList a" "Maybe a" "too many elements to fit in Maybe" +instance HasCardUCT_T NeverEmptyList Maybe where + uContTransT (NEL a []) = Just a + uContTransT _ = uContErrorT "NeverEmptyList" "Maybe" "too many elements to fit in Maybe" + +instance HasCardUCT (Map k e) (Maybe (k, e)) where + uContTrans mp = + case M.minViewWithKey mp of + Nothing -> Nothing + Just (row, rest_mp) -> + case M.null rest_mp of + True -> Just row + False -> uContError "Map k e" "Maybe (k, e)" "too many elements to fit in Maybe" +-- Can't see any way to make an instance HasCardUCT_T here + +-------- + +instance HasCardUCT [a] (NeverEmptyList a) where + uContTrans [] = uContError "[a]" "NeverEmptyList a" "there must be at least 1 element" + uContTrans (h : t) = (NEL h t) +instance HasCardUCT_T ([]) NeverEmptyList where + uContTransT [] = uContErrorT "[a]" "NeverEmptyList a" "there must be at least 1 element" + uContTransT (h : t) = (NEL h t) + +instance Ord k => HasCardUCT [(k, e)] (Map k e) where + uContTrans = M.fromList +-- Can't see any way to make an instance HasCardUCT_T here + +-------- + +instance HasCardUCT (NeverEmptyList a) [a] where + uContTrans (NEL h t) = (h:t) +instance HasCardUCT_T NeverEmptyList ([]) where + uContTransT = uContTrans + +instance HasCardUCT (Map k e) [(k, e)] where + uContTrans = M.toList +-- Can't see any way to make an instance HasCardUCT_T here + +-------- + +instance Ord k => HasCardUCT (NeverEmptyList (k, e)) (Map k e) where + uContTrans (NEL h t) = M.fromList (h:t) +-- Can't see any way to make an instance HasCardUCT_T here + +-------- + +instance HasCardUCT (Map k e) (NeverEmptyList (k, e)) where + uContTrans mp = case M.null mp of { False -> let (h:t) = M.toList mp in (NEL h t) ; True -> uContError "Map k e" "NeverEmptyList (k, e)" "there must be at least 1 element" } +-- Can't see any way to make an instance HasCardUCT_T here + + +-------------------------------------------------------------------------------------- + +instance HasCardUCT [a] (a,a) where { uContTrans l = case l of { (a:b:[]) -> (a,b); _ -> uContError "[a]" "(a,a)" "wrong count of elements" } } +instance HasCardUCT [a] (a,a,a) where { uContTrans l = case l of { (a:b:c:[]) -> (a,b,c); _ -> uContError "[a]" "(a,a,a)" "wrong count of elements" } } +instance HasCardUCT [a] (a,a,a,a) where { uContTrans l = case l of { (a:b:c:d:[]) -> (a,b,c,d); _ -> uContError "[a]" "(a,a,a,a)" "wrong count of elements" } } +instance HasCardUCT [a] (a,a,a,a,a) where { uContTrans l = case l of { (a:b:c:d:e:[]) -> (a,b,c,d,e); _ -> uContError "[a]" "(a,a,a,a,a)" "wrong count of elements" } } +instance HasCardUCT [a] (a,a,a,a,a,a) where { uContTrans l = case l of { (a:b:c:d:e:f:[]) -> (a,b,c,d,e,f); _ -> uContError "[a]" "(a,a,a,a,a,a)" "wrong count of elements" } } +instance HasCardUCT [a] (a,a,a,a,a,a,a) where { uContTrans l = case l of { (a:b:c:d:e:f:g:[]) -> (a,b,c,d,e,f,g); _ -> uContError "[a]" "(a,a,a,a,a,a,a)" "wrong count of elements" } } +instance HasCardUCT [a] (a,a,a,a,a,a,a,a) where { uContTrans l = case l of { (a:b:c:d:e:f:g:h:[]) -> (a,b,c,d,e,f,g,h); _ -> uContError "[a]" "(a,a,a,a,a,a,a,a)" "wrong count of elements" } } +instance HasCardUCT [a] (a,a,a,a,a,a,a,a,a) where { uContTrans l = case l of { (a:b:c:d:e:f:g:h:i:[]) -> (a,b,c,d,e,f,g,h,i); _ -> uContError "[a]" "(a,a,a,a,a,a,a,a,a)" "wrong count of elements" } } +instance HasCardUCT [a] (a,a,a,a,a,a,a,a,a,a) where { uContTrans l = case l of { (a:b:c:d:e:f:g:h:i:j:[]) -> (a,b,c,d,e,f,g,h,i,j); _ -> uContError "[a]" "(a,a,a,a,a,a,a,a,a,a)" "wrong count of elements" } } +instance HasCardUCT [a] (a,a,a,a,a,a,a,a,a,a,a) where { uContTrans l = case l of { (a:b:c:d:e:f:g:h:i:j:k:[]) -> (a,b,c,d,e,f,g,h,i,j,k); _ -> uContError "[a]" "(a,a,a,a,a,a,a,a,a,a,a)" "wrong count of elements" } } + +instance HasCardUCT (a,a) [a] where { uContTrans (a,b) = (a:b:[]) } +instance HasCardUCT (a,a,a) [a] where { uContTrans (a,b,c) = (a:b:c:[]) } +instance HasCardUCT (a,a,a,a) [a] where { uContTrans (a,b,c,d) = (a:b:c:d:[]) } +instance HasCardUCT (a,a,a,a,a) [a] where { uContTrans (a,b,c,d,e) = (a:b:c:d:e:[]) } +instance HasCardUCT (a,a,a,a,a,a) [a] where { uContTrans (a,b,c,d,e,f) = (a:b:c:d:e:f:[]) } +instance HasCardUCT (a,a,a,a,a,a,a) [a] where { uContTrans (a,b,c,d,e,f,g) = (a:b:c:d:e:f:g:[]) } +instance HasCardUCT (a,a,a,a,a,a,a,a) [a] where { uContTrans (a,b,c,d,e,f,g,h) = (a:b:c:d:e:f:g:h:[]) } +instance HasCardUCT (a,a,a,a,a,a,a,a,a) [a] where { uContTrans (a,b,c,d,e,f,g,h,i) = (a:b:c:d:e:f:g:h:i:[]) } +instance HasCardUCT (a,a,a,a,a,a,a,a,a,a) [a] where { uContTrans (a,b,c,d,e,f,g,h,i,j) = (a:b:c:d:e:f:g:h:i:j:[]) } +instance HasCardUCT (a,a,a,a,a,a,a,a,a,a,a) [a] where { uContTrans (a,b,c,d,e,f,g,h,i,j,k) = (a:b:c:d:e:f:g:h:i:j:k:[]) }
+ Data/EmptySet.hs view
@@ -0,0 +1,17 @@+{- +Copyright (C) 2010 Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru> + +All rights reserved. + +For license and copyright information, see the file COPYRIGHT + +-} + +-------------------------------------------------------------------------- +-------------------------------------------------------------------------- + +module Data.EmptySet where + +import Data.Typeable + +data EmptySet a = EmptySet deriving (Eq, Show, Typeable)
+ Data/Intersectable.hs view
@@ -0,0 +1,21 @@+{- +Copyright (C) 2010 Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru> + +All rights reserved. + +For license and copyright information, see the file COPYRIGHT + +-} + +-------------------------------------------------------------------------- +-------------------------------------------------------------------------- + +module Data.Intersectable where + +import Data.Typeable + +data SetsFit set = NoIntersection | Intersection set | FirstInSecond | SecondInFirst | EqualSets deriving (Show, Typeable) + +infixr 9 `setFits` +class Intersectable set where + setFits :: set -> set -> SetsFit set
+ Data/NeverEmptyList.hs view
@@ -0,0 +1,29 @@+{- +Copyright (C) 2010 Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru> + +All rights reserved. + +For license and copyright information, see the file COPYRIGHT + +-} + +-------------------------------------------------------------------------- +-------------------------------------------------------------------------- + +module Data.NeverEmptyList where + +data NeverEmptyList a = NEL a [a] + +-- | @neverEmptyList2List (NEL h t) = h:t@ +nel2List :: NeverEmptyList a -> [a] +nel2List (NEL h t) = h:t + +-- | @list2NeverEmptyList [] = Nothing@ +-- +-- @list2NeverEmptyList (h:t) = Just (NEL h t)@ +list2nel :: [a] -> Maybe (NeverEmptyList a) +list2nel [] = Nothing +list2nel (h:t) = Just (NEL h t) + +nelSingleton :: a -> NeverEmptyList a +nelSingleton a = NEL a []
+ Setup.hs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runghc++import Distribution.Simple+main = defaultMain
+ doinst.sh view
@@ -0,0 +1,8 @@+#! /bin/sh+clear++sudo runghc Setup unregister+sudo runghc Setup configure --user+sudo runghc Setup build+sudo runghc Setup haddock+sudo runghc Setup install
+ examples/CardinalityRangeCompareTest.hs view
@@ -0,0 +1,55 @@+{- +Copyright (C) 2010 Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru> + +All rights reserved. + +For license and copyright information, see the file COPYRIGHT + +-} + +-------------------------------------------------------------------------- +-------------------------------------------------------------------------- + +import Data.Cardinality +import Data.CardinalityRange +import Data.Intersectable +import Data.Map +import Control.Monad + +compare2CRs_testSet :: [(SetsFit CardinalityRange, (CardinalityRange, CardinalityRange))] +compare2CRs_testSet = + [ + (EqualSets, (crXY 5 10, crXY 5 10)) + , (EqualSets, (crX 5, crX 5)) + + , (NoIntersection, (crXY 5 10, crXY 2 4)) + , (NoIntersection, (crXY 5 10, crXY 11 15)) + + , (SecondInFirst, (crXY 5 10, crX 10)) + , (SecondInFirst, (crXY 5 10, crX 5)) + , (SecondInFirst, (crXY 5 10, crXY 5 7)) + , (SecondInFirst, (crXY 5 10, crXY 7 10)) + , (SecondInFirst, (crXY 5 10, crXY 6 8)) + + , (FirstInSecond, (crX 10, crXY 5 10)) + , (FirstInSecond, (crX 5, crXY 5 10)) + , (FirstInSecond, (crXY 5 7, crXY 5 10)) + , (FirstInSecond, (crXY 7 10, crXY 5 10)) + , (FirstInSecond, (crXY 6 8, crXY 5 10)) + + , (Intersection $ crXY 8 10, (crXY 5 10, crXY 8 13)) + , (Intersection $ crXY 5 8, (crXY 2 8, crXY 5 10)) + ] + +compare2CRs_test :: (String -> IO ()) -> IO () +compare2CRs_test _putStrLn = flip mapM_ (zip [1..] compare2CRs_testSet) + (\ (idx, (correct_answer, (cr1, cr2))) -> + let (answ, cr1_2, c2_2) = compare2CRs cr1 cr2 + wrapped_correct_answer :: Either Compare2CRsError (SetsFit CardinalityRange) + wrapped_correct_answer = Right correct_answer + in case (show answ) == (show wrapped_correct_answer) of + True -> _putStrLn (show idx ++ ") OK") + False -> _putStrLn (show idx ++ ") " ++ show answ ++ " /= " ++ show correct_answer) + ) + +main = compare2CRs_test putStrLn
+ examples/ContainerTransformsTests.hs view
@@ -0,0 +1,48 @@+{- +Copyright (C) 2010 Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru> + +All rights reserved. + +For license and copyright information, see the file COPYRIGHT + +-} + +-------------------------------------------------------------------------- +-------------------------------------------------------------------------- + +import Data.EmptySet +import Data.NeverEmptyList +import Data.CardinalityRange +import Data.Map +import Control.Monad +import Control.Monad.Identity + +instance Eq a => Eq (Identity a) where + a == b = runIdentity a == runIdentity b +instance Show a => Show (Identity a) where + show i_a = "Identity " ++ show (runIdentity i_a) + +test_set :: [(Int, Bool)] +test_set = + [ + (10, ((sContTransT []) :: Maybe (Maybe Int)) == Just Nothing) + , (20, ((sContTrans ()) :: Maybe (Maybe Int)) == Just Nothing) + , (30, ((sContTransT [1]) :: (Maybe (Maybe Int))) == Just (Just 1)) + , (40, ((sContTransT [1, 2]) :: (Maybe (Maybe Int))) == Nothing) + , (50, ((sContTransT $ Just "Hello") :: (Maybe (Identity String))) == Just (Identity "Hello")) + , (60, ((sContTransT ["Hello"]) :: Maybe (Identity String)) == Just (Identity "Hello")) + , (70, ((sContTransT (EmptySet :: EmptySet String)) :: (Maybe [String])) == Just []) + , (80, ((sContTransT "Hello") :: Maybe (EmptySet Char)) == Nothing) + , (90, ((sContTransT ("key", "elem")) :: Maybe (Map String String)) == Just (singleton "key" "elem")) + , (100, ((sContTrans [("key1", "elem1"), ("key2", "elem2")]) :: Maybe (Map String String)) == Just (fromList [("key1", "elem1"), ("key2", "elem2")])) + , (110, ((sContTrans (EmptySet :: EmptySet (String, String))) :: Maybe (Map String String)) == Just empty) + , (120, ((sContTrans []) :: Maybe ()) == Just ()) + , (130, ((sContTrans (NEL 'H' "i!")) :: Maybe String) == Just "Hi!") -- Data.NeverEmptyList + , (140, ((sContTrans ()) :: Maybe String) == Just "") + , (150, ((sContTrans "") :: Maybe (Identity Char)) == Nothing) + , (160, ((sContTrans "Hi!") :: Maybe ()) == Nothing) + ] + +main = do putStrLn ("INDEX) IS_VALID | TEST_CASE\n------------------------------") + flip mapM_ test_set + (\ (idx, _case) -> putStrLn (show idx ++ ") " ++ show _case))
+ examples/HelloWorld.hs view
@@ -0,0 +1,146 @@+{- +Copyright (C) 2010 Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru> + +All rights reserved. + +For license and copyright information, see the file COPYRIGHT + +-} + +-------------------------------------------------------------------------- +-------------------------------------------------------------------------- + +{-# LANGUAGE MultiParamTypeClasses #-} + + +import Data.Cardinality +import Data.CardinalityRange +import Data.List +import System.IO + +data MyContainer a = + MyContainer { + field_1 :: Maybe a + , field_2 :: (a, a, a) + , field_3 :: a + , field_4 :: [a] + } + deriving (Show) + +emptiestMyContainer :: MyContainer Int +emptiestMyContainer = MyContainer Nothing (1,1,1) 1 [] + +instance HasCard (MyContainer a) where + cardOf mc = sumLCs + [ cardOf $ field_1 mc -- 0..1 + , cardOf $ field_2 mc -- 3 (uses instance HasCard (a,a,a)) + , preciseC 1 + , cardOf $ field_4 mc -- 0..Inf + ] -- = 4..Inf + +instance HasCardT MyContainer where + cardOfT = cardOf + +instance HasCardConstr (MyContainer a) where + cardinalityConstraintOf mc_a = cardinalityRange (cardOf emptiestMyContainer) infiniteC + +instance HasCardConstrT MyContainer where + cardinalityConstraintOfT = cardinalityConstraintOf + +instance HasCardUCT (MyContainer a) [a] where + uContTrans mc_a = + uContTrans (field_1 mc_a) + ++ uContTrans (field_2 mc_a) + ++ [field_3 mc_a] + ++ field_4 mc_a + +instance HasCardUCT_T MyContainer [] where + uContTransT = uContTrans + +-- We will use this function to instaniate both @HasCardUCT@ and @HasCardUCT_T@. +-- They must use different error throwers, that's why had to define transform +-- outside of instances - in order to avoid doublecoding the same thing. +__uContTrans :: (TransformError_Details -> MyContainer a) -> [a] -> MyContainer a +__uContTrans error_fun a_list = result + where + result = + case a_list of + (e1 : e2 : e3 : e4 : rest_a_list_1) -> + case rest_a_list_1 of + (e5 : rest_a_list_2) -> + MyContainer { + field_1 = Just e1 + , field_2 = (e2,e3,e4) + , field_3 = e5 + , field_4 = rest_a_list_2 + } + _ -> MyContainer { + field_1 = Nothing + , field_2 = (e1,e2,e3) + , field_3 = e4 + , field_4 = rest_a_list_1 + } + _ -> error_fun "not enough elements in list" + +instance HasCardUCT [a] (MyContainer a) where + uContTrans = __uContTrans (uContError "[a]" "MyContainer a") + +instance HasCardUCT_T [] MyContainer where + uContTransT = __uContTrans (uContErrorT "[]" "MyContainer") + +main = do + let f pr c = pr ++ (concat $ intersperse "\n" $ map show c) + let output1 = f "Initial MyContainers:\n" initial_containers + let output2 = f "MyContainers trasformed to lists:\n" initial_containers2lists + let output3 = f "Initial lists:\n" initial_lists + let output4 = f "Lists trasformed to MyContainers:\n" initial_lists2containers + putStrLn output1 + pressAnyKey + putStrLn output2 + pressAnyKey + putStrLn output3 + pressAnyKey + putStrLn output4 + pressAnyKey + where + initial_containers :: [MyContainer Int] + initial_lists :: [[Int]] + initial_containers2lists :: [Maybe [Int]] + initial_lists2containers :: [Maybe (MyContainer Int)] + --------------------------------- + initial_containers = + [ MyContainer (Just 1) (2,3,4) 5 [6,7,8,9,10] + , MyContainer (Just 1) (2,3,4) 5 [] + , MyContainer Nothing (2,3,4) 5 [6,7,8,9,10] + , MyContainer Nothing (2,3,4) 5 [] + ] + initial_lists = + [ [] + , [1] + , [1..3] + , [1..4] + , [1..10] + , [1..5] + , [2..10] + ] + initial_containers2lists = map sContTrans initial_containers + initial_lists2containers = map sContTrans initial_lists + +--------------------------------------------------------------- +-- helpers + +infixr 1 << +(<<) :: Monad m => m b -> m a -> m b +f << x = x >> f + +putStrLn_paged :: Int -> String -> IO () +putStrLn_paged page_size s = f $ lines s + where + f lines_list = + let (to_print, to_next_itera) = splitAt page_size lines_list + in do putStrLn (concat $ intersperse "\n" to_print) + case null to_next_itera of + True -> return () + False -> f to_next_itera << pressAnyKey + +pressAnyKey = hGetChar stdin << putStrLn "\n-------Press any key to continue...-------"