-- |
-- Module      : Data.Express.Utils.Typeable
-- Copyright   : (c) 2016-2024 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
  , countListTy
  , (->::)
  , module Data.Typeable
  )
where

import Data.Typeable
import Data.Express.Utils

-- | Compares two 'TypeRep's.
--
-- Different versions of Typeable/GHC
-- provide different orderings for 'TypeRep's.
-- 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.
--
-- > > typeOf (undefined :: Int -> Int) `compareTy` typeOf (undefined :: () -> () -> ())
-- > LT
--
-- > > typeOf (undefined :: Int) `compareTy` typeOf (undefined :: ())
-- > GT
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 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

-- | Shows a 'TyCon' consistently across different GHC versions.
--   This is needed in the implementation of `compareTy`.
--
-- On GHC <= 9.4:
--
-- > > show listTyCon
-- > "[]"
--
-- On GHC >= 9.6:
--
-- > > show listTyCon
-- > "List"
--
-- On all GHCs:
--
-- > > showTyCon listTyCon
-- > "[]"
--
-- On GHC <= 9.6:
--
-- > > show unitTyCon
-- > "()"
--
-- On GHC >= 9.8:
--
-- > > show unitTyCon
-- > "Unit"
--
-- On all GHCs:
--
-- > > showTyCon unitTyCon
-- > "()"
--
-- Further exceptions to `show :: TyCon -> String` may be added here
-- on future versions.
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

-- | Returns the functional arity of the given 'TypeRep'.
--
-- > > tyArity $ typeOf (undefined :: Int)
-- > 0
--
-- > > tyArity $ typeOf (undefined :: Int -> Int)
-- > 1
--
-- > > tyArity $ typeOf (undefined :: (Int,Int))
-- > 0
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

-- | Returns the ultimate result type of the given 'TypeRep'.
--
-- > > finalResultTy (typeOf (undefined :: Int))
-- > Int
--
-- > > finalResultTy (typeOf (undefined :: Int -> Char))
-- > Char
--
-- > > finalResultTy (typeOf (undefined :: Int -> Char -> Bool))
-- > Bool
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

-- | Deconstructs a functional 'TypeRep' into a pair of 'TypeRep's.
--
-- > > unFunTy $ typeOf (undefined :: Int -> Char -> Bool)
-- > (Int,Char -> Bool)
--
-- This function raises an error on non-functional types.
--
-- (cf. 'argumentTy' and 'resultTy')
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"

-- | Returns the argument 'TypeRep' of a given functional 'TypeRep'.
--
-- > argumentTy $ typeOf (undefined :: Int -> Char)
-- > Int
--
-- This function raises an error on non-functional types.
--
-- (cf. 'resultTy')
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

-- | Returns the result 'TypeRep' of a given functional 'TypeRep'.
--
-- > > resultTy $ typeOf (undefined :: Int -> Char)
-- > Char
--
-- > > resultTy $ typeOf (undefined :: Int -> Char -> Bool)
-- > Char -> Bool
--
-- This function raises an error on non-functional types.
--
-- (cf. 'argumentTy' and 'finalResultTy')
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: Data.Express.Utils.Typeable.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 -> 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"

-- | The 'Bool' type encoded as a 'TypeRep'.
boolTy :: TypeRep
boolTy :: TypeRep
boolTy = Bool -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Bool
forall a. HasCallStack => a
undefined :: Bool)

-- | The 'Int' type encoded as a 'TypeRep'.
intTy :: TypeRep
intTy :: TypeRep
intTy = Int -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Int
forall a. HasCallStack => a
undefined :: Int)

-- | The 'Ordering' type encoded as a 'TypeRep'.
orderingTy :: TypeRep
orderingTy :: TypeRep
orderingTy = Ordering -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Ordering
forall a. HasCallStack => a
undefined :: Ordering)

-- | The function type constructor as a 'TyCon'
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 :: () -> ())

-- | The list type constructor as a 'TyCon'
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 :: [()])

-- | The unit type constructor as a 'TyCon'
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 :: ())

-- | Returns whether a 'TypeRep' is functional.
--
-- > > isFunTy $ typeOf (undefined :: Int -> Int)
-- > True
-- > > isFunTy $ typeOf (undefined :: Int)
-- > False
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

-- | Return the number of outer list nestings in a 'TypeRep'
--
-- > > countListTy $ typeOf (undefined :: Int)
-- > 0
--
-- > > countListTy $ typeOf (undefined :: [Bool])
-- > 1
--
-- > > countListTy $ typeOf (undefined :: [[()]])
-- > 2
--
-- > > countListTy $ typeOf (undefined :: String)
-- > 1
--
-- > > countListTy $ typeOf (undefined :: ([Int],[Bool]))
-- > 0
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

-- | Constructs a comparison type (@ a -> a -> Bool @)
--   from the given argument type.
--
-- > > mkComparisonTy $ typeOf (undefined :: Int)
-- > Int -> Int -> Bool
--
-- > > mkComparisonTy $ typeOf (undefined :: ())
-- > () -> () -> Bool
mkComparisonTy :: TypeRep -> TypeRep
mkComparisonTy :: TypeRep -> TypeRep
mkComparisonTy TypeRep
a = TypeRep
a TypeRep -> TypeRep -> TypeRep
->:: TypeRep
a TypeRep -> TypeRep -> TypeRep
->:: TypeRep
boolTy

-- | Constructs a "compare" type (@ a -> a -> Ordering @)
--   from the given argument type.
--
-- > > mkCompareTy $ typeOf (undefined :: Int)
-- > Int -> Int -> Ordering
--
-- > > mkCompareTy $ typeOf (undefined :: ())
-- > () -> () -> Ordering

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]

-- | Returns types and subtypes from the given list of 'TypeRep's.
--
-- > > typesInList [typeOf (undefined :: () -> Int), typeOf (undefined :: String -> String -> Bool)]
-- > [(),Bool,Char,Int,[Char],() -> Int,[Char] -> Bool,[Char] -> [Char] -> Bool]
--
-- > > typesInList [typeOf (undefined :: (Char,Int))]
-- > [Char,Int,(Char,Int)]
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

-- | An infix alias for 'mkFunTy'.  It is right associative.
(->::) :: 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