diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # ChangeLog for HHP(Happy Haskell Programming) +## 2023-03-17 v1.0.2 + +- Supporting GHC 9.6. + +## 2022-09-15 v1.0.1 + +- Supporting GHC 9.6. + ## 2022-05-30 v1.0.0 - Supporting GHC 9.x only. diff --git a/hhp.cabal b/hhp.cabal --- a/hhp.cabal +++ b/hhp.cabal @@ -1,177 +1,189 @@ -Name: hhp -Version: 1.0.1 -Author: Kazu Yamamoto -Maintainer: Kazu Yamamoto -License: BSD3 -License-File: LICENSE -Homepage: https://github.com/kazu-yamamoto/hhp -Synopsis: Happy Haskell Programming -Description: The hhp command is a backend command to enrich - Haskell programming on editors. - The hhpc/hhpi commands are based on HHP library - which is a wrapper of GHC API and Cabal API. - This package includes the hhpc command, - the hhpi command, - the HHP library, and Emacs front-end. - For more information, please see its home page. - Version 0.x.x supports GHC 8.x only whereas version - 1.x.x suports GHC 9.x only. +cabal-version: >=1.10 +name: hhp +version: 1.0.2 +license: BSD3 +license-file: LICENSE +maintainer: Kazu Yamamoto +author: Kazu Yamamoto +homepage: https://github.com/kazu-yamamoto/hhp +synopsis: Happy Haskell Programming +description: + The hhp command is a backend command to enrich + Haskell programming on editors. + The hhpc/hhpi commands are based on HHP library + which is a wrapper of GHC API and Cabal API. + This package includes the hhpc command, + the hhpi command, + the HHP library, and Emacs front-end. + For more information, please see its home page. + Version 0.x.x supports GHC 8.x only whereas version + 1.x.x suports GHC 9.x only. -Category: Development -Cabal-Version: >= 1.10 -Build-Type: Simple -Data-Dir: elisp -Data-Files: Makefile hhp.el hhp-func.el hhp-doc.el hhp-comp.el - hhp-check.el hhp-process.el hhp-command.el hhp-info.el - hhp-ins-mod.el hhp-indent.el hhp-pkg.el -Extra-Source-Files: ChangeLog.md - test/data/*.cabal - test/data/*.hs - test/data/cabal.sandbox.config.in - test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf - test/data/broken-cabal/*.cabal - test/data/broken-sandbox/*.cabal - test/data/broken-sandbox/cabal.sandbox.config - test/data/check-test-subdir/*.cabal - test/data/check-test-subdir/src/Check/Test/*.hs - test/data/check-test-subdir/test/*.hs - test/data/check-test-subdir/test/Bar/*.hs - test/data/check-packageid/cabal.sandbox.config.in - test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf - test/data/hhp-check/*.cabal - test/data/hhp-check/*.hs - test/data/hhp-check/Data/*.hs - test/data/subdir1/subdir2/dummy +category: Development +build-type: Simple +data-files: + Makefile + hhp.el + hhp-func.el + hhp-doc.el + hhp-comp.el + hhp-check.el + hhp-process.el + hhp-command.el + hhp-info.el + hhp-ins-mod.el + hhp-indent.el + hhp-pkg.el -Library - Default-Language: Haskell2010 - GHC-Options: -Wall - HS-Source-Dirs: lib - Exposed-Modules: Hhp - Hhp.Ghc - Hhp.Internal - Other-Modules: Hhp.Boot - Hhp.Browse - Hhp.CabalApi - Hhp.Check - Hhp.Cradle - Hhp.Debug - Hhp.Doc - Hhp.Find - Hhp.Flag - Hhp.Gap - Hhp.GHCApi - Hhp.GhcPkg - Hhp.Logger - Hhp.Info - Hhp.Lang - Hhp.Lint - Hhp.List - Hhp.PkgDoc - Hhp.Syb - Hhp.Types - Hhp.Things - Build-Depends: base >= 4.9 && < 5 - , Cabal >= 1.24 - , containers - , deepseq - , directory - , exceptions - , filepath - , ghc - , hlint >= 1.8.61 - , process - , syb - , ghc-boot +data-dir: elisp +extra-source-files: + ChangeLog.md + test/data/*.cabal + test/data/*.hs + test/data/cabal.sandbox.config.in + test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf + test/data/broken-cabal/*.cabal + test/data/broken-sandbox/*.cabal + test/data/broken-sandbox/cabal.sandbox.config + test/data/check-test-subdir/*.cabal + test/data/check-test-subdir/src/Check/Test/*.hs + test/data/check-test-subdir/test/*.hs + test/data/check-test-subdir/test/Bar/*.hs + test/data/check-packageid/cabal.sandbox.config.in + test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf + test/data/hhp-check/*.cabal + test/data/hhp-check/*.hs + test/data/hhp-check/Data/*.hs + test/data/subdir1/subdir2/dummy -Executable hhpc - Default-Language: Haskell2010 - Main-Is: hhpc.hs - Other-Modules: Paths_hhp - GHC-Options: -Wall - HS-Source-Dirs: src - Build-Depends: base >= 4.9 && < 5 - , directory - , filepath - , hhp +source-repository head + type: git + location: git://github.com/kazu-yamamoto/hhp.git -Executable hhpi - Default-Language: Haskell2010 - Main-Is: hhpi.hs - Other-Modules: Paths_hhp - GHC-Options: -Wall - HS-Source-Dirs: src - Build-Depends: base >= 4.9 && < 5 - , containers - , directory - , filepath - , hhp +library + exposed-modules: + Hhp + Hhp.Ghc + Hhp.Internal -Test-Suite doctest - Type: exitcode-stdio-1.0 - Default-Language: Haskell2010 - HS-Source-Dirs: test - Ghc-Options: -Wall - Main-Is: doctests.hs - Build-Depends: base - , doctest >= 0.9.3 --- for MIN_VERSION_hlint - , hlint + hs-source-dirs: lib + other-modules: + Hhp.Boot + Hhp.Browse + Hhp.CabalApi + Hhp.Check + Hhp.Cradle + Hhp.Debug + Hhp.Doc + Hhp.Find + Hhp.Flag + Hhp.Gap + Hhp.GHCApi + Hhp.GhcPkg + Hhp.Logger + Hhp.Info + Hhp.Lang + Hhp.Lint + Hhp.List + Hhp.PkgDoc + Hhp.Syb + Hhp.Types + Hhp.Things -Test-Suite spec - Default-Language: Haskell2010 - Main-Is: Spec.hs - Hs-Source-Dirs: test, lib - GHC-Options: -Wall - Type: exitcode-stdio-1.0 - Other-Modules: Dir - BrowseSpec - CabalApiSpec - CheckSpec - FlagSpec - InfoSpec - LangSpec - LintSpec - ListSpec - GhcPkgSpec - Other-Modules: Hhp - Hhp.Boot - Hhp.Browse - Hhp.CabalApi - Hhp.Check - Hhp.Cradle - Hhp.Debug - Hhp.Doc - Hhp.Find - Hhp.Flag - Hhp.Gap - Hhp.GHCApi - Hhp.GhcPkg - Hhp.Info - Hhp.Lang - Hhp.Lint - Hhp.List - Hhp.Logger - Hhp.PkgDoc - Hhp.Syb - Hhp.Types - Hhp.Things - Build-Depends: base >= 4.9 && < 5 - , Cabal >= 1.24 - , containers - , deepseq - , directory - , exceptions - , extra - , filepath - , ghc - , hspec >= 1.7.1 - , process - , syb - , hlint >= 1.7.1 - , ghc-boot - build-tool-depends: hspec-discover:hspec-discover == 2.* + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.9 && <5, + Cabal >=1.24, + containers, + deepseq, + directory, + exceptions, + filepath, + ghc, + hlint >=1.8.61, + process, + syb, + ghc-boot -Source-Repository head - Type: git - Location: git://github.com/kazu-yamamoto/hhp.git +executable hhpc + main-is: hhpc.hs + hs-source-dirs: src + other-modules: Paths_hhp + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.9 && <5, + directory, + filepath, + hhp + +executable hhpi + main-is: hhpi.hs + hs-source-dirs: src + other-modules: Paths_hhp + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.9 && <5, + containers, + directory, + filepath, + hhp + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: hspec-discover:hspec-discover >=2 && <3 + hs-source-dirs: test lib + other-modules: + Dir + BrowseSpec + CabalApiSpec + CheckSpec + FlagSpec + InfoSpec + LangSpec + LintSpec + ListSpec + GhcPkgSpec + Hhp + Hhp.Boot + Hhp.Browse + Hhp.CabalApi + Hhp.Check + Hhp.Cradle + Hhp.Debug + Hhp.Doc + Hhp.Find + Hhp.Flag + Hhp.Gap + Hhp.GHCApi + Hhp.GhcPkg + Hhp.Info + Hhp.Lang + Hhp.Lint + Hhp.List + Hhp.Logger + Hhp.PkgDoc + Hhp.Syb + Hhp.Types + Hhp.Things + + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.9 && <5, + Cabal >=1.24, + containers, + deepseq, + directory, + exceptions, + extra, + filepath, + ghc, + hspec >=1.7.1, + process, + syb, + hlint >=1.7.1, + ghc-boot diff --git a/lib/Hhp/Browse.hs b/lib/Hhp/Browse.hs --- a/lib/Hhp/Browse.hs +++ b/lib/Hhp/Browse.hs @@ -6,7 +6,7 @@ import GHC (Ghc, GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon) import qualified GHC as G import GHC.Core.TyCon (isAlgTyCon) -import GHC.Core.Type (dropForAlls, splitFunTy_maybe, isPredTy, mkVisFunTy) +import GHC.Core.Type (dropForAlls) import GHC.Data.FastString (mkFastString) import GHC.Driver.Session (initSDocContext) import GHC.Types.Name (getOccString) @@ -141,6 +141,10 @@ | otherwise = Nothing removeForAlls :: Type -> Type +removeForAlls = dropForAlls + +{- +removeForAlls :: Type -> Type removeForAlls ty = removeForAlls' ty' tty' where ty' = dropForAlls ty @@ -151,3 +155,4 @@ removeForAlls' ty (Just (pre, ftype, x)) | isPredTy pre = mkVisFunTy pre (dropForAlls ftype) x | otherwise = ty +-} diff --git a/lib/Hhp/Doc.hs b/lib/Hhp/Doc.hs --- a/lib/Hhp/Doc.hs +++ b/lib/Hhp/Doc.hs @@ -5,8 +5,8 @@ , styleUnqualified ) where -import GHC (Ghc, getPrintUnqual) -import GHC.Utils.Outputable (PprStyle, SDoc, neverQualify, runSDoc, PrintUnqualified, PprStyle, Depth(..), mkUserStyle, sdocLineLength, SDocContext) +import GHC (Ghc) +import GHC.Utils.Outputable (PprStyle, SDoc, neverQualify, runSDoc, PprStyle, Depth(..), mkUserStyle, sdocLineLength, SDocContext) import GHC.Utils.Ppr (Mode(..), Style(..), renderStyle, style) import Hhp.Gap @@ -28,10 +28,10 @@ ---------------------------------------------------------------- getStyle :: Ghc PprStyle -getStyle = makeUserStyle <$> getPrintUnqual +getStyle = makeUserStyle <$> getNamePprCtx styleUnqualified :: PprStyle styleUnqualified = makeUserStyle neverQualify -makeUserStyle :: PrintUnqualified -> PprStyle +makeUserStyle :: NamePprCtx -> PprStyle makeUserStyle pu = mkUserStyle pu AllTheWay diff --git a/lib/Hhp/Gap.hs b/lib/Hhp/Gap.hs --- a/lib/Hhp/Gap.hs +++ b/lib/Hhp/Gap.hs @@ -24,6 +24,10 @@ , pprSigmaType , getMessages , hsPatType + , fromNE + , NamePprCtx + , getNamePprCtx + , mkScaledFunctionTys ) where import GHC (Ghc, DynFlags(..), GhcLink(..)) @@ -33,9 +37,11 @@ import GHC.Driver.Session (supportedLanguagesAndExtensions) import GHC.Utils.Outputable (SDoc) -#if __GLASGOW_HASKELL__ >= 904 +#if __GLASGOW_HASKELL__ >= 906 ---------------------------------------------------------------- -import GHC (Backend(..), pushLogHookM) +import GHC (pushLogHookM, NamePprCtx, getNamePprCtx) +import GHC.Core.Type (mkScaledFunctionTys) +import GHC.Driver.Backend (interpreterBackend) import GHC.Driver.Env (hsc_units) import GHC.Driver.Errors.Types (ErrorMessages, GhcMessage) import GHC.Hs.Syn.Type (hsPatType) @@ -46,6 +52,60 @@ import GHC.Types.SourceError (SourceError, srcErrorMessages) import GHC.Types.TyThing (implicitTyThings) import GHC.Types.TyThing.Ppr +import GHC.Utils.Error (pprLocMsgEnvelopeDefault, MsgEnvelope) +import GHC.Utils.Logger (LogAction) + +import Data.List.NonEmpty (toList, NonEmpty) + +pagemode :: Mode +pagemode = PageMode True + +getUnitState :: Ghc UnitState +getUnitState = hsc_units <$> G.getSession + +languagesAndExtensions :: [String] +languagesAndExtensions = supportedLanguagesAndExtensions hostPlatformArchOS + +setEmptyLogger :: DynFlags -> DynFlags +setEmptyLogger = id + +-- we don't want to generate object code so we compile to bytecode +-- (HscInterpreted) which implies LinkInMemory +-- HscInterpreted +setLinkerOptions :: DynFlags -> DynFlags +setLinkerOptions df = df { + ghcLink = LinkInMemory + , backend = interpreterBackend + } + +setLogger :: LogAction -> Ghc () +setLogger logaction = pushLogHookM (\__defaultLogAction -> logaction) + +pprLocErrMessage :: MsgEnvelope GhcMessage -> SDoc +pprLocErrMessage = pprLocMsgEnvelopeDefault + +type LOC = LocatedA + +guessTarget :: G.GhcMonad m => String -> m G.Target +guessTarget file = G.guessTarget file Nothing Nothing + +fromNE :: NonEmpty a -> [a] +fromNE = toList +---------------------------------------------------------------- +#elif __GLASGOW_HASKELL__ >= 904 +---------------------------------------------------------------- +import GHC (Backend(..), Type, pushLogHookM) +import GHC.Core.TyCo.Rep (Scaled) +import GHC.Driver.Env (hsc_units) +import GHC.Driver.Errors.Types (ErrorMessages, GhcMessage) +import GHC.Hs.Syn.Type (hsPatType) +import GHC.Parser.Annotation (locA, LocatedA) +import GHC.Platform.Host (hostPlatformArchOS) +import GHC.Tc.Utils.TcType (pprSigmaType, mkVisFunTys) +import GHC.Types.Error (getMessages) +import GHC.Types.SourceError (SourceError, srcErrorMessages) +import GHC.Types.TyThing (implicitTyThings) +import GHC.Types.TyThing.Ppr import GHC.Utils.Error (pprLocMsgEnvelope, MsgEnvelope) import GHC.Utils.Logger (LogAction) @@ -80,13 +140,26 @@ guessTarget :: G.GhcMonad m => String -> m G.Target guessTarget file = G.guessTarget file Nothing Nothing + +fromNE :: a -> a +fromNE = id + +type NamePprCtx = G.PrintUnqualified + +getNamePprCtx :: G.GhcMonad m => m G.PrintUnqualified +getNamePprCtx = G.getPrintUnqual + +mkScaledFunctionTys :: [Scaled Type] -> Type -> Type +mkScaledFunctionTys = mkVisFunTys ---------------------------------------------------------------- #elif __GLASGOW_HASKELL__ >= 902 ---------------------------------------------------------------- -import GHC (Backend(..), pushLogHookM) +import GHC (Backend(..), pushLogHookM, Type) +import GHC.Core.TyCo.Rep (Scaled) import GHC.Driver.Env (hsc_units) import GHC.Parser.Annotation (locA, LocatedA) import GHC.Platform.Host (hostPlatformArchOS) +import GHC.Tc.Utils.TcType (mkVisFunTys) import GHC.Tc.Utils.Zonk (hsPatType) import GHC.Types.SourceError (SourceError, srcErrorMessages) import GHC.Types.TyThing (implicitTyThings) @@ -132,15 +205,27 @@ getMessages :: a -> a getMessages = id +fromNE :: a -> a +fromNE = id + +type NamePprCtx = G.PrintUnqualified + +getNamePprCtx :: G.GhcMonad m => m G.PrintUnqualified +getNamePprCtx = G.getPrintUnqual + +mkScaledFunctionTys :: [Scaled Type] -> Type -> Type +mkScaledFunctionTys = mkVisFunTys ---------------------------------------------------------------- #else ---------------------------------------------------------------- -import GHC (HscTarget(..), getSessionDynFlags, setSessionDynFlags, Located) +import GHC (HscTarget(..), getSessionDynFlags, setSessionDynFlags, Located, Type) import GHC.Core.Ppr.TyThing +import GHC.Core.TyCo.Rep (Scaled) import GHC.Data.Bag (Bag) import GHC.Driver.Session (LogAction) import GHC.Driver.Types (SourceError, srcErrorMessages, implicitTyThings) import GHC.Platform.Host (cHostPlatformMini) +import GHC.Tc.Utils.TcType (mkVisFunTys) import GHC.Tc.Utils.Zonk (hsPatType) import GHC.Utils.Error (ErrMsg, pprLocErrMsg) @@ -190,5 +275,16 @@ getMessages :: a -> a getMessages = id + +fromNE :: a -> a +fromNE = id + +type NamePprCtx = G.PrintUnqualified + +getNamePprCtx :: G.GhcMonad m => m G.PrintUnqualified +getNamePprCtx = G.getPrintUnqual + +mkScaledFunctionTys :: [Scaled Type] -> Type -> Type +mkScaledFunctionTys = mkVisFunTys ---------------------------------------------------------------- #endif diff --git a/lib/Hhp/Info.hs b/lib/Hhp/Info.hs --- a/lib/Hhp/Info.hs +++ b/lib/Hhp/Info.hs @@ -9,7 +9,6 @@ import GHC (Ghc, TypecheckedModule(..), SrcSpan, Type, GenLocated(L), ModSummary, mgModSummaries, mg_ext, LHsBind, Type, LPat, LHsExpr) import qualified GHC as G -import GHC.Core.Type (mkVisFunTys) import GHC.Core.Utils (exprType) import GHC.Hs.Binds (HsBindLR(..)) import GHC.Hs.Expr (MatchGroupTc(..)) @@ -169,7 +168,7 @@ where in_tys = mg_arg_tys $ mg_ext m out_typ = mg_res_ty $ mg_ext m - typ = mkVisFunTys in_tys out_typ + typ = mkScaledFunctionTys in_tys out_typ spn = locA spnA getTypeLBinding _ _ = return Nothing diff --git a/lib/Hhp/List.hs b/lib/Hhp/List.hs --- a/lib/Hhp/List.hs +++ b/lib/Hhp/List.hs @@ -3,7 +3,6 @@ import GHC (Ghc) import qualified GHC as G -import GHC.Unit.Module.Name (moduleNameString) import GHC.Unit.State (lookupModuleInAllUnits, listVisibleModuleNames) import GHC.Unit.Types (moduleName) @@ -26,7 +25,7 @@ modules :: Options -> Ghc String modules opt = convert opt . arrange <$> (getModules `catch` handler) where - arrange = nub . sort . map (moduleNameString . moduleName) + arrange = nub . sort . map (G.moduleNameString . moduleName) handler (SomeException _) = return [] ---------------------------------------------------------------- diff --git a/lib/Hhp/Logger.hs b/lib/Hhp/Logger.hs --- a/lib/Hhp/Logger.hs +++ b/lib/Hhp/Logger.hs @@ -53,7 +53,14 @@ return $! convert opt logmsg appendLogRef :: LogRef -> LogAction -#if __GLASGOW_HASKELL__ >= 904 +#if __GLASGOW_HASKELL__ >= 906 +appendLogRef (LogRef ref) flag mc src msg = do + let (dump,sev) = case mc of + MCDiagnostic sev0 _ _ -> (False, sev0) + _ -> (True, SevError) -- dummy + ctx = log_default_user_context flag + !l = (dump, ctx, sev, src, msg) +#elif __GLASGOW_HASKELL__ >= 904 appendLogRef (LogRef ref) flag mc src msg = do let (dump,sev) = case mc of MCDiagnostic sev0 _ -> (False, sev0) diff --git a/lib/Hhp/Things.hs b/lib/Hhp/Things.hs --- a/lib/Hhp/Things.hs +++ b/lib/Hhp/Things.hs @@ -40,7 +40,7 @@ infoThing str = do names <- G.parseName str mb_stuffs <- mapM (G.getInfo False) names - let filtered = filterOutChildren getTyThing $ catMaybes mb_stuffs + let filtered = filterOutChildren getTyThing $ catMaybes $ fromNE mb_stuffs return $ vcat (intersperse (text "") $ map (pprInfo . fixInfo) filtered) where getTyThing (t,_,_,_,_) = t diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs --- a/test/InfoSpec.hs +++ b/test/InfoSpec.hs @@ -53,6 +53,6 @@ res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`) it "doesn't fail on unicode output" $ do - hhpcPath <- replace "/t/" "/x/" . replace "spec" "hhpc" <$> getExecutablePath + hhpcPath <- replace "\\t\\" "\\x\\" . replace "/t/" "/x/" . replace "spec" "hhpc" <$> getExecutablePath code <- rawSystem hhpcPath ["info", "test/data/Unicode.hs", "unicode"] code `shouldSatisfy` (== ExitSuccess) diff --git a/test/LintSpec.hs b/test/LintSpec.hs --- a/test/LintSpec.hs +++ b/test/LintSpec.hs @@ -12,7 +12,7 @@ res <- lintSyntax defaultOptions "test/data/hlint.hs" -- hlint displays additional line infomation -- since unknown version (:5:16-26:) - replace "16-26" "16" res `shouldBe` "test/data/hlint.hs:5:16: Warning: Use sum\NULFound:\NUL foldr (+) 0\NULPerhaps:\NUL sum\n" + replace "\\" "/" (replace "16-26" "16" res) `shouldBe` "test/data/hlint.hs:5:16: Warning: Use sum\NULFound:\NUL foldr (+) 0\NULPerhaps:\NUL sum\n" context "without suggestions" $ do it "doesn't output empty line" $ do diff --git a/test/doctests.hs b/test/doctests.hs deleted file mode 100644 --- a/test/doctests.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Main where - -import Test.DocTest - -main :: IO () -main = doctest [ - "-package" - , "ghc" - , "-ilib/" - , "-idist/build/autogen/" - , "-optP-include" - , "-optPdist/build/autogen/cabal_macros.h" - , "lib/Hhp.hs" - ]