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