diff --git a/Cardinality.cabal b/Cardinality.cabal --- a/Cardinality.cabal +++ b/Cardinality.cabal @@ -66,7 +66,11 @@ 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 + . + To interface package functions + . + @import Data.Cardinality@ +Version: 0.2 Copyright: Copyright (c) 2010 Andrejs Sisojevs License: LGPL License-File: COPYRIGHT @@ -81,6 +85,7 @@ Extra-Source-Files: COPYRIGHT COPYING + NEWS doinst.sh examples/CardinalityRangeCompareTest.hs examples/ContainerTransformsTests.hs @@ -89,8 +94,10 @@ Build-Depends: base >= 4 && < 5, containers, mtl Exposed-Modules: + Data.Cardinality.Cardinality + Data.Cardinality.CardinalityRange + Data.Cardinality.ContTrans Data.Cardinality - Data.CardinalityRange Data.EmptySet Data.Intersectable Data.NeverEmptyList diff --git a/Data/Cardinality.hs b/Data/Cardinality.hs --- a/Data/Cardinality.hs +++ b/Data/Cardinality.hs @@ -10,528 +10,12 @@ -------------------------------------------------------------------------- -------------------------------------------------------------------------- -{-# 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 + module Data.Cardinality.Cardinality + , module Data.Cardinality.CardinalityRange + , module Data.Cardinality.ContTrans ) 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 +import Data.Cardinality.Cardinality +import Data.Cardinality.CardinalityRange +import Data.Cardinality.ContTrans diff --git a/Data/Cardinality/Cardinality.hs b/Data/Cardinality/Cardinality.hs new file mode 100644 --- /dev/null +++ b/Data/Cardinality/Cardinality.hs @@ -0,0 +1,537 @@ +{- +Copyright (C) 2010 Andrejs Sisojevs + +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.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 diff --git a/Data/Cardinality/CardinalityRange.hs b/Data/Cardinality/CardinalityRange.hs new file mode 100644 --- /dev/null +++ b/Data/Cardinality/CardinalityRange.hs @@ -0,0 +1,222 @@ +{- +Copyright (C) 2010 Andrejs Sisojevs + +All rights reserved. + +For license and copyright information, see the file COPYRIGHT + +-} + +-------------------------------------------------------------------------- +-------------------------------------------------------------------------- + +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +module Data.Cardinality.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 + ) where + +import Data.Cardinality.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. +-- +-- Uses @'almostStrictCompare2LCs'@ function. +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) diff --git a/Data/Cardinality/ContTrans.hs b/Data/Cardinality/ContTrans.hs new file mode 100644 --- /dev/null +++ b/Data/Cardinality/ContTrans.hs @@ -0,0 +1,582 @@ +{- +Copyright (C) 2010 Andrejs Sisojevs + +All rights reserved. + +For license and copyright information, see the file COPYRIGHT + +-} + +-------------------------------------------------------------------------- +-------------------------------------------------------------------------- + +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +module Data.Cardinality.ContTrans ( + -- * type CardinalityConstraint = CardinalityRange + CardinalityConstraint + , cFitsInCC + , fitsInCC + , fitsInCC_T + , HasCardConstr(..) + , HasCardConstrT(..) + , cFitsIn + , cFitsInT + , fitsIn + , fitsInT + + -- * Container transformation + , HasCardUCT(..) + , HasCardUCT_T(..) + , TransformError_FromTypeName + , TransformError_ToTypeName + , TransformError_Details + , uContError + , uContErrorT + , sContTrans + , sContTransT + , From_LazyCardinality + , To_CardinalityConstraint + , ContainerOrder + , ContTransError(..) + , sContTrans_E + , sContTransT_E + ) where + +import Data.Cardinality.Cardinality +import Data.Cardinality.CardinalityRange +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 + +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` + +-------------------------------------------------------------- +-- Container transformation + +-- | @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 + +-- | Used in @'ContTransError'@. +type From_LazyCardinality = LazyCardinality +-- | Used in @'ContTransError'@. +type To_CardinalityConstraint = CardinalityConstraint +-- | Used in @'ContTransError'@. The kind of container. +data ContainerOrder = + -- | Describes container of the kind @*@. + FirstOrderContainer + -- | Describes container of the kind @(* -> *)@. + | SecondOrderContainer + deriving (Eq, Ord, Show) + +-- | For container transformation we might use more informative error feedback. +-- The @'Ordering'@ in the middle is a relation between subject +-- @From_LazyCardinality@ and @To_CardinalityConstraint@. It's never EQ (and +-- that's the reason for the error). +data ContTransError = ContTransError From_LazyCardinality Ordering To_CardinalityConstraint ContainerOrder deriving (Show) + +-- | Analogue to @'sContTrans'@. Herre, in case of cardinality error, a more +-- informative data structure is returned instead of @Nothing@ (as was +-- in @'sContTrans'@). +sContTrans_E :: ( HasCard from + , HasCardConstr to + , HasCardUCT from to + ) => from -> Either ContTransError to +sContTrans_E from = + let to = uContTrans from + from_card = cardOf from + to_cardConstr = cardinalityConstraintOf to + (fit, from_card_2, to_cardConstr_2) = from_card `cFitsInCR_Proto` to_cardConstr + in case fit of + EQ -> Right to + _ -> Left $ ContTransError from_card_2 fit to_cardConstr_2 FirstOrderContainer + +-- | Analogue to @'sContTransT'@. Herre, in case of cardinality error, a more +-- informative data structure is returned instead of @Nothing@ (as was +-- in @'sContTransT'@). +sContTransT_E :: ( HasCardT from + , HasCardConstrT to + , HasCardUCT_T from to + ) => from a -> Either ContTransError (to a) +sContTransT_E from = + let to = uContTransT from + from_card = cardOfT from + to_cardConstr = cardinalityConstraintOfT to + (fit, from_card_2, to_cardConstr_2) = from_card `cFitsInCR_Proto` to_cardConstr + in case fit of + EQ -> Right to + _ -> Left $ ContTransError from_card_2 fit to_cardConstr_2 SecondOrderContainer + + +-------------------------------------------------------------- +-------------------------------------------------------------- +-- 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:[]) } diff --git a/Data/CardinalityRange.hs b/Data/CardinalityRange.hs deleted file mode 100644 --- a/Data/CardinalityRange.hs +++ /dev/null @@ -1,721 +0,0 @@ -{- -Copyright (C) 2010 Andrejs Sisojevs - -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:[]) } diff --git a/NEWS b/NEWS new file mode 100644 --- /dev/null +++ b/NEWS @@ -0,0 +1,14 @@ +Changes from 0.1 to 0.2 +--------------------------- +* Moved CardinalityConstraint and trasformation typeclasses from + Data.CardinalityRange to new dedicated module Data.Cardinality.ContTrans +* Data.Cardinality -> Data.Cardinality.Cardinality +* Data.CardinalityRange -> Data.Cardinality.CardinalityRange +* Data.Cardinality is now just exporting + Data.Cardinality.Cardinality + Data.Cardinality.CardinalityRange + Data.Cardinality.ContTrans +* To Data.Cardinality.ContTrans added ContTransError data structure and + functions sContTrans_E and sContTransT_E. With these functions it's now + possible a more informative error then it was Nothing with plain sContTrans. + diff --git a/examples/CardinalityRangeCompareTest.hs b/examples/CardinalityRangeCompareTest.hs --- a/examples/CardinalityRangeCompareTest.hs +++ b/examples/CardinalityRangeCompareTest.hs @@ -11,7 +11,6 @@ -------------------------------------------------------------------------- import Data.Cardinality -import Data.CardinalityRange import Data.Intersectable import Data.Map import Control.Monad diff --git a/examples/ContainerTransformsTests.hs b/examples/ContainerTransformsTests.hs --- a/examples/ContainerTransformsTests.hs +++ b/examples/ContainerTransformsTests.hs @@ -12,7 +12,7 @@ import Data.EmptySet import Data.NeverEmptyList -import Data.CardinalityRange +import Data.Cardinality import Data.Map import Control.Monad import Control.Monad.Identity @@ -23,24 +23,24 @@ show i_a = "Identity " ++ show (runIdentity i_a) test_set :: [(Int, Bool)] -test_set = +test_set = zip [1..] [ - (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) + ((sContTransT []) :: Maybe (Maybe Int)) == Just Nothing + , ((sContTrans ()) :: Maybe (Maybe Int)) == Just Nothing + , ((sContTransT [1]) :: (Maybe (Maybe Int))) == Just (Just 1) + , ((sContTransT [1, 2]) :: (Maybe (Maybe Int))) == Nothing + , ((sContTransT $ Just "Hello") :: (Maybe (Identity String))) == Just (Identity "Hello") + , ((sContTransT ["Hello"]) :: Maybe (Identity String)) == Just (Identity "Hello") + , ((sContTransT (EmptySet :: EmptySet String)) :: (Maybe [String])) == Just [] + , ((sContTransT "Hello") :: Maybe (EmptySet Char)) == Nothing + , ((sContTransT ("key", "elem")) :: Maybe (Map String String)) == Just (singleton "key" "elem") + , ((sContTrans [("key1", "elem1"), ("key2", "elem2")]) :: Maybe (Map String String)) == Just (fromList [("key1", "elem1"), ("key2", "elem2")]) + , ((sContTrans (EmptySet :: EmptySet (String, String))) :: Maybe (Map String String)) == Just empty + , ((sContTrans []) :: Maybe ()) == Just () + , ((sContTrans (NEL 'H' "i!")) :: Maybe String) == Just "Hi!" -- Data.NeverEmptyList + , ((sContTrans ()) :: Maybe String) == Just "" + , ((sContTrans "") :: Maybe (Identity Char)) == Nothing + , ((sContTrans "Hi!") :: Maybe ()) == Nothing ] main = do putStrLn ("INDEX) IS_VALID | TEST_CASE\n------------------------------") diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -14,7 +14,6 @@ import Data.Cardinality -import Data.CardinalityRange import Data.List import System.IO