summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDanielG <>2018-08-09 18:21:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-08-09 18:21:00 (GMT)
commitba6bbb0ba3f770125e4ad8a083e8fc5ec8c5379b (patch)
tree352474c742e1df0d5b3cdf85915fb8ac85c5064b
parent5347435c5a90d871687ce7bdc7e54b824d4b097d (diff)
version 0.3.0.0HEAD0.3.0.0master
-rw-r--r--GHC/SYB/Utils.hs287
-rw-r--r--ghc-syb-utils.cabal34
-rw-r--r--test/Regression.hs50
-rw-r--r--test/test-cases/GithubIssue9.hs7
4 files changed, 9 insertions, 369 deletions
diff --git a/GHC/SYB/Utils.hs b/GHC/SYB/Utils.hs
index 1650cca..436c700 100644
--- a/GHC/SYB/Utils.hs
+++ b/GHC/SYB/Utils.hs
@@ -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 @@ everythingStaged stage k z f x
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 :: MonadPlus m => Stage -> GenericM m -> GenericM m
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 @@ everywhereMStaged :: Monad m => Stage -> GenericM m -> GenericM m
-- 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
-
-
diff --git a/ghc-syb-utils.cabal b/ghc-syb-utils.cabal
index 60fbec2..89b2e91 100644
--- a/ghc-syb-utils.cabal
+++ b/ghc-syb-utils.cabal
@@ -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 @@ library
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
diff --git a/test/Regression.hs b/test/Regression.hs
deleted file mode 100644
index dc7c4b6..0000000
--- a/test/Regression.hs
+++ /dev/null
@@ -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)
diff --git a/test/test-cases/GithubIssue9.hs b/test/test-cases/GithubIssue9.hs
deleted file mode 100644
index 74deecd..0000000
--- a/test/test-cases/GithubIssue9.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-module GithubIssue9 where
-
-import Language.Haskell.TH
-
-foo :: Q Exp
-foo = [| \f -> f 2 |]