module Data.TypeLevel.Num.Aliases.TH (genAliases, dec2TypeLevel) where
import Language.Haskell.TH
import Data.TypeLevel.Num.Reps
data Base = Bin | Oct | Dec | Hex
base2Int :: Base -> Int
base2Int Bin = 2
base2Int Oct = 8
base2Int Dec = 10
base2Int Hex = 16
genAliases :: Int
-> Int
-> Int
-> Int
-> Q [Dec]
genAliases nb no nd nh = genAliases' nb no nd nh (maximum [nb,no,nd,nh])
genAliases' :: Int
-> Int
-> Int
-> Int
-> Int
-> Q [Dec]
genAliases' nb no nd nh curr
| curr < 0 = return []
| otherwise =
do rest <- genAliases' nb no nd nh (curr1)
restb <- addAliasBase (curr > nb) ('b' : bStr) ('B' : bStr) rest
resto <- addAliasBase (curr > no) ('o' : oStr) ('O' : oStr) restb
restd <- if curr > nd then return resto
else do val <- genValAlias ('d' : dStr) decRep
typ <- genTypeAlias ('D' : dStr) decRep
if (curr < 10) then return $ val : resto
else return $ val : typ : resto
addAliasBase (curr > no) ('h' : hStr) ('H' : hStr) restd
where
addAliasBase cond vStr tStr rest =
if cond then return rest
else do val <- genValAlias vStr decRep
typ <- genTypeAlias tStr decRep
return $ val : typ : rest
decRep = dec2TypeLevel curr
bStr = toBase Bin curr
oStr = toBase Oct curr
dStr = toBase Dec curr
hStr = toBase Hex curr
dec2TypeLevel :: Int -> Q Type
dec2TypeLevel n
| n < 0 = error "natural number expected"
| n < 10 = let name = case n of
0 -> ''D0; 1 -> ''D1; 2 -> ''D2; 3 -> ''D3; 4 -> ''D4
5 -> ''D5; 6 -> ''D6; 7 -> ''D7; 8 -> ''D8; 9 -> ''D9
in conT name
| otherwise = let (quotient, reminder) = n `quotRem` 10
remType = dec2TypeLevel reminder
quotType = dec2TypeLevel quotient
in (conT ''(:*)) `appT` quotType `appT` remType
genTypeAlias :: String -> Q Type -> Q Dec
genTypeAlias str t = tySynD name [] t
where name = mkName $ str
genValAlias :: String -> Q Type -> Q Dec
genValAlias str t = body
where name = mkName $ str
body = valD (varP name)
(normalB (sigE [| undefined |] t)) []
toBase :: Base
-> Int
-> String
toBase Dec n = show n
toBase b n
| n < 0 = '-' : toBase b ( n)
| n < bi = [int2Char n]
| otherwise = (toBase b rest) ++ [int2Char currDigit]
where bi = base2Int b
(rest, currDigit) = n `quotRem` bi
int2Char :: Int
-> Char
int2Char i
| i' < 10 = toEnum (i'+ 48)
| otherwise = toEnum (i' + 55)
where i' = abs i