ghc-syb-utils 0.2.3.3 → 0.3.0.0
raw patch · 4 files changed
+9/−369 lines, 4 filesdep +bytestringdep −directorydep −filepathdep −ghc-pathsdep ~basedep ~ghcnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: bytestring
Dependencies removed: directory, filepath, ghc-paths, ghc-syb, ghc-syb-utils
Dependency ranges changed: base, ghc
API changes (from Hackage documentation)
- GHC.SYB.Utils: showData :: Data a => Stage -> Int -> a -> String
- GHC.SYB.Utils: showSDoc_ :: SDoc -> String
Files
- GHC/SYB/Utils.hs +4/−283
- ghc-syb-utils.cabal +5/−29
- test/Regression.hs +0/−50
- test/test-cases/GithubIssue9.hs +0/−7
GHC/SYB/Utils.hs view
@@ -3,300 +3,41 @@ {- | "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 <AbsBinds [] [] [HelloWorld.main <= [] main]- HelloWorld.main :: GHC.IOBase.IO ()- []- { main = System.IO.putStrLn "Hello, World!" }>-------------------------- 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 hiding (moduleName)-import Outputable hiding (space) import SrcLoc()-import qualified OccName(occNameString)-import Bag(Bag,bagToList)-import Var(Var)-import FastString(FastString) #if __GLASGOW_HASKELL__ >= 802-import NameSet(NameSet,nameSetElemsStable)+import NameSet(NameSet) #elif __GLASGOW_HASKELL__ >= 709-import NameSet(NameSet,nameSetElems)-#else-import NameSet(NameSet,nameSetToList)-#endif--#if __GLASGOW_HASKELL__ < 700-import GHC.SYB.Instances+import NameSet(NameSet) #endif import Control.Monad-import Data.List -#if __GLASGOW_HASKELL__ >= 802-nameSetElems :: NameSet -> [Name]-nameSetElems = nameSetElemsStable-#elif __GLASGOW_HASKELL__ < 709-nameSetElems :: NameSet -> [Name]-nameSetElems = nameSetToList-#endif--showSDoc_ :: SDoc -> String-#if __GLASGOW_HASKELL__ >= 707-showSDoc_ = showSDoc unsafeGlobalDynFlags-#elif __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` overLit- `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet-#if __GLASGOW_HASKELL__ <= 708- `extQ` postTcType-#endif- `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 i = "\n" ++ replicate i ' '- 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-- overLit :: (HsOverLit RdrName) -> String- overLit = ("{HsOverLit:"++) . (++"}") . showSDoc_ . ppr-- 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 . nameSetElems --#if __GLASGOW_HASKELL__ <= 708- postTcType | stage<TypeChecker = const "{!type placeholder here?!}" :: PostTcType -> String- | otherwise = showSDoc_ . ppr :: Type -> String-#endif- fixity | stage<Renamer = const "{!fixity placeholder here?!}" :: GHC.Fixity -> 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 +everythingStaged stage k z f x | (const False-#if __GLASGOW_HASKELL__ <= 708- `extQ` postTcType-#endif `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-#if __GLASGOW_HASKELL__ <= 708- postTcType = const (stage<TypeChecker) :: PostTcType -> Bool-#endif fixity = const (stage<Renamer) :: GHC.Fixity -> 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 +--everythingBut q k z f x -- | q x = z -- | otherwise = foldl k (f x) (gmapQ (everythingBut q k z f) x) @@ -305,17 +46,11 @@ everythingButStaged :: Stage -> (r -> r -> r) -> r -> GenericQ (r,Bool) -> GenericQ r everythingButStaged stage k z f x | (const False-#if __GLASGOW_HASKELL__ <= 708- `extQ` postTcType-#endif `extQ` fixity `extQ` nameSet) x = z | stop == True = v | otherwise = foldl k v (gmapQ (everythingButStaged stage k z f) x) where (v, stop) = f x nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool-#if __GLASGOW_HASKELL__ <= 708- postTcType = const (stage<TypeChecker) :: PostTcType -> Bool-#endif fixity = const (stage<Renamer) :: GHC.Fixity -> Bool -- | Look up a subterm by means of a maybe-typed filter.@@ -336,15 +71,9 @@ somewhereStaged stage f x | (const False-#if __GLASGOW_HASKELL__ <= 708- `extQ` postTcType-#endif `extQ` fixity `extQ` nameSet) x = mzero | otherwise = f x `mplus` gmapMp (somewhereStaged stage f) x where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool-#if __GLASGOW_HASKELL__ <= 708- postTcType = const (stage<TypeChecker) :: PostTcType -> Bool-#endif fixity = const (stage<Renamer) :: GHC.Fixity -> Bool -- ---------------------------------------------------------------------@@ -375,16 +104,8 @@ -- Bottom-up order is also reflected in order of do-actions everywhereMStaged stage f x | (const False-#if __GLASGOW_HASKELL__ <= 708- `extQ` postTcType-#endif `extQ` fixity `extQ` nameSet) x = return x | otherwise = do x' <- gmapM (everywhereMStaged stage f) x f x' where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool-#if __GLASGOW_HASKELL__ <= 708- postTcType = const (stage<TypeChecker) :: PostTcType -> Bool-#endif fixity = const (stage<Renamer) :: GHC.Fixity -> Bool--
ghc-syb-utils.cabal view
@@ -1,32 +1,23 @@ name: ghc-syb-utils-version: 0.2.3.3+version: 0.3.0.0 license: BSD3 license-file: LICENSE author: Claus Reinke copyright: (c) Claus Reinke 2008-maintainer: Thomas Schilling <nominolo@googlemail.com>-homepage: http://github.com/nominolo/ghc-syb+maintainer: Daniel Gröber <dxld@darkboxed.org>+homepage: https://github.com/DanielG/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.10-tested-with: GHC ==7.8.3, GHC ==7.10.0 -extra-source-files: test/test-cases/*.hs- 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.*+ , ghc >= 7.10 && < 8.6+ , bytestring hs-source-dirs: . default-language: Haskell2010@@ -34,18 +25,3 @@ ghc-options: -Wall exposed-modules: GHC.SYB.Utils----test-suite regression-tests- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Regression.hs- default-language: Haskell2010- build-depends:- base,- directory,- filepath,- ghc,- ghc-paths,- ghc-syb-utils
− test/Regression.hs
@@ -1,50 +0,0 @@-module Main where--import GHC.Paths ( libdir )-import qualified GhcMake as Ghc-import qualified GHC as Ghc-import qualified HscTypes as Ghc-import MonadUtils ( liftIO )-import System.Directory ( getCurrentDirectory )-import System.FilePath ( (</>) )-import System.Exit ( exitWith, ExitCode(..) )-import Control.Monad ( when )--import GHC.SYB.Utils--main :: IO ()-main = do- let ex1 = "test" </> "test-cases" </> "GithubIssue9.hs"-- Ghc.runGhc (Just libdir) $ do- dflags0 <- Ghc.getSessionDynFlags- let dflags = dflags0- { Ghc.ghcLink = Ghc.NoLink- , Ghc.hscTarget = Ghc.HscAsm- }- Ghc.setSessionDynFlags dflags- env <- Ghc.getSession- Ghc.handleSourceError printErrorAndExit $ do- target <- Ghc.guessTarget ex1 Nothing- Ghc.setTargets [target]- ok <- Ghc.load Ghc.LoadAllTargets- when (not (Ghc.succeeded ok)) $ die- let mn = Ghc.mkModuleName "GithubIssue9"- msum <- Ghc.getModSummary mn- parsed <- Ghc.parseModule msum- liftIO $ do- putStrLn "===== Parsed Source =================================="- putStrLn $ showData Parser 1 (Ghc.parsedSource parsed)- typechecked <- Ghc.typecheckModule parsed- liftIO $ do- putStrLn "===== Renamed Source ================================="- putStrLn $ showData Renamer 1 (Ghc.renamedSource typechecked)- putStrLn "===== Type-checked Source ============================"- putStrLn $ showData TypeChecker 1 (Ghc.typecheckedSource typechecked)- return ()--printErrorAndExit :: Ghc.SourceError -> Ghc.Ghc ()-printErrorAndExit err = Ghc.printException err >> die--die :: Ghc.Ghc ()-die = liftIO $ exitWith (ExitFailure 1)
− test/test-cases/GithubIssue9.hs
@@ -1,7 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module GithubIssue9 where--import Language.Haskell.TH--foo :: Q Exp-foo = [| \f -> f 2 |]