module Data.Name.Internal.TH (
name, nameT, nameV, names, (:&), toName
) where
import Numeric (showHex)
import Data.Char (isAlpha, isAlphaNum, isAscii, isUpper, toUpper)
import Language.Haskell.TH
data a :& b
infixr 4 :&
name :: String -> Q [Dec]
name str = do
t <- nameT str
let sig = SigD (mkName str) t
def = ValD (VarP $ mkName str) (NormalB (VarE 'undefined)) []
return [sig, def]
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
nameV :: String -> Q Exp
nameV 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) [] [] []
showI c n = InstanceD [] (
AppT
(ConT ''Show)
(ConT (mkName n))
) [FunD 'show [Clause [WildP]
(NormalB (LitE (StringL [c])))
[]]]
fold c xs = let n = toName c in dataD n : showI c n : xs
return $ foldr fold [] alphaNum