-- | Algorithms and operations on type kinds.
module Data.Type.Kind
	( Kind(..)
	, succKind
	, recurseKind
	, parameters
	, kindVariables
	, kindSignature
	, kindName
	, readKindName
	, generateKinds
	) where

import Data.Word

-- | Type kind representation.
data Kind
	= KindUnit
	| KindArrow Kind Kind
	deriving (Eq,Ord,Show)

-- | Adds @ -> * @ to the end of a kind.
--
-- >             * ==> * -> *
-- >        * -> * ==> * -> * -> *
-- > (* -> *) -> * ==> (* -> *) -> * -> *
succKind :: Kind -> Kind
succKind (KindArrow p r) = KindArrow p $ succKind r
succKind KindUnit        = KindArrow KindUnit KindUnit

-- | Transforms from @k@ to @ k -> * @.
--
-- >             * ==> * -> *
-- >        * -> * ==> (* -> *) -> *
-- > (* -> *) -> * ==> ((* -> *) -> *) -> *
recurseKind :: Kind -> Kind
recurseKind k = KindArrow k KindUnit

-- | Extract kinds of a kinds parameters.
parameters :: Kind -> [Kind]
parameters (KindArrow p r) = p : parameters r
parameters KindUnit = []

-- | Show kinds parameters with kind signatures.
kindVariables
	:: String -- ^ The base string to add in front of a position number.
	-> Kind   -- ^ The kind being shown.
	-> String
kindVariables t k = kv (0::Word) k
	where
	kv c KindUnit               = []
	kv c (KindArrow KindUnit p) = ' ' : t ++ show c ++ kv (succ c) p
	kv c (KindArrow f p)        = " ( " ++ t ++ show c ++ " :: " ++ kindSignature f ++ " )" ++ kv (succ c) p

-- | Get a kind signature from a 'Kind'.
kindSignature :: Kind -> String
kindSignature KindUnit               = "*" 
kindSignature (KindArrow KindUnit p) = "* -> " ++ kindSignature p
kindSignature (KindArrow f p)        = "( " ++ kindSignature f ++ " ) -> " ++ kindSignature p

-- | Get the bastard string representation of a 'Kind'.
kindName :: Kind -> String
kindName KindUnit               = ""
kindName (KindArrow KindUnit p) = 'X' : kindName p
kindName (KindArrow f p)        =
	let
		h KindUnit               = "X"
		h (KindArrow KindUnit p) = 'X' : h p
		h (KindArrow f p)        = 'B' : h f ++ 'E' : h p
	in 'B' : h f ++ 'E' : kindName p

-- | Read the bastard string representation to 'Kind'.
readKindName :: String -> Kind
readKindName ""       = KindUnit
readKindName ('X':xs) = KindArrow KindUnit $ readKindName xs 
readKindName ('B':xs) =
	let
		h ('X':'E':xs) = (xs, KindUnit)
		h ('X':xs)     = let (rs,p) = h xs in (rs, KindArrow KindUnit p)
		h _            = error "Illegal kind name."
	in
	let (rs,p) = h xs
	in KindArrow p $ readKindName rs

-- | Generates all possible 'Kind's given the maximum 'KindUnit's allowed.
--
-- > 1:1 1
-- > *
-- > 
-- > 2:1 2
-- > *->*
-- > 
-- > 3:2 4
-- > *->*->*
-- > (*->*)->*
-- > 
-- > 4:5 9
-- > *->*->*->*
-- > (*->*)->*->*
-- > *->(*->*)->*
-- > (*->*->*)->*
-- > ((*->*)->*)->*
-- > 
-- > 5:14 23
-- > *->*->*->*->*
-- > (*->*)->(*->*)->*
-- > (*->*)->*->*->*
-- > *->(*->*)->*->*
-- > *->*->(*->*)->*
-- > (*->*->*)->*->*
-- > ((*->*)->*)->*->*
-- > *->(*->*->*)->*
-- > *->((*->*)->*)->*
-- > (*->*->*->*)->*
-- > ((*->*)->*->*)->*
-- > (*->(*->*)->*)->*
-- > ((*->*->*)->*)->*
-- > (((*->*)->*)->*)->*
--
-- The series continues: 1,1,2,5,14,42,132,429,1430,4862,...
generateKinds
	:: Int    -- ^the maximum 'KindUnits' allowed.
	-> [Kind]
generateKinds ml = concat $ map kinds_g [1..ml]
	where
	kinds_g l = concat $ map (kinds_h l) [1..max 1 (l-1)]
	kinds_h 1 1 = [KindUnit]
	kinds_h l 1 = map (KindArrow KindUnit) $ kinds_h (l-1) 1
	kinds_h l g =
		let p = [ KindArrow f p | f <- kinds_g g, p <- kinds_g (l-g) ] in
		if g /= l-1 then p ++ map (KindArrow KindUnit) (kinds_h (l-1) g) else p