Cardinality-0.1: Data/CardinalityRange.hs
{-
Copyright (C) 2010 Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru>
All rights reserved.
For license and copyright information, see the file COPYRIGHT
-}
--------------------------------------------------------------------------
--------------------------------------------------------------------------
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
module Data.CardinalityRange (
-- * Core
CardinalityRange_From
, CardinalityRange_To
, CardinalityRange
, cardinalityRange
, cr2Tuple
, lazyVerfyCR
, cFitsInCR_Proto
, cFitsInCR
, fitsInCR
, fitsInCR_T
, FirstOrSecond(..)
, Compare2CRsError(..)
, compare2CRs
, crFitsInCR
-- * Popular cardinality ranges constructors
, crNoConstraint
, cr0
, cr1
, cr0_1
, cr0_Inf
, cr1_Inf
, crX
, crXY
-- * Application 1
, CardinalityConstraint
, cFitsInCC
, fitsInCC
, fitsInCC_T
, HasCardConstr(..)
, HasCardConstrT(..)
, cFitsIn
, cFitsInT
, fitsIn
, fitsInT
-- * Application 2
, HasCardUCT(..)
, HasCardUCT_T(..)
, TransformError_FromTypeName
, TransformError_ToTypeName
, TransformError_Details
, uContError
, uContErrorT
, sContTrans
, sContTransT
) where
import Data.Cardinality
import Data.EmptySet
import Data.Intersectable
import Data.NeverEmptyList
import qualified Data.Map as M
import Data.Map (Map, (!))
import Data.Word
import Data.Typeable
-- import Debug.Trace
import Control.Monad.Identity
--------------------------------------------------------------
-- * Core
type CardinalityRange_From = LazyCardinality
type CardinalityRange_To = LazyCardinality
-- | Constructor: @'cardinalityRange' 'CardinalityRange_From' 'CardinalityRange_To'@
data CardinalityRange = CardinalityRange CardinalityRange_From CardinalityRange_To deriving (Show)
-- | @CardinalityRange@ data constructor. The range is always including it's
-- boundaries. F.e., range
-- @'CardinalityRange' ('preciseC' 1) ('preciseC' 4)@ contains
-- cardinalities [1,2,3,4].
-- First cardinality MUST always be less or equal to second one. However,
-- we do not fully guard from such type of error - we do not refine
-- @'refinableC'@, if it participates in the constriction.
cardinalityRange :: CardinalityRange_From -> CardinalityRange_To -> CardinalityRange
cardinalityRange from to =
case lazyVerfyCR from to of
Just False -> error $ "Cardinality range can't be constructed with lower boundary higher than lower one (" ++ show from ++ ", "++ show to ++ ")."
_ -> CardinalityRange from to
cr2Tuple :: CardinalityRange -> (CardinalityRange_From, CardinalityRange_From)
cr2Tuple (CardinalityRange from to) = (from, to)
lazyVerfyCR :: CardinalityRange_From -> CardinalityRange_To -> Maybe Bool
lazyVerfyCR from to = lazyCompare2LCs from to >>= return . (/= GT)
-- | Root prototype for all subsequent \"FitsIn\" functions. Returns probably
-- refined cardinality and range, which is useful for reuse.
-- If returns @EQ@ then subject cardinality
-- is between boundaries (including) of cardinality range.
cFitsInCR_Proto :: LazyCardinality -> CardinalityRange -> (Ordering, LazyCardinality, CardinalityRange)
cFitsInCR_Proto c (CardinalityRange lo_c hi_c) =
let (ord1, c_2, lo_c_2) = c `almostStrictCompare2LCs` lo_c
in case ord1 of
LT -> (ord1, c_2, cardinalityRange lo_c_2 hi_c)
_ -> let (ord2, c_3, hi_c_2) = c_2 `almostStrictCompare2LCs` hi_c
ord3 = case ord2 of { GT -> GT; _ -> EQ }
in (ord3, c_3, cardinalityRange lo_c_2 hi_c_2)
infixr 9 `cFitsInCR_Proto`
-- | @'LazyCardinality'@ fits in @'CardinalityRange'@?
cFitsInCR :: LazyCardinality -> CardinalityRange -> Bool
cFitsInCR c cr = fst3 (c `cFitsInCR_Proto` cr) == EQ
where fst3 (a,_,_) = a
infixr 9 `cFitsInCR`
-- | Wrapper around @'cFitsInCR'@.
fitsInCR :: HasCard a => a -> CardinalityRange -> Bool
fitsInCR hasC cr = cardOf hasC `cFitsInCR` cr
infixr 9 `fitsInCR`
-- | Wrapper around @'cFitsInCR'@.
fitsInCR_T :: HasCardT c => c a -> CardinalityRange -> Bool
fitsInCR_T hasC cr = cardOfT hasC `cFitsInCR` cr
infixr 9 `fitsInCR_T`
-- | Used in @'Compare2CRsError'@
data FirstOrSecond = First | Second deriving (Show)
-- | Error, that may occur, when performing @'compare2CRs'@
data Compare2CRsError = LowerBoundaryAfterHigher FirstOrSecond CardinalityRange
instance Show Compare2CRsError where
show e = "An error occurred when trying to compare 2 cardinality ranges: " ++
case e of
LowerBoundaryAfterHigher fs cr -> show fs ++ " cardinality range (" ++ show cr ++ ") is ill defined - lower boundary is greater then higher one."
-- | This function is made hard, but fast. It tends to make minimal amount
-- of comparisons, reusing refinements.
compare2CRs :: CardinalityRange -> CardinalityRange -> (Either Compare2CRsError (SetsFit CardinalityRange), CardinalityRange, CardinalityRange)
compare2CRs (CardinalityRange lo_cr1_0 hi_cr1_0) (CardinalityRange lo_cr2_0 hi_cr2_0) =
let step1@(order1, hi_cr1_1, lo_cr2_1) = almostStrictCompare2LCs hi_cr1_0 lo_cr2_0 -- 1: 0 1 1 0
in case order1 of -- traceShow ("Step 1: ", step1)
LT -> (Right NoIntersection, CardinalityRange lo_cr1_0 hi_cr1_1, CardinalityRange lo_cr2_1 hi_cr2_0)
EQ -> let step2@(order2, lo_cr1_1, hi_cr1_2) = almostStrictCompare2LCs lo_cr1_0 hi_cr1_1 -- 2: 1 2 1 0
cr1_2 = CardinalityRange lo_cr1_1 hi_cr1_2
cr2_2 = CardinalityRange lo_cr2_1 hi_cr2_0
answ_2 err_or_fit = (err_or_fit, cr1_2, cr2_2)
in case order2 of -- traceShow ("Step 2: ", step2)
LT -> let step21@(order21, lo_cr2_2, hi_cr2_1) = almostStrictCompare2LCs lo_cr2_1 hi_cr2_0 -- 21: 1 2 2 1
cr1_21 = CardinalityRange lo_cr1_1 hi_cr1_2
cr2_21 = CardinalityRange lo_cr2_2 hi_cr2_1
answ_21 err_or_fit = (err_or_fit, cr1_21, cr2_21)
in answ_21 $ case order21 of
EQ -> Right SecondInFirst
GT -> Right $ Intersection $ CardinalityRange hi_cr1_2 lo_cr2_2
LT -> Left $ LowerBoundaryAfterHigher Second cr2_21
GT -> answ_2 $ Left $ LowerBoundaryAfterHigher First cr1_2
EQ -> let step3@(order3, lo_cr2_2, hi_cr2_1) = almostStrictCompare2LCs lo_cr2_1 hi_cr2_0 -- 3: 1 2 2 1
cr1_3 = CardinalityRange lo_cr1_1 hi_cr1_2
cr2_3 = CardinalityRange lo_cr2_2 hi_cr2_1
answ_3 err_or_fit = (err_or_fit, cr1_3, cr2_3)
in answ_3 $ case order3 of -- traceShow ("Step 3: ", step3)
LT -> Right FirstInSecond
EQ -> Right EqualSets
GT -> Left $ LowerBoundaryAfterHigher First cr1_3
GT -> let step4@(order4, lo_cr1_1, hi_cr2_1) = almostStrictCompare2LCs lo_cr1_0 hi_cr2_0 -- 4: 1 1 1 1
in case order4 of
GT -> (Right NoIntersection, CardinalityRange lo_cr1_1 hi_cr1_1, CardinalityRange lo_cr2_1 hi_cr2_1)
EQ -> let step5@(order5, lo_cr2_2, hi_cr2_2) = almostStrictCompare2LCs lo_cr2_1 hi_cr2_1 -- 5: 1 1 2 2
cr1_5 = CardinalityRange lo_cr1_1 hi_cr1_1
cr2_5 = CardinalityRange lo_cr2_2 hi_cr2_2
answ_5 err_or_fit = (err_or_fit, cr1_5, cr2_5)
in case order5 of
LT -> let step51@(order51, lo_cr1_2, hi_cr1_2) = almostStrictCompare2LCs lo_cr1_1 hi_cr1_1 -- 51: 2 2 2 2
cr1_51 = CardinalityRange lo_cr1_2 hi_cr1_2
cr2_51 = CardinalityRange lo_cr2_2 hi_cr2_2
answ_51 err_or_fit = (err_or_fit, cr1_51, cr2_51)
in answ_51 $ case order51 of
LT -> Left $ LowerBoundaryAfterHigher First cr1_51
EQ -> Right FirstInSecond
GT -> Right $ Intersection $ CardinalityRange lo_cr1_2 hi_cr2_2
EQ -> answ_5 $ Right SecondInFirst
GT -> answ_5 $ Left $ LowerBoundaryAfterHigher Second cr2_5
LT -> let step6@(order6, lo_cr1_2, lo_cr2_2) = almostStrictCompare2LCs lo_cr1_1 lo_cr2_1 -- 6: 2 1 2 1
step7@(order7, hi_cr1_2, hi_cr2_2) = almostStrictCompare2LCs hi_cr1_1 hi_cr2_1 -- 7: 2 2 2 2
cr1_67 = CardinalityRange lo_cr1_2 hi_cr1_2
cr2_67 = CardinalityRange lo_cr2_2 hi_cr2_2
answ_67 _fit = (Right _fit, cr1_67, cr2_67)
in answ_67 $ case (order6, order7) of
(EQ, EQ) -> EqualSets
(EQ, GT) -> SecondInFirst
(LT, EQ) -> SecondInFirst
(LT, GT) -> SecondInFirst
(EQ, LT) -> FirstInSecond
(GT, LT) -> FirstInSecond
(GT, EQ) -> FirstInSecond
(LT, LT) -> Intersection $ CardinalityRange lo_cr2_2 hi_cr1_2
(GT, GT) -> Intersection $ CardinalityRange lo_cr1_2 hi_cr2_2
instance Intersectable CardinalityRange where
setFits cr1 cr2 = case fst3 $ compare2CRs cr1 cr2 of { Right r -> r; Left e -> error $ show e }
where
fst3 :: (a,b,c) -> a
fst3 (a,_,_) = a
-- | Wrapper around @'setFits'@ of typeclass @'Intersectable'@
crFitsInCR :: CardinalityRange -> CardinalityRange -> SetsFit CardinalityRange
crFitsInCR = setFits
infixr 9 `crFitsInCR`
-- * Popular cardinality ranges constructors.
-- | Same as @'cr0_Inf'@.
crNoConstraint :: CardinalityRange
-- | Only zero elements.
cr0 :: CardinalityRange
-- | Only one element.
cr1 :: CardinalityRange
-- | Zero or one element.
cr0_1 :: CardinalityRange
-- | Any count of elements.
cr0_Inf :: CardinalityRange
-- | Any nonzero count of elements.
cr1_Inf :: CardinalityRange
-- | Concrete count of elements.
crX :: PreciseCardinality -> CardinalityRange
-- | A concrete range.
crXY :: PreciseCardinality -> PreciseCardinality -> CardinalityRange
crNoConstraint = cr0_Inf
cr0 = cardinalityRange (preciseC 0) (preciseC 0)
cr1 = cardinalityRange (preciseC 1) (preciseC 1)
cr0_1 = cardinalityRange (preciseC 0) (preciseC 1)
cr0_Inf = cardinalityRange (preciseC 0) infiniteC
cr1_Inf = cardinalityRange (preciseC 1) infiniteC
crX x = cardinalityRange (preciseC x) (preciseC x)
crXY x y = cardinalityRange (preciseC x) (preciseC y)
--------------------------------------------------------------
-- * Application 0
type CardinalityConstraint = CardinalityRange
-- | @cFitsInCC = 'cFitsInCR'@
--
-- Defined to satisfy abbreviation.
cFitsInCC :: LazyCardinality -> CardinalityConstraint -> Bool
cFitsInCC = cFitsInCR
infixr 9 `cFitsInCC`
-- | @fitsInCC = 'fitsInCR'@
--
-- Defined to satisfy abbreviation.
fitsInCC :: HasCard a => a -> CardinalityConstraint -> Bool
fitsInCC = fitsInCR
infixr 9 `fitsInCC`
-- | @fitsInCC = 'fitsInCR_T'@
--
-- Defined to satisfy abbreviation.
fitsInCC_T :: HasCardT c => c a -> CardinalityConstraint -> Bool
fitsInCC_T = fitsInCR_T
infixr 9 `fitsInCC_T`
-- | @HasCardConstr@ = \"Has cardinality constraint\". In other words, \"there
-- is a capacity constraint for this container\".
class HasCardConstr a where
cardinalityConstraintOf :: a -> CardinalityConstraint
-- | @HasCardConstrT@ = \"Has cardinality constraint (for container types of
-- kind @(* -> *)@)\".
-- In other words, \"there is a capacity constraint for this container type
-- of kind @(* -> *)@\".
class HasCardConstrT c where
cardinalityConstraintOfT :: c a -> CardinalityConstraint
-- | Wrapper around @'cFitsInCC'@.
cFitsIn :: HasCardConstr b => LazyCardinality -> b -> Bool
cFitsIn c hasCC = c `cFitsInCC` cardinalityConstraintOf hasCC
infixr 9 `cFitsIn`
-- | Wrapper around @'cFitsInCC'@.
cFitsInT :: HasCardConstrT c => LazyCardinality -> c b -> Bool
cFitsInT c hasCC = c `cFitsInCC` cardinalityConstraintOfT hasCC
infixr 9 `cFitsInT`
-- | Wrapper around @'cFitsInCC'@.
fitsIn :: (HasCard a, HasCardConstr b) => a -> b -> Bool
fitsIn hasC hasCC = cardOf hasC `cFitsInCC` cardinalityConstraintOf hasCC
infixr 9 `fitsIn`
-- | Wrapper around @'cFitsInCC'@.
fitsInT :: (HasCardT c, HasCardConstrT d) => c a -> d b -> Bool
fitsInT hasC hasCC = cardOfT hasC `cFitsInCC` cardinalityConstraintOfT hasCC
infixr 9 `fitsInT`
--------------------------------------------------------------
-- * Application 1
-- | @HasCardUCT@ = \"Has cardinality-unsafe container transform\".
-- Define transform that may thow an error, if contents of @from@ don't fit
-- in @to@ .
class HasCardUCT from to where
-- | \"u-\" prefix stands for \"unsafe-\"
uContTrans :: from -> to
-- | @HasCardUCT_T@ = \"Has cardinality-unsafe container
-- transform (for container types of kind @(* -> *)@)\".
-- Same thing as @'HasCardUCT'@, but for containers of kind @(* -> *)@.
class HasCardUCT_T from to where
-- | \"u-\" prefix stands for \"unsafe-\"
uContTransT :: from a -> to a
type TransformError_FromTypeName = String
type TransformError_ToTypeName = String
type TransformError_Details = String
-- | This error is used by @'HasCardUCT'@
-- typeclass instances in cases when @from@ container's contents
-- don't fit in @to@ container.
uContError :: TransformError_FromTypeName -> TransformError_ToTypeName -> TransformError_Details -> a
uContError from_t_name to_t_name details = error $
"An error occurred in the instance of HasCardUCT"
++ ", when trying to transform from type '" ++ from_t_name ++ "' to type '" ++ to_t_name ++ "'."
++ (case details of
[] -> ""
_ -> "Details: '" ++ details ++ "'."
)
-- | Same as @'uContError'@, but for use in
-- @'HasCardUCT_T'@ typeclass instances
uContErrorT :: TransformError_FromTypeName -> TransformError_ToTypeName -> TransformError_Details -> a
uContErrorT from_t_name to_t_name details = error $
"An error occurred in the instance of HasCardUCT_T"
++ ", when trying to transform from type '" ++ from_t_name ++ "' to type '" ++ to_t_name ++ "'."
++ (case details of
[] -> ""
_ -> "Details: '" ++ details ++ "'."
)
-- | A wrapper around @'uContTrans'@. Contrary to it, where \"u-\" prefix stands
-- for \"unsafe-\", here \"s-\" prefix stands for \"safe-\".
-- This is aimed to localize and exclude case, when contents of @from@ don't
-- fit in @to@ If @'HasCardUCT'@ instaniated
-- correctly, then @'sContTrans'@ should never allow
-- @'uContError'@ to be called by subject instance. It should return @Nothing@
-- instead.
sContTrans :: ( HasCard from
, HasCardConstr to
, HasCardUCT from to
) => from -> Maybe to
sContTrans from =
let to = uContTrans from
in case from `fitsIn` to of
True -> Just to
False -> Nothing
-- | A wrapper around @'uContTransT'@. Contrary to it, where \"u-\" prefix stands
-- for \"unsafe-\", here \"s-\" prefix stands for \"safe-\".
-- This is aimed to localize and exclude case, when contents of @(from a)@ don't
-- fit in @(to a)@ . If @'HasCardUCT_T'@ instaniated
-- correctly, then @'sContTransT'@ should never allow
-- @'uContErrorT'@ to be called by subject instance. It should return @Nothing@
-- instead.
sContTransT :: ( HasCardT from
, HasCardConstrT to
, HasCardUCT_T from to
) => from a -> Maybe (to a)
sContTransT from =
let to = uContTransT from
in case from `fitsInT` to of
True -> Just to
False -> Nothing
--------------------------------------------------------------
--------------------------------------------------------------
-- Instances 0
instance HasCardConstr () where
cardinalityConstraintOf _ = cr0
instance HasCardConstr (EmptySet a) where
cardinalityConstraintOf _ = cr0
instance HasCardConstrT EmptySet where
cardinalityConstraintOfT _ = cr0
-- instance HasCardConstr a where
-- cardinalityConstraintOf _ = cr1
instance HasCardConstr (Identity a) where
cardinalityConstraintOf _ = cr1
instance HasCardConstrT Identity where
cardinalityConstraintOfT _ = cr1
instance HasCardConstr (Maybe a) where
cardinalityConstraintOf _ = cr0_1
instance HasCardConstrT Maybe where
cardinalityConstraintOfT _ = cr0_1
instance HasCardConstr [a] where
cardinalityConstraintOf _ = cr0_Inf
instance HasCardConstrT ([]) where
cardinalityConstraintOfT _ = cr0_Inf
instance HasCardConstr (NeverEmptyList a) where
cardinalityConstraintOf _ = cr1_Inf
instance HasCardConstrT NeverEmptyList where
cardinalityConstraintOfT _ = cr1_Inf
instance HasCardConstr (Map k e) where
cardinalityConstraintOf _ = cr0_Inf
instance HasCardConstrT (Map k) where
cardinalityConstraintOfT _ = cr0_Inf
-- Here actually we may want an other look - one that involves the count of possible values key may take...
instance HasCardConstr (a,a) where { cardinalityConstraintOf _ = crX 2 }
instance HasCardConstr (a,a,a) where { cardinalityConstraintOf _ = crX 3 }
instance HasCardConstr (a,a,a,a) where { cardinalityConstraintOf _ = crX 4 }
instance HasCardConstr (a,a,a,a,a) where { cardinalityConstraintOf _ = crX 5 }
instance HasCardConstr (a,a,a,a,a,a) where { cardinalityConstraintOf _ = crX 6 }
instance HasCardConstr (a,a,a,a,a,a,a) where { cardinalityConstraintOf _ = crX 7 }
instance HasCardConstr (a,a,a,a,a,a,a,a) where { cardinalityConstraintOf _ = crX 8 }
instance HasCardConstr (a,a,a,a,a,a,a,a,a) where { cardinalityConstraintOf _ = crX 9 }
instance HasCardConstr (a,a,a,a,a,a,a,a,a,a) where { cardinalityConstraintOf _ = crX 10 }
instance HasCardConstr (a,a,a,a,a,a,a,a,a,a,a) where { cardinalityConstraintOf _ = crX 11 }
--------------------------------------------------------------
-- Instances 1
{-
instance HasCardUCT a a where
uContTrans = id
instance HasCardUCT_T a a where
uContTransT = id
-}
--------
instance HasCardUCT (EmptySet a) () where
uContTrans _ = ()
instance HasCardUCT () (EmptySet a) where
uContTrans _ = EmptySet
--
instance HasCardUCT (EmptySet a) (Maybe a) where
uContTrans _ = Nothing
instance HasCardUCT_T EmptySet Maybe where
uContTransT = uContTrans
instance HasCardUCT (Maybe a) (EmptySet a) where
uContTrans Nothing = EmptySet
uContTrans _ = uContError "Maybe a" "EmptySet a" "something can not be nothing"
instance HasCardUCT_T Maybe EmptySet where
uContTransT Nothing = EmptySet
uContTransT _ = uContErrorT "Maybe" "EmptySet" "something can not be nothing"
--
instance HasCardUCT (EmptySet a) [a] where
uContTrans _ = []
instance HasCardUCT_T EmptySet ([]) where
uContTransT = uContTrans
instance HasCardUCT [a] (EmptySet a) where
uContTrans [] = EmptySet
uContTrans _ = uContError "[a]" "EmptySet a" "something can not be nothing"
instance HasCardUCT_T ([]) EmptySet where
uContTransT [] = EmptySet
uContTransT _ = uContErrorT "[]" "EmptySet" "something can not be nothing"
--
instance HasCardUCT (EmptySet (k, e)) (Map k e) where
uContTrans _ = M.empty
-- Can't see any way to make an instance HasCardUCT here
instance HasCardUCT (Map k e) (EmptySet (k, e)) where
uContTrans mp =
case M.null mp of
True -> EmptySet
False -> uContError "Map k e" "EmptySet (k, e)" "something can not be nothing"
-- Can't see any way to make an instance HasCardUCT here
--------
{-
instance HasCardUCT a (Identity a) where
uContTrans = Identity
instance HasCardUCT a (Maybe a) where
uContTrans = Just
instance HasCardUCT a [a] where
uContTrans = (: [])
instance HasCardUCT a (NeverEmptyList a) where
uContTrans = nelSingleton
-}
instance HasCardUCT (k, e) (Map k e) where
uContTrans = uncurry M.singleton
instance HasCardUCT_T ((,) k) (Map k) where
uContTransT = uContTrans
--------
{-
instance HasCardUCT (Identity a) a where
uContTrans = runIdentity
instance HasCardUCT (Maybe a) a where
uContTrans (Just a) = a
uContTrans Nothing = uContError "Maybe a" "a" "nothing to identify in Nothing"
instance HasCardUCT [a] a where
uContTrans [] = uContError "[a]" "a" "nothing to identify in empty list"
uContTrans (h : []) = h
uContTrans (h : _) = uContError "[a]" "a" "too many identities"
instance HasCardUCT (NeverEmptyList a) a where
uContTrans (NEL h []) = h
uContTrans (NEL _ _) = uContError "NeverEmptyList a" "a" "too many identities"
-}
instance HasCardUCT (Map k e) (k, e) where
uContTrans mp =
case M.minViewWithKey mp of
Nothing -> uContError "Map k e" "(k, e)" "nothing to identify in empty list"
Just (row, rest_mp) ->
case M.null rest_mp of
True -> row
False -> uContError "Map k e" "(k, e)" "too many identities"
instance HasCardUCT_T (Map k) ((,) k) where
uContTransT = uContTrans
--------
instance HasCardUCT (Identity a) (Maybe a) where
uContTrans = Just . runIdentity
instance HasCardUCT_T Identity Maybe where
uContTransT = uContTrans
instance HasCardUCT (Identity a) [a] where
uContTrans i = [runIdentity i]
instance HasCardUCT_T Identity ([]) where
uContTransT = uContTrans
instance HasCardUCT (Identity a) (NeverEmptyList a) where
uContTrans i = NEL (runIdentity i) []
instance HasCardUCT_T Identity NeverEmptyList where
uContTransT = uContTrans
instance HasCardUCT (Identity (k, e)) (Map k e) where
uContTrans = uContTrans . runIdentity
-- Can't see any way to make an instance HasCardUCT here
--------
instance HasCardUCT (Maybe a) (Identity a) where
uContTrans (Just a) = Identity a
uContTrans Nothing = uContError "Maybe a" "Identity a" "nothing to identify in Nothing"
instance HasCardUCT_T Maybe Identity where
uContTransT = uContTrans
instance HasCardUCT [a] (Identity a) where
uContTrans [] = uContError "[a]" "Identity a" "nothing to identify in empty list"
uContTrans (h : []) = Identity h
uContTrans (h : _) = uContError "[a]" "Identity a" "too many identities"
instance HasCardUCT_T ([]) Identity where
uContTransT = uContTrans
instance HasCardUCT (NeverEmptyList a) (Identity a) where
uContTrans (NEL h []) = Identity h
uContTrans (NEL _ _) = uContError "NeverEmptyList a" "Identity a" "too many identities"
instance HasCardUCT_T NeverEmptyList Identity where
uContTransT = uContTrans
instance HasCardUCT (Map k e) (Identity (k, e)) where
uContTrans mp =
case M.minViewWithKey mp of
Nothing -> uContError "Map k e" "Identity (k, e)" "nothing to identify in empty list"
Just (row, rest_mp) ->
case M.null rest_mp of
True -> Identity row
False -> uContError "Map k e" "Identity (k, e)" "too many identities"
-- Can't see any way to make an instance HasCardUCT_T here
--------
instance HasCardUCT () (Maybe a) where
uContTrans _ = Nothing
instance HasCardUCT () [a] where
uContTrans _ = []
instance HasCardUCT () (Map k e) where
uContTrans _ = M.empty
--------
instance HasCardUCT (Maybe a) () where
uContTrans Nothing = ()
uContTrans _ = uContError "Maybe a" "()" "only Nothing transforms to unity" -- xD ... political, yes
instance HasCardUCT [a] () where
uContTrans [] = ()
uContTrans _ = uContError "[a]" "()" "only empty list transforms to unity"
instance HasCardUCT (Map k e) () where
uContTrans mp = case M.null mp of { True -> (); False -> uContError "Map a" "()" "only empty map transforms to unity"}
--------
instance HasCardUCT (Maybe a) [a] where
uContTrans Nothing = []
uContTrans (Just a) = [a]
instance HasCardUCT_T Maybe ([]) where
uContTransT = uContTrans
instance HasCardUCT (Maybe a) (NeverEmptyList a) where
uContTrans Nothing = uContError "Maybe a" "NeverEmptyList a" "there must be at least 1 element, Nothing is not the case"
uContTrans (Just a) = (NEL a [])
instance HasCardUCT_T Maybe NeverEmptyList where
uContTransT Nothing = uContErrorT "Maybe" "NeverEmptyList" "there must be at least 1 element, Nothing is not the case"
uContTransT (Just a) = (NEL a [])
instance HasCardUCT (Maybe (k, e)) (Map k e) where
uContTrans Nothing = M.empty
uContTrans (Just (k, e)) = M.singleton k e
-- Can't see any way to make an instance HasCardUCT_T here
--------
instance HasCardUCT [a] (Maybe a) where
uContTrans [] = Nothing
uContTrans (h : []) = Just h
uContTrans _ = uContError "[a]" "Maybe a" "too many elements to fit in Maybe"
instance HasCardUCT_T ([]) Maybe where
uContTransT [] = Nothing
uContTransT (h : []) = Just h
uContTransT _ = uContErrorT "[]" "Maybe" "too many elements to fit in Maybe"
instance HasCardUCT (NeverEmptyList a) (Maybe a) where
uContTrans (NEL a []) = Just a
uContTrans _ = uContError "NeverEmptyList a" "Maybe a" "too many elements to fit in Maybe"
instance HasCardUCT_T NeverEmptyList Maybe where
uContTransT (NEL a []) = Just a
uContTransT _ = uContErrorT "NeverEmptyList" "Maybe" "too many elements to fit in Maybe"
instance HasCardUCT (Map k e) (Maybe (k, e)) where
uContTrans mp =
case M.minViewWithKey mp of
Nothing -> Nothing
Just (row, rest_mp) ->
case M.null rest_mp of
True -> Just row
False -> uContError "Map k e" "Maybe (k, e)" "too many elements to fit in Maybe"
-- Can't see any way to make an instance HasCardUCT_T here
--------
instance HasCardUCT [a] (NeverEmptyList a) where
uContTrans [] = uContError "[a]" "NeverEmptyList a" "there must be at least 1 element"
uContTrans (h : t) = (NEL h t)
instance HasCardUCT_T ([]) NeverEmptyList where
uContTransT [] = uContErrorT "[a]" "NeverEmptyList a" "there must be at least 1 element"
uContTransT (h : t) = (NEL h t)
instance Ord k => HasCardUCT [(k, e)] (Map k e) where
uContTrans = M.fromList
-- Can't see any way to make an instance HasCardUCT_T here
--------
instance HasCardUCT (NeverEmptyList a) [a] where
uContTrans (NEL h t) = (h:t)
instance HasCardUCT_T NeverEmptyList ([]) where
uContTransT = uContTrans
instance HasCardUCT (Map k e) [(k, e)] where
uContTrans = M.toList
-- Can't see any way to make an instance HasCardUCT_T here
--------
instance Ord k => HasCardUCT (NeverEmptyList (k, e)) (Map k e) where
uContTrans (NEL h t) = M.fromList (h:t)
-- Can't see any way to make an instance HasCardUCT_T here
--------
instance HasCardUCT (Map k e) (NeverEmptyList (k, e)) where
uContTrans mp = case M.null mp of { False -> let (h:t) = M.toList mp in (NEL h t) ; True -> uContError "Map k e" "NeverEmptyList (k, e)" "there must be at least 1 element" }
-- Can't see any way to make an instance HasCardUCT_T here
--------------------------------------------------------------------------------------
instance HasCardUCT [a] (a,a) where { uContTrans l = case l of { (a:b:[]) -> (a,b); _ -> uContError "[a]" "(a,a)" "wrong count of elements" } }
instance HasCardUCT [a] (a,a,a) where { uContTrans l = case l of { (a:b:c:[]) -> (a,b,c); _ -> uContError "[a]" "(a,a,a)" "wrong count of elements" } }
instance HasCardUCT [a] (a,a,a,a) where { uContTrans l = case l of { (a:b:c:d:[]) -> (a,b,c,d); _ -> uContError "[a]" "(a,a,a,a)" "wrong count of elements" } }
instance HasCardUCT [a] (a,a,a,a,a) where { uContTrans l = case l of { (a:b:c:d:e:[]) -> (a,b,c,d,e); _ -> uContError "[a]" "(a,a,a,a,a)" "wrong count of elements" } }
instance HasCardUCT [a] (a,a,a,a,a,a) where { uContTrans l = case l of { (a:b:c:d:e:f:[]) -> (a,b,c,d,e,f); _ -> uContError "[a]" "(a,a,a,a,a,a)" "wrong count of elements" } }
instance HasCardUCT [a] (a,a,a,a,a,a,a) where { uContTrans l = case l of { (a:b:c:d:e:f:g:[]) -> (a,b,c,d,e,f,g); _ -> uContError "[a]" "(a,a,a,a,a,a,a)" "wrong count of elements" } }
instance HasCardUCT [a] (a,a,a,a,a,a,a,a) where { uContTrans l = case l of { (a:b:c:d:e:f:g:h:[]) -> (a,b,c,d,e,f,g,h); _ -> uContError "[a]" "(a,a,a,a,a,a,a,a)" "wrong count of elements" } }
instance HasCardUCT [a] (a,a,a,a,a,a,a,a,a) where { uContTrans l = case l of { (a:b:c:d:e:f:g:h:i:[]) -> (a,b,c,d,e,f,g,h,i); _ -> uContError "[a]" "(a,a,a,a,a,a,a,a,a)" "wrong count of elements" } }
instance HasCardUCT [a] (a,a,a,a,a,a,a,a,a,a) where { uContTrans l = case l of { (a:b:c:d:e:f:g:h:i:j:[]) -> (a,b,c,d,e,f,g,h,i,j); _ -> uContError "[a]" "(a,a,a,a,a,a,a,a,a,a)" "wrong count of elements" } }
instance HasCardUCT [a] (a,a,a,a,a,a,a,a,a,a,a) where { uContTrans l = case l of { (a:b:c:d:e:f:g:h:i:j:k:[]) -> (a,b,c,d,e,f,g,h,i,j,k); _ -> uContError "[a]" "(a,a,a,a,a,a,a,a,a,a,a)" "wrong count of elements" } }
instance HasCardUCT (a,a) [a] where { uContTrans (a,b) = (a:b:[]) }
instance HasCardUCT (a,a,a) [a] where { uContTrans (a,b,c) = (a:b:c:[]) }
instance HasCardUCT (a,a,a,a) [a] where { uContTrans (a,b,c,d) = (a:b:c:d:[]) }
instance HasCardUCT (a,a,a,a,a) [a] where { uContTrans (a,b,c,d,e) = (a:b:c:d:e:[]) }
instance HasCardUCT (a,a,a,a,a,a) [a] where { uContTrans (a,b,c,d,e,f) = (a:b:c:d:e:f:[]) }
instance HasCardUCT (a,a,a,a,a,a,a) [a] where { uContTrans (a,b,c,d,e,f,g) = (a:b:c:d:e:f:g:[]) }
instance HasCardUCT (a,a,a,a,a,a,a,a) [a] where { uContTrans (a,b,c,d,e,f,g,h) = (a:b:c:d:e:f:g:h:[]) }
instance HasCardUCT (a,a,a,a,a,a,a,a,a) [a] where { uContTrans (a,b,c,d,e,f,g,h,i) = (a:b:c:d:e:f:g:h:i:[]) }
instance HasCardUCT (a,a,a,a,a,a,a,a,a,a) [a] where { uContTrans (a,b,c,d,e,f,g,h,i,j) = (a:b:c:d:e:f:g:h:i:j:[]) }
instance HasCardUCT (a,a,a,a,a,a,a,a,a,a,a) [a] where { uContTrans (a,b,c,d,e,f,g,h,i,j,k) = (a:b:c:d:e:f:g:h:i:j:k:[]) }