{-# LANGUAGE Haskell2010
    , TemplateHaskell
    , TypeOperators
 #-}

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