module Data.Type.Internal.Framework
( TypeID()
, makeTypeID
, applyTypeID
, mapTypeID
, kindStarLimit
) where
import Data.Char (isAlpha)
import Data.Type.Kind
import Data.Type.Internal.Key
import Data.HashTable (hashString)
import Data.Word
import System.IO.Unsafe (unsafePerformIO)
type Key = Word
metaKey :: TypeID -> Key
metaKey = unsafePerformIO $ keyTable succ 0
data TypeID
= TypeID Key String String String
| TypeApp Key TypeID TypeID
instance Hash TypeID where
hashValue (TypeID _ pkg mod occ) = hashString pkg * hashString mod * hashString occ
hashValue (TypeApp _ f p) = hashValue f * hashValue p
hashEqual (TypeID _ pkg0 mod0 occ0) (TypeID _ pkg1 mod1 occ1)
= pkg0==pkg1 && mod0==mod1 && occ0==occ1
hashEqual (TypeApp _ f0 p0) (TypeApp _ f1 p1) = hashEqual f0 f1 && hashEqual p0 p1
hashEqual _ _ = False
instance Ord TypeID where
compare (TypeID k0 _ _ _) (TypeID k1 _ _ _) = compare k0 k1
compare (TypeApp k0 _ _) (TypeID k1 _ _ _) = compare k0 k1
compare (TypeID k0 _ _ _) (TypeApp k1 _ _) = compare k0 k1
compare (TypeApp k0 _ _) (TypeApp k1 _ _) = compare k0 k1
instance Eq TypeID where
(==) (TypeID k0 _ _ _) (TypeID k1 _ _ _) = k0 == k1
(==) (TypeApp k0 _ _) (TypeApp k1 _ _) = k0 == k1
(==) _ _ = False
makeTypeID
:: String
-> String
-> String
-> TypeID
makeTypeID pkg mod occ = let r = TypeID (metaKey r) pkg mod occ in r
applyTypeID
:: TypeID
-> TypeID
-> TypeID
applyTypeID f p = let r = TypeApp (metaKey r) f p in r
mapTypeID
:: forall r
. (String -> String -> String -> r)
-> (r -> r -> r)
-> TypeID
-> r
mapTypeID conf appf (TypeApp _ c p) = appf (mapTypeID conf appf c) (mapTypeID conf appf p)
mapTypeID conf appf (TypeID _ pkg mod occ) = conf pkg mod occ
instance Show TypeID where
show (TypeID _ pkg mod occ) =
let pocc = if isAlpha $ head occ then occ else '(' : occ ++ ")"
in mod ++ "." ++ pocc
show (TypeApp _ f p@(TypeApp _ _ _)) = show f ++ " (" ++ show p ++ ")"
show (TypeApp _ f p) = show f ++ ' ' : show p
kindStarLimit :: Int
kindStarLimit = 8