ghc-dump-util (empty) → 0.1.0.0
raw patch · 8 files changed
+631/−0 lines, 8 filesdep +ansi-wl-pprintdep +basedep +bytestringsetup-changed
Dependencies added: ansi-wl-pprint, base, bytestring, ghc-dump-core, ghc-dump-util, hashable, optparse-applicative, regex-tdfa, regex-tdfa-text, serialise, text, unordered-containers
Files
- LICENSE +30/−0
- Main.hs +133/−0
- Setup.hs +2/−0
- ghc-dump-util.cabal +46/−0
- src/GhcDump/Pretty.hs +246/−0
- src/GhcDump/Reconstruct.hs +107/−0
- src/GhcDump/Repl.hs +9/−0
- src/GhcDump/Util.hs +58/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Ben Gamari++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 Ben Gamari 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.
+ Main.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE ScopedTypeVariables #-}++import Control.Monad+import Data.Maybe+import Data.List (sortBy)+import Data.Monoid+import Data.Ord++import Options.Applicative+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))+import qualified Text.PrettyPrint.ANSI.Leijen as PP++import Text.Regex.TDFA+import Text.Regex.TDFA.Common (Regex)+import Text.Regex.TDFA.Text++import GhcDump.Pretty+import GhcDump.Util+import GhcDump.Ast++data Column a = Col { colWidth :: Int, colHeader :: String, colGet :: (a -> Doc) }++type Table a = [Column a]++renderTable :: forall a. Table a -> [a] -> Doc+renderTable cols xs =+ row (PP.bold . text . colHeader)+ <$$> vcat [ row (flip colGet x) | x <- xs ]+ where+ row :: (Column a -> Doc) -> Doc+ row toCell = go cols+ where+ go :: [Column a] -> Doc+ go [] = PP.empty+ go [col] = align $ toCell col+ go (col : rest) = fillBreak (colWidth col) (align $ toCell col) PP.<+> go rest++filterBindings :: Regex -> Module -> Module+filterBindings re m =+ m { moduleTopBindings = mapMaybe filterTopBinding $ moduleTopBindings m }+ where+ filterTopBinding b'@(NonRecTopBinding b _ _)+ | nameMatches b = Just b'+ | otherwise = Nothing+ filterTopBinding (RecTopBinding bs)+ | not $ null bs' = Just $ RecTopBinding bs'+ | otherwise = Nothing+ where bs' = filter (\(b,_,_) -> nameMatches b) bs++ nameMatches :: Binder -> Bool+ nameMatches b = matchTest re (binderUniqueName b)++modes :: Parser (IO ())+modes = subparser+ $ mode "show" showMode (progDesc "print Core")+ <> mode "list-bindings" listBindingsMode (progDesc "list top-level bindings, their sizes, and types")+ <> mode "summarize" summarizeMode (progDesc "summarize multiple dump files")+ where+ mode name f opts = command name (info (helper <*> f) opts)++ dumpFile :: Parser FilePath+ dumpFile = argument str (metavar "DUMP FILE" <> help "CBOR dump file")++ filterCond :: Parser (Module -> Module)+ filterCond =+ fmap (maybe id filterBindings)+ $ option (str >>= fmap Just . makeRegexM')+ (short 'f' <> long "filter" <> value Nothing <> help "filter bindings by name")+ where+ makeRegexM' = makeRegexM :: String -> ReadM Regex++ prettyOpts :: Parser PrettyOpts+ prettyOpts =+ PrettyOpts+ <$> switch (short 'u' <> long "show-uniques" <> help "Show binder uniques")+ <*> switch (short 'i' <> long "show-idinfo" <> help "Show IdInfo of bindings")+ <*> switch (short 'T' <> long "show-let-types" <> help "Show type signatures for let-bound binders")+ <*> switch (short 'U' <> long "show-unfoldings" <> help "Show unfolding templates")++ showMode =+ run <$> filterCond <*> prettyOpts <*> dumpFile+ where+ run filterFn opts fname = do+ dump <- filterFn <$> GhcDump.Util.readDump fname+ print $ pprModule opts dump++ listBindingsMode =+ run <$> filterCond <*> sortField <*> prettyOpts <*> dumpFile+ where+ sortField =+ option (str >>= readSortField)+ (long "sort" <> short 's' <> value id+ <> help "Sort by (accepted values: terms, types, coercions, type)")+ where+ readSortField "terms" = return $ sortBy (flip $ comparing $ csTerms . getStats)+ readSortField "types" = return $ sortBy (flip $ comparing $ csTypes . getStats)+ readSortField "coercions" = return $ sortBy (flip $ comparing $ csCoercions . getStats)+ readSortField "type" = return $ sortBy (comparing $ binderType . unBndr . getBinder)+ readSortField f = fail $ "unknown sort field "++f++ run filterFn sortBindings opts fname = do+ dump <- filterFn <$> GhcDump.Util.readDump fname+ let table = [ Col 20 "Name" (pprBinder opts . getBinder)+ , Col 6 "Terms" (pretty . csTerms . getStats)+ , Col 6 "Types" (pretty . csTypes . getStats)+ , Col 6 "Coerc." (pretty . csCoercions . getStats)+ , Col 300 "Type" (pprType opts . binderType . unBndr . getBinder)+ ]+ print $ renderTable table (sortBindings $ moduleBindings dump)++ summarizeMode =+ run <$> some dumpFile+ where+ run fnames = do+ mods <- mapM (\fname -> do mod <- readDump fname+ return (fname, mod)) fnames+ let totalSize :: Module -> CoreStats+ totalSize = foldMap getStats . moduleBindings+ let table = [ Col 35 "Name" (text . fst)+ , Col 8 "Terms" (pretty . csTerms . totalSize . snd)+ , Col 8 "Types" (pretty . csTypes . totalSize . snd)+ , Col 8 "Coerc." (pretty . csCoercions . totalSize . snd)+ , Col 35 "Previous phase" (pretty . modulePhase . snd)+ ]+ print $ renderTable table mods+++getBinder (b,_,_) = b+getStats (_,s,_) = s+getRHS (_,_,e) = e++main :: IO ()+main = join $ execParser $ info (helper <*> modes) mempty
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ghc-dump-util.cabal view
@@ -0,0 +1,46 @@+name: ghc-dump-util+version: 0.1.0.0+synopsis: Handy tools for working with @ghc-dump@ dumps.+description:+ @ghc-dump@ is a library, GHC plugin, and set of tools for recording and+ analysing GHC's Core representation. The plugin is compatible with GHC 7.10+ through 8.3, exporting a consistent (albeit somewhat lossy) representation+ across these versions. The AST is encoded as CBOR, which is small and easy to+ deserialise.+ .+ This package provides the AST and compiler plugin. See the @ghc-dump-util@+ package for a useful command-line tool for working with dumps produced by this+ plugin.+license: BSD3+license-file: LICENSE+author: Ben Gamari+maintainer: ben@well-typed.com+copyright: (c) 2017 Ben Gamari+category: Development+build-type: Simple+tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2+cabal-version: >=1.10++library+ exposed-modules: GhcDump.Repl, GhcDump.Util, GhcDump.Pretty, GhcDump.Reconstruct+ hs-source-dirs: src+ build-depends: base < 5.0,+ ghc-dump-core >=0.1 && <0.2,+ bytestring >=0.10 && <0.11,+ unordered-containers >= 0.2,+ hashable >= 1.2,+ text >= 1.0,+ ansi-wl-pprint >= 0.6,+ serialise >=0.2 && <0.3+ default-language: Haskell2010++executable ghc-dump+ main-is: Main.hs+ build-depends: base < 5.0,+ ghc-dump-core >=0.1 && <0.2,+ ghc-dump-util,+ ansi-wl-pprint >= 0.6,+ regex-tdfa >= 1.2,+ regex-tdfa-text,+ optparse-applicative >= 0.13+ default-language: Haskell2010
+ src/GhcDump/Pretty.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module GhcDump.Pretty+ ( Pretty(..)+ , module GhcDump.Pretty+ ) where++import GhcDump.Ast+import GhcDump.Util++import Data.Ratio+import qualified Data.Text as T+import qualified Data.ByteString.Char8 as BS+import Text.PrettyPrint.ANSI.Leijen++data PrettyOpts = PrettyOpts { showUniques :: Bool+ , showIdInfo :: Bool+ , showLetTypes :: Bool+ , showUnfoldings :: Bool+ }++defaultPrettyOpts :: PrettyOpts+defaultPrettyOpts = PrettyOpts { showUniques = False+ , showIdInfo = False+ , showLetTypes = False+ , showUnfoldings = False+ }++-- orphan+instance Pretty T.Text where+ pretty = text . T.unpack++instance Pretty ExternalName where+ pretty n@ExternalName{} = pretty (externalModuleName n) <> "." <> text (T.unpack $ externalName n)+ pretty ForeignCall = "<foreign>"++instance Pretty ModuleName where+ pretty = text . T.unpack . getModuleName++instance Pretty Unique where+ pretty = text . show++instance Pretty BinderId where+ pretty (BinderId b) = pretty b++instance Pretty Binder where+ pretty = pprBinder defaultPrettyOpts++pprBinder :: PrettyOpts -> Binder -> Doc+pprBinder opts b+ | showUniques opts = pretty $ binderUniqueName b+ | otherwise = pretty $ binderName $ unBndr b++instance Pretty TyCon where+ pretty (TyCon t _) = text $ T.unpack t++pprRational :: Rational -> Doc+pprRational r = pretty (numerator r) <> "/" <> pretty (denominator r)++instance Pretty Lit where+ pretty (MachChar x) = "'" <> char x <> "'#"+ pretty (MachStr x) = "\"" <> text (BS.unpack x) <> "\"#"+ pretty MachNullAddr = "nullAddr#"+ pretty (MachInt x) = pretty x <> "#"+ pretty (MachInt64 x) = pretty x <> "#"+ pretty (MachWord x) = pretty x <> "#"+ pretty (MachWord64 x) = pretty x <> "##"+ pretty (MachFloat x) = "FLOAT" <> parens (pprRational x)+ pretty (MachDouble x) = "DOUBLE" <> parens (pprRational x)+ pretty (MachLabel x) = "LABEL"<> parens (pretty x)+ pretty (LitInteger x) = pretty x++instance Pretty CoreStats where+ pretty c =+ "Core Size"+ <>braces (hsep [ "terms="<>int (csTerms c)+ , "types="<>int (csTypes c)+ , "cos="<>int (csCoercions c)+ , "vbinds="<>int (csValBinds c)+ , "jbinds="<>int (csJoinBinds c)+ ])++pprIdInfo :: PrettyOpts -> IdInfo Binder Binder -> IdDetails -> Doc+pprIdInfo opts i d+ | not $ showIdInfo opts = empty+ | otherwise = comment $ "IdInfo:" <+> align doc+ where+ doc = sep $ punctuate ", "+ $ [ pretty d+ , "arity=" <> pretty (idiArity i)+ , "inline=" <> pretty (idiInlinePragma i)+ , "occ=" <> pretty (idiOccInfo i)+ , "str=" <> pretty (idiStrictnessSig i)+ , "dmd=" <> pretty (idiDemandSig i)+ , "call-arity=" <> pretty (idiCallArity i)+ , "unfolding=" <> pprUnfolding opts (idiUnfolding i)+ ] ++ (if idiIsOneShot i then ["one-shot"] else [])++pprUnfolding :: PrettyOpts -> Unfolding Binder Binder -> Doc+pprUnfolding _ NoUnfolding = "NoUnfolding"+pprUnfolding _ BootUnfolding = "BootUnfolding"+pprUnfolding _ OtherCon{} = "OtherCon"+pprUnfolding _ DFunUnfolding = "DFunUnfolding"+pprUnfolding opts CoreUnfolding{..}+ | showUnfoldings opts = "CoreUnf" <> braces+ (align $ sep [ "is-value=" <> pretty unfIsValue+ , "con-like=" <> pretty unfIsConLike+ , "work-free=" <> pretty unfIsWorkFree+ , "guidance=" <> pretty unfGuidance+ , "template=" <> pprExpr opts unfTemplate+ ])+ | otherwise = "CoreUnf{..}"++instance Pretty OccInfo where+ pretty OccManyOccs = "Many"+ pretty OccDead = "Dead"+ pretty OccOneOcc = "One"+ pretty (OccLoopBreaker strong) =+ if strong then "Strong Loopbrk" else "Weak Loopbrk"++instance Pretty IdDetails where+ pretty = text . show++data TyPrec -- See Note [Precedence in types] in TyCoRep.hs+ = TopPrec -- No parens+ | FunPrec -- Function args; no parens for tycon apps+ | TyOpPrec -- Infix operator+ | TyConPrec -- Tycon args; no parens for atomic+ deriving( Eq, Ord )++pprType :: PrettyOpts -> Type -> Doc+pprType opts = pprType' opts TopPrec++pprType' :: PrettyOpts -> TyPrec -> Type -> Doc+pprType' opts _ (VarTy b) = pprBinder opts b+pprType' opts p t@(FunTy _ _) = maybeParens (p >= FunPrec) $ sep $ punctuate " ->" (map (pprType' opts FunPrec) (splitFunTys t))+pprType' opts p (TyConApp tc []) = pretty tc+pprType' opts p (TyConApp tc tys) = maybeParens (p >= TyConPrec) $ pretty tc <+> hsep (map (pprType' opts TyConPrec) tys)+pprType' opts p (AppTy a b) = maybeParens (p >= TyConPrec) $ pprType' opts TyConPrec a <+> pprType' opts TyConPrec b+pprType' opts p t@(ForAllTy _ _) = let (bs, t') = splitForAlls t+ in maybeParens (p >= TyOpPrec)+ $ "forall" <+> hsep (map (pprBinder opts) bs) <> "." <+> pprType opts t'+pprType' opts _ LitTy = "LIT"+pprType' opts _ CoercionTy = "Co"++maybeParens :: Bool -> Doc -> Doc+maybeParens True = parens+maybeParens False = id++instance Pretty Type where+ pretty = pprType defaultPrettyOpts++pprExpr :: PrettyOpts -> Expr -> Doc+pprExpr opts = pprExpr' opts False++pprExpr' :: PrettyOpts -> Bool -> Expr -> Doc+pprExpr' opts _parens (EVar v) = pprBinder opts v+pprExpr' opts _parens (EVarGlobal v) = pretty v+pprExpr' opts _parens (ELit l) = pretty l+pprExpr' opts parens e@(EApp{}) = let (x, ys) = collectArgs e+ in maybeParens parens $ hang' (pprExpr' opts True x) 2 (sep $ map pprArg ys)+ where pprArg (EType t) = char '@' <> pprType' opts TyConPrec t+ pprArg x = pprExpr' opts True x+pprExpr' opts parens x@(ETyLam _ _) = let (bs, x') = collectTyBinders x+ in maybeParens parens+ $ hang' ("Λ" <+> sep (map (pprBinder opts) bs) <+> smallRArrow) 2 (pprExpr' opts False x')+pprExpr' opts parens x@(ELam _ _) = let (bs, x') = collectBinders x+ in maybeParens parens+ $ hang' ("λ" <+> sep (map (pprBinder opts) bs) <+> smallRArrow) 2 (pprExpr' opts False x')+pprExpr' opts parens (ELet xs y) = maybeParens parens $ "let" <+> (align $ vcat $ map (uncurry (pprBinding opts)) xs)+ <$$> "in" <+> align (pprExpr' opts False y)+ where pprBind (b, rhs) = pprBinder opts b <+> equals <+> align (pprExpr' opts False rhs)+pprExpr' opts parens (ECase x b alts) = maybeParens parens+ $ sep [ sep [ "case" <+> pprExpr' opts False x+ , "of" <+> pprBinder opts b <+> "{" ]+ , indent 2 $ vcat $ map pprAlt alts+ , "}"+ ]+ where pprAlt (Alt con bndrs rhs) = hang' (hsep (pretty con : map (pprBinder opts) bndrs) <+> smallRArrow) 2 (pprExpr' opts False rhs)+pprExpr' opts parens (EType t) = maybeParens parens $ "TYPE:" <+> pprType opts t+pprExpr' opts parens ECoercion = "CO"++instance Pretty AltCon where+ pretty (AltDataCon t) = text $ T.unpack t+ pretty (AltLit l) = pretty l+ pretty AltDefault = text "DEFAULT"++instance Pretty Expr where+ pretty = pprExpr defaultPrettyOpts++pprTopBinding :: PrettyOpts -> TopBinding -> Doc+pprTopBinding opts tb =+ case tb of+ NonRecTopBinding b s rhs -> pprTopBind (b,s,rhs)+ RecTopBinding bs -> "rec" <+> braces (line <> vsep (map pprTopBind bs))+ where+ pprTopBind (b@(Bndr b'),s,rhs) =+ pprTypeSig opts b+ <$$> pprIdInfo opts (binderIdInfo b') (binderIdDetails b')+ <$$> comment (pretty s)+ <$$> hang' (pprBinder opts b <+> equals) 2 (pprExpr opts rhs)+ <> line++pprTypeSig :: PrettyOpts -> Binder -> Doc+pprTypeSig opts b@(Bndr b') =+ pprBinder opts b <+> dcolon <+> align (pprType opts (binderType b'))++pprBinding :: PrettyOpts -> Binder -> Expr -> Doc+pprBinding opts b@(Bndr b'@Binder{}) rhs =+ ppWhen (showLetTypes opts) (pprTypeSig opts b)+ <$$> pprIdInfo opts (binderIdInfo b') (binderIdDetails b')+ <$$> hang' (pprBinder opts b <+> equals) 2 (pprExpr opts rhs)+pprBinding opts b@(Bndr TyBinder{}) rhs =+ -- let-bound type variables: who knew?+ hang' (pprBinder opts b <+> equals) 2 (pprExpr opts rhs)++instance Pretty TopBinding where+ pretty = pprTopBinding defaultPrettyOpts++pprModule :: PrettyOpts -> Module -> Doc+pprModule opts m =+ comment (pretty $ modulePhase m)+ <$$> text "module" <+> pretty (moduleName m) <+> "where" <> line+ <$$> vsep (map (pprTopBinding opts) (moduleTopBindings m))++instance Pretty Module where+ pretty = pprModule defaultPrettyOpts++comment :: Doc -> Doc+comment x = "{-" <+> x <+> "-}"++dcolon :: Doc+dcolon = "::"++smallRArrow :: Doc+smallRArrow = "→"++hang' :: Doc -> Int -> Doc -> Doc+hang' d1 n d2 = hang n $ sep [d1, d2]++ppWhen :: Bool -> Doc -> Doc+ppWhen True x = x+ppWhen False _ = empty
+ src/GhcDump/Reconstruct.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE RecordWildCards #-}+module GhcDump.Reconstruct (reconModule) where++import Data.Foldable+import Data.Bifunctor+import Prelude hiding (readFile)++import Data.Hashable+import qualified Data.HashMap.Lazy as HM++import GhcDump.Ast++newtype BinderMap = BinderMap (HM.HashMap BinderId Binder)++instance Hashable BinderId where+ hashWithSalt salt (BinderId (Unique c i)) = salt `hashWithSalt` c `hashWithSalt` i++emptyBinderMap :: BinderMap+emptyBinderMap = BinderMap mempty++insertBinder :: Binder -> BinderMap -> BinderMap+insertBinder (Bndr b) (BinderMap m) = BinderMap $ HM.insert (binderId b) (Bndr b) m++insertBinders :: [Binder] -> BinderMap -> BinderMap+insertBinders bs bm = foldl' (flip insertBinder) bm bs++getBinder :: BinderMap -> BinderId -> Binder+getBinder (BinderMap m) bid+ | Just b <- HM.lookup bid m = b+ | otherwise = error $ "unknown binder "++ show bid ++ ":\nin scope:\n"+ ++ unlines (map (\(bid',b) -> show bid' ++ "\t" ++ show b) (HM.toList m))++-- "recon" == "reconstruct"++reconModule :: SModule -> Module+reconModule m = Module (moduleName m) (modulePhase m) binds+ where+ binds = map reconTopBinding $ moduleTopBindings m+ bm = insertBinders (map (\(a,_,_) -> a) $ concatMap topBindings binds) emptyBinderMap++ reconTopBinding :: STopBinding -> TopBinding+ reconTopBinding (NonRecTopBinding b stats rhs) = NonRecTopBinding b' stats (reconExpr bm rhs)+ where b' = reconBinder bm b+ reconTopBinding (RecTopBinding bs) = RecTopBinding bs'+ where bs' = map (\(a,stats,rhs) -> (reconBinder bm a, stats, reconExpr bm rhs)) bs++reconExpr :: BinderMap -> SExpr -> Expr+reconExpr bm (EVar var) = EVar $ getBinder bm var+reconExpr _ (EVarGlobal n) = EVarGlobal n+reconExpr _ (ELit l) = ELit l+reconExpr bm (EApp x y) = EApp (reconExpr bm x) (reconExpr bm y)+reconExpr bm (ETyLam b x) = let b' = reconBinder bm b+ bm' = insertBinder b' bm+ in ETyLam b' (reconExpr bm' x)+reconExpr bm (ELam b x) = let b' = reconBinder bm b+ bm' = insertBinder b' bm+ in ELam b' (reconExpr bm' x)+reconExpr bm (ELet bs x) = let bs' = map (bimap (reconBinder bm) (reconExpr bm')) bs+ bm' = insertBinders (map fst bs') bm+ in ELet bs' (reconExpr bm' x)+reconExpr bm (ECase x b alts) = let b' = reconBinder bm b+ bm' = insertBinder b' bm+ in ECase (reconExpr bm x) b' (map (reconAlt bm') alts)+reconExpr bm (EType t) = EType (reconType bm t)+reconExpr _ ECoercion = ECoercion++reconBinder :: BinderMap -> SBinder -> Binder+reconBinder bm (SBndr b@Binder{}) =+ Bndr $ b { binderType = reconType bm $ binderType b+ , binderIdInfo = reconIdInfo bm $ binderIdInfo b+ }+reconBinder bm (SBndr b@TyBinder{}) =+ Bndr $ b { binderKind = reconType bm $ binderKind b }++reconIdInfo :: BinderMap -> IdInfo SBinder BinderId -> IdInfo Binder Binder+reconIdInfo bm i =+ i { idiUnfolding = reconUnfolding bm $ idiUnfolding i }++reconUnfolding :: BinderMap -> Unfolding SBinder BinderId -> Unfolding Binder Binder+reconUnfolding _ NoUnfolding = NoUnfolding+reconUnfolding _ BootUnfolding = BootUnfolding+reconUnfolding _ (OtherCon alts) = OtherCon alts+reconUnfolding _ DFunUnfolding = DFunUnfolding+reconUnfolding bm CoreUnfolding{..} = CoreUnfolding { unfTemplate = reconExpr bm unfTemplate+ , .. }++reconAlt :: BinderMap -> SAlt -> Alt+reconAlt bm0 (Alt con bs rhs) =+ let (bm', bs') = doBinders bm0 [] bs+ in Alt con bs' (reconExpr bm' rhs)+ where+ doBinders bm acc [] = (bm, reverse acc)+ doBinders bm acc (b:rest) = doBinders bm' (b':acc) rest+ where+ b' = reconBinder bm b+ bm' = insertBinder b' bm++reconType :: BinderMap -> SType -> Type+reconType bm (VarTy v) = VarTy $ getBinder bm v+reconType bm (FunTy x y) = FunTy (reconType bm x) (reconType bm y)+reconType bm (TyConApp tc tys) = TyConApp tc (map (reconType bm) tys)+reconType bm (AppTy x y) = AppTy (reconType bm x) (reconType bm y)+reconType bm (ForAllTy b x) = let b' = reconBinder bm b+ bm' = insertBinder b' bm+ in ForAllTy b' (reconType bm' x)+reconType _ LitTy = LitTy+reconType _ CoercionTy = CoercionTy
+ src/GhcDump/Repl.hs view
@@ -0,0 +1,9 @@+module GhcDump.Repl+ ( module GhcDump.Ast+ , module GhcDump.Util+ , module GhcDump.Pretty+ ) where++import GhcDump.Ast+import GhcDump.Util+import GhcDump.Pretty
+ src/GhcDump/Util.hs view
@@ -0,0 +1,58 @@+module GhcDump.Util+ ( -- * Convenient IO+ readDump, readDump'+ -- * Manipulating 'Type's+ , splitFunTys+ , splitForAlls+ -- * Manipulating expressions+ , collectArgs+ , collectBinders+ , collectTyBinders+ ) where++import Prelude hiding (readFile)++import qualified Data.ByteString.Lazy as BSL+import qualified Codec.Serialise as Ser++import GhcDump.Ast+import GhcDump.Reconstruct++readDump' :: FilePath -> IO SModule+readDump' fname = Ser.deserialise <$> BSL.readFile fname++readDump :: FilePath -> IO Module+readDump fname = reconModule <$> readDump' fname++splitFunTys :: Type' bndr var -> [Type' bndr var]+splitFunTys = go []+ where+ go acc (FunTy a b) = go (a : acc) b+ go acc t = reverse (t : acc)++splitForAlls :: Type' bndr var -> ([bndr], Type' bndr var)+splitForAlls = go []+ where+ go acc (ForAllTy b t) = go (b : acc) t+ go acc t = (reverse acc, t)++collectBinders :: Expr' bndr var -> ([bndr], Expr' bndr var)+collectBinders = go []+ where+ go :: [bndr] -> Expr' bndr var -> ([bndr], Expr' bndr var)+ go acc (ELam v x) = go (v : acc) x+ go acc x = (reverse acc, x)++collectTyBinders :: Expr' bndr var -> ([bndr], Expr' bndr var)+collectTyBinders = go []+ where+ go :: [bndr] -> Expr' bndr var -> ([bndr], Expr' bndr var)+ go acc (ETyLam v x) = go (v : acc) x+ go acc x = (reverse acc, x)++collectArgs :: Expr' bndr var -> (Expr' bndr var, [Expr' bndr var])+collectArgs = go []+ where+ go :: [Expr' bndr var] -> Expr' bndr var -> (Expr' bndr var, [Expr' bndr var])+ go acc (EApp x y) = go (y : acc) x+ go acc x = (x, acc)