{- 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:[]) }