names 0.2.3 → 0.3
raw patch · 4 files changed
+279/−81 lines, 4 files
Files
- names.cabal +8/−5
- src/Data/Name.hs +271/−5
- src/Data/Name/Internal/Names.hs +0/−13
- src/Data/Name/Internal/TH.hs +0/−58
names.cabal view
@@ -1,8 +1,10 @@ Name: names-Version: 0.2.3+Version: 0.3 Synopsis: Type level names. Description: Type level names. .+ [@v0.1@] Initial.+ . [@v0.2@] Show Instances added. Restricted to latin1. . [@v0.2.1@] Infix operator fixities set.@@ -10,6 +12,10 @@ [@v0.2.2@] Merge "Data.Name" and "Data.Name.TH". . [@v0.2.3@] Added basic Documentation.+ .+ [@v0.3@] Reintroduced Unicode for names.+ Added @Name@ type class.+ TH is not used internally anymore. License: MIT License-File: LICENSE@@ -28,14 +34,11 @@ Source-Repository head type: darcs location: hub.darcs.net:names- tag: v0.2.3+ tag: v0.3 Library Exposed-Modules: Data.Name-- Other-Modules: Data.Name.Internal.Names,- Data.Name.Internal.TH Build-Depends: base >= 4 && < 5, template-haskell >= 2.7
src/Data/Name.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE Haskell2010 , ScopedTypeVariables , TypeOperators+ , DeriveDataTypeable+ , ScopedTypeVariables+ , Trustworthy #-} {- | Type level names.@@ -27,19 +30,282 @@ -} module Data.Name ( (:&),- module Data.Name.Internal.Names,+ Name (..),+ name, nameT, nameV, - name, nameT, nameV+ 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 -import Data.Name.Internal.Names-import Data.Name.Internal.TH+__ = 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 undefined ++ showB undefined+ 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 $ mkName "Data.Name.__")) []+ return [sig, def]++-- FIX: Generate Unicode-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 n = ConT (mkName ("Data.Name." ++ n))++ 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.__")++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)
− src/Data/Name/Internal/Names.hs
@@ -1,13 +0,0 @@-{-# LANGUAGE Haskell2010- , TemplateHaskell- #-}--module Data.Name.Internal.Names where---import qualified Data.Name.Internal.TH as TH---TH.names ['\1' .. '\255']--
− src/Data/Name/Internal/TH.hs
@@ -1,58 +0,0 @@-{-# 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-