packages feed

CoreDump (empty) → 0.1.0.0

raw patch · 5 files changed

+272/−0 lines, 5 filesdep +basedep +ghcdep +haskell-src-extssetup-changed

Dependencies added: base, ghc, haskell-src-exts

Files

+ CoreDump.cabal view
@@ -0,0 +1,30 @@+name:                CoreDump+version:             0.1.0.0++synopsis:+  A GHC plugin for printing GHC's internal Core data structures.++description:         See README file.++license:             BSD3+license-file:        LICENSE+author:              Ömer Sinan Ağacan+maintainer:          omeragacan@gmail.com+category:            GHC+build-type:          Simple+cabal-version:       >=1.10++source-repository head+  type:                git+  location:            git://github.com/osa1/CoreDump.git++library+  exposed-modules:     CoreDump+  other-modules:       CoreDump.Show+  build-depends:+    base >= 4.8 && < 4.9,+    ghc  >= 7.10 && < 8,+    haskell-src-exts+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -Wall
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2015, Omer Sinan Agacan+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/CoreDump.hs view
@@ -0,0 +1,44 @@+module CoreDump (plugin) where++import GhcPlugins++import Data.IORef (writeIORef)+import Data.List (intersperse)++-- For pretty-printing+import Language.Haskell.Exts.Parser+import Language.Haskell.Exts.Pretty++import CoreDump.Show++plugin :: Plugin+plugin = defaultPlugin{installCoreToDos = installPlugin}+  where+    installPlugin :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]+    installPlugin opts todos = do+      getDynFlags >>= liftIO . writeIORef dynFlags_ref+      -- trace ("opts: " ++ show opts) (return ())+      return $ concat+        [ if before then [CoreDoPluginPass "CoreDump - before" pluginPass] else []+        , todos+        , if after then [CoreDoPluginPass "CoreDump - after" pluginPass] else []+        ]+      where+        both   = "both"   `elem` opts+        before = "before" `elem` opts || both+        after  = "after"  `elem` opts || both++pluginPass :: ModGuts -> CoreM ModGuts+pluginPass guts@ModGuts{ mg_binds = binds } = do+    liftIO $ mapM_ putStrLn $ intersperse "" $ map showPretty binds+    return guts++showPretty :: Show a => a -> String+showPretty a =+    case parseExp s of+      ParseOk x          -> prettyPrint x+      -- ParseFailed loc reason ->+      --   trace ("parse failed: " ++ show (loc, reason)) s+      ParseFailed{}      -> s+  where+    s = show a
+ src/CoreDump/Show.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE FlexibleInstances, StandaloneDeriving, TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | We define lots of orphan Show instances here, for debugging and learning+-- purposes.+--+-- Most of the time while trying to figure out when a constructor is used or how+-- is a term compiled, it's easiest to just create an example and run the plugin+-- on it.+--+-- Without Show instances though, we can't easily inspect compiled outputs.+-- Outputable generated strings hide lots of details(especially constructors),+-- but we still export a `showOutputable` here, for similar reasons.+--+module CoreDump.Show where++-- import Control.Monad.IO.Class+import Data.IORef+import System.IO.Unsafe (unsafePerformIO)++import Class+import CostCentre+import Demand+import ForeignCall+import GhcPlugins+import IdInfo+import PrimOp+import TypeRep++import Prelude++--------------------------------------------------------------------------------++{-# NOINLINE dynFlags_ref #-}+dynFlags_ref :: IORef DynFlags+dynFlags_ref = unsafePerformIO (newIORef undefined)++{-# NOINLINE dynFlags #-}+dynFlags :: DynFlags+dynFlags = unsafePerformIO (readIORef dynFlags_ref)++-- initDynFlags :: (HasDynFlags m, MonadIO m) => m ()+-- initDynFlags = getDynFlags >>= liftIO .writeIORef dynFlags++showOutputable :: Outputable a => a -> String+showOutputable = showSDoc dynFlags . ppr++--------------------------------------------------------------------------------+-- * Orphan Show instances++deriving instance Show a => Show (Expr a)+deriving instance Show Type+deriving instance Show Literal+deriving instance Show a => Show (Tickish a)+deriving instance Show a => Show (Bind a)+deriving instance Show AltCon+deriving instance Show TyLit+deriving instance Show FunctionOrData+deriving instance Show Module+deriving instance Show CostCentre+deriving instance Show Role+deriving instance Show LeftOrRight+deriving instance Show IsCafCC++instance Show Class where+  show _ = "Class"++deriving instance Show IdDetails+deriving instance Show PrimOp+deriving instance Show ForeignCall+deriving instance Show TickBoxOp+deriving instance Show PrimOpVecCat+deriving instance Show CCallSpec+deriving instance Show CCallTarget+deriving instance Show CCallConv+deriving instance Show SpecInfo+deriving instance Show OccInfo+deriving instance Show InlinePragma+deriving instance Show OneShotInfo+deriving instance Show CafInfo+deriving instance Show Unfolding+deriving instance Show UnfoldingSource+deriving instance Show UnfoldingGuidance+deriving instance Show Activation+deriving instance Show CoreRule+deriving instance Show StrictSig+deriving instance Show DmdType++instance Show RuleFun where+  show _ = "RuleFun"++instance Show (UniqFM a) where+  show _ = "UniqFM"++data SIdInfo+  = IdInfo Arity SpecInfo Unfolding CafInfo+           OneShotInfo InlinePragInfo OccInfo+           StrictSig Demand ArityInfo+  deriving (Show)++instance Show IdInfo where+  show info = show (IdInfo arityInfo_ specInfo_ unfoldingInfo_+                           cafInfo_ oneShotInfo_ inlinePragInfo_+                           occInfo_ strictnessInfo_ demandInfo_+                           callArityInfo_)+    where+      arityInfo_ = arityInfo info+      specInfo_  = specInfo info+      unfoldingInfo_ = unfoldingInfo info+      cafInfo_   = cafInfo info+      oneShotInfo_ = oneShotInfo info+      inlinePragInfo_ = inlinePragInfo info+      occInfo_ = occInfo info+      strictnessInfo_ = strictnessInfo info+      demandInfo_ = demandInfo info+      callArityInfo_ = callArityInfo info++-- Unique's Show instance is not parseable by haskell-src-exts,+-- disabling it for now+data SId = Id Name {- Unique -} Type IdDetails IdInfo+  deriving (Show)++data STyVar = TyVar Name+  deriving (Show)++instance Show Var where+    show v+      | isId v    = show (Id name {- uniq_ -} ty details info)+      | otherwise = show (TyVar name)+      where+        name = varName v+        -- uniq_ = varUnique v+        ty   = varType v++        details = idDetails v+        info    = idInfo v++instance Show DataCon where+    show = show . dataConName++instance Show TyCon where+    show = show . tyConName++instance Show ModuleName where+    show = show . moduleNameString++instance Show PackageKey where+    show = show . packageKeyString++instance Show Name where+    show = showOutputable . nameOccName++-- deriving instance Show Name+instance Show OccName where+    show = showOutputable++instance Show Coercion where+    show _ = "Coercion"++-- Instance for non-terms related stuff.++deriving instance Show CoreToDo+deriving instance Show SimplifierMode+deriving instance Show CompilerPhase+deriving instance Show FloatOutSwitches++instance Show PluginPass where+    show _ = "PluginPass"