summaryrefslogtreecommitdiff
path: root/utils/check-ppr
diff options
context:
space:
mode:
Diffstat (limited to 'utils/check-ppr')
-rw-r--r--utils/check-ppr/Main.hs219
-rw-r--r--utils/check-ppr/README20
-rw-r--r--utils/check-ppr/check-ppr.cabal32
-rw-r--r--utils/check-ppr/ghc.mk18
4 files changed, 289 insertions, 0 deletions
diff --git a/utils/check-ppr/Main.hs b/utils/check-ppr/Main.hs
new file mode 100644
index 0000000000..c61b0e6d4c
--- /dev/null
+++ b/utils/check-ppr/Main.hs
@@ -0,0 +1,219 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+
+import Data.Data hiding (Fixity)
+import Data.List
+import Bag
+import FastString
+import NameSet
+import SrcLoc
+import HsSyn
+import OccName hiding (occName)
+import GHC hiding (moduleName)
+import Var
+import DynFlags
+import Outputable hiding (space)
+import System.Environment( getArgs )
+import System.Exit
+import System.FilePath
+
+import qualified Data.ByteString as B
+import qualified Data.Map as Map
+
+main::IO()
+main = do
+ args <- getArgs
+ case args of
+ [libdir,fileName] -> testOneFile libdir fileName
+ _ -> putStrLn "invoke with the libdir and a file to parse."
+
+testOneFile :: FilePath -> String -> IO ()
+testOneFile libdir fileName = do
+ p <- parseOneFile libdir fileName
+ let
+ origAst = showAstData 0 (pm_parsed_source p)
+ pped = pragmas ++ "\n" ++ pp (pm_parsed_source p)
+ anns = pm_annotations p
+ pragmas = getPragmas anns
+
+ newFile = dropExtension fileName <.> "ppr" <.> takeExtension fileName
+ astFile = fileName <.> "ast"
+
+ writeFile astFile origAst
+ writeFile newFile pped
+
+ p' <- parseOneFile libdir newFile
+
+ let newAstStr = showAstData 0 (pm_parsed_source p')
+
+ if origAst == newAstStr
+ then do
+ -- putStrLn "ASTs matched"
+ exitSuccess
+ else do
+ putStrLn "AST Match Failed"
+ putStrLn "\n===================================\nOrig\n\n"
+ putStrLn origAst
+ putStrLn "\n===================================\nNew\n\n"
+ putStrLn newAstStr
+ exitFailure
+
+
+parseOneFile :: FilePath -> FilePath -> IO ParsedModule
+parseOneFile libdir fileName = do
+ let modByFile m =
+ case ml_hs_file $ ms_location m of
+ Nothing -> False
+ Just fn -> fn == fileName
+ runGhc (Just libdir) $ do
+ dflags <- getSessionDynFlags
+ let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream
+ _ <- setSessionDynFlags dflags2
+ addTarget Target { targetId = TargetFile fileName Nothing
+ , targetAllowObjCode = True
+ , targetContents = Nothing }
+ _ <- load LoadAllTargets
+ graph <- getModuleGraph
+ let
+ modSum = case filter modByFile graph of
+ [x] -> x
+ xs -> error $ "Can't find module, got:"
+ ++ show (map (ml_hs_file . ms_location) xs)
+ parseModule modSum
+
+getPragmas :: ApiAnns -> String
+getPragmas anns = pragmaStr
+ where
+ tokComment (L _ (AnnBlockComment s)) = s
+ tokComment (L _ (AnnLineComment s)) = s
+ tokComment _ = ""
+
+ comments = case Map.lookup noSrcSpan (snd anns) of
+ Nothing -> []
+ Just cl -> map tokComment $ sortLocated cl
+ pragmas = filter (\c -> isPrefixOf "{-#" c ) comments
+ pragmaStr = intercalate "\n" pragmas
+
+pp :: (Outputable a) => a -> String
+pp a = showPpr unsafeGlobalDynFlags a
+
+
+-- | Show a GHC AST with SrcSpan's blanked out, to avoid comparing locations,
+-- only structure
+showAstData :: Data a => Int -> a -> String
+showAstData n =
+ generic
+ `ext1Q` list
+ `extQ` string `extQ` fastString `extQ` srcSpan
+ `extQ` bytestring
+ `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon
+ `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
+ `extQ` fixity
+ `ext2Q` located
+ where generic :: Data a => a -> String
+ generic t = indent n ++ "(" ++ showConstr (toConstr t)
+ ++ space (unwords (gmapQ (showAstData (n+1)) t)) ++ ")"
+ space "" = ""
+ space s = ' ':s
+ indent i = "\n" ++ replicate i ' '
+ string = show :: String -> String
+ fastString = ("{FastString: "++) . (++"}") . show
+ :: FastString -> String
+ bytestring = show :: B.ByteString -> String
+ list l = indent n ++ "["
+ ++ intercalate "," (map (showAstData (n+1)) l)
+ ++ "]"
+
+ name = ("{Name: "++) . (++"}") . showSDocDebug_ . ppr
+ :: Name -> String
+ occName = ("{OccName: "++) . (++"}") . OccName.occNameString
+ moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . ppr
+ :: ModuleName -> String
+
+ srcSpan :: SrcSpan -> String
+ srcSpan _ss = "{ "++ "ss" ++"}"
+
+ var = ("{Var: "++) . (++"}") . showSDocDebug_ . 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 = ("{NameSet: "++) . (++"}") . list . nameSetElemsStable
+
+ fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . ppr
+ :: Fixity -> String
+
+ located :: (Data b,Data loc) => GenLocated loc b -> String
+ located (L ss a) =
+ indent n ++ "("
+ ++ case cast ss of
+ Just (s :: SrcSpan) ->
+ srcSpan s
+ Nothing -> "nnnnnnnn"
+ ++ showAstData (n+1) a
+ ++ ")"
+
+showSDoc_ :: SDoc -> String
+showSDoc_ = showSDoc unsafeGlobalDynFlags
+
+showSDocDebug_ :: SDoc -> String
+showSDocDebug_ = showSDocDebug unsafeGlobalDynFlags
+
+-- ---------------------------------------------------------------------
+
+-- Copied from syb for the test
+
+
+-- | The type constructor for queries
+newtype Q q x = Q { unQ :: x -> q }
+
+-- | Extend a generic query by a type-specific case
+extQ :: ( Typeable a
+ , Typeable b
+ )
+ => (a -> q)
+ -> (b -> q)
+ -> a
+ -> q
+extQ f g a = maybe (f a) g (cast a)
+
+-- | Type extension of queries for type constructors
+ext1Q :: (Data d, Typeable t)
+ => (d -> q)
+ -> (forall e. Data e => t e -> q)
+ -> d -> q
+ext1Q def ext = unQ ((Q def) `ext1` (Q ext))
+
+
+-- | Type extension of queries for type constructors
+ext2Q :: (Data d, Typeable t)
+ => (d -> q)
+ -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
+ -> d -> q
+ext2Q def ext = unQ ((Q def) `ext2` (Q ext))
+
+-- | Flexible type extension
+ext1 :: (Data a, Typeable t)
+ => c a
+ -> (forall d. Data d => c (t d))
+ -> c a
+ext1 def ext = maybe def id (dataCast1 ext)
+
+
+
+-- | Flexible type extension
+ext2 :: (Data a, Typeable t)
+ => c a
+ -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
+ -> c a
+ext2 def ext = maybe def id (dataCast2 ext)
diff --git a/utils/check-ppr/README b/utils/check-ppr/README
new file mode 100644
index 0000000000..ac0eb55977
--- /dev/null
+++ b/utils/check-ppr/README
@@ -0,0 +1,20 @@
+
+This programme is intended to be used by any GHC developers working on the AST
+and/or pretty printer by providing a way to check that the same AST is generated
+from the pretty printed AST as from the original source.
+
+i.e., it checks whether
+
+ parse (ppr (parse s)) === parse s
+
+
+This utility is also intended to be used in tests, so that when new features are
+added the ability to round-trip the AST via ppr is tested.
+
+Usage
+
+In a test Makefile
+
+ $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" FileToParse.hs
+
+See examples in (REPO_HOME)/testsuite/tests/printer/Makefile
diff --git a/utils/check-ppr/check-ppr.cabal b/utils/check-ppr/check-ppr.cabal
new file mode 100644
index 0000000000..96863e58fa
--- /dev/null
+++ b/utils/check-ppr/check-ppr.cabal
@@ -0,0 +1,32 @@
+Name: check-ppr
+Version: 0.1
+Copyright: XXX
+License: BSD3
+-- XXX License-File: LICENSE
+Author: XXX
+Maintainer: XXX
+Synopsis: A utilities for checking the consistency of GHC's pretty printer
+Description:
+ This utility is used to check the consistency of the GHC pretty printer, by
+ parsing a file, pretty printing it, and then re-parsing the pretty printed
+ version. See @utils/check-ppr/README@ in GHC's source distribution for
+ details.
+Category: Development
+build-type: Simple
+cabal-version: >=1.10
+
+Executable check-ppr
+ Default-Language: Haskell2010
+
+ Main-Is: Main.hs
+
+ Ghc-Options: -Wall
+
+ Build-Depends: base >= 4 && < 5,
+ bytestring,
+ containers,
+ -- Cabal >= 1.25 && <1.27,
+ Cabal >= 1.24 && <1.27,
+ directory,
+ filepath,
+ ghc
diff --git a/utils/check-ppr/ghc.mk b/utils/check-ppr/ghc.mk
new file mode 100644
index 0000000000..189b447171
--- /dev/null
+++ b/utils/check-ppr/ghc.mk
@@ -0,0 +1,18 @@
+# -----------------------------------------------------------------------------
+#
+# (c) 2009 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture
+# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying
+#
+# -----------------------------------------------------------------------------
+
+utils/check-ppr_USES_CABAL = YES
+utils/check-ppr_PACKAGE = check-ppr
+utils/check-ppr_dist-install_PROGNAME = check-ppr
+utils/check-ppr_dist-install_INSTALL = NO
+utils/check-ppr_dist-install_INSTALL_INPLACE = YES
+$(eval $(call build-prog,utils/check-ppr,dist-install,2))
View Lorry Controller Status