module Data.Type.Kind
( Kind(..)
, succKind
, recurseKind
, parameters
, kindVariables
, kindSignature
, kindName
, readKindName
, generateKinds
) where
import Data.Word
data Kind
= KindUnit
| KindArrow Kind Kind
deriving (Eq,Ord,Show)
succKind :: Kind -> Kind
succKind (KindArrow p r) = KindArrow p $ succKind r
succKind KindUnit = KindArrow KindUnit KindUnit
recurseKind :: Kind -> Kind
recurseKind k = KindArrow k KindUnit
parameters :: Kind -> [Kind]
parameters (KindArrow p r) = p : parameters r
parameters KindUnit = []
kindVariables
:: String
-> Kind
-> 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
kindSignature :: Kind -> String
kindSignature KindUnit = "*"
kindSignature (KindArrow KindUnit p) = "* -> " ++ kindSignature p
kindSignature (KindArrow f p) = "( " ++ kindSignature f ++ " ) -> " ++ kindSignature p
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
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
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 1 1 = [KindUnit]
kinds_h l 1 = map (KindArrow KindUnit) $ kinds_h (l1) 1
kinds_h l g =
let p = [ KindArrow f p | f <- kinds_g g, p <- kinds_g (lg) ] in
if g /= l1 then p ++ map (KindArrow KindUnit) (kinds_h (l1) g) else p