diff --git a/.git/COMMIT_EDITMSG b/.git/COMMIT_EDITMSG --- a/.git/COMMIT_EDITMSG +++ b/.git/COMMIT_EDITMSG @@ -1,10 +1,9 @@ - +add some functions # Please enter the commit message for your changes. Lines starting # with '#' will be ignored, and an empty message aborts the commit. # On branch master -# Your branch is ahead of 'origin/master' by 2 commits. -# (use "git push" to publish your local commits) +# Your branch is up-to-date with 'origin/master'. # -# Untracked files: -# #README.md# +# Changes to be committed: +# modified: Utils.hs # diff --git a/.git/COMMIT_EDITMSG~ b/.git/COMMIT_EDITMSG~ --- a/.git/COMMIT_EDITMSG~ +++ b/.git/COMMIT_EDITMSG~ @@ -2,13 +2,8 @@ # Please enter the commit message for your changes. Lines starting # with '#' will be ignored, and an empty message aborts the commit. # On branch master -# Your branch is ahead of 'origin/master' by 1 commit. -# (use "git push" to publish your local commits) +# Your branch is up-to-date with 'origin/master'. # # Changes to be committed: -# modified: src/Language/Haskell/TH/Utils.hs -# modified: template-haskell-util.cabal -# -# Untracked files: -# #README.md# +# modified: Utils.hs # diff --git a/.git/index b/.git/index Binary files a/.git/index and b/.git/index differ diff --git a/.git/logs/HEAD b/.git/logs/HEAD --- a/.git/logs/HEAD +++ b/.git/logs/HEAD @@ -5,3 +5,4 @@ be3fb7a2051f825f8d2a8b3d299a604abf2b5244 084a706a37d6164dfb1fab5dcd4e098bcdfe0ffa HaskellZhangSong 1424587127 +0800 commit: update me 084a706a37d6164dfb1fab5dcd4e098bcdfe0ffa 9d75ddda94952b2353bcb98b30ffa96708137edb HaskellZhangSong 1424591499 +0800 commit: delete somefiles 9d75ddda94952b2353bcb98b30ffa96708137edb 3bc5e4c57a4d26371071febf2c9201f648327754 HaskellZhangSong 1424591528 +0800 commit: update on some functions +3bc5e4c57a4d26371071febf2c9201f648327754 9f2a3202024981da42b4521ac1ade80ad3d7b546 HaskellZhangSong 1424932625 +0800 commit: add some functions diff --git a/.git/logs/refs/heads/master b/.git/logs/refs/heads/master --- a/.git/logs/refs/heads/master +++ b/.git/logs/refs/heads/master @@ -5,3 +5,4 @@ be3fb7a2051f825f8d2a8b3d299a604abf2b5244 084a706a37d6164dfb1fab5dcd4e098bcdfe0ffa HaskellZhangSong 1424587127 +0800 commit: update me 084a706a37d6164dfb1fab5dcd4e098bcdfe0ffa 9d75ddda94952b2353bcb98b30ffa96708137edb HaskellZhangSong 1424591499 +0800 commit: delete somefiles 9d75ddda94952b2353bcb98b30ffa96708137edb 3bc5e4c57a4d26371071febf2c9201f648327754 HaskellZhangSong 1424591528 +0800 commit: update on some functions +3bc5e4c57a4d26371071febf2c9201f648327754 9f2a3202024981da42b4521ac1ade80ad3d7b546 HaskellZhangSong 1424932625 +0800 commit: add some functions diff --git a/.git/logs/refs/remotes/origin/master b/.git/logs/refs/remotes/origin/master --- a/.git/logs/refs/remotes/origin/master +++ b/.git/logs/refs/remotes/origin/master @@ -3,3 +3,4 @@ d1247d5c2308a73ca68c144ce67b060d3023b385 be3fb7a2051f825f8d2a8b3d299a604abf2b5244 HaskellZhangSong 1424587031 +0800 update by push be3fb7a2051f825f8d2a8b3d299a604abf2b5244 084a706a37d6164dfb1fab5dcd4e098bcdfe0ffa HaskellZhangSong 1424587175 +0800 update by push 084a706a37d6164dfb1fab5dcd4e098bcdfe0ffa 3bc5e4c57a4d26371071febf2c9201f648327754 HaskellZhangSong 1424591608 +0800 update by push +3bc5e4c57a4d26371071febf2c9201f648327754 9f2a3202024981da42b4521ac1ade80ad3d7b546 HaskellZhangSong 1424932730 +0800 update by push diff --git a/.git/objects/0e/b705ecf8acd3e0faadbf5b8f9223c3f2af7d2f b/.git/objects/0e/b705ecf8acd3e0faadbf5b8f9223c3f2af7d2f new file mode 100644 Binary files /dev/null and b/.git/objects/0e/b705ecf8acd3e0faadbf5b8f9223c3f2af7d2f differ diff --git a/.git/objects/25/e665418344ac3e22647b09133c46f11764adc7 b/.git/objects/25/e665418344ac3e22647b09133c46f11764adc7 new file mode 100644 Binary files /dev/null and b/.git/objects/25/e665418344ac3e22647b09133c46f11764adc7 differ diff --git a/.git/objects/35/d3e81042a51a696393d60d9e6091189c807d4f b/.git/objects/35/d3e81042a51a696393d60d9e6091189c807d4f new file mode 100644 Binary files /dev/null and b/.git/objects/35/d3e81042a51a696393d60d9e6091189c807d4f differ diff --git a/.git/objects/62/4eb04567b70087227deed14cc2935aa0ff6446 b/.git/objects/62/4eb04567b70087227deed14cc2935aa0ff6446 new file mode 100644 Binary files /dev/null and b/.git/objects/62/4eb04567b70087227deed14cc2935aa0ff6446 differ diff --git a/.git/objects/68/c829d10241779b0f24a4fb2da9c5eb4d41942c b/.git/objects/68/c829d10241779b0f24a4fb2da9c5eb4d41942c new file mode 100644 Binary files /dev/null and b/.git/objects/68/c829d10241779b0f24a4fb2da9c5eb4d41942c differ diff --git a/.git/objects/9b/2c7a465fcbdaddb77e0203ea65b458b7c6df31 b/.git/objects/9b/2c7a465fcbdaddb77e0203ea65b458b7c6df31 new file mode 100644 Binary files /dev/null and b/.git/objects/9b/2c7a465fcbdaddb77e0203ea65b458b7c6df31 differ diff --git a/.git/objects/9f/2a3202024981da42b4521ac1ade80ad3d7b546 b/.git/objects/9f/2a3202024981da42b4521ac1ade80ad3d7b546 new file mode 100644 --- /dev/null +++ b/.git/objects/9f/2a3202024981da42b4521ac1ade80ad3d7b546 @@ -0,0 +1,2 @@ +x­Î=NÄ0@ajŸbz¤h<þ—Vˆ’žŽnÖo"b%Þû³ Ž@ûO/Ö¶ äÝÓÁ\³›]`[ț 1è*×J9êêm4‚³Šïs¼ñù)ûþ±r¿½~ƒËŸ,¿´üØë:fãm_òh/ -ÙdȓƒgŒˆê¡å)ÿS\ +œ£ Ô{ÏsýTߣôTè diff --git a/.git/refs/heads/master b/.git/refs/heads/master --- a/.git/refs/heads/master +++ b/.git/refs/heads/master @@ -1,1 +1,1 @@ -3bc5e4c57a4d26371071febf2c9201f648327754 +9f2a3202024981da42b4521ac1ade80ad3d7b546 diff --git a/.git/refs/remotes/origin/master b/.git/refs/remotes/origin/master --- a/.git/refs/remotes/origin/master +++ b/.git/refs/remotes/origin/master @@ -1,1 +1,1 @@ -3bc5e4c57a4d26371071febf2c9201f648327754 +9f2a3202024981da42b4521ac1ade80ad3d7b546 diff --git a/src/Language/Haskell/TH/Utils.hs b/src/Language/Haskell/TH/Utils.hs --- a/src/Language/Haskell/TH/Utils.hs +++ b/src/Language/Haskell/TH/Utils.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + module Language.Haskell.TH.Utils( appExp, appExp', appConT, appConT', @@ -8,34 +10,94 @@ curryKind, getTypeNames, getTVBName , - getCompositeType + getCompositeType,getConName, + seqTuple2, seqTuple3,seqTuple4, + rename, rename', rename'', + nameToExp, printQ ) where import Language.Haskell.TH import Language.Haskell.TH.Lib import Data.List (foldl1,foldr1) +import Control.Monad +import Language.Haskell.TH.Syntax --- | Apply a list of expression, [(+), 1, 2] to (+) 1 2 +-- | Pretty print spliced code +pprintQ :: Ppr a => Q a -> IO () +pprintQ q = runQ q >>= putStrLn.pprint + +-- | Print AST +printQ :: Show a => Q a -> IO () +printQ q = runQ q >>= putStrLn.show + +-- | sequence-like functons on tuples +seqTuple2 :: (Q a, Q b) -> Q (a, b) +seqTuple2 (a,b) = liftM2 (,) a b + +seqTuple3 :: (Q a, Q b, Q c) -> Q (a, b, c) +seqTuple3 (a,b,c) = liftM3 (,,) a b c + +seqTuple4 :: (Q a, Q b, Q c, Q d) -> Q (a, b, c, d) +seqTuple4 (a,b,c,d) = liftM4 (,,,) a b c d + +-- | Rename a 'Name' +rename' :: Name -> (String -> String) -> Name +rename' n f = mkName $ f $ nameBase n + +rename'' :: Name -> (String -> String) -> Q Name +rename'' n f = do + let nameStr = f $ nameBase n + return $ mkName nameStr + +rename :: Q Name -> (String -> String) -> Q Name +rename n f = do + bn <- n + let nameStr = f $ nameBase bn + return $ mkName nameStr + +{-| +> data Foo = Foo { foo :: Int } +> > $(nameToExp (++"1") 'foo) +> "foo1" +-} + +nameToExp :: (String -> String) -- ^ Function to change name. + -> Name + -> Q Exp +nameToExp f = litE . stringL . f . nameBase + +-- | Makes a string literal expression from a constructor's name. +conNameExp :: Con -> Q Exp +conNameExp = litE . stringL . nameBase . getConName + +-- | Apply a list of expression +-- | > [(+), 1, 2] to (+) 1 2 appExp :: [ExpQ] -> ExpQ appExp = appsE appExp' :: [Exp] -> Exp appExp' = foldl1 AppE --- | Apply a type constructor, convert [a, b, c] to a b c like 'appExp' +-- | Apply a type constructor +-- | > convert [a, b, c] to a b c like 'appExp' + +{-| +> > pprint $ appConT' (map ConT [''(,), ''Int , ''Bool]) +> "GHC.Tuple.(,) GHC.Types.Int GHC.Types.Bool" --i.e. (Int,Bool) +-} + appConT :: [TypeQ] -> TypeQ appConT = foldl1 appT appConT' :: [Type] -> Type appConT' = foldl1 AppT +-- | > convert [a, b, c] to a -> b -> c {-| -> > pprint $ appConT' (map ConT [''(,), ''Int , ''Bool]) -> "GHC.Tuple.(,) GHC.Types.Int GHC.Types.Bool" -|-} - --- | convert [a, b, c] to a -> b -> c +> > pprint $ curryType' (map ConT [''Int , ''Int , ''Bool]) +> "GHC.Types.Int -> GHC.Types.Int -> GHC.Types.Bool" +-} curryType :: [TypeQ] -> TypeQ curryType = foldr1 (\t1 -> appT (appT arrowT t1)) @@ -43,9 +105,9 @@ curryType' = foldr1 (\t1 -> AppT (AppT ArrowT t1)) {-| -> > pprint $ curryType' (map ConT [''Int , ''Int , ''Bool]) -> "GHC.Types.Int -> GHC.Types.Int -> GHC.Types.Bool" -|-} +> > genBT' "a" 3 +> ([PlainTV a1,PlainTV a2,PlainTV a3],[VarT a1,VarT a2,VarT a3]) +-} -- | Generate a list of type Bind and Type genBT :: String -> Int -> Q ([TyVarBndr], [TypeQ]) @@ -60,11 +122,11 @@ in (map (plainTV.mkName) ns, map (VarT . mkName) ns) {-| -> > genBT' "a" 3 -> ([PlainTV a1,PlainTV a2,PlainTV a3],[VarT a1,VarT a2,VarT a3]) -|-} - --- | Pattern and expression +> > genPE' "a" 3 +> ([VarP a1,VarP a2,VarP a3],[VarE a1,VarE a2,VarE a3]) +-} + +-- | Related patterns and expressions genPE :: String -> Int -> Q ([PatQ],[ExpQ]) genPE name n = do let ns = [name++ (show i) | i <- [1..n]] @@ -75,37 +137,44 @@ genPE' :: String -> Int -> ([Pat], [Exp]) genPE' name n = let ns = [name++ (show i) | i <- [1..n]] in (map (VarP . mkName) ns,map (VarE . mkName) ns) -{-| -> > genPE' "a" 3 -> ([VarP a1,VarP a2,VarP a3],[VarE a1,VarE a2,VarE a3]) -|-} --- | Apply a list of kinds + +-- | Apply a list of kinds, like 'appConT' appKinds :: [Kind] -> Kind appKinds = foldr1 AppT --- | convert [k1,k2,k3] to k1 -> k2 -> k3,like 'curryType' +-- | > convert [k1,k2,k3] to k1 -> k2 -> k3,like 'curryType' curryKind :: [Kind] -> Kind curryKind = curryType' --- | get type Names recursively +-- | Get name from constructors +getConName :: Con -> Name +getConName (NormalC name _) = name +getConName (RecC name _) = name +getConName (InfixC _ name _) = name +getConName (ForallC _ _ con) = getConName con + +-- | Get type Names recursively getTypeNames :: Type -> [Name] getTypeNames (ForallT tvbs cxt t) = getTypeNames t getTypeNames (ConT n) = [n] getTypeNames (AppT t1 t2) = getTypeNames t1 ++ getTypeNames t2 getTypeNames _ = [] --- | get type var bind name +-- | Get type var bind name getTVBName :: TyVarBndr -> Name getTVBName (PlainTV name ) = name getTVBName (KindedTV name _) = name third (a,b,c) = c --- | get all names recursively from a constructor +-- | Get all names recursively from a constructor getCompositeType :: Con -> [Name] getCompositeType (NormalC n sts) = concatMap getTypeNames (map snd sts) getCompositeType (RecC n vars) = concatMap getTypeNames (map third vars) getCompositeType (InfixC st1 n st2) = concatMap getTypeNames [snd st1 , snd st2] -- This could be a problem since it will lose info for context and type variables getCompositeType (ForallC tvbs cxt con) = getCompositeType con + + + diff --git a/template-haskell-util.cabal b/template-haskell-util.cabal --- a/template-haskell-util.cabal +++ b/template-haskell-util.cabal @@ -2,7 +2,7 @@ -- further documentation, see http://haskell.org/cabal/users-guide/ name: template-haskell-util -version: 0.1.0.1 +version: 0.1.0.2 synopsis: Some utilities for template Haskell. description: Some functions that might be useful when you use template haskell. homepage: https://github.com/HaskellZhangSong/TemplateHaskellUtils