module Data.Cardinality.ContTrans (
CardinalityConstraint
, cFitsInCC
, fitsInCC
, fitsInCC_T
, HasCardConstr(..)
, HasCardConstrT(..)
, cFitsIn
, cFitsInT
, fitsIn
, fitsInT
, 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 Control.Monad.Identity
type CardinalityConstraint = CardinalityRange
cFitsInCC :: LazyCardinality -> CardinalityConstraint -> Bool
cFitsInCC = cFitsInCR
infixr 9 `cFitsInCC`
fitsInCC :: HasCard a => a -> CardinalityConstraint -> Bool
fitsInCC = fitsInCR
infixr 9 `fitsInCC`
fitsInCC_T :: HasCardT c => c a -> CardinalityConstraint -> Bool
fitsInCC_T = fitsInCR_T
infixr 9 `fitsInCC_T`
class HasCardConstr a where
cardinalityConstraintOf :: a -> CardinalityConstraint
class HasCardConstrT c where
cardinalityConstraintOfT :: c a -> CardinalityConstraint
cFitsIn :: HasCardConstr b => LazyCardinality -> b -> Bool
cFitsIn c hasCC = c `cFitsInCC` cardinalityConstraintOf hasCC
infixr 9 `cFitsIn`
cFitsInT :: HasCardConstrT c => LazyCardinality -> c b -> Bool
cFitsInT c hasCC = c `cFitsInCC` cardinalityConstraintOfT hasCC
infixr 9 `cFitsInT`
fitsIn :: (HasCard a, HasCardConstr b) => a -> b -> Bool
fitsIn hasC hasCC = cardOf hasC `cFitsInCC` cardinalityConstraintOf hasCC
infixr 9 `fitsIn`
fitsInT :: (HasCardT c, HasCardConstrT d) => c a -> d b -> Bool
fitsInT hasC hasCC = cardOfT hasC `cFitsInCC` cardinalityConstraintOfT hasCC
infixr 9 `fitsInT`
class HasCardUCT from to where
uContTrans :: from -> to
class HasCardUCT_T from to where
uContTransT :: from a -> to a
type TransformError_FromTypeName = String
type TransformError_ToTypeName = String
type TransformError_Details = String
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 ++ "'."
)
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 ++ "'."
)
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
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
type From_LazyCardinality = LazyCardinality
type To_CardinalityConstraint = CardinalityConstraint
data ContainerOrder =
FirstOrderContainer
| SecondOrderContainer
deriving (Eq, Ord, Show)
data ContTransError = ContTransError From_LazyCardinality Ordering To_CardinalityConstraint ContainerOrder deriving (Show)
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
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
instance HasCardConstr () where
cardinalityConstraintOf _ = cr0
instance HasCardConstr (EmptySet a) where
cardinalityConstraintOf _ = cr0
instance HasCardConstrT EmptySet where
cardinalityConstraintOfT _ = cr0
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
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 }
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
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"
instance HasCardUCT (k, e) (Map k e) where
uContTrans = uncurry M.singleton
instance HasCardUCT_T ((,) k) (Map k) where
uContTransT = uContTrans
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
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"
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"
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
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"
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
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
instance Ord k => HasCardUCT (NeverEmptyList (k, e)) (Map k e) where
uContTrans (NEL h t) = M.fromList (h:t)
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" }
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:[]) }