ghc-dump-tree (empty) → 0.2.0.0
raw patch · 8 files changed
+587/−0 lines, 8 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, ghc, ghc-dump-tree, optparse-applicative, pretty, pretty-show, process, unordered-containers, vector
Files
- CONTRIBUTORS +4/−0
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +6/−0
- Setup.hs +2/−0
- ghc-dump-tree.cabal +64/−0
- src/Language/Haskell/GHC/DumpTree.hs +430/−0
- src/Main.hs +48/−0
+ CONTRIBUTORS view
@@ -0,0 +1,4 @@+Edsko de Vries+Alan Zimmerman+Robin Palotai (Google Inc)+JP Moresmau
+ ChangeLog.md view
@@ -0,0 +1,3 @@+0.2.0.0+-------+* Initial Hackage release. Thanks to all contributors (see CONTRIBUTORS)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Edsko de Vries++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 the name of Edsko de Vries nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT+OWNER OR 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.
+ README.md view
@@ -0,0 +1,6 @@+# ghc-dump-tree++Dump GHC's abstract syntax trees (parsed, renamed, and type checked) in text or+JSON format. Useful for GHC devs or people who want to do something with GHC's+AST but don't want to hook into the GHC API itself. Tested with GHC 7.4, GHC 7.8+and GHC 7.10.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ghc-dump-tree.cabal view
@@ -0,0 +1,64 @@+name: ghc-dump-tree+version: 0.2.0.0+synopsis: Dump GHC's parsed, renamed, and type checked ASTs+description: Useful for GHC devs or people who want to do something with+ GHC's AST but don't want to hook into the GHC API itself.+license: BSD3+license-file: LICENSE+author: Edsko de Vries+maintainer: edsko@well-typed.com+copyright: Copyright 2015 Well-Typed LLP+homepage: https://github.com/edsko/ghc-dump-tree+bug-reports: https://github.com/edsko/ghc-dump-tree/issues+category: Development+build-type: Simple+cabal-version: >=1.10+tested-with: GHC==7.4.2, GHC==7.8.3, GHC==7.10.0.20150310++extra-source-files:+ ChangeLog.md+ README.md+ CONTRIBUTORS++source-repository head+ type: git+ location: https://github.com/edsko/ghc-dump-tree.git++library+ build-depends: base >=4.5 && <4.9,+ aeson >=0.7 && <0.11,+ bytestring >=0.9 && <0.11,+ ghc >=7.4 && <7.12,+ pretty >=1.1 && <1.2,+ pretty-show >=1.6 && <1.7,+ process >=1.1 && <1.3,+ unordered-containers >=0.2 && <0.3,+ vector >=0.10 && <0.12+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall -fno-warn-orphans+ other-extensions: CPP+ default-extensions: RecordWildCards+ OverloadedStrings+ exposed-modules: Language.Haskell.GHC.DumpTree++executable ghc-dump-tree+ main-is: Main.hs+ build-depends: base >=4.5 && <4.9,+ aeson >=0.7 && <0.11,+ bytestring >=0.9 && <0.11,+ ghc >=7.4 && <7.12,+ optparse-applicative >=0.11 && <0.13,+ pretty >=1.1 && <1.2,+ pretty-show >=1.6 && <1.7,+ process >=1.1 && <1.3,+ unordered-containers >=0.2 && <0.3,+ vector >=0.10 && <0.12,+ ghc-dump-tree+ hs-source-dirs: src+ other-modules: Language.Haskell.GHC.DumpTree+ default-language: Haskell2010+ ghc-options: -Wall -fno-warn-orphans+ other-extensions: CPP+ default-extensions: RecordWildCards+ OverloadedStrings
+ src/Language/Haskell/GHC/DumpTree.hs view
@@ -0,0 +1,430 @@+{-# LANGUAGE CPP #-}+module Language.Haskell.GHC.DumpTree+ ( treesForTargetsIO+ , treesForTargets+ , treesForSession+ , treeDumpFlags+ , dumpJson+ , treesToDoc+ , dumpText+ , Trees(..)+ ) where++import Prelude hiding (mod)+import Control.Arrow (second)+import Control.Exception+import Control.Monad+import Data.Aeson (ToJSON(..), object, (.=))+import Data.Data (Data, cast, toConstr, showConstr, gmapQ)+import Data.List (isInfixOf, isPrefixOf)+import Data.String (fromString)++import System.Process (readProcess)+import Text.Show.Pretty (Value(..),valToDoc)+import Text.PrettyPrint+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy as B.Lazy+import qualified Data.HashMap.Strict as HashMap++import Bag+import Exception+import GHC+import HscTypes+import Module+import MonadUtils+import Name+import Outputable (Outputable, showSDoc, ppr)+import RdrName+import TcEvidence+import Var+import qualified OccName as Occ+++{-------------------------------------------------------------------------------+ Translate AST to Value+-------------------------------------------------------------------------------}++pretty :: (Outputable a, GhcMonad m) => a -> m String+pretty x = do+#if MIN_VERSION_ghc(7,6,3)+ dynFlags <- getSessionDynFlags+ return $! showSDoc dynFlags (ppr x)+#else+ return $! showSDoc (ppr x)+#endif++pretty' :: (Outputable a, GhcMonad m) => a -> m Value+pretty' = liftM String . pretty++-- | Construct a `Value` from any term implementing `data`+--+-- We have a number of special cases, solving two different kinds of problems:+--+-- * Some datatypes in GHC don't have an informative Data instance but are+-- marked as "abstract". We test for these types specifically so that we can+-- use a custom pretty-printer rather than just showing "{abstract}".+-- * Some subterms in ghc contain error values. We try to catch these and+-- show them as more readable strings (defaulting to showing the exception).+--+-- Moreover, for a few types we show both the pretty-printed form and the+-- actual tree; we are careful to do this only for top-level occurrences of+-- these types.+valueFromData :: (Data a, GhcMonad m) => a -> m Value+valueFromData = go False+ where+ -- Bool indicates if we just added a pretty-printed form as well+ -- (so that we don't do it for directly recursive values)+ go :: (Data a, GhcMonad m) => Bool -> a -> m Value+ go b x+ -- Types where we want to show both a pretty-printed value and a tree+ | Just x' <- cast x :: Maybe (HsType Name) = withPretty b x'+ | Just x' <- cast x :: Maybe (HsType Var) = withPretty b x'+ | Just x' <- cast x :: Maybe Type = withPretty b x'+ -- Abstract types we cannot traverse+ | Just x' <- cast x :: Maybe SrcSpan = pretty' x'+ | Just x' <- cast x :: Maybe TyCon = pretty' x'+ -- We cannot traverse names either, but we don't want to just call+ -- the pretty-printer because we would lose too much information+ | Just x' <- cast x :: Maybe Module = prettyModule x'+ | Just x' <- cast x :: Maybe ModuleName = prettyModuleName x'+ | Just x' <- cast x :: Maybe Name = prettyName x'+ | Just x' <- cast x :: Maybe OccName = prettyOccName x'+ | Just x' <- cast x :: Maybe RdrName = prettyRdrName x'+ | Just x' <- cast x :: Maybe TcEvBinds = prettyTcEvBinds x'+ | Just x' <- cast x :: Maybe Var = prettyVar x'+ -- Otherwise just construct a generic value+ | otherwise = generic False x++ generic :: (Data a, GhcMonad m) => Bool -> a -> m Value+ generic b x = ghandle handleException $ do+ constrName <- liftIO $ evaluate $ showConstr $ toConstr x+ Con constrName <$> sequence (gmapQ (go b) x)++ withPretty :: (Data a, Outputable a,GhcMonad m) => Bool -> a -> m Value+ withPretty True x = generic True x+ withPretty False x = do+ prettied <- pretty x+ tree <- generic True x+ return $! Rec "" [(prettied, tree)]++ handleException :: GhcMonad m => SomeException -> m Value+ handleException e =+ case isKnownPanic (show e) of+ Just panic -> return $! String $ "<<" ++ panic ++ ">>"+ Nothing -> return $! String $ show e++ isKnownPanic :: String -> Maybe String+ isKnownPanic e = msum $ map aux knownPanics+ where+ aux panic | panic `isInfixOf` e = Just panic+ | otherwise = Nothing++ knownPanics :: [String]+ knownPanics = [+ "PostTcExpr"+ , "PostTcKind"+ , "PostTcType"+ , "fixity"+ , "placeHolderNames"+ ]++-- | Clean up a value generated by valueFromData+cleanupValue :: Value -> Value+cleanupValue (Con nm vals)+ | nm == "[]" = case vals of+ [] -> List []+ _ -> error "cleanupValue: invalid tree"+ | nm == "(:)" = case vals of+ [x, xs] -> case cleanupValue xs of+ List xs' -> List (cleanupValue x : xs')+ _ -> error "cleanupValue: invalid tree"+ _ -> error "cleanupValue: invalid tree"+ | isTuple nm = Tuple (map cleanupValue vals)+ | isBag nm = case vals of+ [contents] -> Con "Bag.listToBag" [cleanupValue contents]+ _ -> error "cleanupValue: invalid tree"+ | otherwise = Con nm (map cleanupValue vals)+ where+ isTuple :: String -> Bool+ isTuple ('(' : nm') = all (== ',') (init nm') && last nm' == ')'+ isTuple _ = False++ isBag :: String -> Bool+ isBag = isPrefixOf "{abstract:Bag"++cleanupValue (String s) = String s+cleanupValue (Rec nm flds) = Rec nm $ map (second cleanupValue) flds+cleanupValue _ = error "cleanupValue: unexpected Value"++{-------------------------------------------------------------------------------+ Specialized functions for the different kinds of names++ * OccName most primitive type: just a string and namespace+ (variable, data constructor, etc.)+ * RdrName come directly from the parser+ * Name after renaming+ * Var after typechecking+ * Id alias for Var+-------------------------------------------------------------------------------}++prettyOccName :: GhcMonad m => OccName -> m Value+prettyOccName nm+ | occNameSpace nm == Occ.varName = mk "VarName"+ | occNameSpace nm == Occ.dataName = mk "DataName"+ | occNameSpace nm == Occ.tvName = mk "TvName"+ | occNameSpace nm == Occ.tcClsName = mk "TcClsName"+ | otherwise = error "unexpected OccName"+ where+ mk :: GhcMonad m => String -> m Value+ mk namespace = return $! Rec "" [(namespace, String (occNameString nm))]++prettyTcEvBinds :: GhcMonad m => TcEvBinds -> m Value+prettyTcEvBinds (TcEvBinds mut) = pretty' mut+prettyTcEvBinds (EvBinds bagOfEvBind) = do+ let evBinds = bagToList bagOfEvBind+ fmap (Con "TcEvBinds") $! mapM prettyEvBind evBinds++prettyEvBind :: GhcMonad m => EvBind -> m Value+prettyEvBind (EvBind var term) = do+ pVar <- prettyVar var+ pTerm <- pretty' term+ return $! Rec "" [("ev_var", pVar), ("ev_term", pTerm)]++prettyRdrName :: GhcMonad m => RdrName -> m Value+prettyRdrName (Unqual nm) = prettyOccName nm+prettyRdrName (Exact nm) = prettyName nm+prettyRdrName (Qual mod nm) = do+ Rec "" fields <- prettyOccName nm+ qual <- prettyModuleName mod+ return $! Rec "" (("Qual", qual):fields)+prettyRdrName (Orig mod nm) = do+ Rec "" fields <- prettyOccName nm+ orig <- prettyModule mod+ return $! Rec "" (("Orig", orig):fields)++prettyName :: GhcMonad m => Name -> m Value+prettyName nm = do+ Rec "" fields <- prettyOccName (nameOccName nm)+ loc <- pretty' (nameSrcSpan nm)+ sort <- prettyNameSort+ return $! Rec "" (("n_loc",loc):("n_sort",sort):fields)+ where+ prettyNameSort :: GhcMonad m => m Value+ prettyNameSort+ | Just _tyThing <- wiredInNameTyThing_maybe nm = do+ mod <- prettyModule (nameModule nm)+ -- TODO: Do somethng with tyThing+ return $! Rec "" [("WiredIn", mod)]+ | isExternalName nm = do+ mod <- prettyModule (nameModule nm)+ return $! Rec "" [("External", mod)]+ | isInternalName nm = do+ return $! String "Internal"+ | isSystemName nm = do+ return $! String "System"+ | otherwise =+ error "Unexpected NameSort"++prettyVar :: GhcMonad m => Var -> m Value+prettyVar nm = do+ Rec "" fields <- prettyName $ Var.varName nm+ typ <- valueFromData $ varType nm+ -- TODO: There is more information we could extract about Vars+ return $! Rec "" (("varType", typ):fields)++prettyModuleName :: GhcMonad m => ModuleName -> m Value+prettyModuleName = return . String . moduleNameString++#if MIN_VERSION_ghc(7,10,0)+prettyModule :: GhcMonad m => Module -> m Value+prettyModule mod = do+ pkg <- prettyPackageKey $ modulePackageKey mod+ nm <- prettyModuleName $ moduleName mod+ return $! Con "Module" [pkg, nm]++prettyPackageKey :: GhcMonad m => PackageKey -> m Value+prettyPackageKey = return . String . packageKeyString+#else+prettyModule :: GhcMonad m => Module -> m Value+prettyModule mod = do+ pkg <- prettyPackageId $ modulePackageId mod+ nm <- prettyModuleName $ moduleName mod+ return $! Con "Module" [pkg, nm]++prettyPackageId :: GhcMonad m => PackageId -> m Value+prettyPackageId = return . String . packageIdString+#endif++{-------------------------------------------------------------------------------+ Extracting ASTs from a set of targets+-------------------------------------------------------------------------------}++data Trees = Trees {+ treeModule :: String+ , treeParsed :: Value+ , treeRenamed :: Value+ , treeTypechecked :: Value+ , treeExports :: Value+ } deriving (Eq,Show)++treesForModSummary :: GhcMonad m => ModSummary -> m Trees+treesForModSummary modSummary = do+ parsed <- parseModule modSummary+ let wrapErr se = return $ Left $ show $ bagToList $ srcErrorMessages se+ eTypechecked <- handleSourceError wrapErr (Right <$> typecheckModule parsed)++ treeModule <- pretty (ms_mod_name modSummary)+ treeParsed <- mkTree (pm_parsed_source parsed)+ treeRenamed <- mkRenamedTree eTypechecked+ treeTypechecked <- mkTypeCheckedTree eTypechecked+ treeExports <- mkExportTree eTypechecked+ return Trees{..}+ where+ mkTree :: (Data a,GhcMonad m) => a -> m Value+ mkTree = liftM cleanupValue . valueFromData++ mkRenamedTree (Right typechecked) =+ case tm_renamed_source typechecked of+ Just renamed -> mkTree renamed+ Nothing -> return $ String $ show treeNotAvailable+ mkRenamedTree (Left errors) = return (String errors)++ mkTypeCheckedTree (Right typechecked) =+ mkTree $ tm_typechecked_source typechecked+ mkTypeCheckedTree (Left errors) = return (String errors)++ mkExportTree (Right typechecked) =+ mkTree $ modInfoExports $ tm_checked_module_info typechecked+ mkExportTree (Left _) = return $ String $ show treeNotAvailable++ treeNotAvailable :: String+ treeNotAvailable = "<<NOT AVAILABLE>>"++-- | Get dyn flags: Don't compile anything+treeDumpFlags :: DynFlags -> DynFlags+treeDumpFlags dynFlags = dynFlags {+ hscTarget = HscNothing+ , ghcLink = NoLink+ }++-- | Generate trees for modules in session+treesForSession :: GhcMonad m => m [Trees]+treesForSession = do+ hscEnv <- getSession+ mapM treesForModSummary $ hsc_mod_graph hscEnv++-- | Generate trees for given files, when already in GHC+treesForTargets :: GhcMonad m => [FilePath] -> m [Trees]+treesForTargets targets = do+ liftIO $ putStrLn "in treesForTargets"+ gbracket+ getSessionDynFlags+ setSessionDynFlags+ $ \dynFlags -> do+ let dynFlags' = treeDumpFlags dynFlags+ void $ setSessionDynFlags dynFlags'+ -- Construct module graph+ setTargets (map mkTarget targets)+ void $ load LoadAllTargets+ --+ -- generate each module+ treesForSession+ where+ mkTarget :: FilePath -> Target+ mkTarget fp = Target {+ targetId = TargetFile fp Nothing+ , targetAllowObjCode = False+ , targetContents = Nothing+ }++-- | Generate trees for given files, starting a GHC session+-- "ghc" needs to be in the PATH+treesForTargetsIO :: [FilePath] -> IO [Trees]+treesForTargetsIO targets = do+ libdir:_ <- lines <$> readProcess "ghc" ["--print-libdir"] ""+ runGhc (Just libdir) (treesForTargets targets)+++-- | Convert Trees to Doc+treesToDoc :: Trees -> Doc+treesToDoc Trees{..} = do+ text ("# " ++ treeModule)+ $$+ text ""+ $$+ sectionV "## Parsed" treeParsed+ $$+ sectionV "## Renamed" treeRenamed+ $$+ sectionV "## Typechecked" treeTypechecked+ $$+ sectionV "## Exports" treeExports+ where+ sectionV title v = text title $$ valToDoc v $$ text ""++{-------------------------------------------------------------------------------+ Dump the trees to stdout in text format+-------------------------------------------------------------------------------}+dumpText :: [Trees] -> IO ()+dumpText = mapM_ (putStrLn . render . treesToDoc)+ -- where+ -- go :: Trees -> IO ()+ -- go Trees{..} = do+ -- section ("# " ++ treesModule) $ do+ -- section "## Parsed" $ showTree treeParsed+ -- section "## Renamed" $ showTree treeRenamed+ -- section "## Typechecked" $ showTree treeTypechecked+ -- section "## Exports" $ showTree treeExports+ --+ -- section :: String -> IO () -> IO ()+ -- section title = bracket_ (putStrLn title) (putStrLn "")+ --+ -- showTree :: Value -> IO ()+ -- showTree = putStrLn . valToStr++{-------------------------------------------------------------------------------+ Dump in JSON format+-------------------------------------------------------------------------------}++instance ToJSON Value where+ -- Special cases+ toJSON (Con "False" []) = Aeson.Bool False+ toJSON (Con "True" []) = Aeson.Bool True+ toJSON (Con "Bag.listToBag" [xs]) = toJSON xs+ toJSON (Con "L" [loc, x]) =+ case toJSON x of+ Aeson.Object obj' -> Aeson.Object (HashMap.insert "location" (toJSON loc) obj')+ nonObject -> nonObject -- we lose the location information in this case++ -- Rest+ toJSON (Con nm []) = Aeson.String (fromString nm)+ toJSON (Con nm vals) = object [ fromString nm .= vals ]+ toJSON (Tuple vals) = toJSON vals+ toJSON (List vals) = toJSON vals+ toJSON (String s) = Aeson.String (fromString s)+ toJSON (Rec "" flds) = object $ map (\(fld, val) -> fromString fld .= val) flds+ toJSON _ = error "toJSON: Unexpected Value"+++instance ToJSON Trees where+ toJSON Trees{..} = object [+ "module" .= treeModule+ , "parsed" .= treeParsed+ , "renamed" .= treeRenamed+ , "typechecked" .= treeTypechecked+ , "exports" .= treeExports+ ]++dumpJson :: [Trees] -> IO ()+dumpJson = B.Lazy.putStr . Aeson.encode++{-------------------------------------------------------------------------------+ Orphans+-------------------------------------------------------------------------------}++#if MIN_VERSION_ghc(7,8,0)+#else+instance Applicative Ghc where+ pure = return+ (<*>) = ap+#endif
+ src/Main.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}+module Main (main) where++import Language.Haskell.GHC.DumpTree++import Prelude+import Options.Applicative++++#if MIN_VERSION_base(4,8,0)+#else+import Data.Monoid (mconcat)+#endif++{-------------------------------------------------------------------------------+ Main application+-------------------------------------------------------------------------------}++main :: IO ()+main = do+ Options{..} <- execParser opts+ trees <- treesForTargetsIO optionsTargets+ if optionsDumpJson+ then dumpJson trees+ else dumpText trees+ where+ opts = info (helper <*> parseOptions) $ mconcat [+ fullDesc+ , header "ghc-dump-tree - Dump GHC's ASTs"+ ]++{-------------------------------------------------------------------------------+ Command line arguments+-------------------------------------------------------------------------------}++data Options = Options {+ optionsDumpJson :: Bool+ , optionsTargets :: [FilePath]+ }++parseOptions :: Parser Options+parseOptions = Options+ <$> (switch $ mconcat [+ long "json"+ , help "Output JSON"+ ])+ <*> some (argument str (metavar "TARGETS..."))