module Data.Name (
(:&),
Name (..),
name, nameT, nameV, names,
U0, U1, U2, U3, U4, U5, U6, U7, U8, U9,
UA, UB, UC, UD, UE, UF,
X0, X1, X2, X3, X4, X5, X6, X7, X8, X9,
XA, XB, XC, XD, XE, XF,
D0, D1, D2, D3, D4, D5, D6, D7, D8, D9,
A, B, C, D, E, F, G, H, I, J, K, L, M,
N, O, P, Q, R, S, T, U, V, W, X, Y, Z,
A_, B_, C_, D_, E_, F_, G_, H_, I_, J_, K_, L_, M_,
N_, O_, P_, Q_, R_, S_, T_, U_, V_, W_, X_, Y_, Z_,
__
) where
import Data.Char
import Data.Typeable
import Language.Haskell.TH hiding (Name, Q)
import qualified Language.Haskell.TH as TH
import Numeric
__ = error "Data.Name.undefined: Names are types, not values."
class Show a => Name a where
nameOf :: a -> String
nameOf = show
data a :& b deriving Typeable
infixr 4 :&
instance (Show a, Show b) => Show (a :& b) where
show _ = let showA = show :: a -> String
showB = show :: b -> String
in showA __ ++ showB __
instance (Name a, Name b) => Name (a :& b)
name :: String -> TH.Q [Dec]
name str = do
t <- nameT str
let sig = SigD (mkName str) t
def = ValD (VarP $ mkName str) (NormalB (VarE '__)) []
return [sig, def]
class Names' a where
names' :: [String] -> a
instance Names' (TH.Q [Dec]) where
names' = fmap concat . mapM name
instance Names' a => Names' (String -> a) where
names' xs x = names' (x:xs)
names :: Names' a => a
names = names' []
nameT :: String -> TH.Q Type
nameT str = return $ foldr f (last names) (init names)
where
names = map toName str
f x xs = AppT (AppT (ConT ''(:&)) x) xs
conT = ConT . nameFor
toName c
| c `elem` ['0'..'9'] = conT ('D' : [c])
| c `elem` ['a'..'z'] = conT [toUpper c]
| c `elem` ['A'..'Z'] = conT (c : "_")
| otherwise =
let h = map toUpper . flip showHex ""
i = fromEnum c
u = conT ('U' : h (i `quot` 16^4))
xA = conT ('X' : h (i `rem` 16^4 `quot` 16^3))
xB = conT ('X' : h (i `rem` 16^3 `quot` 16^2))
xC = conT ('X' : h (i `rem` 16^2 `quot` 16))
xD = conT ('X' : h (i `rem` 16))
in foldr AppT xD [u, xA, xB, xC]
nameV :: String -> TH.Q Exp
nameV str = nameT str >>= return . SigE (VarE $ mkName "Data.Name.__")
nameFor str = case str of
"A" -> ''A ; "B" -> ''B ; "C" -> ''C ; "D" -> ''D ; "E" -> ''E ; "F" -> ''F ;
"G" -> ''G ; "H" -> ''H ; "I" -> ''I ; "J" -> ''J ; "K" -> ''K ; "L" -> ''L ;
"M" -> ''M ; "N" -> ''N ; "O" -> ''O ; "P" -> ''P ; "Q" -> ''Q ; "R" -> ''R ;
"S" -> ''S ; "T" -> ''T ; "U" -> ''U ; "V" -> ''V ; "W" -> ''W ; "X" -> ''X ;
"Y" -> ''Y ; "Z" -> ''Z
"A_" -> ''A_ ; "B_" -> ''B_ ; "C_" -> ''C_ ; "D_" -> ''D_ ; "E_" -> ''E_ ; "F_" -> ''F_ ;
"G_" -> ''G_ ; "H_" -> ''H_ ; "I_" -> ''I_ ; "J_" -> ''J_ ; "K_" -> ''K_ ; "L_" -> ''L_ ;
"M_" -> ''M_ ; "N_" -> ''N_ ; "O_" -> ''O_ ; "P_" -> ''P_ ; "Q_" -> ''Q_ ; "R_" -> ''R_ ;
"S_" -> ''S_ ; "T_" -> ''T_ ; "U_" -> ''U_ ; "V_" -> ''V_ ; "W_" -> ''W_ ; "X_" -> ''X_ ;
"Y_" -> ''Y_ ; "Z_" -> ''Z_
"D0" -> ''D0 ; "D1" -> ''D1 ; "D2" -> ''D2 ; "D3" -> ''D3 ; "D4" -> ''D4 ;
"D5" -> ''D5 ; "D6" -> ''D6 ; "D7" -> ''D7 ; "D8" -> ''D8 ; "D9" -> ''D9 ;
"X0" -> ''X0 ; "X1" -> ''X1 ; "X2" -> ''X2 ; "X3" -> ''X3 ; "X4" -> ''X4 ;
"X5" -> ''X5 ; "X6" -> ''X6 ; "X7" -> ''X7 ; "X8" -> ''X8 ; "X9" -> ''X9 ;
"XA" -> ''XA ; "XB" -> ''XB ; "XC" -> ''XC ; "XD" -> ''XD ; "XE" -> ''XE ;
"XF" -> ''XF ;
"U0" -> ''U0 ; "U1" -> ''U1 ; "U2" -> ''U2 ; "U3" -> ''U3 ; "U4" -> ''U4 ;
"U5" -> ''U5 ; "U6" -> ''U6 ; "U7" -> ''U7 ; "U8" -> ''U8 ; "U9" -> ''U9 ;
"UA" -> ''UA ; "UB" -> ''UB ; "UC" -> ''UC ; "UD" -> ''UD ; "UE" -> ''UE ;
"UF" -> ''UF ;
_ -> undefined
data U0 a b c d deriving Typeable
data U1 a b c d deriving Typeable
data U2 a b c d deriving Typeable
data U3 a b c d deriving Typeable
data U4 a b c d deriving Typeable
data U5 a b c d deriving Typeable
data U6 a b c d deriving Typeable
data U7 a b c d deriving Typeable
data U8 a b c d deriving Typeable
data U9 a b c d deriving Typeable
data UA a b c d deriving Typeable
data UB a b c d deriving Typeable
data UC a b c d deriving Typeable
data UD a b c d deriving Typeable
data UE a b c d deriving Typeable
data UF a b c d deriving Typeable
data D0 deriving Typeable ; instance Show D0 where { show _ = "0" } ; instance Name D0
data D1 deriving Typeable ; instance Show D1 where { show _ = "1" } ; instance Name D1
data D2 deriving Typeable ; instance Show D2 where { show _ = "2" } ; instance Name D2
data D3 deriving Typeable ; instance Show D3 where { show _ = "3" } ; instance Name D3
data D4 deriving Typeable ; instance Show D4 where { show _ = "4" } ; instance Name D4
data D5 deriving Typeable ; instance Show D5 where { show _ = "5" } ; instance Name D5
data D6 deriving Typeable ; instance Show D6 where { show _ = "6" } ; instance Name D6
data D7 deriving Typeable ; instance Show D7 where { show _ = "7" } ; instance Name D7
data D8 deriving Typeable ; instance Show D8 where { show _ = "8" } ; instance Name D8
data D9 deriving Typeable ; instance Show D9 where { show _ = "9" } ; instance Name D9
data A_ deriving Typeable ; instance Show A_ where { show _ = "A" } ; instance Name A_
data B_ deriving Typeable ; instance Show B_ where { show _ = "B" } ; instance Name B_
data C_ deriving Typeable ; instance Show C_ where { show _ = "C" } ; instance Name C_
data D_ deriving Typeable ; instance Show D_ where { show _ = "D" } ; instance Name D_
data E_ deriving Typeable ; instance Show E_ where { show _ = "E" } ; instance Name E_
data F_ deriving Typeable ; instance Show F_ where { show _ = "F" } ; instance Name F_
data G_ deriving Typeable ; instance Show G_ where { show _ = "G" } ; instance Name G_
data H_ deriving Typeable ; instance Show H_ where { show _ = "H" } ; instance Name H_
data I_ deriving Typeable ; instance Show I_ where { show _ = "I" } ; instance Name I_
data J_ deriving Typeable ; instance Show J_ where { show _ = "J" } ; instance Name J_
data K_ deriving Typeable ; instance Show K_ where { show _ = "K" } ; instance Name K_
data L_ deriving Typeable ; instance Show L_ where { show _ = "L" } ; instance Name L_
data M_ deriving Typeable ; instance Show M_ where { show _ = "M" } ; instance Name M_
data N_ deriving Typeable ; instance Show N_ where { show _ = "N" } ; instance Name N_
data O_ deriving Typeable ; instance Show O_ where { show _ = "O" } ; instance Name O_
data P_ deriving Typeable ; instance Show P_ where { show _ = "P" } ; instance Name P_
data Q_ deriving Typeable ; instance Show Q_ where { show _ = "Q" } ; instance Name Q_
data R_ deriving Typeable ; instance Show R_ where { show _ = "R" } ; instance Name R_
data S_ deriving Typeable ; instance Show S_ where { show _ = "S" } ; instance Name S_
data T_ deriving Typeable ; instance Show T_ where { show _ = "T" } ; instance Name T_
data U_ deriving Typeable ; instance Show U_ where { show _ = "U" } ; instance Name U_
data V_ deriving Typeable ; instance Show V_ where { show _ = "V" } ; instance Name V_
data W_ deriving Typeable ; instance Show W_ where { show _ = "W" } ; instance Name W_
data X_ deriving Typeable ; instance Show X_ where { show _ = "X" } ; instance Name X_
data Y_ deriving Typeable ; instance Show Y_ where { show _ = "Y" } ; instance Name Y_
data Z_ deriving Typeable ; instance Show Z_ where { show _ = "Z" } ; instance Name Z_
data A deriving Typeable ; instance Show A where { show _ = "a" } ; instance Name A
data B deriving Typeable ; instance Show B where { show _ = "b" } ; instance Name B
data C deriving Typeable ; instance Show C where { show _ = "c" } ; instance Name C
data D deriving Typeable ; instance Show D where { show _ = "d" } ; instance Name D
data E deriving Typeable ; instance Show E where { show _ = "e" } ; instance Name E
data F deriving Typeable ; instance Show F where { show _ = "f" } ; instance Name F
data G deriving Typeable ; instance Show G where { show _ = "g" } ; instance Name G
data H deriving Typeable ; instance Show H where { show _ = "h" } ; instance Name H
data I deriving Typeable ; instance Show I where { show _ = "i" } ; instance Name I
data J deriving Typeable ; instance Show J where { show _ = "j" } ; instance Name J
data K deriving Typeable ; instance Show K where { show _ = "k" } ; instance Name K
data L deriving Typeable ; instance Show L where { show _ = "l" } ; instance Name L
data M deriving Typeable ; instance Show M where { show _ = "m" } ; instance Name M
data N deriving Typeable ; instance Show N where { show _ = "n" } ; instance Name N
data O deriving Typeable ; instance Show O where { show _ = "o" } ; instance Name O
data P deriving Typeable ; instance Show P where { show _ = "p" } ; instance Name P
data Q deriving Typeable ; instance Show Q where { show _ = "q" } ; instance Name Q
data R deriving Typeable ; instance Show R where { show _ = "r" } ; instance Name R
data S deriving Typeable ; instance Show S where { show _ = "s" } ; instance Name S
data T deriving Typeable ; instance Show T where { show _ = "t" } ; instance Name T
data U deriving Typeable ; instance Show U where { show _ = "u" } ; instance Name U
data V deriving Typeable ; instance Show V where { show _ = "v" } ; instance Name V
data W deriving Typeable ; instance Show W where { show _ = "w" } ; instance Name W
data X deriving Typeable ; instance Show X where { show _ = "x" } ; instance Name X
data Y deriving Typeable ; instance Show Y where { show _ = "y" } ; instance Name Y
data Z deriving Typeable ; instance Show Z where { show _ = "z" } ; instance Name Z
class Hex a where hex :: a -> Int
data X0 deriving Typeable ; instance Hex X0 where hex _ = 0
data X1 deriving Typeable ; instance Hex X1 where hex _ = 1
data X2 deriving Typeable ; instance Hex X2 where hex _ = 2
data X3 deriving Typeable ; instance Hex X3 where hex _ = 3
data X4 deriving Typeable ; instance Hex X4 where hex _ = 4
data X5 deriving Typeable ; instance Hex X5 where hex _ = 5
data X6 deriving Typeable ; instance Hex X6 where hex _ = 6
data X7 deriving Typeable ; instance Hex X7 where hex _ = 7
data X8 deriving Typeable ; instance Hex X8 where hex _ = 8
data X9 deriving Typeable ; instance Hex X9 where hex _ = 9
data XA deriving Typeable ; instance Hex XA where hex _ = 10
data XB deriving Typeable ; instance Hex XB where hex _ = 11
data XC deriving Typeable ; instance Hex XC where hex _ = 12
data XD deriving Typeable ; instance Hex XD where hex _ = 13
data XE deriving Typeable ; instance Hex XE where hex _ = 14
data XF deriving Typeable ; instance Hex XF where hex _ = 15
instance (Hex a, Hex b, Hex c, Hex d) => Show (U0 a b c d) where
show _ = let xA = hex :: a -> Int ; xB = hex :: b -> Int
xC = hex :: c -> Int ; xD = hex :: d -> Int
in [toEnum $ xA __ * 16^3 + xB __ * 16^2 + xC __ * 16 + xD __]
instance (Hex a, Hex b, Hex c, Hex d) => Show (U1 a b c d) where
show _ = let xA = hex :: a -> Int ; xB = hex :: b -> Int
xC = hex :: c -> Int ; xD = hex :: d -> Int
in [toEnum $ 1 * 16^4 + xA __ * 16^3 + xB __ * 16^2 + xC __ * 16 + xD __]
instance (Hex a, Hex b, Hex c, Hex d) => Show (U2 a b c d) where
show _ = let xA = hex :: a -> Int ; xB = hex :: b -> Int
xC = hex :: c -> Int ; xD = hex :: d -> Int
in [toEnum $ 2 * 16^4 + xA __ * 16^3 + xB __ * 16^2 + xC __ * 16 + xD __]
instance (Hex a, Hex b, Hex c, Hex d) => Show (U3 a b c d) where
show _ = let xA = hex :: a -> Int ; xB = hex :: b -> Int
xC = hex :: c -> Int ; xD = hex :: d -> Int
in [toEnum $ 3 * 16^4 + xA __ * 16^3 + xB __ * 16^2 + xC __ * 16 + xD __]
instance (Hex a, Hex b, Hex c, Hex d) => Show (U4 a b c d) where
show _ = let xA = hex :: a -> Int ; xB = hex :: b -> Int
xC = hex :: c -> Int ; xD = hex :: d -> Int
in [toEnum $ 4 * 16^4 + xA __ * 16^3 + xB __ * 16^2 + xC __ * 16 + xD __]
instance (Hex a, Hex b, Hex c, Hex d) => Show (U5 a b c d) where
show _ = let xA = hex :: a -> Int ; xB = hex :: b -> Int
xC = hex :: c -> Int ; xD = hex :: d -> Int
in [toEnum $ 5 * 16^4 + xA __ * 16^3 + xB __ * 16^2 + xC __ * 16 + xD __]
instance (Hex a, Hex b, Hex c, Hex d) => Show (U6 a b c d) where
show _ = let xA = hex :: a -> Int ; xB = hex :: b -> Int
xC = hex :: c -> Int ; xD = hex :: d -> Int
in [toEnum $ 6 * 16^4 + xA __ * 16^3 + xB __ * 16^2 + xC __ * 16 + xD __]
instance (Hex a, Hex b, Hex c, Hex d) => Show (U7 a b c d) where
show _ = let xA = hex :: a -> Int ; xB = hex :: b -> Int
xC = hex :: c -> Int ; xD = hex :: d -> Int
in [toEnum $ 7 * 16^4 + xA __ * 16^3 + xB __ * 16^2 + xC __ * 16 + xD __]
instance (Hex a, Hex b, Hex c, Hex d) => Show (U8 a b c d) where
show _ = let xA = hex :: a -> Int ; xB = hex :: b -> Int
xC = hex :: c -> Int ; xD = hex :: d -> Int
in [toEnum $ 8 * 16^4 + xA __ * 16^3 + xB __ * 16^2 + xC __ * 16 + xD __]
instance (Hex a, Hex b, Hex c, Hex d) => Show (U9 a b c d) where
show _ = let xA = hex :: a -> Int ; xB = hex :: b -> Int
xC = hex :: c -> Int ; xD = hex :: d -> Int
in [toEnum $ 9 * 16^4 + xA __ * 16^3 + xB __ * 16^2 + xC __ * 16 + xD __]
instance (Hex a, Hex b, Hex c, Hex d) => Show (UA a b c d) where
show _ = let xA = hex :: a -> Int ; xB = hex :: b -> Int
xC = hex :: c -> Int ; xD = hex :: d -> Int
in [toEnum $ 10 * 16^4 + xA __ * 16^3 + xB __ * 16^2 + xC __ * 16 + xD __]
instance (Hex a, Hex b, Hex c, Hex d) => Show (UB a b c d) where
show _ = let xA = hex :: a -> Int ; xB = hex :: b -> Int
xC = hex :: c -> Int ; xD = hex :: d -> Int
in [toEnum $ 11 * 16^4 + xA __ * 16^3 + xB __ * 16^2 + xC __ * 16 + xD __]
instance (Hex a, Hex b, Hex c, Hex d) => Show (UC a b c d) where
show _ = let xA = hex :: a -> Int ; xB = hex :: b -> Int
xC = hex :: c -> Int ; xD = hex :: d -> Int
in [toEnum $ 12 * 16^4 + xA __ * 16^3 + xB __ * 16^2 + xC __ * 16 + xD __]
instance (Hex a, Hex b, Hex c, Hex d) => Show (UD a b c d) where
show _ = let xA = hex :: a -> Int ; xB = hex :: b -> Int
xC = hex :: c -> Int ; xD = hex :: d -> Int
in [toEnum $ 13 * 16^4 + xA __ * 16^3 + xB __ * 16^2 + xC __ * 16 + xD __]
instance (Hex a, Hex b, Hex c, Hex d) => Show (UE a b c d) where
show _ = let xA = hex :: a -> Int ; xB = hex :: b -> Int
xC = hex :: c -> Int ; xD = hex :: d -> Int
in [toEnum $ 14 * 16^4 + xA __ * 16^3 + xB __ * 16^2 + xC __ * 16 + xD __]
instance (Hex a, Hex b, Hex c, Hex d) => Show (UF a b c d) where
show _ = let xA = hex :: a -> Int ; xB = hex :: b -> Int
xC = hex :: c -> Int ; xD = hex :: d -> Int
in [toEnum $ 15 * 16^4 + xA __ * 16^3 + xB __ * 16^2 + xC __ * 16 + xD __]
instance (Hex a, Hex b, Hex c, Hex d) => Name (U0 a b c d)
instance (Hex a, Hex b, Hex c, Hex d) => Name (U1 a b c d)
instance (Hex a, Hex b, Hex c, Hex d) => Name (U2 a b c d)
instance (Hex a, Hex b, Hex c, Hex d) => Name (U3 a b c d)
instance (Hex a, Hex b, Hex c, Hex d) => Name (U4 a b c d)
instance (Hex a, Hex b, Hex c, Hex d) => Name (U5 a b c d)
instance (Hex a, Hex b, Hex c, Hex d) => Name (U6 a b c d)
instance (Hex a, Hex b, Hex c, Hex d) => Name (U7 a b c d)
instance (Hex a, Hex b, Hex c, Hex d) => Name (U8 a b c d)
instance (Hex a, Hex b, Hex c, Hex d) => Name (U9 a b c d)
instance (Hex a, Hex b, Hex c, Hex d) => Name (UA a b c d)
instance (Hex a, Hex b, Hex c, Hex d) => Name (UB a b c d)
instance (Hex a, Hex b, Hex c, Hex d) => Name (UC a b c d)
instance (Hex a, Hex b, Hex c, Hex d) => Name (UD a b c d)
instance (Hex a, Hex b, Hex c, Hex d) => Name (UE a b c d)
instance (Hex a, Hex b, Hex c, Hex d) => Name (UF a b c d)