├── .gitignore ├── Setup.hs ├── Language └── Haskell │ └── TH │ ├── Cleanup.hs │ └── Cleanup │ ├── Rules.hs │ └── Lens.hs ├── th-pprint.cabal └── LICENSE /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Language/Haskell/TH/Cleanup.hs: -------------------------------------------------------------------------------- 1 | module Language.Haskell.TH.Cleanup ( 2 | renderNoLength 3 | , simplifiedTH 4 | ) where 5 | 6 | import Control.Lens 7 | import Language.Haskell.TH 8 | import Language.Haskell.TH.Cleanup.Rules 9 | import Language.Haskell.TH.Cleanup.Lens 10 | import Language.Haskell.TH.PprLib 11 | import qualified Text.PrettyPrint as HPJ 12 | 13 | renderNoLength :: Ppr a => a -> String 14 | renderNoLength = 15 | HPJ.renderStyle (HPJ.style { HPJ.lineLength = maxBound }) . to_HPJ_Doc . ppr 16 | 17 | -- | Simplifies and pretty-prints declarations. Will give back a quoted string. 18 | -- 19 | -- Can be used from GHCi like so: 20 | -- 21 | -- > putStrLn $(simplifiedTH =<< makePrisms ''Either) 22 | simplifiedTH :: [Dec] -> ExpQ 23 | simplifiedTH = 24 | stringE . renderNoLength . fmap (transform simplifyDec . removeAllModNames) 25 | -------------------------------------------------------------------------------- /th-pprint.cabal: -------------------------------------------------------------------------------- 1 | name: th-pprint 2 | version: 0.2.0.0 3 | license: BSD3 4 | license-file: LICENSE 5 | author: Brian McKenna 6 | maintainer: brian@brianmckenna.org 7 | category: Development 8 | build-type: Simple 9 | cabal-version: >=1.10 10 | synopsis: Simplify and render Template Haskell 11 | description: 12 | Simplify and render Template Haskell. Functions to dump TH code for easy 13 | inspection and/or copy-pasting the result into your Haskell files. 14 | . 15 | For example: 16 | . 17 | > putStrLn $(simplifiedTH =<< makePrisms ''Maybe) 18 | 19 | source-repository head 20 | type: git 21 | location: https://github.com/puffnfresh/th-pprint.git 22 | 23 | library 24 | exposed-modules: Language.Haskell.TH.Cleanup 25 | , Language.Haskell.TH.Cleanup.Lens 26 | , Language.Haskell.TH.Cleanup.Rules 27 | build-depends: base >= 4.5 && < 5 28 | , lens 29 | , pretty 30 | , template-haskell 31 | default-language: Haskell2010 32 | -------------------------------------------------------------------------------- /Language/Haskell/TH/Cleanup/Rules.hs: -------------------------------------------------------------------------------- 1 | module Language.Haskell.TH.Cleanup.Rules ( 2 | emptyForallT 3 | , filterModName 4 | , removeModName 5 | , removeAllModNames 6 | , simplifyDec 7 | , simplifyClause 8 | ) where 9 | 10 | import Control.Lens 11 | import Language.Haskell.TH 12 | import Language.Haskell.TH.Cleanup.Lens 13 | import Language.Haskell.TH.Syntax 14 | 15 | emptyForallT :: Type -> Maybe Type 16 | emptyForallT (ForallT [] _ a) = 17 | Just a 18 | emptyForallT _ = 19 | Nothing 20 | 21 | filterModName :: (ModName -> Bool) -> Name -> Name 22 | filterModName f = 23 | _Name . _2 %~ f' 24 | where 25 | f' (NameG _ _ c) | not (f c)= 26 | NameS 27 | f' n = 28 | n 29 | 30 | removeModName :: Name -> Name 31 | removeModName = 32 | filterModName (const False) 33 | 34 | removeAllModNames :: Dec -> Dec 35 | removeAllModNames = 36 | decName %~ removeModName 37 | 38 | simplifyDec :: Dec -> Dec 39 | simplifyDec = 40 | (rewriteOn (_SigD . _2) emptyForallT) . 41 | (_FunD . _2 . single %~ simplifyClause) 42 | 43 | single :: Traversal' [a] a 44 | single f [a] = 45 | (:[]) <$> f a 46 | single _ xs = 47 | pure xs 48 | 49 | simplifyClause :: Clause -> Clause 50 | simplifyClause (Clause [] (NormalB (LamE pats b)) []) = 51 | Clause pats (NormalB b) [] 52 | simplifyClause c = 53 | c 54 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Brian McKenna 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Brian McKenna nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Language/Haskell/TH/Cleanup/Lens.hs: -------------------------------------------------------------------------------- 1 | module Language.Haskell.TH.Cleanup.Lens ( 2 | _FunD 3 | , _SigD 4 | , _Name 5 | , typeName 6 | , clauseName 7 | , decName 8 | , matchName 9 | , expName 10 | , patName 11 | , bodyExp 12 | ) where 13 | 14 | import Control.Lens 15 | import Language.Haskell.TH 16 | import Language.Haskell.TH.Lens 17 | import Language.Haskell.TH.Syntax 18 | 19 | _Name :: Iso' Name (OccName, NameFlavour) 20 | _Name = iso (\(Name x1_0 x2_1) -> (x1_0, x2_1)) (\(x1_2, x2_3) -> Name x1_2 x2_3) 21 | 22 | typeName :: Traversal' Type Name 23 | typeName f (VarT a) = 24 | VarT <$> f a 25 | typeName f (ConT a) = 26 | ConT <$> f a 27 | typeName f (PromotedT a) = 28 | PromotedT <$> f a 29 | typeName f (InfixT a b c) = 30 | flip (InfixT a) c <$> f b 31 | typeName f (UInfixT a b c) = 32 | flip (UInfixT a) c <$> f b 33 | typeName f a = 34 | (plate . typeName) f a 35 | 36 | clauseName :: Traversal' Clause Name 37 | clauseName f (Clause a b c) = 38 | Clause <$> (traverse . patName) f a <*> (bodyExp . expName) f b <*> (traverse . decName) f c 39 | 40 | decName :: Traversal' Dec Name 41 | decName f (FunD a b) = 42 | FunD <$> f a <*> (traverse . clauseName) f b 43 | decName f (ValD a b c) = 44 | ValD <$> patName f a <*> (bodyExp . expName) f b <*> (traverse . decName) f c 45 | decName f (ClassD a b c d e) = 46 | ClassD <$> (traverse . typeName) f a <*> f b <*> pure c <*> pure d <*> (traverse . decName) f e 47 | decName f (InstanceD a b c d) = 48 | InstanceD a <$> (traverse . typeName) f b <*> typeName f c <*> (traverse . decName) f d 49 | decName f (SigD a b) = 50 | SigD <$> f a <*> typeName f b 51 | decName f (DefaultSigD a b) = 52 | DefaultSigD <$> f a <*> typeName f b 53 | decName f (TySynInstD a (TySynEqn b c)) = 54 | TySynInstD <$> f a <*> (TySynEqn <$> (traverse . typeName) f b <*> typeName f c) 55 | decName _ a = 56 | pure a 57 | 58 | matchName :: Traversal' Match Name 59 | matchName f (Match a b c) = 60 | Match <$> patName f a <*> (bodyExp . expName) f b <*> (traverse . decName) f c 61 | 62 | expName :: Traversal' Exp Name 63 | expName f (VarE a) = 64 | VarE <$> f a 65 | expName f (ConE a) = 66 | ConE <$> f a 67 | expName f (LamE a b) = 68 | LamE <$> (traverse . patName) f a <*> expName f b 69 | expName f (LetE a b) = 70 | LetE <$> (traverse . decName) f a <*> expName f b 71 | expName f (CaseE a b) = 72 | CaseE <$> expName f a <*> (traverse . matchName) f b 73 | expName f a = 74 | (plate . expName) f a 75 | 76 | patName :: Traversal' Pat Name 77 | patName f (VarP a) = 78 | VarP <$> f a 79 | patName f (ConP a b) = 80 | ConP <$> f a <*> (traverse . patName) f b 81 | patName _ a = 82 | pure a 83 | 84 | bodyExp :: Traversal' Body Exp 85 | bodyExp = 86 | failing _NormalB (_GuardedB . traverse . _2) 87 | --------------------------------------------------------------------------------