module Data.Express.Utils.Typeable
( tyArity
, unFunTy
, isFunTy
, argumentTy
, resultTy
, finalResultTy
, boolTy
, intTy
, orderingTy
, mkComparisonTy
, mkCompareTy
, funTyCon
, compareTy
, elementTy
, typesIn
, typesInList
, countListTy
, (->::)
, module Data.Typeable
)
where
import Data.Typeable
import Data.Express.Utils
compareTy :: TypeRep -> TypeRep -> Ordering
compareTy :: TypeRep -> TypeRep -> Ordering
compareTy TypeRep
t1 TypeRep
t2 | TypeRep
t1 TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRep
t2 = Ordering
EQ
compareTy TypeRep
t1 TypeRep
t2 = TypeRep -> Int
tyArity TypeRep
t1 Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` TypeRep -> Int
tyArity TypeRep
t2
Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> [TypeRep] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeRep]
ts1 Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` [TypeRep] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeRep]
ts2
Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> TyCon -> String
showTyCon TyCon
c1 String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` TyCon -> String
showTyCon TyCon
c2
Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> (Ordering -> Ordering -> Ordering)
-> Ordering -> [Ordering] -> Ordering
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
(<>) Ordering
EQ ((TypeRep -> TypeRep -> Ordering)
-> [TypeRep] -> [TypeRep] -> [Ordering]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TypeRep -> TypeRep -> Ordering
compareTy [TypeRep]
ts1 [TypeRep]
ts2)
where
(TyCon
c1,[TypeRep]
ts1) = TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
t1
(TyCon
c2,[TypeRep]
ts2) = TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
t2
showTyCon :: TyCon -> String
showTyCon :: TyCon -> String
showTyCon TyCon
con
| TyCon
con TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
listTyCon = String
"[]"
| TyCon
con TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unitTyCon = String
"()"
| Bool
otherwise = TyCon -> String
forall a. Show a => a -> String
show TyCon
con
tyArity :: TypeRep -> Int
tyArity :: TypeRep -> Int
tyArity TypeRep
t
| TypeRep -> Bool
isFunTy TypeRep
t = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TypeRep -> Int
tyArity (TypeRep -> TypeRep
resultTy TypeRep
t)
| Bool
otherwise = Int
0
finalResultTy :: TypeRep -> TypeRep
finalResultTy :: TypeRep -> TypeRep
finalResultTy TypeRep
t
| TypeRep -> Bool
isFunTy TypeRep
t = TypeRep -> TypeRep
finalResultTy (TypeRep -> TypeRep
resultTy TypeRep
t)
| Bool
otherwise = TypeRep
t
unFunTy :: TypeRep -> (TypeRep,TypeRep)
unFunTy :: TypeRep -> (TypeRep, TypeRep)
unFunTy TypeRep
t
| TypeRep -> Bool
isFunTy TypeRep
t = let (TyCon
f,[TypeRep
a,TypeRep
b]) = TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
t in (TypeRep
a,TypeRep
b)
| Bool
otherwise = String -> String -> (TypeRep, TypeRep)
forall a. String -> String -> a
errorOn String
"unFunTy" (String -> (TypeRep, TypeRep)) -> String -> (TypeRep, TypeRep)
forall a b. (a -> b) -> a -> b
$ String
"`" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not a function type"
argumentTy :: TypeRep -> TypeRep
argumentTy :: TypeRep -> TypeRep
argumentTy = (TypeRep, TypeRep) -> TypeRep
forall a b. (a, b) -> a
fst ((TypeRep, TypeRep) -> TypeRep)
-> (TypeRep -> (TypeRep, TypeRep)) -> TypeRep -> TypeRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> (TypeRep, TypeRep)
unFunTy
resultTy :: TypeRep -> TypeRep
resultTy :: TypeRep -> TypeRep
resultTy = (TypeRep, TypeRep) -> TypeRep
forall a b. (a, b) -> b
snd ((TypeRep, TypeRep) -> TypeRep)
-> (TypeRep -> (TypeRep, TypeRep)) -> TypeRep -> TypeRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> (TypeRep, TypeRep)
unFunTy
elementTy :: TypeRep -> TypeRep
elementTy :: TypeRep -> TypeRep
elementTy TypeRep
t
| TypeRep -> Bool
isListTy TypeRep
t = let (TyCon
_,[TypeRep
a]) = TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
t in TypeRep
a
| Bool
otherwise = String -> String -> TypeRep
forall a. String -> String -> a
errorOn String
"elementTy" (String -> TypeRep) -> String -> TypeRep
forall a b. (a -> b) -> a -> b
$ String
"`" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not a list type"
boolTy :: TypeRep
boolTy :: TypeRep
boolTy = Bool -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Bool
forall a. HasCallStack => a
undefined :: Bool)
intTy :: TypeRep
intTy :: TypeRep
intTy = Int -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Int
forall a. HasCallStack => a
undefined :: Int)
orderingTy :: TypeRep
orderingTy :: TypeRep
orderingTy = Ordering -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Ordering
forall a. HasCallStack => a
undefined :: Ordering)
funTyCon :: TyCon
funTyCon :: TyCon
funTyCon = TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> TypeRep -> TyCon
forall a b. (a -> b) -> a -> b
$ (() -> ()) -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (() -> ()
forall a. HasCallStack => a
undefined :: () -> ())
listTyCon :: TyCon
listTyCon :: TyCon
listTyCon = TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> TypeRep -> TyCon
forall a b. (a -> b) -> a -> b
$ [()] -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf ([()]
forall a. HasCallStack => a
undefined :: [()])
unitTyCon :: TyCon
unitTyCon :: TyCon
unitTyCon = TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> TypeRep -> TyCon
forall a b. (a -> b) -> a -> b
$ () -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (()
forall a. HasCallStack => a
undefined :: ())
isFunTy :: TypeRep -> Bool
isFunTy :: TypeRep -> Bool
isFunTy TypeRep
t =
case TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
t of
(TyCon
con,[TypeRep
_,TypeRep
_]) | TyCon
con TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
funTyCon -> Bool
True
(TyCon, [TypeRep])
_ -> Bool
False
isListTy :: TypeRep -> Bool
isListTy :: TypeRep -> Bool
isListTy TypeRep
t = case TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
t of
(TyCon
con,[TypeRep
_]) | TyCon
con TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
listTyCon -> Bool
True
(TyCon, [TypeRep])
_ -> Bool
False
countListTy :: TypeRep -> Int
countListTy :: TypeRep -> Int
countListTy TypeRep
t = case TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
t of
(TyCon
con,[TypeRep
t']) | TyCon
con TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
listTyCon -> Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TypeRep -> Int
countListTy TypeRep
t'
(TyCon, [TypeRep])
_ -> Int
0
mkComparisonTy :: TypeRep -> TypeRep
mkComparisonTy :: TypeRep -> TypeRep
mkComparisonTy TypeRep
a = TypeRep
a TypeRep -> TypeRep -> TypeRep
->:: TypeRep
a TypeRep -> TypeRep -> TypeRep
->:: TypeRep
boolTy
mkCompareTy :: TypeRep -> TypeRep
mkCompareTy :: TypeRep -> TypeRep
mkCompareTy TypeRep
a = TypeRep
a TypeRep -> TypeRep -> TypeRep
->:: TypeRep
a TypeRep -> TypeRep -> TypeRep
->:: TypeRep
orderingTy
typesIn :: TypeRep -> [TypeRep]
typesIn :: TypeRep -> [TypeRep]
typesIn TypeRep
t = [TypeRep] -> [TypeRep]
typesInList [TypeRep
t]
typesInList :: [TypeRep] -> [TypeRep]
typesInList :: [TypeRep] -> [TypeRep]
typesInList [TypeRep]
ts = (TypeRep -> TypeRep -> Ordering) -> [TypeRep] -> [TypeRep]
forall a. (a -> a -> Ordering) -> [a] -> [a]
nubSortBy TypeRep -> TypeRep -> Ordering
compareTy ([TypeRep] -> [TypeRep]) -> [TypeRep] -> [TypeRep]
forall a b. (a -> b) -> a -> b
$ [TypeRep] -> [TypeRep] -> [TypeRep]
tins [TypeRep]
ts []
where
tin :: TypeRep -> [TypeRep] -> [TypeRep]
tin TypeRep
t = (TypeRep
tTypeRep -> [TypeRep] -> [TypeRep]
forall a. a -> [a] -> [a]
:) ([TypeRep] -> [TypeRep])
-> ([TypeRep] -> [TypeRep]) -> [TypeRep] -> [TypeRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeRep] -> [TypeRep] -> [TypeRep]
tins (TypeRep -> [TypeRep]
typeRepArgs TypeRep
t)
tins :: [TypeRep] -> [TypeRep] -> [TypeRep]
tins = (TypeRep -> ([TypeRep] -> [TypeRep]) -> [TypeRep] -> [TypeRep])
-> ([TypeRep] -> [TypeRep]) -> [TypeRep] -> [TypeRep] -> [TypeRep]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (([TypeRep] -> [TypeRep])
-> ([TypeRep] -> [TypeRep]) -> [TypeRep] -> [TypeRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (([TypeRep] -> [TypeRep])
-> ([TypeRep] -> [TypeRep]) -> [TypeRep] -> [TypeRep])
-> (TypeRep -> [TypeRep] -> [TypeRep])
-> TypeRep
-> ([TypeRep] -> [TypeRep])
-> [TypeRep]
-> [TypeRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> [TypeRep] -> [TypeRep]
tin) [TypeRep] -> [TypeRep]
forall a. a -> a
id
(->::) :: TypeRep -> TypeRep -> TypeRep
->:: :: TypeRep -> TypeRep -> TypeRep
(->::) = TypeRep -> TypeRep -> TypeRep
mkFunTy
infixr 9 ->::
errorOn :: String -> String -> a
errorOn :: forall a. String -> String -> a
errorOn String
fn String
msg = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Data.Express.Utils.Typeable." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg