-- |
-- Module      : Data.Express.Utils.Typeable
-- Copyright   : (c) 2016-2021 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- This module is part of Express.
--
-- Utilities to manipulate 'TypeRep's (of 'Typeable' values).
module Data.Express.Utils.Typeable
  ( tyArity
  , unFunTy
  , isFunTy
  , argumentTy
  , resultTy
  , finalResultTy
  , boolTy
  , intTy
  , orderingTy
  , mkComparisonTy
  , mkCompareTy
  , funTyCon
  , compareTy
  , elementTy
  , typesIn
  , typesInList
  , (->::)
  , module Data.Typeable
  )
where

import Data.Typeable
import Data.Monoid ((<>))
import Data.Express.Utils.List

-- Different versions of Typeable/GHC provide different orderings for TypeReps.
-- The following is a version independent ordering, with the following
-- properties:
--
-- * functional types with more arguments are larger;
-- * type constructors with more arguments are larger.
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 -- optional optimization
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 (t :: * -> *) a. Foldable t => t a -> Int
length [TypeRep]
ts1 Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` [TypeRep] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeRep]
ts2
               Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> TyCon -> String
forall a. Show a => a -> String
show TyCon
c1 String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` TyCon -> String
forall a. Show a => a -> String
show TyCon
c2
               Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> (Ordering -> Ordering -> Ordering)
-> Ordering -> [Ordering] -> Ordering
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

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 -> (TypeRep, TypeRep)
forall a. HasCallStack => String -> a
error (String -> (TypeRep, TypeRep)) -> String -> (TypeRep, TypeRep)
forall a b. (a -> b) -> a -> b
$ String
"error (unFunTy): `" 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

-- | This function returns the type of the element of a list.
--   It will throw an error when not given the list type.
--
--   > > > elementTy $ typeOf (undefined :: [Int])
--   > Int
--   > > > elementTy $ typeOf (undefined :: [[Int]])
--   > [Int]
--   > > > elementTy $ typeOf (undefined :: [Bool])
--   > Bool
--   > > > elementTy $ typeOf (undefined :: Bool)
--   > *** Exception: error (elementTy): `Bool' is not a list type
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 -> TypeRep
forall a. HasCallStack => String -> a
error (String -> TypeRep) -> String -> TypeRep
forall a b. (a -> b) -> a -> b
$ String
"error (elementTy): `" 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 :: [()])

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

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

-- | /O(n)/.
-- Return all sub types of a given type including itself.
--
-- > > typesIn $ typeOf (undefined :: Int)
-- > [Int]
--
-- > > typesIn $ typeOf (undefined :: Bool)
-- > [Bool]
--
-- > > typesIn $ typeOf (undefined :: [Int])
-- > [ Int
-- > , [Int]
-- > ]
--
-- > > typesIn $ typeOf (undefined :: Int -> Int -> Int)
-- > [ Int
-- > , Int -> Int
-- > , Int -> Int -> Int
-- > ]
--
-- > > typesIn $ typeOf (undefined :: Int -> [Int] -> [Int])
-- > [ Int
-- > , [Int]
-- > , [Int] -> [Int]
-- > , Int -> [Int] -> [Int]
-- > ]
--
-- > > typesIn $ typeOf (undefined :: Maybe Bool)
-- > [ Bool
-- > , Maybe Bool
-- > ]
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]
ts  =  (([TypeRep] -> [TypeRep])
 -> ([TypeRep] -> [TypeRep]) -> [TypeRep] -> [TypeRep])
-> ([TypeRep] -> [TypeRep])
-> [[TypeRep] -> [TypeRep]]
-> [TypeRep]
-> [TypeRep]
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]
forall a. a -> a
id ((TypeRep -> [TypeRep] -> [TypeRep])
-> [TypeRep] -> [[TypeRep] -> [TypeRep]]
forall a b. (a -> b) -> [a] -> [b]
map TypeRep -> [TypeRep] -> [TypeRep]
tin [TypeRep]
ts)

-- | An infix alias for 'mkFunTy'.  It is right associative.
(->::) :: TypeRep -> TypeRep -> TypeRep
->:: :: TypeRep -> TypeRep -> TypeRep
(->::) = TypeRep -> TypeRep -> TypeRep
mkFunTy
infixr 9 ->::