{-# LANGUAGE TemplateHaskell #-}

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

import Language.Haskell.TH (Kind(StarK,ArrowK),conE,appE)
import Language.Haskell.TH.Syntax (Lift,lift)

instance Lift Kind where
	lift StarK = conE 'StarK
	lift (ArrowK p r) = conE 'ArrowK `appE` lift p `appE` lift r

-- | Counts the number of 'StarK's in a 'Kind'.
kindStars :: Kind -> Int
kindStars StarK = 1
kindStars (ArrowK p r) = kindStars p + kindStars r

-- | Adds @ -> * @ to the end of a 'Kind'.
--
-- >             * ==> * -> *
-- >        * -> * ==> * -> * -> *
-- > (* -> *) -> * ==> (* -> *) -> * -> *
succKind :: Kind -> Kind
succKind (ArrowK p r) = ArrowK p $ succKind r
succKind StarK        = ArrowK StarK StarK

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

-- | Extract the parameters of a 'Kind'.
-- Reverse of 'fromParameters'.
toParameters :: Kind -> [Kind]
toParameters (ArrowK p r) = p : toParameters r
toParameters StarK = []

-- | Combine parameter to form a type constructors 'Kind'.
-- Reverse of 'toParameters'.
fromParameters :: [Kind] -> Kind
fromParameters (x:xs) = ArrowK x (fromParameters xs)
fromParameters []     = StarK

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

-- | Get the bastard string representation of a 'Kind'.
kindName :: Kind -> String
kindName StarK               = ""
kindName (ArrowK StarK p) = 'X' : kindName p
kindName (ArrowK f p)        =
	let
		h StarK               = "X"
		h (ArrowK StarK p) = 'X' : h p
		h (ArrowK 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 ""       = StarK
readKindName ('X':xs) = ArrowK StarK $ readKindName xs 
readKindName ('B':xs) =
	let
		h ('X':'E':xs) = (xs, StarK)
		h ('X':xs)     = let (rs,p) = h xs in (rs, ArrowK StarK p)
		h _            = error "Illegal kind name."
	in
	let (rs,p) = h xs
	in ArrowK p $ readKindName rs

-- | Generates all possible 'Kind's given the maximum 'StarK'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 'StarK's 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 l 1 = [foldr (.) id (replicate (l-1) $ ArrowK StarK) StarK]
	kinds_h l g =
		let p = [ ArrowK f p | f <- kinds_g g, p <- kinds_g (l-g) ]
		in if g /= l-1 then p ++ map (ArrowK StarK) (kinds_h (l-1) g) else p