diff --git a/.git/COMMIT_EDITMSG b/.git/COMMIT_EDITMSG --- a/.git/COMMIT_EDITMSG +++ b/.git/COMMIT_EDITMSG @@ -1,9 +1,10 @@ -add some functions +cabal file update # 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 up-to-date with 'origin/master'. +# Your branch is ahead of 'origin/master' by 1 commit. +# (use "git push" to publish your local commits) # # Changes to be committed: -# modified: Utils.hs +# modified: template-haskell-util.cabal # diff --git a/.git/COMMIT_EDITMSG~ b/.git/COMMIT_EDITMSG~ --- a/.git/COMMIT_EDITMSG~ +++ b/.git/COMMIT_EDITMSG~ @@ -2,8 +2,9 @@ # 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 up-to-date with 'origin/master'. +# Your branch is ahead of 'origin/master' by 1 commit. +# (use "git push" to publish your local commits) # # Changes to be committed: -# modified: Utils.hs +# modified: template-haskell-util.cabal # 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 @@ -6,3 +6,5 @@ 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 +9f2a3202024981da42b4521ac1ade80ad3d7b546 5f1699dd4e3d55b4caa1e57011c3532da41e3399 HaskellZhangSong 1424945343 +0800 commit: added print functions +5f1699dd4e3d55b4caa1e57011c3532da41e3399 01a44973c56cb3b89b9b94d32e0674fb4139b519 HaskellZhangSong 1424945392 +0800 commit: cabal file update 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 @@ -6,3 +6,5 @@ 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 +9f2a3202024981da42b4521ac1ade80ad3d7b546 5f1699dd4e3d55b4caa1e57011c3532da41e3399 HaskellZhangSong 1424945343 +0800 commit: added print functions +5f1699dd4e3d55b4caa1e57011c3532da41e3399 01a44973c56cb3b89b9b94d32e0674fb4139b519 HaskellZhangSong 1424945392 +0800 commit: cabal file update 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 @@ -4,3 +4,4 @@ be3fb7a2051f825f8d2a8b3d299a604abf2b5244 084a706a37d6164dfb1fab5dcd4e098bcdfe0ffa HaskellZhangSong 1424587175 +0800 update by push 084a706a37d6164dfb1fab5dcd4e098bcdfe0ffa 3bc5e4c57a4d26371071febf2c9201f648327754 HaskellZhangSong 1424591608 +0800 update by push 3bc5e4c57a4d26371071febf2c9201f648327754 9f2a3202024981da42b4521ac1ade80ad3d7b546 HaskellZhangSong 1424932730 +0800 update by push +9f2a3202024981da42b4521ac1ade80ad3d7b546 01a44973c56cb3b89b9b94d32e0674fb4139b519 HaskellZhangSong 1424945432 +0800 update by push diff --git a/.git/objects/01/a44973c56cb3b89b9b94d32e0674fb4139b519 b/.git/objects/01/a44973c56cb3b89b9b94d32e0674fb4139b519 new file mode 100644 --- /dev/null +++ b/.git/objects/01/a44973c56cb3b89b9b94d32e0674fb4139b519 @@ -0,0 +1,3 @@ +x­Î=Â0 @aæœÂ;R7qÁBŒìllnâЊ´©J¸??â¬ßðôB™¦±BÛùM]U GV +Øc׳Mœ¼SÞÒNuESrÈf‘Uç +”°cŽÑ«‹D½"¨´³ˆÁ‘k£xT瘍<ëPV8Ëã®9_™o—2ßàð“æKÍÇNC©“Œ¹ e:úÖ³'Ç-líÞZóÖ÷rÕ¿ÄL^2¤1+<—(UÍ IVB diff --git a/.git/objects/06/14f36be9b51319da5697bdeb915abdeef87598 b/.git/objects/06/14f36be9b51319da5697bdeb915abdeef87598 new file mode 100644 Binary files /dev/null and b/.git/objects/06/14f36be9b51319da5697bdeb915abdeef87598 differ diff --git a/.git/objects/08/2597fc126f447143f810f32ce83938409c4055 b/.git/objects/08/2597fc126f447143f810f32ce83938409c4055 new file mode 100644 Binary files /dev/null and b/.git/objects/08/2597fc126f447143f810f32ce83938409c4055 differ diff --git a/.git/objects/14/cc1d44e537fa8f1f5f188c77de2de18c399dd8 b/.git/objects/14/cc1d44e537fa8f1f5f188c77de2de18c399dd8 new file mode 100644 Binary files /dev/null and b/.git/objects/14/cc1d44e537fa8f1f5f188c77de2de18c399dd8 differ diff --git a/.git/objects/1d/c0ca8607b48e6eb1ef35d1a875020bad45711b b/.git/objects/1d/c0ca8607b48e6eb1ef35d1a875020bad45711b new file mode 100644 Binary files /dev/null and b/.git/objects/1d/c0ca8607b48e6eb1ef35d1a875020bad45711b differ diff --git a/.git/objects/1e/427715ecf5a13ab5e0dd5148343b3c5c85ede3 b/.git/objects/1e/427715ecf5a13ab5e0dd5148343b3c5c85ede3 new file mode 100644 Binary files /dev/null and b/.git/objects/1e/427715ecf5a13ab5e0dd5148343b3c5c85ede3 differ diff --git a/.git/objects/4e/5006d92e85b87d8f4d74bcc32eb6533505ce5e b/.git/objects/4e/5006d92e85b87d8f4d74bcc32eb6533505ce5e new file mode 100644 Binary files /dev/null and b/.git/objects/4e/5006d92e85b87d8f4d74bcc32eb6533505ce5e differ diff --git a/.git/objects/5f/1699dd4e3d55b4caa1e57011c3532da41e3399 b/.git/objects/5f/1699dd4e3d55b4caa1e57011c3532da41e3399 new file mode 100644 Binary files /dev/null and b/.git/objects/5f/1699dd4e3d55b4caa1e57011c3532da41e3399 differ diff --git a/.git/objects/95/1c9d9e5c1b16b90f9f43e97c5e6ee8daeff319 b/.git/objects/95/1c9d9e5c1b16b90f9f43e97c5e6ee8daeff319 new file mode 100644 Binary files /dev/null and b/.git/objects/95/1c9d9e5c1b16b90f9f43e97c5e6ee8daeff319 differ diff --git a/.git/objects/d1/f000c134b3b213d6a4be1bd79e2ae3bd7fe8de b/.git/objects/d1/f000c134b3b213d6a4be1bd79e2ae3bd7fe8de new file mode 100644 Binary files /dev/null and b/.git/objects/d1/f000c134b3b213d6a4be1bd79e2ae3bd7fe8de differ 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 @@ -9f2a3202024981da42b4521ac1ade80ad3d7b546 +01a44973c56cb3b89b9b94d32e0674fb4139b519 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 @@ -9f2a3202024981da42b4521ac1ade80ad3d7b546 +01a44973c56cb3b89b9b94d32e0674fb4139b519 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,4 +1,17 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell , DeriveGeneric,StandaloneDeriving, TypeFamilies,UndecidableInstances, MagicHash #-} +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.TH.Utils +-- Copyright : None +-- License : MIT (see the file libraries/base/LICENSE) +-- +-- Maintainer : Haskell.Zhang.Song@hotmail.com +-- Stability : experimental +-- Portability : non-portable +-- +-- Some auxiliary functions that might be needed when using template Haskell +-- +----------------------------------------------------------------------------- module Language.Haskell.TH.Utils( appExp, appExp', @@ -11,37 +24,199 @@ getTypeNames, getTVBName , getCompositeType,getConName, - seqTuple2, seqTuple3,seqTuple4, + seqTup2, seqTup3,seqTup4, rename, rename', rename'', - nameToExp, printQ + nameToExp, + printQ, pprintQ, printiQ, printi, + -- | exported GenericPretty package + module Text.PrettyPrint.GenericPretty ) where import Language.Haskell.TH -import Language.Haskell.TH.Lib +import Language.Haskell.TH.Lib hiding (Role) import Data.List (foldl1,foldr1) import Control.Monad import Language.Haskell.TH.Syntax +import Text.PrettyPrint.GenericPretty +import GHC.Generics hiding (Fixity) +import GHC.Word +import GHC.Types +-- sorry for the following messy, I will write a library to generate empty instances automatically +instance Out Name +instance Out Type +instance Out TyVarBndr +instance Out TyLit +instance Out Exp +instance Out Lit +instance Out Pat +instance Out Dec +instance Out Clause +instance Out FunDep +instance Out Foreign +instance Out Fixity +instance Out Pragma +instance Out FamFlavour +instance Out TySynEqn +instance Out Role +instance Out Loc +instance Out Info +instance Out Module +instance Out ModuleInfo +instance Out Strict +instance Out Callconv +instance Out Safety +instance Out Stmt +instance Out Range +instance (Generic a,Out a) => Out (TExp a) +instance Out FixityDirection +instance Out Match +instance Out Guard +instance Out Body +instance Out ModName +instance Out NameFlavour +instance Out Con +instance Out Inline +instance Out RuleBndr +instance Out RuleMatch +instance Out Pred +instance Out Phases +instance Out PkgName +instance Out OccName +instance Out AnnTarget +instance Out Word8 + +-- sorry for the messy, I will also write a library to do this automatically +deriving instance Generic FixityDirection +deriving instance Generic Inline +deriving instance Generic RuleBndr +deriving instance Generic Match +deriving instance Generic Name +deriving instance Generic RuleMatch +deriving instance Generic Pred +deriving instance Generic Phases +deriving instance Generic Con +deriving instance Generic Module +deriving instance Generic AnnTarget +deriving instance Generic Type +deriving instance Generic TyVarBndr +deriving instance Generic TyLit +deriving instance Generic Exp +deriving instance Generic Lit +deriving instance Generic Pat +deriving instance Generic Dec +deriving instance Generic Clause +deriving instance Generic FunDep +deriving instance Generic Foreign +deriving instance Generic Fixity +deriving instance Generic Pragma +deriving instance Generic FamFlavour +deriving instance Generic TySynEqn +deriving instance Generic Role +deriving instance Generic Loc +deriving instance Generic Info +deriving instance Generic ModuleInfo +deriving instance Generic Strict +deriving instance Generic Callconv +deriving instance Generic Safety +deriving instance Generic Stmt +deriving instance Generic Range +deriving instance Generic a => Generic (TExp a) +deriving instance Generic Guard +deriving instance Generic Body +deriving instance Generic ModName +deriving instance Generic PkgName +deriving instance Generic OccName + +data C_Word8 +data D_Word8 + +instance Datatype D_Word8 where + datatypeName _ = "Word" + moduleName _ = "GHC.Word" +instance Constructor C_Word8 where + conName _ = "" + +deriving instance Generic NameSpace +instance Out NameSpace + +instance Generic Word8 where + type Rep Word8 = D1 D_Word8 (C1 C_Word8 (S1 NoSelector (Rec0 Word8))) + from x = M1 (M1 (M1 (K1 x))) + to (M1 (M1 (M1 (K1 x)))) = x + +-- This is bacause GHC 7.8 does not support unboxed value to be made into Generic +instance Generic NameFlavour where + type Rep NameFlavour = (Rep NameFlavour') + from (NameS) = from NameS' + from (NameQ m) = from (NameQ' m) + from (NameU i) = from (NameU' (I# i)) + from (NameL i) = from (NameL' (I# i)) + from (NameG ns p m) = from (NameG' ns p m) + to M1 {unM1 = L1 (L1 (M1 {unM1 = U1}))} = NameS + to M1 {unM1 = L1 (R1 (M1 {unM1 = M1 {unM1 = K1 {unK1 = ModName mn }}}))} = NameQ (ModName mn) + to M1 {unM1 = R1 (L1 (M1 {unM1 = M1 {unM1 = K1 {unK1 = (I# n)}}}))} = NameU n + to M1 {unM1 = R1 (R1 (L1 (M1 {unM1 = M1 {unM1 = K1 {unK1 = (I# n)}}})))} = NameL n + to M1 {unM1 = R1 (R1 (R1 (M1 {unM1 = M1 {unM1 = K1 {unK1 = ns}} :*: (M1 {unM1 = K1 {unK1 = PkgName p}} :*: M1 {unM1 = K1 {unK1 = ModName m}})})))} = NameG ns (PkgName p) (ModName m) + +data NameFlavour' = NameS' + | NameQ' ModName + | NameU' Int + | NameL' Int + | NameG' NameSpace PkgName ModName + deriving (Generic,Show) + +deriving instance Show NameSpace + -- | Pretty print spliced code pprintQ :: Ppr a => Q a -> IO () pprintQ q = runQ q >>= putStrLn.pprint --- | Print AST +-- | Print AST with indentions. There are also other exported functions from genericpretty library. See 'Out'. +{-| +> runQ [| (1+1) * 5|] >>= pp -- or use +> printiQ [| (1+1) * 5|] +InfixE (Just InfixE (Just LitE (IntegerL 1)) + (VarE (Name (OccName "+") + (NameG' VarName + (PkgName "base") + (ModName "GHC.Num")))) + (Just LitE (IntegerL 1))) + (VarE (Name (OccName "*") + (NameG' VarName + (PkgName "base") + (ModName "GHC.Num")))) + (Just LitE (IntegerL 5)) +-} +printiQ :: Out a => Q a -> IO () +printiQ q = runQ q >>= pp + +-- | Print AST with identions +printi :: Out a => a -> IO () +printi a = pp a + +-- | Print AST of the code. 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 +seqTup2 :: (Q a, Q b) -> Q (a, b) +seqTup2 (a,b) = liftM2 (,) a b -seqTuple3 :: (Q a, Q b, Q c) -> Q (a, b, c) -seqTuple3 (a,b,c) = liftM3 (,,) a b c +seqTup3 :: (Q a, Q b, Q c) -> Q (a, b, c) +seqTup3 (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 +seqTup4 :: (Q a, Q b, Q c, Q d) -> Q (a, b, c, d) +seqTup4 (a,b,c,d) = liftM4 (,,,) a b c d -- | Rename a 'Name' +rename :: Q Name -> (String -> String) -> Q Name +rename n f = do + bn <- n + let nameStr = f $ nameBase bn + return $ mkName nameStr + rename' :: Name -> (String -> String) -> Name rename' n f = mkName $ f $ nameBase n @@ -50,18 +225,11 @@ 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 @@ -72,15 +240,19 @@ conNameExp = litE . stringL . nameBase . getConName -- | Apply a list of expression --- | > [(+), 1, 2] to (+) 1 2 +{-| +> [(+), 1, 2] to (+) 1 2 +> appExp' [VarE '(+) , (LitE (IntegerL 1)), (LitE (IntegerL 2))] +> >AppE (AppE (VarE GHC.Num.+) (LitE (IntegerL 1))) (LitE (IntegerL 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 like 'appExp' {-| > > pprint $ appConT' (map ConT [''(,), ''Int , ''Bool]) @@ -117,6 +289,7 @@ typ <- sequence $ map (return.varT.mkName) ns return (tvb,typ) +-- | Generate a list of type Bind and Type without Q genBT' :: String -> Int -> ([TyVarBndr], [Type]) genBT' name n = let ns = [name++ (show i) | i <- [1..n]] in (map (plainTV.mkName) ns, map (VarT . mkName) ns) @@ -126,7 +299,7 @@ > ([VarP a1,VarP a2,VarP a3],[VarE a1,VarE a2,VarE a3]) -} --- | Related patterns and expressions +-- | Generate related patterns and expressions genPE :: String -> Int -> Q ([PatQ],[ExpQ]) genPE name n = do let ns = [name++ (show i) | i <- [1..n]] @@ -134,6 +307,7 @@ exp <- sequence $ map (return.varE.mkName) ns return (pat,exp) +-- | Generate related patterns and expressions without Q 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) @@ -142,7 +316,7 @@ appKinds :: [Kind] -> Kind appKinds = foldr1 AppT --- | > convert [k1,k2,k3] to k1 -> k2 -> k3,like 'curryType' +-- | Like 'curryType' but on kind level curryKind :: [Kind] -> Kind curryKind = curryType' @@ -174,7 +348,4 @@ 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.2 +version: 0.1.0.3 synopsis: Some utilities for template Haskell. description: Some functions that might be useful when you use template haskell. homepage: https://github.com/HaskellZhangSong/TemplateHaskellUtils @@ -22,6 +22,6 @@ Language.Haskell.TH.Utils -- other-modules: -- other-extensions: - build-depends: base ==4.* , template-haskell >= 2.9 + build-depends: base ==4.* , template-haskell >= 2.9 , GenericPretty >= 1.2.1 hs-source-dirs: src default-language: Haskell2010