{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Data.Type.Internal.Framework
	( TypeID()
--	, TypeWrapper(..)
	, 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
{-# NOINLINE metaKey #-}
metaKey :: TypeID -> Key
metaKey = unsafePerformIO $ keyTable succ 0

-- | An unique identifier for types.
-- The order given is arbitrary but stable during program execution.
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

-- | Used internally when defining instances of the 'Meta' classes.
makeTypeID
	:: String -- ^ Name of the package where the type constructor resides.
	-> String -- ^ Name of the module where the type constructor resides.
	-> String -- ^ The type constructor name.
	-> TypeID -- ^ The TypeID of the given type constructor.
makeTypeID pkg mod occ = let r = TypeID (metaKey r) pkg mod occ in r


-- | Used internally when defining instances of the 'Meta' classes.
applyTypeID
	:: TypeID -- ^ The incomplete TypeID to which the type parameter is being applied to.
	-> TypeID -- ^ The TypeID that is given as a parameter.
	-> TypeID -- ^ Resulting type id.
applyTypeID f p = let r = TypeApp (metaKey r) f p in r

-- | Used mainly internally, but may be useful for defining custom 'show' like functions for 'TypeID's.
--
-- Extracts the raw data that was used to construct 'TypeID's.
mapTypeID
	:: forall r
	.  (String -> String -> String -> r) -- ^ Extract the data given to 'makeTypeID'
	-> (r -> r -> r)           -- ^ Extract the data given to 'applyTypeID'
	-> TypeID                  -- ^ The TypeID from which the data needs to be extracted.
	-> r                       -- ^ The extract.
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

-- -- | Class for all the 'Type', 'TypeX', ... types.
-- class TypeWrapper t where
--	type_          :: t
--	kindOf         :: t -> Kind

-- | The maximum number of 'StarK's in 'Kind's this library was compiled to handle.
kindStarLimit :: Int
kindStarLimit = 8