ghc-syb-utils-0.2.1.1/0000755000000000000000000000000012023716211012524 5ustar0000000000000000ghc-syb-utils-0.2.1.1/ghc-syb-utils.cabal0000644000000000000000000000154512023716211016207 0ustar0000000000000000name: ghc-syb-utils version: 0.2.1.1 license: BSD3 license-file: LICENSE author: Claus Reinke copyright: (c) Claus Reinke 2008 maintainer: Thomas Schilling homepage: http://github.com/nominolo/ghc-syb description: Scrap Your Boilerplate utilities for the GHC API. synopsis: Scrap Your Boilerplate utilities for the GHC API. category: Development stability: provisional build-type: Simple cabal-version: >= 1.6 tested-with: GHC ==6.10.4, GHC ==6.12.1, GHC ==7.6.1 library build-depends: base >= 4 && < 5 , syb >= 0.1.0 if impl(ghc >= 7.0) build-depends: ghc else build-depends: ghc >= 6.10, ghc-syb == 0.2.* hs-source-dirs: . extensions: Rank2Types, CPP exposed-modules: GHC.SYB.Utils ghc-syb-utils-0.2.1.1/LICENSE0000644000000000000000000000272612023716211013540 0ustar0000000000000000Copyright 2008, Claus Reinke All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither name of the author nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ghc-syb-utils-0.2.1.1/Setup.hs0000644000000000000000000000012512023716211014156 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main :: IO () main = defaultMainghc-syb-utils-0.2.1.1/GHC/0000755000000000000000000000000012023716211013125 5ustar0000000000000000ghc-syb-utils-0.2.1.1/GHC/SYB/0000755000000000000000000000000012023716211013562 5ustar0000000000000000ghc-syb-utils-0.2.1.1/GHC/SYB/Utils.hs0000644000000000000000000002052312023716211015220 0ustar0000000000000000{-# LANGUAGE CPP #-} {- | "GHC.Syb.Utils" provides common utilities for the Ghc Api, either based on Data\/Typeable or for use with Data.Generics over Ghc Api types. example output of 'showData' on 'parsedSource', 'renamedSource', and 'typecheckedSource' for a trivial @HelloWorld@ module, compared with 'ppr' output: @ ------------------------- pretty-printed parsedSource module HelloWorld where main = putStrLn "Hello, World!" ------------------------- pretty-printed renamedSource Just (HelloWorld.main = System.IO.putStrLn "Hello, World!", [import Prelude], Nothing, Nothing, (HaddockModInfo (Nothing) (Nothing) (Nothing) (Nothing))) ------------------------- pretty-printed typecheckedSource Just ------------------------- shown parsedSource (L {HelloWorld.hs:1:0} (HsModule (Just (L {HelloWorld.hs:1:7-16} {ModuleName: HelloWorld})) (Nothing) [] [ (L {HelloWorld.hs:2:0-30} (ValD (FunBind (L {HelloWorld.hs:2:0-3} (Unqual {OccName: main})) (False) (MatchGroup [ (L {HelloWorld.hs:2:0-30} (Match [] (Nothing) (GRHSs [ (L {HelloWorld.hs:2:7-30} (GRHS [] (L {HelloWorld.hs:2:7-30} (HsApp (L {HelloWorld.hs:2:7-14} (HsVar (Unqual {OccName: putStrLn}))) (L {HelloWorld.hs:2:16-30} (HsLit (HsString {FastString: "Hello, World!"})))))))] (EmptyLocalBinds))))] {!type placeholder here?!}) (WpHole) {!NameSet placeholder here!} (Nothing))))] (Nothing) (HaddockModInfo (Nothing) (Nothing) (Nothing) (Nothing)) (Nothing))) ------------------------- shown renamedSource ((,,,,) (HsGroup (ValBindsOut [ ((,) (NonRecursive) {Bag(Located (HsBind Name)): [ (L {HelloWorld.hs:2:0-30} (FunBind (L {HelloWorld.hs:2:0-3} {Name: HelloWorld.main}) (False) (MatchGroup [ (L {HelloWorld.hs:2:0-30} (Match [] (Nothing) (GRHSs [ (L {HelloWorld.hs:2:7-30} (GRHS [] (L {HelloWorld.hs:2:7-30} (HsApp (L {HelloWorld.hs:2:7-14} (HsVar {Name: System.IO.putStrLn})) (L {HelloWorld.hs:2:16-30} (HsLit (HsString {FastString: "Hello, World!"})))))))] (EmptyLocalBinds))))] {!type placeholder here?!}) (WpHole) {NameSet: [{Name: System.IO.putStrLn}]} (Nothing)))]})] []) [] [] [] [] [] [] [] [] []) [ (L {Implicit import declaration} (ImportDecl (L {Implicit import declaration} {ModuleName: Prelude}) (False) (False) (Nothing) (Nothing)))] (Nothing) (Nothing) (HaddockModInfo (Nothing) (Nothing) (Nothing) (Nothing))) ------------------------- shown typecheckedSource {Bag(Located (HsBind Var)): [ (L {HelloWorld.hs:2:0-30} (AbsBinds [] [] [ ((,,,) [] {Var: HelloWorld.main} {Var: main} [])] {Bag(Located (HsBind Var)): [ (L {HelloWorld.hs:2:0-30} (FunBind (L {HelloWorld.hs:2:0-3} {Var: main}) (False) (MatchGroup [ (L {HelloWorld.hs:2:0-30} (Match [] (Nothing) (GRHSs [ (L {HelloWorld.hs:2:7-30} (GRHS [] (L {HelloWorld.hs:2:7-30} (HsApp (L {HelloWorld.hs:2:7-14} (HsVar {Var: System.IO.putStrLn})) (L {HelloWorld.hs:2:16-30} (HsLit (HsString {FastString: "Hello, World!"})))))))] (EmptyLocalBinds))))] GHC.IOBase.IO ()) (WpHole) {!NameSet placeholder here!} (Nothing)))]}))]} @ -} module GHC.SYB.Utils where import Data.Generics -- import qualified GHC.Paths import PprTyThing import DynFlags import GHC import Outputable import SrcLoc import qualified OccName(occNameString) import Bag(Bag,bagToList) import Var(Var) import FastString(FastString) import NameSet(NameSet,nameSetToList) #if __GLASGOW_HASKELL__ < 700 import GHC.SYB.Instances #endif import Data.List showSDoc_ :: SDoc -> String #if __GLASGOW_HASKELL__ < 706 showSDoc_ = showSDoc #else showSDoc_ = showSDoc tracingDynFlags #endif -- | Ghc Ast types tend to have undefined holes, to be filled -- by later compiler phases. We tag Asts with their source, -- so that we can avoid such holes based on who generated the Asts. data Stage = Parser | Renamer | TypeChecker deriving (Eq,Ord,Show) -- | Generic Data-based show, with special cases for GHC Ast types, -- and simplistic indentation-based layout (the 'Int' parameter); -- showing abstract types abstractly and avoiding known potholes -- (based on the 'Stage' that generated the Ast) showData :: Data a => Stage -> Int -> a -> String showData stage n = generic `ext1Q` list `extQ` string `extQ` fastString `extQ` srcSpan `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet `extQ` postTcType `extQ` fixity where generic :: Data a => a -> String generic t = indent n ++ "(" ++ showConstr (toConstr t) ++ space (concat (intersperse " " (gmapQ (showData stage (n+1)) t))) ++ ")" space "" = "" space s = ' ':s indent n = "\n" ++ replicate n ' ' string = show :: String -> String fastString = ("{FastString: "++) . (++"}") . show :: FastString -> String list l = indent n ++ "[" ++ concat (intersperse "," (map (showData stage (n+1)) l)) ++ "]" name = ("{Name: "++) . (++"}") . showSDoc_ . ppr :: Name -> String occName = ("{OccName: "++) . (++"}") . OccName.occNameString moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . ppr :: ModuleName -> String srcSpan = ("{"++) . (++"}") . showSDoc_ . ppr :: SrcSpan -> String var = ("{Var: "++) . (++"}") . showSDoc_ . ppr :: Var -> String dataCon = ("{DataCon: "++) . (++"}") . showSDoc_ . ppr :: DataCon -> String bagRdrName:: Bag (Located (HsBind RdrName)) -> String bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . bagToList bagName :: Bag (Located (HsBind Name)) -> String bagName = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . bagToList bagVar :: Bag (Located (HsBind Var)) -> String bagVar = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . bagToList nameSet | stage `elem` [Parser,TypeChecker] = const ("{!NameSet placeholder here!}") :: NameSet -> String | otherwise = ("{NameSet: "++) . (++"}") . list . nameSetToList postTcType | stage String | otherwise = showSDoc_ . ppr :: Type -> String fixity | stage String | otherwise = ("{Fixity: "++) . (++"}") . showSDoc_ . ppr :: GHC.Fixity -> String -- | Like 'everything', but avoid known potholes, based on the 'Stage' that -- generated the Ast. everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r everythingStaged stage k z f x | (const False `extQ` postTcType `extQ` fixity `extQ` nameSet) x = z | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x) where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool postTcType = const (stage Bool fixity = const (stage Bool -- | A variation of 'everything', using a 'GenericQ Bool' to skip -- parts of the input 'Data'. --everythingBut :: GenericQ Bool -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r --everythingBut q k z f x -- | q x = z -- | otherwise = foldl k (f x) (gmapQ (everythingBut q k z f) x)