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
kindStars :: Kind -> Int
kindStars StarK = 1
kindStars (ArrowK p r) = kindStars p + kindStars r
succKind :: Kind -> Kind
succKind (ArrowK p r) = ArrowK p $ succKind r
succKind StarK = ArrowK StarK StarK
recurseKind :: Kind -> Kind
recurseKind k = ArrowK k StarK
toParameters :: Kind -> [Kind]
toParameters (ArrowK p r) = p : toParameters r
toParameters StarK = []
fromParameters :: [Kind] -> Kind
fromParameters (x:xs) = ArrowK x (fromParameters xs)
fromParameters [] = StarK
kindSignature :: Kind -> String
kindSignature StarK = "*"
kindSignature (ArrowK StarK p) = "* -> " ++ kindSignature p
kindSignature (ArrowK f p) = "( " ++ kindSignature f ++ " ) -> " ++ kindSignature p
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
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
generateKinds
:: Int
-> [Kind]
generateKinds ml = concat $ map kinds_g [1..ml]
where
kinds_g l = concat $ map (kinds_h l) [1..max 1 (l1)]
kinds_h l 1 = [foldr (.) id (replicate (l1) $ ArrowK StarK) StarK]
kinds_h l g =
let p = [ ArrowK f p | f <- kinds_g g, p <- kinds_g (lg) ]
in if g /= l1 then p ++ map (ArrowK StarK) (kinds_h (l1) g) else p