Move traceAst

haskell · Aug 18, 2022 · 4223717 · 4223717
1 parent 20dcf6c
commit 4223717
Show file tree

Hide file tree

Showing 6 changed files with 73 additions and 41 deletions.
diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal
@@ -172,7 +172,6 @@ library
         Development.IDE.GHC.Compat.Util
         Development.IDE.Core.Compile
         Development.IDE.GHC.CoreFile
-        Development.IDE.GHC.Dump
         Development.IDE.GHC.Error
         Development.IDE.GHC.Orphans
         Development.IDE.GHC.Util

diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs
@@ -26,7 +26,6 @@ module Development.IDE.GHC.Util(
     setHieDir,
     dontWriteHieFiles,
     disableWarningsAsErrors,
-    traceAst,
     printOutputable
     ) where
 
@@ -70,7 +69,6 @@ import           Debug.Trace
 import           Development.IDE.GHC.Compat        as GHC
 import qualified Development.IDE.GHC.Compat.Parser as Compat
 import qualified Development.IDE.GHC.Compat.Units  as Compat
-import           Development.IDE.GHC.Dump          (showAstDataHtml)
 import           Development.IDE.Types.Location
 import           Foreign.ForeignPtr
 import           Foreign.Ptr
@@ -281,36 +279,6 @@ ioe_dupHandlesNotCompatible h =
 --------------------------------------------------------------------------------
 -- Tracing exactprint terms
 
-{-# NOINLINE timestamp #-}
-timestamp :: POSIXTime
-timestamp = utcTimeToPOSIXSeconds $ unsafePerformIO getCurrentTime
-
-debugAST :: Bool
-debugAST = unsafePerformIO (getEnvDefault "GHCIDE_DEBUG_AST" "0") == "1"
-
--- | Prints an 'Outputable' value to stderr and to an HTML file for further inspection
-traceAst :: (Data a, Outputable a, HasCallStack) => String -> a -> a
-traceAst lbl x
-  | debugAST = trace doTrace x
-  | otherwise = x
-  where
-#if MIN_VERSION_ghc(9,2,0)
-    renderDump = renderWithContext defaultSDocContext{sdocStyle = defaultDumpStyle, sdocPprDebug = True}
-#else
-    renderDump = showSDocUnsafe . ppr
-#endif
-    htmlDump = showAstDataHtml x
-    doTrace = unsafePerformIO $ do
-        u <- U.newUnique
-        let htmlDumpFileName = printf "/tmp/hls/%s-%s-%d.html" (show timestamp) lbl (U.hashUnique u)
-        writeFile htmlDumpFileName $ renderDump htmlDump
-        return $ unlines
-            [prettyCallStack callStack ++ ":"
--- #if MIN_VERSION_ghc(9,2,0)
-            -- , exactPrint x
--- #endif
-            , "file://" ++ htmlDumpFileName]
-
 -- Should in `Development.IDE.GHC.Orphans`,
 -- leave it here to prevent cyclic module dependency
 #if !MIN_VERSION_ghc(8,10,0)

diff --git a/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal b/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal
@@ -21,6 +21,8 @@ library
   exposed-modules:  Development.IDE.GHC.ExactPrint
                     Development.IDE.GHC.Compat.ExactPrint
                     Development.IDE.Plugin.CodeAction
+                    Development.IDE.Plugin.CodeAction.Util
+                    Development.IDE.GHC.Dump
   other-modules:    Development.IDE.Plugin.CodeAction.Args
                     Development.IDE.Plugin.CodeAction.ExactPrint
                     Development.IDE.Plugin.CodeAction.PositionIndexed
@@ -53,6 +55,7 @@ library
     , aeson
     , base                  >=4.12 && <5
     , ghc
+    , bytestring
     , ghc-boot
     , regex-tdfa
     , text-rope
@@ -73,6 +76,7 @@ library
     , mtl
     , lens
     , data-default
+    , time
   ghc-options: -Wall -Wno-name-shadowing
   default-language: Haskell2010
 

diff --git a/ghcide/src/Development/IDE/GHC/Dump.hs → ...or-plugin/src/Development/IDE/GHC/Dump.hs b/ghcide/src/Development/IDE/GHC/Dump.hs → ...or-plugin/src/Development/IDE/GHC/Dump.hs
@@ -2,6 +2,7 @@
 module Development.IDE.GHC.Dump(showAstDataHtml) where
 import           Data.Data                       hiding (Fixity)
 import           Development.IDE.GHC.Compat      hiding (NameAnn)
+import           Development.IDE.GHC.Compat.ExactPrint
 #if MIN_VERSION_ghc(8,10,1)
 import           GHC.Hs.Dump
 #else
@@ -21,18 +22,18 @@ import           GhcPlugins
 import           Prelude                         hiding ((<>))
 
 -- | Show a GHC syntax tree in HTML.
+#if MIN_VERSION_ghc(9,2,1)
+showAstDataHtml :: (Data a, ExactPrint a, Outputable a) => a -> SDoc
+#else
 showAstDataHtml :: (Data a, Outputable a) => a -> SDoc
+#endif
 showAstDataHtml a0 = html $
     header $$
     body (tag' [("id",text (show @String "myUL"))] "ul" $ vcat
         [
--- #if MIN_VERSION_ghc(9,2,1)
-
--- #else
 #if MIN_VERSION_ghc(9,2,1)
---             li (pre $ text (exactPrint a0)),
---             li (showAstDataHtml' a0),
---             li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan NoBlankEpAnnotations a0)
+            li (pre $ text (exactPrint a0)),
+            li (showAstDataHtml' a0),
             li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan NoBlankEpAnnotations a0)
 #else
             li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan a0)
@@ -56,7 +57,6 @@ showAstDataHtml a0 = html $
     header = tag "head" $ tag "style" $ text css
     html = tag "html"
     pre = tag "pre"
-{-
 #if MIN_VERSION_ghc(9,2,1)
     showAstDataHtml' :: Data a => a -> SDoc
     showAstDataHtml' =
@@ -282,7 +282,6 @@ showAstDataHtml a0 = html $
                 Nothing -> text "locatedAnn:unmatched" <+> tag
                            <+> (text (showConstr (toConstr ss)))
 #endif
--}
 
 
 normalize_newlines :: String -> String

diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs
@@ -34,6 +34,8 @@ import           GHC.Stack                       (HasCallStack)
 import           Language.Haskell.GHC.ExactPrint
 import           Language.LSP.Types
 
+import           Development.IDE.Plugin.CodeAction.Util
+
 -- GHC version specific imports. For any supported GHC version, make sure there is no warning in imports.
 #if MIN_VERSION_ghc(9,2,0)
 import           Control.Lens   (_head, _last, over)

diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Util.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Util.hs
@@ -0,0 +1,60 @@
+module Development.IDE.Plugin.CodeAction.Util where
+
+#if MIN_VERSION_ghc(9,2,0)
+import           GHC.Utils.Outputable
+#else
+import           Development.IDE.GHC.Compat.Util
+import           Development.IDE.GHC.Compat
+#endif
+import           Data.Data                         (Data)
+import qualified Data.Unique                       as U
+import           Debug.Trace
+import           Development.IDE.GHC.Compat.ExactPrint as GHC
+import           GHC.Stack
+import           System.Environment.Blank          (getEnvDefault)
+import           System.IO.Unsafe
+import           Text.Printf
+import           Development.IDE.GHC.Dump          (showAstDataHtml)
+import           Data.Time.Clock.POSIX             (POSIXTime, getCurrentTime,
+                                                    utcTimeToPOSIXSeconds)
+--------------------------------------------------------------------------------
+-- Tracing exactprint terms
+
+-- Should in `Development.IDE.GHC.Orphans`,
+-- leave it here to prevent cyclic module dependency
+
+#if !MIN_VERSION_ghc(8,10,0)
+instance Outputable SDoc where
+  ppr = id
+#endif
+
+{-# NOINLINE timestamp #-}
+timestamp :: POSIXTime
+timestamp = utcTimeToPOSIXSeconds $ unsafePerformIO getCurrentTime
+
+debugAST :: Bool
+debugAST = unsafePerformIO (getEnvDefault "GHCIDE_DEBUG_AST" "0") == "1"
+
+-- | Prints an 'Outputable' value to stderr and to an HTML file for further inspection
+traceAst :: (Data a, ExactPrint a, Outputable a, HasCallStack) => String -> a -> a
+traceAst lbl x
+  | debugAST = trace doTrace x
+  | otherwise = x
+  where
+#if MIN_VERSION_ghc(9,2,0)
+    renderDump = renderWithContext defaultSDocContext{sdocStyle = defaultDumpStyle, sdocPprDebug = True}
+#else
+    renderDump = showSDocUnsafe . ppr
+#endif
+    htmlDump = showAstDataHtml x
+    doTrace = unsafePerformIO $ do
+        u <- U.newUnique
+        let htmlDumpFileName = printf "/tmp/hls/%s-%s-%d.html" (show timestamp) lbl (U.hashUnique u)
+        writeFile htmlDumpFileName $ renderDump htmlDump
+        return $ unlines
+            [prettyCallStack callStack ++ ":"
+#if MIN_VERSION_ghc(9,2,0)
+            , exactPrint x
+#endif
+            , "file://" ++ htmlDumpFileName]
+