module Data.Name.Internal.TH (
name, nameT, names, (:&), toName
) where
import Numeric (showHex)
import Data.Char (isAlpha, isAlphaNum, isAscii, isUpper, toUpper)
import Language.Haskell.TH
data a :& b
infixr 3 :&
nameT :: String -> Q Type
nameT str = return $ foldr f (conT $ last names) (init names)
where names = map toName str
conT n = ConT $ mkName ("Data.Name." ++ n)
f x xs = AppT (AppT (ConT ''(:&)) (conT x)) xs
name :: String -> Q Exp
name str = nameT str >>= return . SigE (VarE 'undefined)
toName c
| c `elem` ['0'..'9'] = 'D' : [c]
| isAscii c = if isUpper c then c : "_" else [toUpper c]
| True = 'U' : padLeft (map toUpper (showHex (fromEnum c) ""))
where padLeft str = replicate (4 length str) '0' ++ str
names chars = do
let alpha = filter isAlpha chars
alphaNum = filter isAlphaNum chars
dataD = \n -> DataD [] (mkName n) [] [] []
return [ dataD $ toName c | c <- alphaNum ]