diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 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-util.cabal b/ghc-dump-util.cabal new file mode 100644 --- /dev/null +++ b/ghc-dump-util.cabal @@ -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 diff --git a/src/GhcDump/Pretty.hs b/src/GhcDump/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/GhcDump/Pretty.hs @@ -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 = "" + +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 diff --git a/src/GhcDump/Reconstruct.hs b/src/GhcDump/Reconstruct.hs new file mode 100644 --- /dev/null +++ b/src/GhcDump/Reconstruct.hs @@ -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 diff --git a/src/GhcDump/Repl.hs b/src/GhcDump/Repl.hs new file mode 100644 --- /dev/null +++ b/src/GhcDump/Repl.hs @@ -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 diff --git a/src/GhcDump/Util.hs b/src/GhcDump/Util.hs new file mode 100644 --- /dev/null +++ b/src/GhcDump/Util.hs @@ -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)