From 1ca4e5f399a3ab902a483d2e81b629557a1e9694 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Thu, 15 Dec 2016 19:16:37 +0100 Subject: [PATCH] Make 'render' work with ghc <8.0 --- Language/Haskell/GhcMod/Browse.hs | 2 +- Language/Haskell/GhcMod/CaseSplit.hs | 2 +- Language/Haskell/GhcMod/FillSig.hs | 6 +++--- Language/Haskell/GhcMod/Gap.hs | 16 ++++++++++++++++ Language/Haskell/GhcMod/Info.hs | 4 ++-- Language/Haskell/GhcMod/Logger.hs | 2 +- Language/Haskell/GhcMod/Pretty.hs | 24 +++++++++++++++--------- src/GHCMod.hs | 13 ++++--------- 8 files changed, 43 insertions(+), 26 deletions(-) diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index 53bf2d4fd..ef87d5752 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/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 $ diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index d3ea11253..cbb3b519d 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/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 ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index c58e2484b..0b7c54a14 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index ec2e41c24..1f8667bc9 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/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 + + ---------------------------------------------------------------- ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index dc18f7c77..9d3ce66f9 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/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)] diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 62c6e0fa0..9b919e85b 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Pretty.hs b/Language/Haskell/GhcMod/Pretty.hs index 2e498e9a4..f0b7e616f 100644 --- a/Language/Haskell/GhcMod/Pretty.hs +++ b/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 . -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 diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 1cc11d761..26f186527 100644 --- a/src/GHCMod.hs +++ b/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