Make 'render' work with ghc <8.0

Language/Haskell/GhcMod/Browse.hs

@@ -46,7 +46,7 @@ browse opts pkgmdl = do
       goPkgModule `G.gcatch` (\(SomeException _) -> goHomeModule)
 
     logException ex =
-        gmLog GmException "browse" $ showDoc ex
+        gmLog GmException "browse" $ showToDoc ex
 
     goPkgModule = do
       runGmPkgGhc $

Language/Haskell/GhcMod/CaseSplit.hs

@@ -70,7 +70,7 @@ splits file lineNo colNo =
  where
    handler (SomeException ex) = do
      gmLog GmException "splits" $
-           text "" $$ nest 4 (showDoc ex)
+           text "" $$ nest 4 (showToDoc ex)
      emptyResult =<< outputOpts
 
 ----------------------------------------------------------------

Language/Haskell/GhcMod/FillSig.hs

@@ -36,7 +36,7 @@ import Language.Haskell.GhcMod.DynFlags
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.SrcUtils
 import Language.Haskell.GhcMod.Logging (gmLog)
-import Language.Haskell.GhcMod.Pretty (showDoc)
+import Language.Haskell.GhcMod.Pretty (showToDoc)
 import Language.Haskell.GhcMod.Doc
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)
@@ -378,7 +378,7 @@ refine file lineNo colNo (Expression expr) =
   where
    handler (SomeException ex) = do
      gmLog GmException "refining" $
-           text "" $$ nest 4 (showDoc ex)
+           text "" $$ nest 4 (showToDoc ex)
      emptyResult =<< outputOpts
 
 -- Look for the variable in the specified position
@@ -475,7 +475,7 @@ auto file lineNo colNo =
  where
    handler (SomeException ex) = do
      gmLog GmException "auto-refining" $
-           text "" $$ nest 4 (showDoc ex)
+           text "" $$ nest 4 (showToDoc ex)
      emptyResult =<< outputOpts
 
 -- Functions we do not want in completions

Language/Haskell/GhcMod/Gap.hs

@@ -31,6 +31,7 @@ module Language.Haskell.GhcMod.Gap (
   , occNameForUser
   , deSugar
   , showDocWith
+  , render
   , GapThing(..)
   , fromTyThing
   , fileModSummary
@@ -200,6 +201,21 @@ showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags)
 showDocWith _ = Pretty.showDocWith
 #endif
 
+render :: Pretty.Doc -> String
+#if __GLASGOW_HASKELL__ >= 800
+render = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt ""
+#else
+render = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt ""
+#endif
+ where
+   string_txt :: Pretty.TextDetails -> String -> String
+   string_txt (Pretty.Chr c)   s  = c:s
+   string_txt (Pretty.Str s1)  s2 = s1 ++ s2
+   string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2
+   string_txt (Pretty.ZStr s1) s2 = zString s1 ++ s2
+   string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2
+
+
 ----------------------------------------------------------------
 ----------------------------------------------------------------
 

Language/Haskell/GhcMod/Info.hs

@@ -37,7 +37,7 @@ info file expr =
         convert' =<< body
   where
     handler (SomeException ex) = do
-      gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex)
+      gmLog GmException "info" $ text "" $$ nest 4 (showToDoc ex)
       convert' "Cannot show info"
 
     body :: (GhcMonad m, GmState m, GmEnv m) => m String
@@ -69,7 +69,7 @@ types withConstraints file lineNo colNo =
         convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
  where
    handler (SomeException ex) = do
-     gmLog GmException "types" $ showDoc ex
+     gmLog GmException "types" $ showToDoc ex
      return []
 
 getSrcSpanType :: (GhcMonad m) => Bool -> G.ModSummary -> Int -> Int -> m [(SrcSpan, G.Type)]

Language/Haskell/GhcMod/Logger.hs

@@ -32,8 +32,8 @@ import Language.Haskell.GhcMod.Doc (showPage)
 import Language.Haskell.GhcMod.DynFlags (withDynFlags)
 import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Error
-import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)
 import Language.Haskell.GhcMod.Pretty
+import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Prelude
 

Language/Haskell/GhcMod/Pretty.hs

@@ -14,7 +14,18 @@
 -- You should have received a copy of the GNU Affero General Public License
 -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
-module Language.Haskell.GhcMod.Pretty where
+module Language.Haskell.GhcMod.Pretty
+  ( render
+  , renderSDoc
+  , gmComponentNameDoc
+  , gmLogLevelDoc
+  , (<+>:)
+  , fnDoc
+  , showToDoc
+  , warnDoc
+  , strLnDoc
+  , strDoc
+  ) where
 
 import Control.Arrow hiding ((<+>))
 import Data.Char
@@ -26,12 +37,7 @@ import Outputable (SDoc, withPprStyleDoc)
 
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Doc
-
-docStyle :: Style
-docStyle = style { ribbonsPerLine = 1.2 }
-
-render :: Doc -> String
-render = renderStyle docStyle
+import Language.Haskell.GhcMod.Gap (render)
 
 renderSDoc :: GhcMonad m => SDoc -> m Doc
 renderSDoc sdoc = do
@@ -64,8 +70,8 @@ a <+>: b = (a <> colon) <+> b
 fnDoc :: FilePath -> Doc
 fnDoc = doubleQuotes . text
 
-showDoc :: Show a => a -> Doc
-showDoc = strLnDoc . show
+showToDoc :: Show a => a -> Doc
+showToDoc = strLnDoc . show
 
 warnDoc :: Doc -> Doc
 warnDoc d = text "Warning" <+>: d

src/GHCMod.hs

@@ -12,21 +12,16 @@ import Language.Haskell.GhcMod
 import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.Find (AsyncSymbolDb, newAsyncSymbolDb, getAsyncSymbolDb)
+import Language.Haskell.GhcMod.Find
+import Language.Haskell.GhcMod.Pretty
 import System.FilePath ((</>))
 import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
                         removeDirectoryRecursive)
 import System.IO
 import System.Exit
-import Pretty hiding ((<>))
 import GHCMod.Options
 import Prelude
 
-ghcModStyle :: Style
-ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 }
-
-----------------------------------------------------------------
-
 handler :: IOish m => GhcModT m a -> GhcModT m a
 handler = flip gcatches
           [ GHandler $ \(e :: ExitCode) -> throw e
@@ -42,7 +37,7 @@ main =
       hSetEncoding stdin enc
       catches (progMain res) [
               Handler $ \(e :: GhcModError) ->
-                runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e)
+                runGmOutT globalOptions $ exitError $ render (gmeDoc e)
             ]
 
 progMain :: (Options, GhcModCommands) -> IO ()
@@ -124,7 +119,7 @@ wrapGhcCommands opts cmd =
        Right _ ->
            return ()
        Left ed ->
-           exitError $ renderStyle ghcModStyle (gmeDoc ed)
+           exitError $ render (gmeDoc ed)
 
    loadMMappedFiles from (Just to) = loadMappedFile from to
    loadMMappedFiles from (Nothing) = do