diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,4 @@ +Edsko de Vries +Alan Zimmerman +Robin Palotai (Google Inc) +JP Moresmau diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +0.2.0.0 +------- +* Initial Hackage release. Thanks to all contributors (see CONTRIBUTORS) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ghc-dump-tree.cabal b/ghc-dump-tree.cabal new file mode 100644 --- /dev/null +++ b/ghc-dump-tree.cabal @@ -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 diff --git a/src/Language/Haskell/GHC/DumpTree.hs b/src/Language/Haskell/GHC/DumpTree.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GHC/DumpTree.hs @@ -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 = "<>" + +-- | 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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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..."))